frama-c-Fluorine-20130601/0000755000175000017500000000000012155634043014000 5ustar mehdimehdiframa-c-Fluorine-20130601/man/0000755000175000017500000000000012155634040014550 5ustar mehdimehdiframa-c-Fluorine-20130601/man/frama-c.10000644000175000017500000003605112155630367016155 0ustar mehdimehdi.\" .\" .\" This file is part of Frama-C. .\" .\" Copyright (C) 2007-2013 .\" 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). .\" .\" .TH FRAMA-C 1 2013-04-17 .SH NAME frama-c[.byte] \- a static analyzer for C programs .P frama-c-gui[.byte] \- the graphical interface of frama-c .SH SYNOPSIS .B frama-c [ .I options ] .I files .SH DESCRIPTION .B frama-c is a suite of tools dedicated to the analysis of source code written in C. It gathers several static analysis techniques in a single collaborative framework. This framework can be extended by additional plugins placed in the .B $FRAMAC_PLUGIN directory. The command .IP frama\-c \-help .PP will provide the full list of the plugins that are currently installed. .P .B frama-c-gui is the graphical user interface of .BR frama-c . It features the same options as the command-line version. .P .BR frama-c.byte\ and\ frama-c-gui.byte\ are the ocaml bytecode versions of the command-line and graphical user interface respectively. By default, Frama-C recognizes .B .c files as C files needing pre-processing and .B .i files as C files having been already pre-processed. Some plugins may extend the list of recognized files. Pre-processing can be customized through the .B -cpp-command and .B -cpp-extra-args options. .SH OPTIONS .B Syntax .P Options taking an additional parameter can also be written under the form .IP .RI - option = param .PP This option is mandatory when .I param starts with a dash ('-') .P Most options that takes no parameter have a corresponding .IP .RI -no -option .PP option which has the opposite effect. .P .B Help options .TP .B \-help gives a short usage notice and the list of installed plugins. .TP .BI \-kernel\-help prints the list of options recognized by Frama-C's kernel .TP .BI \-verbose\ n Sets verbosity level (default is 1). Setting it to 0 will output less progress messages. This level can also be set on a per \fIplugin\fP basis, with option \fB-\fP\fIplugin\fP\fB-verbose\fP \fIn\fP. Verbosity level of the kernel can be controlled with option \fB-kernel\-verbose\fP \fIn\fP. .TP .BI \-debug\ n Sets debugging level (default is 0, meaning no debugging messages). This option has the same per plugin (and kernel) specializations as \fB-verbose\fP. .TP .B -quiet Sets verbosity and debugging level to 0. .P .B Options controlling Frama-C's kernel .TP .BI \-absolute\-valid\-range\ considers that all numerical addresses in the range .I min-max are valid. Bounds are parsed as ocaml integer constants. By default, all numerical addresses are considered invalid. .TP .BI \-add\-path\ p1[,p2[...,pn]] adds directories .IR \ through .IR \ to the list of directories in which plugins are searched .TP .B [-no]-allow-duplication allows duplication of small blocks during normalization of tests and loops. Otherwise, normalization use labels and gotos. Bigger blocks and blocks with non-trivial control flow are never duplicated. Defaults to yes. .TP .B [-no]-annot reads ACSL annotation. This is the default. Annotation are not pre-processed by default. Use .B -pp-annot for that. .TP .BI \-big\-ints\-hex\ max integers larger than .I max are displayed in hexadecimal (by default, all integers are displayed in decimal) .TP .B -check performs integrity checks on the internal AST (for developers only). .TP .B [-no]-collapse-call-cast allows implicit cast between the value returned by a function and the lvalue it is assigned to. Otherwise, a temporary variable is used and the cast is made explicit. Defaults to yes. .TP .B [-no]-constfold folds all syntactically constant expressions in the code before analyses. Defaults to no. .TP .B [-no]-continue-annot-error When analyzing an annotation, the default behavior (the .B -no version of this option) when a typechecking error occurs is to reject the source file as is the case for typechecking errors within the C code. With this option on, the typechecker will only output a warning and discard the annotation but typechecking will continue (errors in C code are still fatal, though). .TP .BI -cpp-command\ cmd Uses .I cmd as the command to pre-process C files. Defaults to the .B CPP environment variable or to .IP gcc \-C \-E \-I. .IP if it is not set. In order to preserve ACSL annotations, the preprocessor must keep comments (the .B -C option for gcc). .IR %1 \ and\ %2 can be used in .I cmd to denote the original source file and the pre-processed file respectively .TP .BI -cpp-extra-args\ args Gives additional arguments to the pre-processor. This is only useful when .B -preprocess-annot is set. Pre-processing annotations is done in two separate pre-processing stages. The first one is a normal pass on the C code which retains macro definitions. These are then used in the second pass during which annotations are pre-processed. .I args are used only for the first pass, so that arguments that should not be used twice (such as additional include directives or macro definitions) must thus go there instead of .BR -cpp-command . .TP .B [-no]-dynlink When on, load all the dynamic plug-ins found in the search path (see .B -print-plugin-path for more information on the default search path). Otherwise, only plugins requested by .B -load-modules will be loaded. Default behavior is on. .TP .BI -enums\ repr Choose the way the representation of enumerated types is determined. .B frama-c -enums help gives the list of available options. Default is .B gcc-enums .TP .BI -float-digits\ n When outputting floating-point numbers, display .I n digits. Defaults to 12. .TP .B -float-flush-to-zero Floating point operations flush to zero .TP .B -float-hex display floats as hexadecimal .TP .B -float-normal display floats with standard Ocaml routine .TP .B -float-relative display float interval as [ .IR lower_bound ++ width\ ] .TP .B [-no]-force-rl-arg-eval forces right to left evaluation order for arguments of function calls. Otherwise the evaluation order is left unspecified, as in C standard. Defaults to no. .TP .B -journal-disable Do not output a journal of the current session. See .BR -journal-enable . .TP .B -journal-enable On by default, dumps a journal of all the actions performed during the current Frama-C session in the form of an ocaml script that can be replayed with .BR -load-script . The name of the script can be set with the .B -journal-name option. .TP .BI -journal-name\ name Set the name of the journal file (without the .I .ml extension). Defaults to frama_c_journal. .TP .B -initialized-padding-locals Implicit initialization of locals sets padding bits to 0. If false, padding bits are left uninitialized (default to yes). .TP .B [-no]-keep-comments Tries to preserve comments when pretty-printing the source code (defaults to no). .TP .B [-no]-keep-switch When .B -simplify-cfg is set, keeps switch statements. Defaults to no. .TP .B -keep-unused-specified-functions See .B -remove-unused-specified-functions .TP .B [-no]-lib-entry Indicates that the entry point is called during program execution. This implies in particular that global variables can not be assumed to have their initial values. The default is .BR -no-lib-entry : the entry point is also the starting point of the program and globals have their initial value. .TP .BI -load\ file load the (previously saved) state contained in .IR file . .TP .BI -load-module\ m1[,m2[...,mn]] loads the ocaml modules .IR through .IR . These modules must be .BR .cmxs files for the native code version of Frama-c and .BR .cmo or .cma files for the bytecode version (see the Dynlink section of Ocaml manual for more information). All modules which are present in the plugin search paths are automatically loaded. .TP .BI -load-script\ s1[,s2,[...,sn]] loads the ocaml scripts .IR \ through .IR . The scripts must be .BR .ml files. They must be compilable relying only on Ocaml standard library and Frama-C's API. If some custom compilation step is needed, compile them outside of Frama-C and use .B -load-module instead. .TP .BI -machdep\ machine uses .I machine as the current machine-dependent configuration (size of the various integer types, endiandness, ...). The list of currently supported machines is available through .B -machdep help option. Default is .B x86_32 .TP .BI -main\ f Sets .I f as the entry point of the analysis. Defaults to 'main'. By default, it is considered as the starting point of the program under analysis. Use .B -lib-entry if .I f is supposed to be called in the middle of an execution. .TP .B -obfuscate prints an obfuscated version of the code (where original identifiers are replaced by meaningless one) and exits. The correspondance table between original and new symbols is kept at the beginning of the result. .TP .BI -ocode\ file redirects pretty-printed code to .I file instead of standard output. .TP .B [-no]-orig-name During the normalization phase, some variables may get renamed when different variable with the same name can co-exist (e.g. a global variable and a formal parameter). When this option is on, a message is printed each time this occurs. Defaults to no. .TP .B [-no]-warn-signed-downcast generate alarms when signed downcasts may exceed the destination range (default to no). .TP .B [-no]-warn-signed-overflow generate alarms for signed operations that overflow (default to yes). .TP .B [-no]-warn-unsigned-downcast generate alarms when unsigned downcasts may exceed the destination range (default to no). .TP .B [-no]-warn-unsigned-overflow generate alarms for unsigned operations that overflow (default to no). .TP .B [-no]-pp-annot pre-process annotations. This is currently only possible when using gcc (or GNU cpp) pre-processor. The default is to not pre-process annotations. .TP .B [-no]-print pretty-prints the source code as normalized by CIL (defaults to no). .TP .B -print-libpath outputs the directory where Frama-C kernel library is installed .TP .B -print-path alias of .B -print-share-path .TP .B -print-plugin-path outputs the directory where Frama-C searches its plugins (can be overidden by the .B FRAMAC_PLUGIN variable and the .B -add-path option) .TP .B -print-share-path outputs the directory where Frama-C stores its data (can be overidden by the .B FRAMAC_SHARE variable) .TP .B -remove-unused-specified-functions keeps function prototypes that have an ACSL specification but are not used in the code. This is the default. Functions having the attribute .B FRAMAC_BUILTIN are always kept. .TP .B -safe-arrays For multidimensional arrays or arrays that are fields inside structs , assumes that all accesses must be in bound (set by default). The opposite option is .B -unsafe-arrays .TP .BI -save\ file Saves Frama-C's state into .I file after analyses have taken place. .TP .B [-no]-simplify-cfg removes break, continue and switch statement before analyses. Defaults to no. .TP .B -then allows to compose analyzes: a first run of Frama-C will occur with the options before .B -then and a second run will be done with the options after .B -then on the current project from the first run. .TP .BI \-then\-on\ prj Similar to .B -then except that the second run is performed in project .I prj If no such project exists, Frama-C exits with an error. .TP .BI -time\ file appends user time and date in the given .I file when Frama-C exits. .TP .B -typecheck forces typechecking of the source files. This option is only relevant if no further analysis is requested (as typechecking will implicitely occurs before the analysis is launched). .TP .BI -ulevel\ n syntactically unroll loops .I n times before the analysis. This can be quite costly and some plugins (e.g. the value analysis) provide more efficient ways to perform the same thing. See their respective manuals for more information. This can also be activated on a per-loop basis via the .B loop pragma unroll directive. A negative value for .I n will inhibit such pragmas. .TP .B [-no]-unicode outputs ACSL formulas with utf8 characters. This is the default. When given the .B -no-unicode option, Frama-C will use the ASCII version instead. See the ACSL manual for the correspondance. .TP .B -unsafe-arrays see .B -safe-arrays .TP .B [-no]-unspecified-access checks that read/write accesses occuring in unspecified order (according to the C standard's notion of sequence point) are performed on separate locations. With .BR -no-unspecified-access , assumes that it is always the case (this is the default). .TP .B \-version outputs the version string of Frama-C .TP .BI -warn-decimal-float\ warns when a floating-point constant cannot be exactly represented (e.g. 0.1). .I can be one of .BR none ,\ once ,\ or\ all .TP .B [-no]-warn-undeclared-callee warns when a function is called before it has been declared (set by default). Frama-C .P .B Plugins specific options .P For each .IR plugin , the command .IP .RI frama-c\ - plugin -help .PP will give the list of options that are specific to the plugin. .SH EXIT STATUS .TP .B 0 Successful execution .TP .B 1 Invalid user input .TP .B 2 User interruption (kill or equivalent) .TP .B 3 Unimplemented feature .TP .B 4 5 6 Internal error .TP .B 125 Unknown error .P Exit status greater than 2 can be considered as a bug (or a feature request for the case of exit status 3) and may be reported on Frama-C's BTS (see below). .SH ENVIRONMENT VARIABLES It is possible to control the places where Frama-C looks for its files through the following variables. .TP .B FRAMAC_LIB The directory where kernel's compiled interfaces are installed .TP .B FRAMAC_PLUGIN The directory where Frama-C can find standard plug-ins. If you wish to have plugins in several places, use \fB-add-path\fP instead. .TP .B FRAMAC_SHARE The directory where Frama-C datas are installed. .SH SEE ALSO .BR Frama-C\ user\ manual :\ $FRAMAC_SHARE /manuals/user-manual.pdf .P .BR Frama-C\ homepage : http://frama-c.com .P .BR Frama-C\ BTS : http://bts.frama-c.com frama-c-Fluorine-20130601/VERSION0000644000175000017500000000002212155630370015041 0ustar mehdimehdiFluorine-20130601 frama-c-Fluorine-20130601/cil/0000755000175000017500000000000012155634040014544 5ustar mehdimehdiframa-c-Fluorine-20130601/cil/ocamlutil/0000755000175000017500000000000012155634040016535 5ustar mehdimehdiframa-c-Fluorine-20130601/cil/ocamlutil/alpha.mli0000755000175000017500000001331512155630367020343 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Alpha conversion. *) (** This is the type of the elements that are recorded by the alpha * conversion functions in order to be able to undo changes to the tables * they modify. Useful for implementing * scoping *) type 'a undoAlphaElement (** This is the type of the elements of the alpha renaming table. These * elements can carry some data associated with each occurrence of the name. *) type 'a alphaTableData (** Create a new name based on a given name. The new name is formed from a * prefix (obtained from the given name by stripping a suffix consisting of _ * followed by only digits), followed by a special separator and then by a * positive integer suffix. The first argument is a table mapping name * prefixes to some data that specifies what suffixes have been used and how * to create the new one. This function updates the table with the new * largest suffix generated. The "undolist" argument, when present, will be * used by the function to record information that can be used by * {!Alpha.undoAlphaChanges} to undo those changes. Note that the undo * information will be in reverse order in which the action occurred. Returns * the new name and, if different from the lookupname, the location of the * previous occurrence. This function knows about the location implicitly * from the [(Cil.CurrentLoc.get ())]. *) val newAlphaName: alphaTable:(string, 'a alphaTableData ref) Hashtbl.t -> undolist: 'a undoAlphaElement list ref option -> lookupname:string -> data:'a -> string * 'a (** Register a name with an alpha conversion table to ensure that when later * we call newAlphaName we do not end up generating this one *) val registerAlphaName: alphaTable:(string, 'a alphaTableData ref) Hashtbl.t -> undolist: 'a undoAlphaElement list ref option -> lookupname:string -> data:'a -> unit (** Split the name in preparation for newAlphaName. The prefix returned is used to index into the hashtable. The next result value is a separator (either empty or the separator chosen to separate the original name from the index) *) val docAlphaTable: Format.formatter -> (string, 'a alphaTableData ref) Hashtbl.t -> unit val getAlphaPrefix: lookupname:string -> string (** Undo the changes to a table *) val undoAlphaChanges: alphaTable:(string, 'a alphaTableData ref) Hashtbl.t -> undolist:'a undoAlphaElement list -> unit frama-c-Fluorine-20130601/cil/ocamlutil/cilconfig.mli0000644000175000017500000001200612155630367021204 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Reading and storing configuration files from the filesystem. Currently only used in Frama-C's GUI.*) (************************************************************************ *) (** {2 Configuration} *) (* ************************************************************************) (** The configuration data can be of several types **) type configData = ConfInt of int | ConfBool of bool | ConfFloat of float | ConfString of string | ConfList of configData list (** Load the configuration from a file *) val loadConfiguration: string -> unit (** Save the configuration in a file. Overwrites the previous values *) val saveConfiguration: string -> unit (** Clear all configuration data *) val clearConfiguration: unit -> unit (** Set a configuration element, with a key. Overwrites the previous values *) val setConfiguration: string -> configData -> unit (** Find a configuration elements, given a key. Raises Not_found if it cannot * find it *) val findConfiguration: string -> configData (** Like findConfiguration but extracts the integer *) val findConfigurationInt: string -> int (** Looks for an integer configuration element, and if it is found, it uses * the given function. Otherwise, does nothing *) val useConfigurationInt: string -> (int -> unit) -> unit val findConfigurationFloat: string -> float val useConfigurationFloat: string -> (float -> unit) -> unit val findConfigurationBool: string -> bool val useConfigurationBool: string -> (bool -> unit) -> unit val findConfigurationString: string -> string val useConfigurationString: string -> (string -> unit) -> unit val findConfigurationList: string -> configData list val useConfigurationList: string -> (configData list -> unit) -> unit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/cil/ocamlutil/cilconfig.ml0000644000175000017500000002316112155630367021037 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) module H = Hashtbl (************************************************************************ Configuration ************************************************************************) let absoluteFilename (fname: string) = if Filename.is_relative fname then Filename.concat (Sys.getcwd ()) fname else fname (** The configuration data can be of several types **) type configData = ConfInt of int | ConfBool of bool | ConfFloat of float | ConfString of string | ConfList of configData list (* Store here window configuration file *) let configurationData: (string, configData) H.t = H.create 13 let clearConfiguration () = H.clear configurationData let setConfiguration (key: string) (c: configData) = H.replace configurationData key c let findConfiguration (key: string) : configData = H.find configurationData key let findConfigurationInt (key: string) : int = match findConfiguration key with ConfInt i -> i | _ -> Kernel.warning "Configuration %s is not an integer" key; raise Not_found let findConfigurationFloat (key: string) : float = match findConfiguration key with ConfFloat i -> i | _ -> Kernel.warning "Configuration %s is not a float" key; raise Not_found let useConfigurationInt (key: string) (f: int -> unit) = try f (findConfigurationInt key) with Not_found -> () let useConfigurationFloat (key: string) (f: float -> unit) = try f (findConfigurationFloat key) with Not_found -> () let findConfigurationString (key: string) : string = match findConfiguration key with ConfString s -> s | _ -> Kernel.warning "Configuration %s is not a string" key; raise Not_found let useConfigurationString (key: string) (f: string -> unit) = try f (findConfigurationString key) with Not_found -> () let findConfigurationBool (key: string) : bool = match findConfiguration key with ConfBool b -> b | _ -> Kernel.warning "Configuration %s is not a boolean" key; raise Not_found let useConfigurationBool (key: string) (f: bool -> unit) = try f (findConfigurationBool key) with Not_found -> () let findConfigurationList (key: string) : configData list = match findConfiguration key with ConfList l -> l | _ -> Kernel.warning "Configuration %s is not a list" key; raise Not_found let useConfigurationList (key: string) (f: configData list -> unit) = try f (findConfigurationList key) with Not_found -> () let saveConfiguration (fname: string) = (** Convert configuration data to a string, for saving externally *) let configToString (c: configData) : string = let buff = Buffer.create 80 in let rec loop (c: configData) : unit = match c with ConfInt i -> Buffer.add_char buff 'i'; Buffer.add_string buff (string_of_int i); Buffer.add_char buff ';' | ConfBool b -> Buffer.add_char buff 'b'; Buffer.add_string buff (string_of_bool b); Buffer.add_char buff ';' | ConfFloat f -> Buffer.add_char buff 'f'; Buffer.add_string buff (string_of_float f); Buffer.add_char buff ';' | ConfString s -> if String.contains s '"' then Kernel.fatal "Guilib: configuration string contains quotes"; Buffer.add_char buff '"'; Buffer.add_string buff s; Buffer.add_char buff '"'; (* '"' *) | ConfList l -> Buffer.add_char buff '['; List.iter loop l; Buffer.add_char buff ']' in loop c; Buffer.contents buff in try let oc = open_out fname in Kernel.debug "Saving configuration to %s@." (absoluteFilename fname); H.iter (fun k c -> output_string oc (k ^ "\n"); output_string oc ((configToString c) ^ "\n")) configurationData; close_out oc with _ -> Kernel.warning "Cannot open configuration file %s\n" fname (** Make some regular expressions early *) let intRegexp = Str.regexp "i\\([^;]+\\);" let floatRegexp = Str.regexp "f\\([^;]+\\);" let boolRegexp = Str.regexp "b\\(\\(true\\)\\|\\(false\\)\\);" let stringRegexp = Str.regexp "\"\\([^\"]*\\)\"" let loadConfiguration (fname: string) : unit = H.clear configurationData; let stringToConfig (s: string) : configData = let idx = ref 0 in (** the current index *) let l = String.length s in let rec getOne () : configData = if !idx >= l then raise Not_found; if Str.string_match intRegexp s !idx then begin idx := Str.match_end (); let p = Str.matched_group 1 s in (try ConfInt (int_of_string p) with Failure "int_of_string" -> Kernel.warning "Invalid integer configuration element %s" p; raise Not_found) end else if Str.string_match floatRegexp s !idx then begin idx := Str.match_end (); let p = Str.matched_group 1 s in (try ConfFloat (float_of_string p) with Failure "float_of_string" -> Kernel.warning "Invalid float configuration element %s" p; raise Not_found) end else if Str.string_match boolRegexp s !idx then begin idx := Str.match_end (); ConfBool (bool_of_string (Str.matched_group 1 s)) end else if Str.string_match stringRegexp s !idx then begin idx := Str.match_end (); ConfString (Str.matched_group 1 s) end else if String.get s !idx = '[' then begin (* We are starting a list *) incr idx; let rec loop (acc: configData list) : configData list = if !idx >= l then begin Kernel.warning "Non-terminated list in configuration %s" s; raise Not_found end; if String.get s !idx = ']' then begin incr idx; List.rev acc end else loop (getOne () :: acc) in ConfList (loop []) end else begin Kernel.warning "Bad configuration element in a list: %s" (String.sub s !idx (l - !idx)); raise Not_found end in getOne () in (try let ic = open_in fname in Kernel.debug "Loading configuration from %s@." (absoluteFilename fname); (try while true do let k = input_line ic in let s = input_line ic in try let c = stringToConfig s in setConfiguration k c with Not_found -> () done with End_of_file -> ()); close_in ic; with _ -> () (* no file, ignore *)); () (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/cil/ocamlutil/alpha.ml0000755000175000017500000002413512155630367020174 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) module H = Hashtbl let debugAlpha (_prefix: string) = false (*** Alpha conversion ***) let alphaSeparator = "_" let alphaSeparatorLen = String.length alphaSeparator (** For each prefix we remember the next integer suffix to use and the list * of suffixes, each with some data assciated with the newAlphaName that * created the suffix. *) type 'a alphaTableData = Big_int.big_int * (string * 'a) list type 'a undoAlphaElement = AlphaChangedSuffix of 'a alphaTableData ref * 'a alphaTableData (* The * reference that was changed and * the old suffix *) | AlphaAddedSuffix of string (* We added this new entry to the * table *) (* Create a new name based on a given name. The new name is formed from a * prefix (obtained from the given name by stripping a suffix consisting of * the alphaSeparator followed by only digits), followed by alphaSeparator * and then by a positive integer suffix. The first argument is a table * mapping name prefixes to the largest suffix used so far for that * prefix. The largest suffix is one when only the version without suffix has * been used. *) let rec newAlphaName ~(alphaTable: (string, 'a alphaTableData ref) H.t) ~(undolist: 'a undoAlphaElement list ref option) ~(lookupname: string) ~(data: 'a) : string * 'a = alphaWorker ~alphaTable:alphaTable ~undolist:undolist ~lookupname:lookupname ~data:data true (** Just register the name so that we will not use in the future *) and registerAlphaName ~(alphaTable: (string, 'a alphaTableData ref) H.t) ~(undolist: 'a undoAlphaElement list ref option) ~(lookupname: string) ~(data: 'a) : unit = ignore (alphaWorker ~alphaTable:alphaTable ~undolist:undolist ~lookupname:lookupname ~data:data false) and alphaWorker ~(alphaTable: (string, 'a alphaTableData ref) H.t) ~(undolist: 'a undoAlphaElement list ref option) ~(lookupname: string) ~(data:'a) (make_new: bool) : string * 'a = let prefix, suffix, (numsuffix: Big_int.big_int) = splitNameForAlpha ~lookupname in if debugAlpha prefix then (Kernel.debug "Alpha worker: prefix=%s suffix=%s (%s) create=%b. " prefix suffix (Big_int.string_of_big_int numsuffix) make_new); let newname, (olddata: 'a) = try let rc = H.find alphaTable prefix in let max, suffixes = !rc in (* We have seen this prefix *) if debugAlpha prefix then Kernel.debug " Old max %s. Old suffixes: @[%a@]" (Big_int.string_of_big_int max) (Pretty_utils.pp_list (fun fmt (s,_) -> Format.fprintf fmt "%s" s)) suffixes ; (* Save the undo info *) (match undolist with Some l -> l := AlphaChangedSuffix (rc, !rc) :: !l | _ -> ()); let newmax, newsuffix, (olddata: 'a), newsuffixes = if Big_int.gt_big_int numsuffix max then begin (* Clearly we have not seen it *) numsuffix, suffix, data, (suffix, data) :: suffixes end else begin match List.filter (fun (n, _) -> n = suffix) suffixes with [] -> (* Not found *) max, suffix, data, (suffix, data) :: suffixes | [(_, l) ] -> (* We have seen this exact suffix before *) if make_new then let newsuffix = alphaSeparator ^ (Big_int.string_of_big_int (Big_int.succ_big_int max )) in Big_int.succ_big_int max, newsuffix, l, (newsuffix, data) :: suffixes else max, suffix, data, suffixes | _ -> (Kernel.fatal "Cil.alphaWorker") end in rc := (newmax, newsuffixes); prefix ^ newsuffix, olddata with Not_found -> begin (* First variable with this prefix *) (match undolist with Some l -> l := AlphaAddedSuffix prefix :: !l | _ -> ()); H.add alphaTable prefix (ref (numsuffix, [ (suffix, data) ])); if debugAlpha prefix then (Kernel.debug " First seen. "); lookupname, data (* Return the original name *) end in if debugAlpha prefix then (Kernel.debug " Res=: %s \n" newname (* d_loc oldloc *)); newname, olddata (* Strip the suffix. Return the prefix, the suffix (including the separator * and the numeric value, possibly empty), and the * numeric value of the suffix (possibly -1 if missing) *) and splitNameForAlpha ~(lookupname: string) : (string * string * Big_int.big_int) = let len = String.length lookupname in (* Search backward for the numeric suffix. Return the first digit of the * suffix. Returns len if no numeric suffix *) let rec skipSuffix (i: int) = if i = -1 then -1 else let c = Char.code (String.get lookupname i) - Char.code '0' in if c >= 0 && c <= 9 then skipSuffix (i - 1) else (i + 1) in let startSuffix = skipSuffix (len - 1) in if startSuffix >= len (* No digits at all at the end *) || startSuffix <= alphaSeparatorLen (* Not enough room for a prefix and * the separator before suffix *) || (* Suffix starts with a 0 and has more characters after that *) (startSuffix < len - 1 && String.get lookupname startSuffix = '0') || alphaSeparator <> String.sub lookupname (startSuffix - alphaSeparatorLen) alphaSeparatorLen then (lookupname, "", (Big_int.minus_big_int Big_int.unit_big_int)) (* No valid suffix in the name *) else (String.sub lookupname 0 (startSuffix - alphaSeparatorLen), String.sub lookupname (startSuffix - alphaSeparatorLen) (len - startSuffix + alphaSeparatorLen), Big_int.big_int_of_string (String.sub lookupname startSuffix (len - startSuffix))) let getAlphaPrefix ~(lookupname:string) : string = let p, _, _ = splitNameForAlpha ~lookupname:lookupname in p (* Undoes the changes as specified by the undolist *) let undoAlphaChanges ~(alphaTable: (string, 'a alphaTableData ref) H.t) ~(undolist: 'a undoAlphaElement list) = List.iter (function AlphaChangedSuffix (where, old) -> where := old | AlphaAddedSuffix name -> if debugAlpha name then (Kernel.debug "Removing %s from alpha table\n" name); H.remove alphaTable name) undolist let docAlphaTable fmt (alphaTable: (string, 'a alphaTableData ref) H.t) = let acc = ref [] in H.iter (fun k d -> acc := (k, !d) :: !acc) alphaTable; Pretty_utils.pp_list ~sep:"@\n" (fun fmt (k, (d, _)) -> Format.fprintf fmt " %s -> %s" k (Big_int.string_of_big_int d)) fmt !acc frama-c-Fluorine-20130601/cil/src/0000755000175000017500000000000012155634040015333 5ustar mehdimehdiframa-c-Fluorine-20130601/cil/src/cilmsg.ml0000644000175000017500000000746312155630367017165 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) let hadErrors = ref false let errorstack = ref [] let had_errors () = !hadErrors let clear_errors () = hadErrors := false let set_error (_:Log.event) = hadErrors := true let push_errors () = errorstack := !hadErrors :: !errorstack ; hadErrors := false let pop_errors () = match !errorstack with | [] -> Kernel.fatal "Error stack is inconsistent." | old :: stack -> errorstack := stack; hadErrors := old let () = Kernel.register Log.Error set_error; Kernel.register Log.Failure set_error (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/cil/src/cil.ml0000644000175000017500000077326212155630367016465 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* * CIL: An intermediate language for analyzing C progams. * * Version Tue Dec 12 15:21:52 PST 2000 * Scott McPeak, George Necula, Wes Weimer * *) open Cil_const open Logic_const open Format open Cil_datatype open Cil_types (* ************************************************************************* *) (* Reporting messages *) (* ************************************************************************* *) (* Set this to true to check that your code correctly calls some of the functions below. *) let check_invariants = false (* A reference to the current location *) module CurrentLoc = Cil_const.CurrentLoc let () = Log.set_current_source (fun () -> fst (CurrentLoc.get ())) let pp_thisloc fmt = Location.pretty fmt (CurrentLoc.get ()) let register_ast_dependencies, add_ast_dependency = let list_self = ref [] in (fun ast -> State_dependency_graph.add_dependencies ~from:ast !list_self), (fun state -> list_self := state :: !list_self) let voidType = Cil_const.voidType let intType = TInt(IInt,[]) let uintType = TInt(IUInt,[]) let longType = TInt(ILong,[]) let ulongType = TInt(IULong,[]) let ulongLongType = TInt(IULongLong, []) let charType = TInt(IChar, []) let charPtrType = TPtr(charType,[]) let charConstPtrType = TPtr(TInt(IChar, [Attr("const", [])]),[]) let voidPtrType = TPtr(voidType, []) let voidConstPtrType = TPtr(TVoid [Attr ("const", [])], []) let intPtrType = TPtr(intType, []) let uintPtrType = TPtr(uintType, []) let doubleType = TFloat(FDouble, []) let floatType = TFloat(FFloat, []) let longDoubleType = TFloat (FLongDouble, []) let empty_size_cache () = {scache=Not_Computed} type theMachine = { mutable msvcMode: bool; (** Whether the pretty printer should print output for the MS VC compiler. Default is GCC *) mutable useLogicalOperators: bool; mutable theMachine: mach; (** Cil.initCil will set this to the current machine description. *) mutable lowerConstants: bool; (** Do lower constants (default true) *) mutable insertImplicitCasts: bool; (** Do insert implicit casts (default true) *) mutable underscore_name: bool; mutable stringLiteralType: typ; mutable upointKind: ikind; mutable upointType: typ; mutable wcharKind: ikind; (** An integer type that fits wchar_t. *) mutable wcharType: typ; mutable ptrdiffKind: ikind; (** An integer type that fits ptrdiff_t. *) mutable ptrdiffType: typ; mutable typeOfSizeOf: typ; (** An integer type that is the type of sizeof. *) mutable kindOfSizeOf: ikind; } type lineDirectiveStyle = | LineComment (** Before every element, print the line * number in comments. This is ignored by * processing tools (thus errors are reproted * in the CIL output), but useful for * visual inspection *) | LineCommentSparse (** Like LineComment but only print a line * directive for a new source line *) | LinePreprocessorInput (** Use #line directives *) | LinePreprocessorOutput (** Use # nnn directives (in gcc mode) *) type miscState = { mutable lineDirectiveStyle: lineDirectiveStyle option; mutable print_CIL_Input: bool; mutable printCilAsIs: bool; mutable lineLength: int; mutable warnTruncate: bool } let default_machdep = Machdep_x86_32.gcc let createMachine () = (* Contain dummy values *) { msvcMode = false; useLogicalOperators = false; theMachine = default_machdep; lowerConstants = false(*true*); insertImplicitCasts = true; underscore_name = true; stringLiteralType = charPtrType; upointKind = IChar; upointType = voidType; wcharKind = IChar; wcharType = voidType; ptrdiffKind = IChar; ptrdiffType = voidType; typeOfSizeOf = voidType; kindOfSizeOf = IUInt } let copyMachine src dst = dst.msvcMode <- src.msvcMode; dst.useLogicalOperators <- src.useLogicalOperators; dst.theMachine <- src.theMachine; dst.lowerConstants <- src.lowerConstants; dst.insertImplicitCasts <- src.insertImplicitCasts; dst.underscore_name <- src.underscore_name; dst.stringLiteralType <- src.stringLiteralType; dst.upointKind <- src.upointKind; dst.upointType <- src.upointType; dst.wcharKind <- src.wcharKind; dst.wcharType <- src.wcharType; dst.ptrdiffKind <- src.ptrdiffKind; dst.ptrdiffType <- src.ptrdiffType; dst.typeOfSizeOf <- src.typeOfSizeOf; dst.kindOfSizeOf <- src.kindOfSizeOf (* A few globals that control the interpretation of C source *) let theMachine = createMachine () let theMachineProject = ref (createMachine ()) module Machine_datatype = Datatype.Make (struct include Datatype.Serializable_undefined type t = theMachine let name = "theMachine" let reprs = [ theMachine ] let copy x = let m = createMachine () in copyMachine x m; m let mem_project = Datatype.never_any_project end) module TheMachine = State_builder.Register (Machine_datatype) (struct type t = theMachine let create = createMachine let get () = !theMachineProject let set m = theMachineProject := m; copyMachine !theMachineProject theMachine let clear m = copyMachine (createMachine ()) m let clear_some_projects _ _ = false end) (struct let name = "theMachine" let unique_name = name let dependencies = [ Kernel.Machdep.self ] end) let selfMachine = TheMachine.self let () = State_dependency_graph.add_dependencies ~from:selfMachine Logic_env.builtin_states let selfMachine_is_computed = TheMachine.is_computed let set_msvcMode b = theMachine.msvcMode <- b let miscState = { lineDirectiveStyle = Some LinePreprocessorInput; print_CIL_Input = false; printCilAsIs = false; lineLength = 80; warnTruncate = true } (* sm: return the string 's' if we're printing output for gcc, suppres * it if we're printing for CIL to parse back in. the purpose is to * hide things from gcc that it complains about, but still be able * to do lossless transformations when CIL is the consumer *) let forgcc (s: string) : string = if miscState.print_CIL_Input then "" else s let debugConstFold = false (* TODO: migrate that to Cil_const as well *) module Sid = State_builder.SharedCounter(struct let name = "sid" end) module Eid = State_builder.SharedCounter(struct let name = "eid" end) let new_exp ~loc e = { eloc = loc; eid = Eid.next (); enode = e } let dummy_exp e = { eid = -1; enode = e; eloc = Cil_datatype.Location.unknown } (** The Abstract Syntax of CIL *) (** To be able to add/remove features easily, each feature should be packaged * as an interface with the following interface. These features should be *) type featureDescr = { fd_enabled: bool ref; (** The enable flag. Set to default value *) fd_name: string; (** This is used to construct an option "--doxxx" and "--dontxxx" that * enable and disable the feature *) fd_description: string; (* A longer name that can be used to document the new options *) fd_extraopt: (string * Arg.spec * string) list; (** Additional command line options. The description strings should usually start with a space for Arg.align to print the --help nicely. *) fd_doit: (file -> unit); (** This performs the transformation *) fd_post_check: bool; (* Whether to perform a CIL consistency checking after this stage, if * checking is enabled (--check is passed to cilly) *) } (* A reference to the current global being visited *) let currentGlobal: global ref = ref (GText "dummy") let argsToList : (string * typ * attributes) list option -> (string * typ * attributes) list = function None -> [] | Some al -> al (* A hack to allow forward reference of d_exp *) let pp_typ_ref = Extlib.mk_fun "Cil.pp_typ_ref" let pp_global_ref = Extlib.mk_fun "Cil.pp_global_ref" let pp_exp_ref = Extlib.mk_fun "Cil.pp_exp_ref" let pp_lval_ref = Extlib.mk_fun "Cil.pp_lval_ref" let pp_ikind_ref = Extlib.mk_fun "Cil.pp_ikind_ref" let pp_attribute_ref = Extlib.mk_fun "Cil.pp_attribute_ref" let pp_attributes_ref = Extlib.mk_fun "Cil.pp_attributes_ref" let default_behavior_name = "default!" let is_default_mk_behavior ~name ~assumes = name = default_behavior_name && assumes =[] let is_default_behavior b = is_default_mk_behavior b.b_name b.b_assumes let find_default_behavior spec = try Some (List.find is_default_behavior spec.spec_behavior) with Not_found -> None let find_default_requires behaviors = try (List.find is_default_behavior behaviors).b_requires with Not_found -> [] let rec stripInfo e = match e.enode with | Info(e',_) -> stripInfo e' | _ -> e let rec addOffset (toadd: offset) (off: offset) : offset = match off with | NoOffset -> toadd | Field(fid', offset) -> Field(fid', addOffset toadd offset) | Index(e, offset) -> Index(e, addOffset toadd offset) let mkBlock (slst: stmt list) : block = { battrs = []; bstmts = slst; blocals = []} let mkStmt ?(ghost=false) ?(valid_sid=false) (sk: stmtkind) : stmt = { skind = sk; labels = []; (* It is better to create statements with a valid sid, so that they can safely be used in tables. I only do it when performing Jessie analysis, as other plugins rely on specific sid values for their tests (e.g. slicing). *) sid = if valid_sid then Sid.next () else -1; succs = []; preds = []; ghost = ghost} let stmt_of_instr_list ?(loc=Location.unknown) = function | [] -> Instr (Skip loc) | [i] -> Instr i | il -> let b = mkBlock (List.map (fun i -> mkStmt (Instr i)) il) in match b.bstmts with | [] -> Instr (Skip loc) | [s] when b.battrs = [] -> s.skind | _ -> Block b (**** Utility functions ******) (**** ATTRIBUTES ****) let bitfield_attribute_name = "FRAMA_C_BITFIELD_SIZE" (** Construct sorted lists of attributes ***) let attributeName = function Attr(a, _) | AttrAnnot a -> a let addAttribute (Attr(an, _) | AttrAnnot an as a: attribute) (al: attributes) = let rec insertSorted = function [] -> [a] | ((Attr(an0, _) | AttrAnnot an0 as a0) :: rest) as l -> if an < an0 then a :: l else if Cil_datatype.Attribute.equal a a0 then l (* Do not add if already in there *) else a0 :: insertSorted rest (* Make sure we see all attributes with * this name *) in insertSorted al (** The second attribute list is sorted *) let addAttributes al0 (al: attributes) : attributes = if al0 == [] then al else List.fold_left (fun acc a -> addAttribute a acc) al al0 let dropAttribute (an: string) (al: attributes) = List.filter (fun a -> attributeName a <> an) al let dropAttributes (anl: string list) (al: attributes) = List.fold_left (fun acc an -> dropAttribute an acc) al anl let hasAttribute (s: string) (al: attribute list) : bool = List.exists (fun a -> attributeName a = s) al let filterAttributes (s: string) (al: attribute list) : attribute list = List.filter (fun a -> attributeName a = s) al let findAttribute (s: string) (al: attribute list) : attrparam list = List.fold_left (fun acc -> function | Attr (an, param) when an = s -> param @ acc | _ -> acc) [] al let rec typeAttrs = function TVoid a -> a | TInt (_, a) -> a | TFloat (_, a) -> a | TNamed (t, a) -> addAttributes a (typeAttrs t.ttype) | TPtr (_, a) -> a | TArray (_, _, _,a) -> a | TComp (comp, _, a) -> addAttributes comp.cattr a | TEnum (enum, a) -> addAttributes enum.eattr a | TFun (_, _, _, a) -> a | TBuiltin_va_list a -> a let typeAttr = function | TVoid a | TInt (_, a) | TFloat (_, a) | TNamed (_, a) | TPtr (_, a) | TArray (_, _, _, a) | TComp (_, _, a) | TEnum (_, a) | TFun (_, _, _, a) | TBuiltin_va_list a -> a let setTypeAttrs t a = match t with TVoid _ -> TVoid a | TInt (i, _) -> TInt (i, a) | TFloat (f, _) -> TFloat (f, a) | TNamed (t, _) -> TNamed(t, a) | TPtr (t', _) -> TPtr(t', a) | TArray (t', l, s, _) -> TArray(t', l, s, a) | TComp (comp, s, _) -> TComp (comp, s, a) | TEnum (enum, _) -> TEnum (enum, a) | TFun (r, args, v, _) -> TFun(r,args,v,a) | TBuiltin_va_list _ -> TBuiltin_va_list a let qualifier_attributes = [ "const"; "restrict"; "volatile"] let filter_qualifier_attributes al = List.filter (fun a -> List.mem (attributeName a) qualifier_attributes) al let splitArrayAttributes = List.partition (fun a -> List.mem (attributeName a) qualifier_attributes) let rec typeAddAttributes a0 t = begin match a0 with | [] -> (* no attributes, keep same type *) t | _ -> (* anything else: add a0 to existing attributes *) let add (a: attributes) = addAttributes a0 a in match t with TVoid a -> TVoid (add a) | TInt (ik, a) -> TInt (ik, add a) | TFloat (fk, a) -> TFloat (fk, add a) | TEnum (enum, a) -> TEnum (enum, add a) | TPtr (t, a) -> TPtr (t, add a) | TArray (t, l, s, a) -> let att_elt, att_typ = splitArrayAttributes a0 in TArray (arrayPushAttributes att_elt t, l, s, addAttributes att_typ a) | TFun (t, args, isva, a) -> TFun(t, args, isva, add a) | TComp (comp, s, a) -> TComp (comp, s, add a) | TNamed (t, a) -> TNamed (t, add a) | TBuiltin_va_list a -> TBuiltin_va_list (add a) end (* Push attributes that belong to the type of the elements of the array as far as possible *) and arrayPushAttributes al = function | TArray (bt, l, s, a) -> TArray (arrayPushAttributes al bt, l, s, a) | t -> typeAddAttributes al t let typeRemoveAttributes (anl: string list) t = let drop (al: attributes) = dropAttributes anl al in match t with TVoid a -> TVoid (drop a) | TInt (ik, a) -> TInt (ik, drop a) | TFloat (fk, a) -> TFloat (fk, drop a) | TEnum (enum, a) -> TEnum (enum, drop a) | TPtr (t, a) -> TPtr (t, drop a) | TArray (t, l, s, a) -> TArray (t, l, s, drop a) | TFun (t, args, isva, a) -> TFun(t, args, isva, drop a) | TComp (comp, s, a) -> TComp (comp, s, drop a) | TNamed (t, a) -> TNamed (t, drop a) | TBuiltin_va_list a -> TBuiltin_va_list (drop a) (* JS: build an attribute annotation from [s]. *) let mkAttrAnnot s = "/*@ " ^ s ^ " */" (* Internal attributes. Won't be pretty-printed *) let reserved_attributes = ref [] let register_shallow_attribute s = reserved_attributes:=s::!reserved_attributes let type_remove_qualifier_attributes = typeRemoveAttributes qualifier_attributes type attributeClass = | AttrName of bool (* Attribute of a name. If argument is true and we are on MSVC then * the attribute is printed using __declspec as part of the storage * specifier *) | AttrFunType of bool (* Attribute of a function type. If argument is true and we are on * MSVC then the attribute is printed just before the function name *) | AttrType (* Attribute of a type *) (* This table contains the mapping of predefined attributes to classes. * Extend this table with more attributes as you need. This table is used to * determine how to associate attributes with names or type during cabs2cil * conversion *) let attributeHash: (string, attributeClass) Hashtbl.t = let table = Hashtbl.create 13 in List.iter (fun a -> Hashtbl.add table a (AttrName false)) [ "section"; "constructor"; "destructor"; "unused"; "used"; "weak"; "no_instrument_function"; "alias"; "no_check_memory_usage"; "exception"; "model"; (* "restrict"; *) "aconst"; "__asm__" (* Gcc uses this to specifiy the name to be used in * assembly for a global *)]; (* Now come the MSVC declspec attributes *) List.iter (fun a -> Hashtbl.add table a (AttrName true)) [ "thread"; "naked"; "dllimport"; "dllexport"; "selectany"; "allocate"; "nothrow"; "novtable"; "property"; "noreturn"; "uuid"; "align" ]; List.iter (fun a -> Hashtbl.add table a (AttrFunType false)) [ "format"; "regparm"; "longcall"; "noinline"; "always_inline"; ]; List.iter (fun a -> Hashtbl.add table a (AttrFunType true)) [ "stdcall";"cdecl"; "fastcall" ]; List.iter (fun a -> Hashtbl.add table a AttrType) [ "const"; "volatile"; "restrict"; "mode" ]; table let attributeClass = Hashtbl.find attributeHash let registerAttribute = Hashtbl.add attributeHash let removeAttribute = Hashtbl.remove attributeHash (** Partition the attributes into classes *) let partitionAttributes ~(default:attributeClass) (attrs: attribute list) : attribute list * attribute list * attribute list = let rec loop (n,f,t) = function [] -> n, f, t | (Attr(an, _) | AttrAnnot an as a) :: rest -> match (try Hashtbl.find attributeHash an with Not_found -> default) with AttrName _ -> loop (addAttribute a n, f, t) rest | AttrFunType _ -> loop (n, addAttribute a f, t) rest | AttrType -> loop (n, f, addAttribute a t) rest in loop ([], [], []) attrs let unrollType (t: typ) : typ = let rec withAttrs (al: attributes) (t: typ) : typ = match t with TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype | x -> typeAddAttributes al x in withAttrs [] t let () = punrollType := unrollType (* Unroll typedefs, discarding all intermediate attribute. To be used only when one is interested in the shape of the type *) let rec unrollTypeSkel = function | TNamed (r, _) -> unrollTypeSkel r.ttype | x -> x let isFunctionType t = match unrollTypeSkel t with TFun _ -> true | _ -> false (* Make a varinfo. Used mostly as a helper function below *) let makeVarinfo ?(logic=false) ?(generated=true) global formal name typ = (* Strip const from type for locals *) let vi = { vorig_name = name; vname = name; vid = -1; vglob = global; vdefined = false; vformal = formal; vgenerated = generated; vtype = if formal || global then typ else typeRemoveAttributes ["const"] typ; vdecl = Location.unknown; vinline = false; vattr = []; vstorage = NoStorage; vaddrof = false; vreferenced = false; vdescr = None; vdescrpure = true; vghost = false; vlogic = logic; vlogic_var_assoc = None } in set_vid vi; vi module FormalsDecl = State_builder.Hashtbl (Varinfo.Hashtbl) (Datatype.List(Varinfo)) (struct let name = "FormalsDecl" let dependencies = [] (* depends on Ast.self; see below *) let size = 47 end) let selfFormalsDecl = FormalsDecl.self let () = add_ast_dependency selfFormalsDecl let makeFormalsVarDecl (n,t,a) = let vi = makeVarinfo ~generated:false false true n t in vi.vattr <- a; vi let setFormalsDecl vi typ = match unrollType typ with | TFun(_, Some args, _, _) -> FormalsDecl.replace vi (List.map makeFormalsVarDecl args) | TFun(_,None,_,_) -> () | _ -> Kernel.error ~current:true "trying to assigns formal parameters to an object \ that is not a function prototype" let getFormalsDecl vi = FormalsDecl.find vi let unsafeSetFormalsDecl vi args = FormalsDecl.replace vi args let removeFormalsDecl vi = FormalsDecl.remove vi let iterFormalsDecl = FormalsDecl.iter let () = Cil_datatype.Kf.set_formal_decls := unsafeSetFormalsDecl (* Set the formals and re-create the function name based on the information*) let setFormals (f: fundec) (forms: varinfo list) = unsafeSetFormalsDecl f.svar forms; List.iter (fun v -> v.vformal <- true) forms; f.sformals <- forms; (* Set the formals *) assert (getFormalsDecl f.svar == f.sformals); match unrollType f.svar.vtype with TFun(rt, _, isva, fa) -> f.svar.vtype <- TFun(rt, Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) forms), isva, fa) | _ -> Kernel.fatal "Set formals. %s does not have function type" f.svar.vname let empty_funspec () = { spec_behavior = []; spec_variant = None; spec_terminates = None; spec_complete_behaviors = []; spec_disjoint_behaviors = [] } let is_empty_funspec (spec : funspec) = spec.spec_behavior = [] && spec.spec_variant = None && spec.spec_terminates = None && spec.spec_complete_behaviors = [] && spec.spec_disjoint_behaviors = [] let is_empty_behavior b = b.b_assumes = [] && b.b_requires = [] && b.b_post_cond = [] && b.b_assigns = WritesAny && b.b_allocation = FreeAllocAny && b.b_extended = [] (** Different visiting actions. 'a will be instantiated with [exp], [instr], etc. @see Plugin Development Guide *) type 'a visitAction = SkipChildren (** Do not visit the children. Return the node as it is. *) | DoChildren (** Continue with the children of this node. Rebuild the node on return if any of the children changes (use == test) *) | DoChildrenPost of ('a -> 'a) | JustCopy | JustCopyPost of ('a -> 'a) | ChangeTo of 'a (** Replace the expression with the given one *) | ChangeToPost of 'a * ('a -> 'a) | ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire exp is replaced by the first parameter. Then continue with the children. On return rebuild the node if any of the children has changed and then apply the function on the node *) type visitor_behavior = { (* copy mutable structure which are not shared across the AST*) cfile: file -> file; cinitinfo: initinfo -> initinfo; cblock: block -> block; cfunspec: funspec -> funspec; cfunbehavior: funbehavior -> funbehavior; cidentified_term: identified_term -> identified_term; cidentified_predicate: identified_predicate -> identified_predicate; (* get the copy of a shared value *) get_stmt: stmt -> stmt; get_compinfo: compinfo -> compinfo; get_fieldinfo: fieldinfo -> fieldinfo; get_model_info: model_info -> model_info; get_enuminfo: enuminfo -> enuminfo; get_enumitem: enumitem -> enumitem; get_typeinfo: typeinfo -> typeinfo; get_varinfo: varinfo -> varinfo; get_logic_info: logic_info -> logic_info; get_logic_type_info: logic_type_info -> logic_type_info; get_logic_var: logic_var -> logic_var; get_kernel_function: kernel_function -> kernel_function; get_fundec: fundec -> fundec; (* get the original value tied to a copy *) get_original_stmt: stmt -> stmt; get_original_compinfo: compinfo -> compinfo; get_original_fieldinfo: fieldinfo -> fieldinfo; get_original_model_info: model_info -> model_info; get_original_enuminfo: enuminfo -> enuminfo; get_original_enumitem: enumitem -> enumitem; get_original_typeinfo: typeinfo -> typeinfo; get_original_varinfo: varinfo -> varinfo; get_original_logic_info: logic_info -> logic_info; get_original_logic_type_info: logic_type_info -> logic_type_info; get_original_logic_var: logic_var -> logic_var; get_original_kernel_function: kernel_function -> kernel_function; get_original_fundec: fundec -> fundec; (* change a binding... use with care *) set_stmt: stmt -> stmt -> unit; set_compinfo: compinfo -> compinfo -> unit; set_fieldinfo: fieldinfo -> fieldinfo -> unit; set_model_info: model_info -> model_info -> unit; set_enuminfo: enuminfo -> enuminfo -> unit; set_enumitem: enumitem -> enumitem -> unit; set_typeinfo: typeinfo -> typeinfo -> unit; set_varinfo: varinfo -> varinfo -> unit; set_logic_info: logic_info -> logic_info -> unit; set_logic_type_info: logic_type_info -> logic_type_info -> unit; set_logic_var: logic_var -> logic_var -> unit; set_kernel_function: kernel_function -> kernel_function -> unit; set_fundec: fundec -> fundec -> unit; (* change a reference... use with care *) set_orig_stmt: stmt -> stmt -> unit; set_orig_compinfo: compinfo -> compinfo -> unit; set_orig_fieldinfo: fieldinfo -> fieldinfo -> unit; set_orig_model_info: model_info -> model_info -> unit; set_orig_enuminfo: enuminfo -> enuminfo -> unit; set_orig_enumitem: enumitem -> enumitem -> unit; set_orig_typeinfo: typeinfo -> typeinfo -> unit; set_orig_varinfo: varinfo -> varinfo -> unit; set_orig_logic_info: logic_info -> logic_info -> unit; set_orig_logic_type_info: logic_type_info -> logic_type_info -> unit; set_orig_logic_var: logic_var -> logic_var -> unit; set_orig_kernel_function: kernel_function -> kernel_function -> unit; set_orig_fundec: fundec -> fundec -> unit; (* copy fields that can referenced in other places of the AST*) memo_stmt: stmt -> stmt; memo_varinfo: varinfo -> varinfo; memo_compinfo: compinfo -> compinfo; memo_model_info: model_info -> model_info; memo_enuminfo: enuminfo -> enuminfo; memo_enumitem: enumitem -> enumitem; memo_typeinfo: typeinfo -> typeinfo; memo_logic_info: logic_info -> logic_info; memo_logic_type_info: logic_type_info -> logic_type_info; memo_fieldinfo: fieldinfo -> fieldinfo; memo_logic_var: logic_var -> logic_var; memo_kernel_function: kernel_function -> kernel_function; memo_fundec: fundec -> fundec; (* is the behavior a copy behavior *) is_copy_behavior: bool; project: Project.t option; (* reset memoizing tables *) reset_behavior_varinfo: unit -> unit; reset_behavior_compinfo: unit -> unit; reset_behavior_enuminfo: unit -> unit; reset_behavior_enumitem: unit -> unit; reset_behavior_typeinfo: unit -> unit; reset_behavior_logic_info: unit -> unit; reset_behavior_logic_type_info: unit -> unit; reset_behavior_fieldinfo: unit -> unit; reset_behavior_model_info: unit -> unit; reset_behavior_stmt: unit -> unit; reset_logic_var: unit -> unit; reset_behavior_kernel_function: unit -> unit; reset_behavior_fundec: unit -> unit; (* iterates over tables *) iter_visitor_varinfo: (varinfo -> varinfo -> unit) -> unit; iter_visitor_compinfo: (compinfo -> compinfo -> unit) -> unit; iter_visitor_enuminfo: (enuminfo -> enuminfo -> unit) -> unit; iter_visitor_enumitem: (enumitem -> enumitem -> unit) -> unit; iter_visitor_typeinfo: (typeinfo -> typeinfo -> unit) -> unit; iter_visitor_stmt: (stmt -> stmt -> unit) -> unit; iter_visitor_logic_info: (logic_info -> logic_info -> unit) -> unit; iter_visitor_logic_type_info: (logic_type_info -> logic_type_info -> unit) -> unit; iter_visitor_fieldinfo: (fieldinfo -> fieldinfo -> unit) -> unit; iter_visitor_model_info: (model_info -> model_info -> unit) -> unit; iter_visitor_logic_var: (logic_var -> logic_var -> unit) -> unit; iter_visitor_kernel_function: (kernel_function -> kernel_function -> unit) -> unit; iter_visitor_fundec: (fundec -> fundec -> unit) -> unit; (* folds over tables *) fold_visitor_varinfo: 'a.(varinfo -> varinfo -> 'a -> 'a) -> 'a -> 'a; fold_visitor_compinfo: 'a.(compinfo -> compinfo -> 'a -> 'a) -> 'a -> 'a; fold_visitor_enuminfo: 'a.(enuminfo -> enuminfo -> 'a -> 'a) -> 'a -> 'a; fold_visitor_enumitem: 'a.(enumitem -> enumitem -> 'a -> 'a) -> 'a -> 'a; fold_visitor_typeinfo: 'a.(typeinfo -> typeinfo -> 'a -> 'a) -> 'a -> 'a; fold_visitor_stmt: 'a.(stmt -> stmt -> 'a -> 'a) -> 'a -> 'a; fold_visitor_logic_info: 'a. (logic_info -> logic_info -> 'a -> 'a) -> 'a -> 'a; fold_visitor_logic_type_info: 'a.(logic_type_info -> logic_type_info -> 'a -> 'a) -> 'a -> 'a; fold_visitor_fieldinfo: 'a.(fieldinfo -> fieldinfo -> 'a -> 'a) -> 'a -> 'a; fold_visitor_model_info: 'a. (model_info -> model_info -> 'a -> 'a) -> 'a -> 'a; fold_visitor_logic_var: 'a.(logic_var -> logic_var -> 'a -> 'a) -> 'a -> 'a; fold_visitor_kernel_function: 'a.(kernel_function -> kernel_function -> 'a -> 'a) -> 'a -> 'a; fold_visitor_fundec: 'a.(fundec -> fundec -> 'a -> 'a) -> 'a -> 'a; } let is_copy_behavior b = b.is_copy_behavior let memo_varinfo b = b.memo_varinfo let memo_compinfo b = b.memo_compinfo let memo_fieldinfo b = b.memo_fieldinfo let memo_model_info b = b.memo_model_info let memo_enuminfo b = b.memo_enuminfo let memo_enumitem b = b.memo_enumitem let memo_stmt b = b.memo_stmt let memo_typeinfo b = b.memo_typeinfo let memo_logic_info b = b.memo_logic_info let memo_logic_type_info b = b.memo_logic_type_info let memo_logic_var b = b.memo_logic_var let memo_kernel_function b = b.memo_kernel_function let memo_fundec b = b.memo_fundec let reset_behavior_varinfo b = b.reset_behavior_varinfo () let reset_behavior_compinfo b = b.reset_behavior_compinfo () let reset_behavior_enuminfo b = b.reset_behavior_enuminfo () let reset_behavior_enumitem b = b.reset_behavior_enumitem () let reset_behavior_typeinfo b = b.reset_behavior_typeinfo () let reset_behavior_logic_info b = b.reset_behavior_logic_info () let reset_behavior_logic_type_info b = b.reset_behavior_logic_type_info () let reset_behavior_fieldinfo b = b.reset_behavior_fieldinfo () let reset_behavior_model_info b = b.reset_behavior_model_info () let reset_behavior_stmt b = b.reset_behavior_stmt () let reset_logic_var b = b.reset_logic_var () let reset_behavior_kernel_function b = b.reset_behavior_kernel_function () let reset_behavior_fundec b = b.reset_behavior_fundec () let get_varinfo b = b.get_varinfo let get_compinfo b = b.get_compinfo let get_fieldinfo b = b.get_fieldinfo let get_model_info b = b.get_model_info let get_enuminfo b = b.get_enuminfo let get_enumitem b = b.get_enumitem let get_stmt b = b.get_stmt let get_typeinfo b = b.get_typeinfo let get_logic_info b = b.get_logic_info let get_logic_type_info b = b.get_logic_type_info let get_logic_var b = b.get_logic_var let get_kernel_function b = b.get_kernel_function let get_fundec b = b.get_fundec let get_original_varinfo b = b.get_original_varinfo let get_original_compinfo b = b.get_original_compinfo let get_original_fieldinfo b = b.get_original_fieldinfo let get_original_model_info b = b.get_original_model_info let get_original_enuminfo b = b.get_original_enuminfo let get_original_enumitem b = b.get_original_enumitem let get_original_stmt b = b.get_original_stmt let get_original_typeinfo b = b.get_original_typeinfo let get_original_logic_info b = b.get_original_logic_info let get_original_logic_type_info b = b.get_original_logic_type_info let get_original_logic_var b = b.get_original_logic_var let get_original_kernel_function b = b.get_original_kernel_function let get_original_fundec b = b.get_original_fundec let set_varinfo b = b.set_varinfo let set_compinfo b = b.set_compinfo let set_fieldinfo b = b.set_fieldinfo let set_model_info b = b.set_model_info let set_enuminfo b = b.set_enuminfo let set_enumitem b = b.set_enumitem let set_stmt b = b.set_stmt let set_typeinfo b = b.set_typeinfo let set_logic_info b = b.set_logic_info let set_logic_type_info b = b.set_logic_type_info let set_logic_var b = b.set_logic_var let set_kernel_function b = b.set_kernel_function let set_fundec b = b.set_fundec let set_orig_varinfo b = b.set_orig_varinfo let set_orig_compinfo b = b.set_orig_compinfo let set_orig_fieldinfo b = b.set_orig_fieldinfo let set_orig_model_info b = b.set_model_info let set_orig_enuminfo b = b.set_orig_enuminfo let set_orig_enumitem b = b.set_orig_enumitem let set_orig_stmt b = b.set_orig_stmt let set_orig_typeinfo b = b.set_orig_typeinfo let set_orig_logic_info b = b.set_orig_logic_info let set_orig_logic_type_info b = b.set_orig_logic_type_info let set_orig_logic_var b = b.set_orig_logic_var let set_orig_kernel_function b= b.set_orig_kernel_function let set_orig_fundec b = b.set_orig_fundec let iter_visitor_varinfo b = b.iter_visitor_varinfo let iter_visitor_compinfo b = b.iter_visitor_compinfo let iter_visitor_enuminfo b = b.iter_visitor_enuminfo let iter_visitor_enumitem b = b.iter_visitor_enumitem let iter_visitor_typeinfo b = b.iter_visitor_typeinfo let iter_visitor_stmt b = b.iter_visitor_stmt let iter_visitor_logic_info b= b.iter_visitor_logic_info let iter_visitor_logic_type_info b = b .iter_visitor_logic_type_info let iter_visitor_fieldinfo b = b.iter_visitor_fieldinfo let iter_visitor_model_info b = b.iter_visitor_model_info let iter_visitor_logic_var b = b.iter_visitor_logic_var let iter_visitor_kernel_function b = b.iter_visitor_kernel_function let iter_visitor_fundec b = b.iter_visitor_fundec let fold_visitor_varinfo b = b.fold_visitor_varinfo let fold_visitor_compinfo b = b.fold_visitor_compinfo let fold_visitor_enuminfo b = b.fold_visitor_enuminfo let fold_visitor_enumitem b = b.fold_visitor_enumitem let fold_visitor_typeinfo b = b.fold_visitor_typeinfo let fold_visitor_stmt b = b.fold_visitor_stmt let fold_visitor_logic_info b = b.fold_visitor_logic_info let fold_visitor_logic_type_info b = b.fold_visitor_logic_type_info let fold_visitor_fieldinfo b = b.fold_visitor_fieldinfo let fold_visitor_model_info b = b.fold_visitor_model_info let fold_visitor_logic_var b = b.fold_visitor_logic_var let fold_visitor_kernel_function b = b.fold_visitor_kernel_function let fold_visitor_fundec b = b.fold_visitor_fundec let id = Extlib.id let alphabetaunit _ _ = () let alphabetabeta _ x = x let alphabetafalse _ _ = false let unitunit: unit -> unit = id let alphatrue _ = true let alphaunit _ = () let inplace_visit () = { cfile = id; get_compinfo = id; get_fieldinfo = id; get_model_info = id; get_enuminfo = id; get_enumitem = id; get_typeinfo = id; get_varinfo = id; get_logic_var = id; get_stmt = id; get_logic_info = id; get_logic_type_info = id; get_kernel_function = id; get_fundec = id; get_original_compinfo = id; get_original_fieldinfo = id; get_original_model_info = id; get_original_enuminfo = id; get_original_enumitem = id; get_original_typeinfo = id; get_original_varinfo = id; get_original_logic_var = id; get_original_stmt = id; get_original_logic_info = id; get_original_logic_type_info = id; get_original_kernel_function = id; get_original_fundec = id; cinitinfo = id; cblock = id; cfunspec = id; cfunbehavior = id; cidentified_term = id; cidentified_predicate = id; is_copy_behavior = false; project = None; memo_varinfo = id; memo_compinfo = id; memo_enuminfo = id; memo_enumitem = id; memo_typeinfo = id; memo_logic_info = id; memo_logic_type_info = id; memo_stmt = id; memo_fieldinfo = id; memo_model_info = id; memo_logic_var = id; memo_kernel_function = id; memo_fundec = id; set_varinfo = alphabetaunit; set_compinfo = alphabetaunit; set_enuminfo = alphabetaunit; set_enumitem = alphabetaunit; set_typeinfo = alphabetaunit; set_logic_info = alphabetaunit; set_logic_type_info = alphabetaunit; set_stmt = alphabetaunit; set_fieldinfo = alphabetaunit; set_model_info = alphabetaunit; set_logic_var = alphabetaunit; set_kernel_function = alphabetaunit; set_fundec = alphabetaunit; set_orig_varinfo = alphabetaunit; set_orig_compinfo = alphabetaunit; set_orig_enuminfo = alphabetaunit; set_orig_enumitem = alphabetaunit; set_orig_typeinfo = alphabetaunit; set_orig_logic_info = alphabetaunit; set_orig_logic_type_info = alphabetaunit; set_orig_stmt = alphabetaunit; set_orig_fieldinfo = alphabetaunit; set_orig_model_info = alphabetaunit; set_orig_logic_var = alphabetaunit; set_orig_kernel_function = alphabetaunit; set_orig_fundec = alphabetaunit; reset_behavior_varinfo = unitunit; reset_behavior_compinfo = unitunit; reset_behavior_enuminfo = unitunit; reset_behavior_enumitem = unitunit; reset_behavior_typeinfo = unitunit; reset_behavior_logic_info = unitunit; reset_behavior_logic_type_info = unitunit; reset_behavior_fieldinfo = unitunit; reset_behavior_model_info = unitunit; reset_behavior_stmt = unitunit; reset_logic_var = unitunit; reset_behavior_kernel_function = unitunit; reset_behavior_fundec = unitunit; iter_visitor_varinfo = alphaunit; iter_visitor_compinfo = alphaunit; iter_visitor_enuminfo = alphaunit; iter_visitor_enumitem = alphaunit; iter_visitor_typeinfo = alphaunit; iter_visitor_stmt = alphaunit; iter_visitor_logic_info = alphaunit; iter_visitor_logic_type_info = alphaunit; iter_visitor_fieldinfo = alphaunit; iter_visitor_model_info = alphaunit; iter_visitor_logic_var = alphaunit; iter_visitor_kernel_function = alphaunit; iter_visitor_fundec = alphaunit; fold_visitor_varinfo = alphabetabeta; fold_visitor_compinfo = alphabetabeta; fold_visitor_enuminfo = alphabetabeta; fold_visitor_enumitem = alphabetabeta; fold_visitor_typeinfo = alphabetabeta; fold_visitor_stmt = alphabetabeta; fold_visitor_logic_info = alphabetabeta; fold_visitor_logic_type_info = alphabetabeta; fold_visitor_fieldinfo = alphabetabeta; fold_visitor_model_info = alphabetabeta; fold_visitor_logic_var = alphabetabeta; fold_visitor_kernel_function = alphabetabeta; fold_visitor_fundec = alphabetabeta; } let copy_visit prj = let varinfos = Cil_datatype.Varinfo.Hashtbl.create 103 in let compinfos = Cil_datatype.Compinfo.Hashtbl.create 17 in let enuminfos = Cil_datatype.Enuminfo.Hashtbl.create 17 in let enumitems = Cil_datatype.Enumitem.Hashtbl.create 17 in let typeinfos = Cil_datatype.Typeinfo.Hashtbl.create 17 in let logic_infos = Cil_datatype.Logic_info.Hashtbl.create 17 in let logic_type_infos = Cil_datatype.Logic_type_info.Hashtbl.create 17 in let fieldinfos = Cil_datatype.Fieldinfo.Hashtbl.create 17 in let model_infos = Cil_datatype.Model_info.Hashtbl.create 17 in let stmts = Cil_datatype.Stmt.Hashtbl.create 103 in let logic_vars = Cil_datatype.Logic_var.Hashtbl.create 17 in let kernel_functions = Cil_datatype.Kf.Hashtbl.create 17 in let fundecs = Cil_datatype.Varinfo.Hashtbl.create 17 in let orig_varinfos = Cil_datatype.Varinfo.Hashtbl.create 103 in let orig_compinfos = Cil_datatype.Compinfo.Hashtbl.create 17 in let orig_enuminfos = Cil_datatype.Enuminfo.Hashtbl.create 17 in let orig_enumitems = Cil_datatype.Enumitem.Hashtbl.create 17 in let orig_typeinfos = Cil_datatype.Typeinfo.Hashtbl.create 17 in let orig_logic_infos = Cil_datatype.Logic_info.Hashtbl.create 17 in let orig_logic_type_infos = Cil_datatype.Logic_type_info.Hashtbl.create 17 in let orig_fieldinfos = Cil_datatype.Fieldinfo.Hashtbl.create 17 in let orig_model_infos = Cil_datatype.Model_info.Hashtbl.create 17 in let orig_stmts = Cil_datatype.Stmt.Hashtbl.create 103 in let orig_logic_vars = Cil_datatype.Logic_var.Hashtbl.create 17 in let orig_kernel_functions = Cil_datatype.Kf.Hashtbl.create 17 in let orig_fundecs = Cil_datatype.Varinfo.Hashtbl.create 17 in let temp_memo_logic_var x = (* Format.printf "search for %s#%d@." x.lv_name x.lv_id;*) let res = try Cil_datatype.Logic_var.Hashtbl.find logic_vars x with Not_found -> (* Format.printf "Not found@.";*) let new_x = { x with lv_id = x.lv_id } in Cil_datatype.Logic_var.Hashtbl.add logic_vars x new_x; Cil_datatype.Logic_var.Hashtbl.add orig_logic_vars new_x x; new_x in (* Format.printf "res is %s#%d@." res.lv_name res.lv_id;*) res in let temp_memo_varinfo x = try Cil_datatype.Varinfo.Hashtbl.find varinfos x with Not_found -> let new_x = { x with vid = x.vid } in Cil_datatype.Varinfo.Hashtbl.add varinfos x new_x; Cil_datatype.Varinfo.Hashtbl.add orig_varinfos new_x x; new_x in let temp_memo_fundec f = try Cil_datatype.Varinfo.Hashtbl.find fundecs f.svar with Not_found -> let v = temp_memo_varinfo f.svar in let new_f = { f with svar = v } in Cil_datatype.Varinfo.Hashtbl.add fundecs f.svar new_f; Cil_datatype.Varinfo.Hashtbl.add orig_fundecs v f; new_f in { cfile = (fun x -> { x with fileName = x.fileName }); get_compinfo = (fun x -> try Cil_datatype.Compinfo.Hashtbl.find compinfos x with Not_found -> x); get_fieldinfo = (fun x -> try Cil_datatype.Fieldinfo.Hashtbl.find fieldinfos x with Not_found -> x); get_model_info = (fun x -> try Cil_datatype.Model_info.Hashtbl.find model_infos x with Not_found -> x); get_enuminfo = (fun x -> try Cil_datatype.Enuminfo.Hashtbl.find enuminfos x with Not_found -> x); get_enumitem = (fun x -> try Cil_datatype.Enumitem.Hashtbl.find enumitems x with Not_found -> x); get_typeinfo = (fun x -> try Cil_datatype.Typeinfo.Hashtbl.find typeinfos x with Not_found -> x); get_varinfo = (fun x -> try Cil_datatype.Varinfo.Hashtbl.find varinfos x with Not_found -> x); get_stmt = (fun x -> try Cil_datatype.Stmt.Hashtbl.find stmts x with Not_found -> x); get_logic_info = (fun x -> try Cil_datatype.Logic_info.Hashtbl.find logic_infos x with Not_found -> x); get_logic_type_info = (fun x -> try Cil_datatype.Logic_type_info.Hashtbl.find logic_type_infos x with Not_found -> x); get_logic_var = (fun x -> try Cil_datatype.Logic_var.Hashtbl.find logic_vars x with Not_found -> x); get_kernel_function = (fun x -> try Cil_datatype.Kf.Hashtbl.find kernel_functions x with Not_found -> x); get_fundec = (fun x -> try Cil_datatype.Varinfo.Hashtbl.find fundecs x.svar with Not_found -> x); get_original_compinfo = (fun x -> try Cil_datatype.Compinfo.Hashtbl.find orig_compinfos x with Not_found -> x); get_original_fieldinfo = (fun x -> try Cil_datatype.Fieldinfo.Hashtbl.find orig_fieldinfos x with Not_found -> x); get_original_model_info = (fun x -> try Cil_datatype.Model_info.Hashtbl.find orig_model_infos x with Not_found -> x); get_original_enuminfo = (fun x -> try Cil_datatype.Enuminfo.Hashtbl.find orig_enuminfos x with Not_found -> x); get_original_enumitem = (fun x -> try Cil_datatype.Enumitem.Hashtbl.find orig_enumitems x with Not_found -> x); get_original_typeinfo = (fun x -> try Cil_datatype.Typeinfo.Hashtbl.find orig_typeinfos x with Not_found -> x); get_original_varinfo = (fun x -> try Cil_datatype.Varinfo.Hashtbl.find orig_varinfos x with Not_found -> x); get_original_stmt = (fun x -> try Cil_datatype.Stmt.Hashtbl.find orig_stmts x with Not_found -> x); get_original_logic_var = (fun x -> try Cil_datatype.Logic_var.Hashtbl.find orig_logic_vars x with Not_found -> x); get_original_logic_info = (fun x -> try Cil_datatype.Logic_info.Hashtbl.find orig_logic_infos x with Not_found -> x); get_original_logic_type_info = (fun x -> try Cil_datatype.Logic_type_info.Hashtbl.find orig_logic_type_infos x with Not_found -> x); get_original_kernel_function = (fun x -> try Cil_datatype.Kf.Hashtbl.find orig_kernel_functions x with Not_found -> x); get_original_fundec = (fun x -> try Cil_datatype.Varinfo.Hashtbl.find orig_fundecs x.svar with Not_found -> x); cinitinfo = (fun x -> { init = x.init }); cblock = (fun x -> { x with battrs = x.battrs }); cfunspec = (fun x -> { x with spec_behavior = x.spec_behavior}); cfunbehavior = (fun x -> { x with b_name = x.b_name}); cidentified_predicate = (fun x -> { x with ip_id = x.ip_id }); cidentified_term = (fun x -> { x with it_id = x.it_id}); is_copy_behavior = true; project = Some prj; reset_behavior_varinfo = (fun () -> Cil_datatype.Varinfo.Hashtbl.clear varinfos; Cil_datatype.Varinfo.Hashtbl.clear orig_varinfos); reset_behavior_compinfo = (fun () -> Cil_datatype.Compinfo.Hashtbl.clear compinfos; Cil_datatype.Compinfo.Hashtbl.clear orig_compinfos); reset_behavior_enuminfo = (fun () -> Cil_datatype.Enuminfo.Hashtbl.clear enuminfos; Cil_datatype.Enuminfo.Hashtbl.clear orig_enuminfos); reset_behavior_enumitem = (fun () -> Cil_datatype.Enumitem.Hashtbl.clear enumitems; Cil_datatype.Enumitem.Hashtbl.clear orig_enumitems); reset_behavior_typeinfo = (fun () -> Cil_datatype.Typeinfo.Hashtbl.clear typeinfos; Cil_datatype.Typeinfo.Hashtbl.clear orig_typeinfos); reset_behavior_logic_info = (fun () -> Cil_datatype.Logic_info.Hashtbl.clear logic_infos; Cil_datatype.Logic_info.Hashtbl.clear orig_logic_infos); reset_behavior_logic_type_info = (fun () -> Cil_datatype.Logic_type_info.Hashtbl.clear logic_type_infos; Cil_datatype.Logic_type_info.Hashtbl.clear orig_logic_type_infos); reset_behavior_fieldinfo = (fun () -> Cil_datatype.Fieldinfo.Hashtbl.clear fieldinfos; Cil_datatype.Fieldinfo.Hashtbl.clear orig_fieldinfos); reset_behavior_model_info = (fun () -> Cil_datatype.Model_info.Hashtbl.clear model_infos; Cil_datatype.Model_info.Hashtbl.clear orig_model_infos); reset_behavior_stmt = (fun () -> Cil_datatype.Stmt.Hashtbl.clear stmts; Cil_datatype.Stmt.Hashtbl.clear orig_stmts); reset_logic_var = (fun () -> Cil_datatype.Logic_var.Hashtbl.clear logic_vars; Cil_datatype.Logic_var.Hashtbl.clear orig_logic_vars); reset_behavior_kernel_function = (fun () -> Cil_datatype.Kf.Hashtbl.clear kernel_functions; Cil_datatype.Kf.Hashtbl.clear orig_kernel_functions); reset_behavior_fundec = (fun () -> Cil_datatype.Varinfo.Hashtbl.clear fundecs; Cil_datatype.Varinfo.Hashtbl.clear orig_fundecs); memo_varinfo = temp_memo_varinfo; memo_compinfo = (fun x -> try Cil_datatype.Compinfo.Hashtbl.find compinfos x with Not_found -> let new_x = { x with ckey = x.ckey } in Cil_datatype.Compinfo.Hashtbl.add compinfos x new_x; Cil_datatype.Compinfo.Hashtbl.add orig_compinfos new_x x; new_x); memo_enuminfo = (fun x -> try Cil_datatype.Enuminfo.Hashtbl.find enuminfos x with Not_found -> let new_x = { x with ename = x.ename } in Cil_datatype.Enuminfo.Hashtbl.add enuminfos x new_x; Cil_datatype.Enuminfo.Hashtbl.add orig_enuminfos new_x x; new_x); memo_enumitem = (fun x -> try Cil_datatype.Enumitem.Hashtbl.find enumitems x with Not_found -> let new_x = { x with einame = x.einame } in Cil_datatype.Enumitem.Hashtbl.add enumitems x new_x; Cil_datatype.Enumitem.Hashtbl.add orig_enumitems new_x x; new_x); memo_typeinfo = (fun x -> try Cil_datatype.Typeinfo.Hashtbl.find typeinfos x with Not_found -> let new_x = { x with tname = x.tname } in Cil_datatype.Typeinfo.Hashtbl.add typeinfos x new_x; Cil_datatype.Typeinfo.Hashtbl.add orig_typeinfos new_x x; new_x); memo_logic_info = (fun x -> try Cil_datatype.Logic_info.Hashtbl.find logic_infos x with Not_found -> let new_v = temp_memo_logic_var x.l_var_info in let new_x = { x with l_var_info = new_v } in Cil_datatype.Logic_info.Hashtbl.add logic_infos x new_x; Cil_datatype.Logic_info.Hashtbl.add orig_logic_infos new_x x; new_x); memo_logic_type_info = (fun x -> try Cil_datatype.Logic_type_info.Hashtbl.find logic_type_infos x with Not_found -> let new_x = { x with lt_name = x.lt_name } in Cil_datatype.Logic_type_info.Hashtbl.add logic_type_infos x new_x; Cil_datatype.Logic_type_info.Hashtbl.add orig_logic_type_infos new_x x; new_x); memo_stmt = (fun x -> try Cil_datatype.Stmt.Hashtbl.find stmts x with Not_found -> let new_x = { x with sid = x.sid } in Cil_datatype.Stmt.Hashtbl.add stmts x new_x; Cil_datatype.Stmt.Hashtbl.add orig_stmts new_x x; new_x); memo_fieldinfo = (fun x -> try Cil_datatype.Fieldinfo.Hashtbl.find fieldinfos x with Not_found -> let new_x = { x with fname = x.fname } in Cil_datatype.Fieldinfo.Hashtbl.add fieldinfos x new_x; Cil_datatype.Fieldinfo.Hashtbl.add orig_fieldinfos new_x x; new_x); memo_model_info = (fun x -> try Cil_datatype.Model_info.Hashtbl.find model_infos x with Not_found -> let new_x = { x with mi_name = x.mi_name } in Cil_datatype.Model_info.Hashtbl.add model_infos x new_x; Cil_datatype.Model_info.Hashtbl.add orig_model_infos new_x x; new_x ); memo_logic_var = temp_memo_logic_var; memo_kernel_function = (fun x -> try Cil_datatype.Kf.Hashtbl.find kernel_functions x with Not_found -> let fundec = match x.fundec with | Definition (f,l) -> Definition (temp_memo_fundec f,l) | Declaration(s,v,p,l) -> Declaration(s,temp_memo_varinfo v,p,l) in let new_x = { x with fundec = fundec } in Cil_datatype.Kf.Hashtbl.add kernel_functions x new_x; Cil_datatype.Kf.Hashtbl.add orig_kernel_functions new_x x; new_x); memo_fundec = temp_memo_fundec; set_varinfo = Cil_datatype.Varinfo.Hashtbl.replace varinfos; set_compinfo = Cil_datatype.Compinfo.Hashtbl.replace compinfos; set_enuminfo = Cil_datatype.Enuminfo.Hashtbl.replace enuminfos; set_enumitem = Cil_datatype.Enumitem.Hashtbl.replace enumitems; set_typeinfo = Cil_datatype.Typeinfo.Hashtbl.replace typeinfos; set_logic_info = Cil_datatype.Logic_info.Hashtbl.replace logic_infos; set_logic_type_info = Cil_datatype.Logic_type_info.Hashtbl.replace logic_type_infos; set_stmt = Cil_datatype.Stmt.Hashtbl.replace stmts; set_fieldinfo = Cil_datatype.Fieldinfo.Hashtbl.replace fieldinfos; set_model_info = Cil_datatype.Model_info.Hashtbl.replace model_infos; set_logic_var = Cil_datatype.Logic_var.Hashtbl.replace logic_vars; set_kernel_function = Cil_datatype.Kf.Hashtbl.replace kernel_functions; set_fundec = (fun x y -> Cil_datatype.Varinfo.Hashtbl.replace fundecs x.svar y); set_orig_varinfo = Cil_datatype.Varinfo.Hashtbl.replace orig_varinfos; set_orig_compinfo = Cil_datatype.Compinfo.Hashtbl.replace orig_compinfos; set_orig_enuminfo = Cil_datatype.Enuminfo.Hashtbl.replace orig_enuminfos; set_orig_enumitem = Cil_datatype.Enumitem.Hashtbl.replace orig_enumitems; set_orig_typeinfo = Cil_datatype.Typeinfo.Hashtbl.replace orig_typeinfos; set_orig_logic_info = Cil_datatype.Logic_info.Hashtbl.replace orig_logic_infos; set_orig_logic_type_info = Cil_datatype.Logic_type_info.Hashtbl.replace orig_logic_type_infos; set_orig_stmt = Cil_datatype.Stmt.Hashtbl.replace orig_stmts; set_orig_fieldinfo = Cil_datatype.Fieldinfo.Hashtbl.replace orig_fieldinfos; set_orig_model_info = Cil_datatype.Model_info.Hashtbl.replace orig_model_infos; set_orig_logic_var = Cil_datatype.Logic_var.Hashtbl.replace orig_logic_vars; set_orig_kernel_function = Cil_datatype.Kf.Hashtbl.replace orig_kernel_functions; set_orig_fundec = (fun x y -> Cil_datatype.Varinfo.Hashtbl.replace orig_fundecs x.svar y); iter_visitor_varinfo = (fun f -> Cil_datatype.Varinfo.Hashtbl.iter f varinfos); iter_visitor_compinfo = (fun f -> Cil_datatype.Compinfo.Hashtbl.iter f compinfos); iter_visitor_enuminfo = (fun f -> Cil_datatype.Enuminfo.Hashtbl.iter f enuminfos); iter_visitor_enumitem = (fun f -> Cil_datatype.Enumitem.Hashtbl.iter f enumitems); iter_visitor_typeinfo = (fun f -> Cil_datatype.Typeinfo.Hashtbl.iter f typeinfos); iter_visitor_stmt = (fun f -> Cil_datatype.Stmt.Hashtbl.iter f stmts); iter_visitor_logic_info = (fun f -> Cil_datatype.Logic_info.Hashtbl.iter f logic_infos); iter_visitor_logic_type_info = (fun f -> Cil_datatype.Logic_type_info.Hashtbl.iter f logic_type_infos); iter_visitor_fieldinfo = (fun f -> Cil_datatype.Fieldinfo.Hashtbl.iter f fieldinfos); iter_visitor_model_info = (fun f -> Cil_datatype.Model_info.Hashtbl.iter f model_infos); iter_visitor_logic_var = (fun f -> Cil_datatype.Logic_var.Hashtbl.iter f logic_vars); iter_visitor_kernel_function = (fun f -> Cil_datatype.Kf.Hashtbl.iter f kernel_functions); iter_visitor_fundec = (fun f -> let f _ new_fundec = let old_fundec = Cil_datatype.Varinfo.Hashtbl.find orig_fundecs new_fundec.svar in f old_fundec new_fundec in Cil_datatype.Varinfo.Hashtbl.iter f fundecs); fold_visitor_varinfo = (fun f i -> Cil_datatype.Varinfo.Hashtbl.fold f varinfos i); fold_visitor_compinfo = (fun f i -> Cil_datatype.Compinfo.Hashtbl.fold f compinfos i); fold_visitor_enuminfo = (fun f i -> Cil_datatype.Enuminfo.Hashtbl.fold f enuminfos i); fold_visitor_enumitem = (fun f i -> Cil_datatype.Enumitem.Hashtbl.fold f enumitems i); fold_visitor_typeinfo = (fun f i -> Cil_datatype.Typeinfo.Hashtbl.fold f typeinfos i); fold_visitor_stmt = (fun f i -> Cil_datatype.Stmt.Hashtbl.fold f stmts i); fold_visitor_logic_info = (fun f i -> Cil_datatype.Logic_info.Hashtbl.fold f logic_infos i); fold_visitor_logic_type_info = (fun f i -> Cil_datatype.Logic_type_info.Hashtbl.fold f logic_type_infos i); fold_visitor_fieldinfo = (fun f i -> Cil_datatype.Fieldinfo.Hashtbl.fold f fieldinfos i); fold_visitor_model_info = (fun f i -> Cil_datatype.Model_info.Hashtbl.fold f model_infos i); fold_visitor_logic_var = (fun f i -> Cil_datatype.Logic_var.Hashtbl.fold f logic_vars i); fold_visitor_kernel_function = (fun f i -> Cil_datatype.Kf.Hashtbl.fold f kernel_functions i); fold_visitor_fundec = (fun f i -> let f _ new_fundec acc = let old_fundec = Cil_datatype.Varinfo.Hashtbl.find orig_fundecs new_fundec.svar in f old_fundec new_fundec acc in Cil_datatype.Varinfo.Hashtbl.fold f fundecs i); } (* sm/gn: cil visitor interface for traversing Cil trees. *) (* Use visitCilStmt and/or visitCilFile to use this. *) (* Some of the nodes are changed in place if the children are changed. Use * one of Change... actions if you want to copy the node *) (** A visitor interface for traversing CIL trees. Create instantiations of * this type by specializing the class {!Cil.nopCilVisitor}. *) class type cilVisitor = object method behavior: visitor_behavior method project: Project.t option method plain_copy_visitor: cilVisitor method vfile: file -> file visitAction (** visit a file. *) method vvdec: varinfo -> varinfo visitAction (** Invoked for each variable declaration. The subtrees to be traversed * are those corresponding to the type and attributes of the variable. * Note that variable declarations are all the [GVar], [GVarDecl], [GFun], * all the [varinfo] in formals of function types, and the formals and * locals for function definitions. This means that the list of formals * in a function definition will be traversed twice, once as part of the * function type and second as part of the formals in a function * definition. *) method vvrbl: varinfo -> varinfo visitAction (** Invoked on each variable use. Here only the [SkipChildren] and * [ChangeTo] actions make sense since there are no subtrees. Note that * the type and attributes of the variable are not traversed for a * variable use *) method vexpr: exp -> exp visitAction (** Invoked on each expression occurence. The subtrees are the * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the * variable use. *) method vlval: lval -> lval visitAction (** Invoked on each lvalue occurence *) method voffs: offset -> offset visitAction (** Invoked on each offset occurrence that is *not* as part * of an initializer list specification, i.e. in an lval or * recursively inside an offset. *) method vinitoffs: offset -> offset visitAction (** Invoked on each offset appearing in the list of a * CompoundInit initializer. *) method vinst: instr -> instr list visitAction (** Invoked on each instruction occurrence. The [ChangeTo] action can * replace this instruction with a list of instructions *) method vstmt: stmt -> stmt visitAction (** Control-flow statement. *) method vblock: block -> block visitAction (** Block. Replaced in place. *) method vfunc: fundec -> fundec visitAction (** Function definition. Replaced in place. *) method vglob: global -> global list visitAction (** Global (vars, types, etc.) *) method vinit: varinfo -> offset -> init -> init visitAction (** Initializers for globals, * pass the global where this * occurs, and the offset *) method vtype: typ -> typ visitAction (** Use of some type. Note * that for structure/union * and enumeration types the * definition of the * composite type is not * visited. Use [vglob] to * visit it. *) method vcompinfo: compinfo -> compinfo visitAction method venuminfo: enuminfo -> enuminfo visitAction method vfieldinfo: fieldinfo -> fieldinfo visitAction method venumitem: enumitem -> enumitem visitAction method vattr: attribute -> attribute list visitAction (** Attribute. Each attribute can be replaced by a list *) method vattrparam: attrparam -> attrparam visitAction (** Attribute parameters. *) (** Add here instructions while visiting to queue them to * preceede the current statement or instruction being processed *) method queueInstr: instr list -> unit (** Gets the queue of instructions and resets the queue *) method unqueueInstr: unit -> instr list val current_stmt : stmt Stack.t method push_stmt: stmt -> unit method pop_stmt: stmt -> unit method current_stmt: stmt option method current_kinstr: kinstr method current_func: fundec option method set_current_func: fundec -> unit method reset_current_func: unit -> unit method vlogic_type: logic_type -> logic_type visitAction method vmodel_info: model_info -> model_info visitAction method videntified_term: identified_term -> identified_term visitAction method vterm: term -> term visitAction method vterm_node: term_node -> term_node visitAction method vterm_lval: term_lval -> term_lval visitAction method vterm_lhost: term_lhost -> term_lhost visitAction method vterm_offset: term_offset -> term_offset visitAction method vlogic_label: logic_label -> logic_label visitAction method vlogic_info_decl: logic_info -> logic_info visitAction method vlogic_info_use: logic_info -> logic_info visitAction method vlogic_type_info_decl: logic_type_info -> logic_type_info visitAction method vlogic_type_info_use: logic_type_info -> logic_type_info visitAction method vlogic_type_def: logic_type_def -> logic_type_def visitAction method vlogic_ctor_info_decl: logic_ctor_info -> logic_ctor_info visitAction method vlogic_ctor_info_use: logic_ctor_info -> logic_ctor_info visitAction method vlogic_var_use: logic_var -> logic_var visitAction method vlogic_var_decl: logic_var -> logic_var visitAction method vquantifiers: quantifiers -> quantifiers visitAction method videntified_predicate: identified_predicate -> identified_predicate visitAction method vpredicate: predicate -> predicate visitAction method vpredicate_named: predicate named -> predicate named visitAction method vbehavior: funbehavior -> funbehavior visitAction method vspec: funspec -> funspec visitAction method vassigns: identified_term assigns -> identified_term assigns visitAction method vfrees: identified_term list -> identified_term list visitAction method vallocates: identified_term list -> identified_term list visitAction method vallocation: identified_term allocation -> identified_term allocation visitAction method vloop_pragma: term loop_pragma -> term loop_pragma visitAction method vslice_pragma: term slice_pragma -> term slice_pragma visitAction method vimpact_pragma: term impact_pragma -> term impact_pragma visitAction method vdeps: identified_term deps -> identified_term deps visitAction method vfrom: identified_term from -> identified_term from visitAction method vcode_annot: code_annotation -> code_annotation visitAction method vannotation: global_annotation -> global_annotation visitAction method fill_global_tables: unit method get_filling_actions: (unit -> unit) Queue.t end (* the default visitor does nothing at each node, but does *) (* not stop; hence they return true *) class internal_genericCilVisitor current_func behavior queue: cilVisitor = object(self) method behavior = behavior method project = behavior.project; method plain_copy_visitor = let obj = new internal_genericCilVisitor current_func behavior queue in assert (obj#get_filling_actions == self#get_filling_actions); obj method fill_global_tables = let action () = Queue.iter (fun f -> f()) queue in (match self#project with | None -> action () | Some prj -> Project.on prj action ()); Queue.clear queue method get_filling_actions = queue method vfile _f = DoChildren val current_stmt = Stack.create () method push_stmt s = Stack.push s current_stmt method pop_stmt _s = ignore (Stack.pop current_stmt) method current_stmt = try Some (Stack.top current_stmt) with Stack.Empty -> None method current_kinstr = try Kstmt (Stack.top current_stmt) with Stack.Empty -> Kglobal method current_func = !current_func method set_current_func f = current_func := Some f method reset_current_func () = current_func := None method vvrbl (_v:varinfo) = DoChildren method vvdec (_v:varinfo) = DoChildren method vexpr (_e:exp) = DoChildren method vlval (_l:lval) = DoChildren method voffs (_o:offset) = DoChildren method vinitoffs (_o:offset) = DoChildren method vinst (_i:instr) = DoChildren method vstmt (_s:stmt) = DoChildren method vblock (_b: block) = DoChildren method vfunc (_f:fundec) = DoChildren method vglob (_g:global) = DoChildren method vinit (_forg: varinfo) (_off: offset) (_i:init) = DoChildren method vtype (_t:typ) = DoChildren method vcompinfo _ = DoChildren method venuminfo _ = DoChildren method vfieldinfo _ = DoChildren method venumitem _ = DoChildren method vattr (_a: attribute) = DoChildren method vattrparam (_a: attrparam) = DoChildren val mutable instrQueue = [] method queueInstr (il: instr list) = List.iter (fun i -> instrQueue <- i :: instrQueue) il method unqueueInstr () = let res = List.rev instrQueue in instrQueue <- []; res method vmodel_info _ = DoChildren method vlogic_type _lt = DoChildren method videntified_term _t = DoChildren method vterm _t = DoChildren method vlogic_label _l = DoChildren method vterm_node _tn = DoChildren method vterm_lval _tl = DoChildren method vterm_lhost _tl = DoChildren method vterm_offset _vo = DoChildren method vlogic_info_decl _li = DoChildren method vlogic_info_use _li = DoChildren method vlogic_type_info_decl _ = DoChildren method vlogic_type_info_use _ = DoChildren method vlogic_type_def _ = DoChildren method vlogic_ctor_info_decl _ = DoChildren method vlogic_ctor_info_use _ = DoChildren method vlogic_var_decl _lv = DoChildren method vlogic_var_use _lv = DoChildren method vquantifiers _q = DoChildren method videntified_predicate _ip = DoChildren method vpredicate _p = DoChildren method vpredicate_named _p = DoChildren method vbehavior _b = DoChildren method vspec _s = DoChildren method vassigns _s = DoChildren method vfrees _s = DoChildren method vallocates _s = DoChildren method vallocation _s = DoChildren method vloop_pragma _ = DoChildren method vslice_pragma _ = DoChildren method vimpact_pragma _ = DoChildren method vdeps _ = DoChildren method vfrom _ = DoChildren method vcode_annot _ca = DoChildren method vannotation _a = DoChildren end class genericCilVisitor bhv = let current_func = ref None in let queue = Queue.create () in internal_genericCilVisitor current_func bhv queue class nopCilVisitor = object inherit genericCilVisitor (inplace_visit ()) end let apply_on_project ?selection vis f arg = match vis#project with | None -> f arg | Some prj -> Project.on ?selection prj f arg let assertEmptyQueue vis = if vis#unqueueInstr () <> [] then (* Either a visitor inserted an instruction somewhere that it shouldn't have (i.e. at the top level rather than inside of a statement), or there's a bug in the visitor engine. *) Kernel.fatal "Visitor's instruction queue is not empty.@\n\ You should only use queueInstr inside a function body!"; () (*** Define the visiting engine ****) (* visit all the nodes in a Cil expression *) let doVisit (vis: 'visitor) only_copy_vis (previsit: 'a -> 'a) (startvisit: 'a -> 'a visitAction) (children: 'visitor -> 'a -> 'a) (node: 'a) : 'a = let node' = previsit node in let action = startvisit node' in match action with SkipChildren -> node' | ChangeTo node' -> node' | ChangeToPost (node',f) -> f node' | DoChildren | DoChildrenPost _ | JustCopy | ChangeDoChildrenPost _ | JustCopyPost _ -> let nodepre = match action with ChangeDoChildrenPost (node', _) -> node' | _ -> node' in let vis = match action with JustCopy | JustCopyPost _ -> only_copy_vis | _ -> vis in let nodepost = children vis nodepre in match action with | DoChildrenPost f | ChangeDoChildrenPost (_, f) | JustCopyPost f -> f nodepost | _ -> nodepost let doVisitCil vis previsit startvisit children node = doVisit vis vis#plain_copy_visitor previsit startvisit children node let rev_until i l = let rec aux acc = function [] -> acc | i'::_ when i' == i -> acc | i'::l -> aux (i'::acc) l in aux [] l (* mapNoCopy is like map but avoid copying the list if the function does not * change the elements. *) let mapNoCopy (f: 'a -> 'a) orig = let rec aux ((acc,has_changed) as res) l = match l with [] -> if has_changed then List.rev acc else orig | i :: resti -> let i' = f i in if has_changed then aux (i'::acc,true) resti else if i' != i then aux (i'::rev_until i orig,true) resti else aux res resti in aux ([],false) orig let mapNoCopyList (f: 'a -> 'a list) orig = let rec aux ((acc,has_changed) as res) l = match l with [] -> if has_changed then List.rev acc else orig | i :: resti -> let l' = f i in if has_changed then aux (List.rev_append l' acc,true) resti else (match l' with [i'] when i' == i -> aux res resti | _ -> aux (List.rev_append l' (rev_until i orig), true) resti) in aux ([],false) orig (* A visitor for lists *) let doVisitList (vis: 'visit) only_copy_vis (previsit: 'a -> 'a) (startvisit: 'a -> 'a list visitAction) (children: 'visit -> 'a -> 'a) (node: 'a) : 'a list = let node' = previsit node in let action = startvisit node' in match action with SkipChildren -> [node'] | ChangeTo nodes' -> nodes' | ChangeToPost (nodes',f) -> f nodes' | _ -> let nodespre = match action with ChangeDoChildrenPost (nodespre, _) -> nodespre | _ -> [node'] in let vis = match action with JustCopy | JustCopyPost _ -> only_copy_vis | _ -> vis in let nodespost = mapNoCopy (children vis) nodespre in match action with | DoChildrenPost f | ChangeDoChildrenPost (_, f) | JustCopyPost f -> f nodespost | _ -> nodespost let doVisitListCil vis previsit startvisit children node = doVisitList vis vis#plain_copy_visitor previsit startvisit children node let optMapNoCopy f o = match o with None -> o | Some x -> let x' = f x in if x' != x then Some x' else o let debugVisit = false let visitCilConst vis c = match c with | CEnum ei -> (* In case of deep copy, we must change the enumitem*) let ei' = vis#behavior.get_enumitem ei in if ei' != ei then CEnum ei' else c | _ -> c let visitCilLConst vis c = match c with | LEnum ei -> (* In case of deep copy, we must change the enumitem*) let ei' = vis#behavior.get_enumitem ei in if ei' != ei then LEnum ei' else c | _ -> c let copy_logic_label is_copy l = if is_copy then begin match l with | StmtLabel s -> StmtLabel (ref !s) | LogicLabel(_,s) -> LogicLabel(None,s) (* we don't copy the associated statement. It will be recomputed if needed. *) end else l let rec visitCilTerm vis t = let oldloc = CurrentLoc.get () in CurrentLoc.set t.term_loc; let res = doVisitCil vis (fun x-> x) vis#vterm childrenTerm t in CurrentLoc.set oldloc; res and childrenTerm vis t = let tn' = visitCilTermNode vis t.term_node in let tt' = visitCilLogicType vis t.term_type in if tn' != t.term_node || tt' != t.term_type then { t with term_node = tn'; term_type = tt' } else t and visitCilTermNode vis tn = doVisitCil vis id vis#vterm_node childrenTermNode tn and childrenTermNode vis tn = let vTerm t = visitCilTerm vis t in let vTermLval tl = visitCilTermLval vis tl in let vTyp t = visitCilType vis t in let vLogicInfo li = visitCilLogicInfoUse vis li in match tn with | TConst c -> let c' = visitCilLConst vis c in if c' != c then TConst c' else tn | TDataCons (ci,args) -> let ci' = doVisitCil vis id vis#vlogic_ctor_info_use alphabetabeta ci in let args' = mapNoCopy vTerm args in if ci' != ci || args != args' then TDataCons(ci',args') else tn | TLval tl -> let tl' = vTermLval tl in if tl' != tl then TLval tl' else tn | TSizeOf t -> let t' = vTyp t in if t' != t then TSizeOf t' else tn | TSizeOfE t -> let t' = vTerm t in if t' != t then TSizeOfE t' else tn | TSizeOfStr _ -> tn | TAlignOf t -> let t' = vTyp t in if t' != t then TAlignOf t' else tn | TAlignOfE t -> let t' = vTerm t in if t' != t then TAlignOfE t' else tn | TUnOp (op,t) -> let t' = vTerm t in if t' != t then TUnOp (op,t') else tn | TBinOp(op,t1,t2) -> let t1' = vTerm t1 in let t2' = vTerm t2 in if t1' != t1 || t2' != t2 then TBinOp(op,t1',t2') else tn | TCastE(ty,te) -> let ty' = vTyp ty in let te' = vTerm te in if ty' != ty || te' != te then TCastE(ty',te') else tn | TAddrOf tl -> let tl' = vTermLval tl in if tl' != tl then TAddrOf tl' else tn | TStartOf tl -> let tl' = vTermLval tl in if tl' != tl then TStartOf tl' else tn | Tapp(li,labels,args) -> let li' = vLogicInfo li in let labels' = mapNoCopy (visitCilLogicLabelApp vis) labels in (* Format.eprintf "Cil.children_term_node: li = %s(%d), li' = %s(%d)@." li.l_var_info.lv_name li.l_var_info.lv_id li'.l_var_info.lv_name li'.l_var_info.lv_id; *) let args' = mapNoCopy vTerm args in if li' != li || labels' != labels || args' != args then Tapp(li',labels',args') else tn | Tif(test,ttrue,tfalse) -> let test' = vTerm test in let ttrue' = vTerm ttrue in let tfalse' = vTerm tfalse in if test' != test || ttrue' != ttrue || tfalse' != tfalse then Tif(test',ttrue',tfalse') else tn | Tat(t,s) -> let t' = vTerm t in let s' = visitCilLogicLabel vis s in if t' != t || s' != s then Tat (t',s') else tn | Toffset (s,t) -> let s' = visitCilLogicLabel vis s in let t' = vTerm t in if t' != t || s' != s then Toffset (s',t') else tn | Tbase_addr (s,t) -> let s' = visitCilLogicLabel vis s in let t' = vTerm t in if t' != t || s' != s then Tbase_addr (s',t') else tn | Tblock_length (s,t)-> let s' = visitCilLogicLabel vis s in let t' = vTerm t in if t' != t || s' != s then Tblock_length (s',t') else tn | Tnull -> tn | TCoerce(te,ty) -> let ty' = vTyp ty in let te' = vTerm te in if ty' != ty || te' != te then TCoerce(te',ty') else tn | TCoerceE(te,tc) -> let tc' = vTerm tc in let te' = vTerm te in if tc' != tc || te' != te then TCoerceE(te',tc') else tn | TUpdate (tc,toff,te) -> let tc' = vTerm tc in let te' = vTerm te in let toff' = visitCilTermOffset vis toff in if tc' != tc || (te' != te || toff' != toff) then TUpdate(tc',toff',te') else tn | Tlambda(prms,te) -> let prms' = visitCilQuantifiers vis prms in let te' = vTerm te in if prms' != prms || te' != te then Tlambda(prms',te') else tn | Ttypeof t -> let t' = vTerm t in if t' != t then Ttypeof t' else tn | Ttype ty -> let ty' = vTyp ty in if ty' != ty then Ttype ty' else tn | Tunion locs -> let locs' = mapNoCopy (visitCilTerm vis) locs in if locs != locs' then Tunion(locs') else tn | Tinter locs -> let locs' = mapNoCopy (visitCilTerm vis) locs in if locs != locs' then Tinter(locs') else tn | Tcomprehension(lval,quant,pred) -> let quant' = visitCilQuantifiers vis quant in let lval' = visitCilTerm vis lval in let pred' = (optMapNoCopy (visitCilPredicateNamed vis)) pred in if lval' != lval || quant' != quant || pred' != pred then Tcomprehension(lval',quant',pred') else tn | Tempty_set -> tn | Trange(low,high) -> let low' = optMapNoCopy (visitCilTerm vis) low in let high' = optMapNoCopy (visitCilTerm vis) high in if low != low' || high != high' then Trange(low',high') else tn | Tlet(def,body) -> let def'= visitCilLogicInfo vis def in let body' = visitCilTerm vis body in if def != def' || body != body' then Tlet(def',body') else tn | TLogic_coerce(ty,t) -> let ty' = visitCilLogicType vis ty in let t' = visitCilTerm vis t in if ty' != ty || t' != t then TLogic_coerce(ty',t') else tn and visitCilLogicLabel vis l = doVisitCil vis (copy_logic_label vis#behavior.is_copy_behavior) vis#vlogic_label childrenLogicLabel l and childrenLogicLabel vis l = match l with StmtLabel s -> s := vis#behavior.get_stmt !s; l | LogicLabel _ -> l and visitCilLogicLabelApp vis (l1,l2 as p) = let l1' = visitCilLogicLabel vis l1 in let l2' = visitCilLogicLabel vis l2 in if l1 != l1' || l2 != l2' then (l1',l2') else p and visitCilTermLval vis tl = doVisitCil vis id vis#vterm_lval childrenTermLval tl and childrenTermLval vis ((tlv,toff) as tl)= let tlv' = visitCilTermLhost vis tlv in let toff' = visitCilTermOffset vis toff in if tlv' != tlv || toff' != toff then (tlv',toff') else tl and visitCilTermLhost vis tl = doVisitCil vis id vis#vterm_lhost childrenTermLhost tl and childrenTermLhost vis tl = match tl with TVar v -> let v' = visitCilLogicVarUse vis v in if v' != v then TVar v' else tl | TResult ty -> let ty' = visitCilType vis ty in if ty' != ty then TResult ty' else tl | TMem t -> let t' = visitCilTerm vis t in if t' != t then TMem t' else tl and visitCilTermOffset vis toff = doVisitCil vis id vis#vterm_offset childrenTermOffset toff and childrenTermOffset vis toff = let vOffset o = visitCilTermOffset vis o in let vTerm t = visitCilTerm vis t in match toff with TNoOffset -> toff | TField (fi, t) -> let t' = vOffset t in let fi' = vis#behavior.get_fieldinfo fi in if t' != t || fi != fi' then TField(fi',t') else toff | TIndex(t,o) -> let t' = vTerm t in let o' = vOffset o in if t' != t || o' != o then TIndex(t',o') else toff | TModel (mi,t) -> let t' = vOffset t in let mi' = vis#behavior.get_model_info mi in if t' != t || mi != mi' then TModel(mi', t') else toff and visitCilLogicInfoUse vis li = (* First, visit the underlying varinfo to fill the copy tables if needed. *) let new_v = visitCilLogicVarUse vis li.l_var_info in let new_li = doVisitCil vis vis#behavior.get_logic_info vis#vlogic_info_use alphabetabeta li in new_li.l_var_info <- new_v; new_li and visitCilLogicInfo vis li = (* visit first the underlying varinfo. This will fill internal tables of copy behavior if needed. *) let new_v = visitCilLogicVarDecl vis li.l_var_info in let res = doVisitCil vis vis#behavior.memo_logic_info vis#vlogic_info_decl childrenLogicInfo li in res.l_var_info <- new_v; res and childrenLogicInfo vis li = (* NB: underlying varinfo has been already visited. *) let lt = optMapNoCopy (visitCilLogicType vis) li.l_type in let lp = mapNoCopy (visitCilLogicVarDecl vis) li.l_profile in li.l_type <- lt; li.l_profile <- lp; li.l_body <- begin match li.l_body with | LBnone -> li.l_body | LBreads ol -> let l = mapNoCopy (visitCilIdTerm vis) ol in if l != ol then LBreads l else li.l_body | LBterm ot -> let t = visitCilTerm vis ot in if t != ot then LBterm t else li.l_body | LBinductive inddef -> let i = mapNoCopy (fun (id,labs,tvars,p) -> (id, labs, tvars, visitCilPredicateNamed vis p)) inddef in if i != inddef then LBinductive i else li.l_body | LBpred odef -> let def = visitCilPredicateNamed vis odef in if def != odef then LBpred def else li.l_body end; li and visitCilLogicTypeInfo vis lt = doVisitCil vis vis#behavior.memo_logic_type_info vis#vlogic_type_info_decl childrenLogicTypeInfo lt and childrenLogicTypeInfo vis lt = let def = optMapNoCopy (visitCilLogicTypeDef vis) lt.lt_def in lt.lt_def <- def; lt and visitCilLogicTypeDef vis def = doVisitCil vis id vis#vlogic_type_def childrenLogicTypeDef def and childrenLogicTypeDef vis def = match def with | LTsum l -> let l' = mapNoCopy (visitCilLogicCtorInfoAddTable vis) l in if l != l' then LTsum l' else def | LTsyn typ -> let typ' = visitCilLogicType vis typ in if typ != typ' then LTsyn typ else def and visitCilLogicCtorInfoAddTable vis ctor = let ctor' = visitCilLogicCtorInfo vis ctor in if is_copy_behavior vis#behavior then Queue.add (fun () -> Logic_env.add_logic_ctor ctor'.ctor_name ctor') vis#get_filling_actions; ctor' and visitCilLogicCtorInfo vis ctor = doVisitCil vis id vis#vlogic_ctor_info_decl childrenLogicCtorInfo ctor and childrenLogicCtorInfo vis ctor = let ctor_type = doVisitCil vis vis#behavior.get_logic_type_info vis#vlogic_type_info_use alphabetabeta ctor.ctor_type in let ctor_params = mapNoCopy (visitCilLogicType vis) ctor.ctor_params in if ctor_type != ctor.ctor_type || ctor_params != ctor.ctor_params then { ctor with ctor_type = ctor_type; ctor_params = ctor_params } else ctor and visitCilLogicType vis t = doVisitCil vis id vis#vlogic_type childrenLogicType t and childrenLogicType vis ty = match ty with Ctype t -> let t' = visitCilType vis t in if t != t' then Ctype t' else ty | Linteger | Lreal -> ty | Ltype (s,l) -> let s' = doVisitCil vis vis#behavior.get_logic_type_info vis#vlogic_type_info_use alphabetabeta s in let l' = mapNoCopy (visitCilLogicType vis) l in if s' != s || l' != l then Ltype (s',l') else ty | Larrow(args,rttyp) -> let args' = mapNoCopy(visitCilLogicType vis) args in let rttyp' = visitCilLogicType vis rttyp in if args' != args || rttyp' != rttyp then Larrow(args',rttyp') else ty | Lvar _ -> ty and visitCilLogicVarDecl vis lv = (* keep names in C and logic worlds in sync *) (match lv.lv_origin with None -> () | Some cv -> lv.lv_name <- cv.vname); doVisitCil vis vis#behavior.memo_logic_var vis#vlogic_var_decl childrenLogicVarDecl lv and childrenLogicVarDecl vis lv = lv.lv_type <- visitCilLogicType vis lv.lv_type; lv.lv_origin <- optMapNoCopy (visitCilVarUse vis) lv.lv_origin; lv and visitCilLogicVarUse vis lv = if vis#behavior.is_copy_behavior && Logic_env.is_builtin_logic_function lv.lv_name then begin (* Do as if the variable has been declared. We'll fill the logic info table of the new project at the end. Behavior's logic_var table is filled as a side effect. *) let siblings = Logic_env.find_all_logic_functions lv.lv_name in let siblings' = List.map (visitCilLogicInfo vis) siblings in (*Format.printf "new vars:@."; List.iter (fun x -> Format.printf "%s#%d@." x.l_var_info.lv_name x.l_var_info.lv_id) siblings'; *) Queue.add (fun () -> (* Add them to env only once *) List.iter (fun x -> if not (Logic_env.Logic_builtin_used.mem x) then begin (* Format.printf "Adding info for %s#%d@." x.l_var_info.lv_name x.l_var_info.lv_id; *) Logic_env.Logic_builtin_used.add x; Logic_env.Logic_info.add x.l_var_info.lv_name x end) siblings') vis#get_filling_actions; end; doVisitCil vis vis#behavior.get_logic_var vis#vlogic_var_use childrenLogicVarUse lv and childrenLogicVarUse vis lv = lv.lv_origin <- optMapNoCopy (visitCilVarUse vis) lv.lv_origin; lv and visitCilQuantifiers vis lv = doVisitCil vis id vis#vquantifiers (fun vis l -> mapNoCopy (visitCilLogicVarDecl vis) l) lv and visitCilIdPredicate vis ip = doVisitCil vis vis#behavior.cidentified_predicate vis#videntified_predicate childrenIdentified_predicate ip and visitCilPredicate vis p = doVisitCil vis id vis#vpredicate childrenPredicate p and visitCilPredicateNamed vis p = doVisitCil vis id vis#vpredicate_named childrenPredicateNamed p and childrenIdentified_predicate vis ip = let p = Logic_const.pred_of_id_pred ip in let p' = visitCilPredicateNamed vis p in if p != p' then { ip with ip_name = p'.name; ip_content = p'.content; ip_loc = p'.loc } else ip and childrenPredicateNamed vis p = let content = visitCilPredicate vis p.content in if content != p.content then { p with content = content} else p and childrenPredicate vis p = let vPred p = visitCilPredicateNamed vis p in let vLogicInfo li = visitCilLogicInfoUse vis li in let vTerm t = visitCilTerm vis t in match p with Pfalse | Ptrue -> p | Papp (pred,labels,args) -> let pred' = vLogicInfo pred in let labels' = mapNoCopy (visitCilLogicLabelApp vis) labels in let args' = mapNoCopy vTerm args in if pred' != pred || labels' != labels || args' != args then Papp(pred',labels',args') else p | Prel(rel,t1,t2) -> let t1' = vTerm t1 in let t2' = vTerm t2 in if t1' != t1 || t2' != t2 then Prel(rel,t1',t2') else p | Pand(p1,p2) -> let p1' = vPred p1 in let p2' = vPred p2 in if p1' != p1 || p2' != p2 then Pand(p1',p2') else p | Por(p1,p2) -> let p1' = vPred p1 in let p2' = vPred p2 in if p1' != p1 || p2' != p2 then Por(p1',p2') else p | Pxor(p1,p2) -> let p1' = vPred p1 in let p2' = vPred p2 in if p1' != p1 || p2' != p2 then Pxor(p1',p2') else p | Pimplies(p1,p2) -> let p1' = vPred p1 in let p2' = vPred p2 in if p1' != p1 || p2' != p2 then Pimplies(p1',p2') else p | Piff(p1,p2) -> let p1' = vPred p1 in let p2' = vPred p2 in if p1' != p1 || p2' != p2 then Piff(p1',p2') else p | Pnot p1 -> let p1' = vPred p1 in if p1' != p1 then Pnot p1' else p | Pif(t,ptrue,pfalse) -> let t' = vTerm t in let ptrue' = vPred ptrue in let pfalse' = vPred pfalse in if t' != t || ptrue' != ptrue || pfalse' != pfalse then Pif(t', ptrue',pfalse') else p | Plet(def,p1) -> let def' = visitCilLogicInfo vis def in let p1' = vPred p1 in if def' != def || p1' != p1 then Plet(def',p1') else p | Pforall(quant,p1) -> let quant' = visitCilQuantifiers vis quant in let p1' = vPred p1 in if quant' != quant || p1' != p1 then Pforall(quant', p1') else p | Pexists(quant,p1) -> let quant' = visitCilQuantifiers vis quant in let p1' = vPred p1 in if quant' != quant || p1' != p1 then Pexists(quant', p1') else p | Pat(p1,s) -> let p1' = vPred p1 in let s' = visitCilLogicLabel vis s in if p1' != p1 || s != s' then Pat(p1',s') else p | Pallocable (s,t) -> let s' = visitCilLogicLabel vis s in let t' = vTerm t in if t' != t || s != s' then Pallocable (s',t') else p | Pfreeable (s,t) -> let s' = visitCilLogicLabel vis s in let t' = vTerm t in if t' != t || s != s' then Pfreeable (s',t') else p | Pvalid (s,t) -> let s' = visitCilLogicLabel vis s in let t' = vTerm t in if t' != t || s != s' then Pvalid (s',t') else p | Pvalid_read (s,t) -> let s' = visitCilLogicLabel vis s in let t' = vTerm t in if t' != t || s != s' then Pvalid_read (s',t') else p | Pinitialized (s,t) -> let s' = visitCilLogicLabel vis s in let t' = vTerm t in if t' != t || s != s' then Pinitialized (s',t') else p | Pseparated seps -> let seps' = mapNoCopy vTerm seps in if seps' != seps then Pseparated seps' else p | Pfresh (s1,s2,t,n) -> let s1' = visitCilLogicLabel vis s1 in let s2' = visitCilLogicLabel vis s2 in let t' = vTerm t in let n' = vTerm n in if t' != t || n' != n || s1 != s1' || s2 != s2' then Pfresh (s1',s2',t',n') else p | Psubtype(te,tc) -> let tc' = vTerm tc in let te' = vTerm te in if tc' != tc || te' != te then Psubtype(te',tc') else p and visitCilIdTerm vis loc = doVisitCil vis vis#behavior.cidentified_term vis#videntified_term childrenIdentified_term loc and childrenIdentified_term vis loc = let loc' = visitCilTerm vis loc.it_content in if loc' != loc.it_content then { loc with it_content = loc' } else loc and visitCilAllocation vis fa = doVisitCil vis id vis#vallocation childrenAllocation fa and childrenAllocation vis fa = match fa with FreeAllocAny -> fa | FreeAlloc(f,a) -> let f' = visitCilFrees vis f in let a' = visitCilAllocates vis a in if f != f' || a' != a then FreeAlloc(f',a') else fa and visitCilFrees vis l = doVisitCil vis id vis#vfrees childrenFreeAlloc l and visitCilAllocates vis l = doVisitCil vis id vis#vallocates childrenFreeAlloc l and childrenFreeAlloc vis l = mapNoCopy (visitCilIdTerm vis) l and visitCilAssigns vis a = doVisitCil vis id vis#vassigns childrenAssigns a and childrenAssigns vis a = match a with WritesAny -> a | Writes l -> let l' = mapNoCopy (visitCilFrom vis) l in if l' != l then Writes l' else a and visitCilFrom vis f = doVisitCil vis id vis#vfrom childrenFrom f and childrenFrom vis ((b,f) as a) = let b' = visitCilIdTerm vis b in let f' = visitCilDeps vis f in if b!=b' || f!=f' then (b',f') else a and visitCilDeps vis d = doVisitCil vis id vis#vdeps childrenDeps d and childrenDeps vis d = match d with FromAny -> d | From l -> let l' = mapNoCopy (visitCilIdTerm vis) l in if l !=l' then From l' else d and visitCilBehavior vis b = doVisitCil vis vis#behavior.cfunbehavior vis#vbehavior childrenBehavior b and childrenBehavior vis b = b.b_assumes <- visitCilPredicates vis b.b_assumes; b.b_requires <- visitCilPredicates vis b.b_requires; b.b_post_cond <- mapNoCopy (function ((k,p) as pc) -> let p' = visitCilIdPredicate vis p in if p != p' then (k,p') else pc) b.b_post_cond; b.b_assigns <- visitCilAssigns vis b.b_assigns; b.b_allocation <- visitCilAllocation vis b.b_allocation ; b.b_extended <- mapNoCopy (visitCilExtended vis) b.b_extended; b and visitCilExtended vis (s,id,p as orig) = let r = mapNoCopy (visitCilIdPredicate vis) p in if r == p then orig else (s,id,r) and visitCilPredicates vis ps = mapNoCopy (visitCilIdPredicate vis) ps and visitCilBehaviors vis bs = mapNoCopy (visitCilBehavior vis) bs and visitCilFunspec vis s = doVisitCil vis vis#behavior.cfunspec vis#vspec childrenSpec s and childrenSpec vis s = s.spec_behavior <- visitCilBehaviors vis s.spec_behavior; s.spec_variant <- optMapNoCopy (fun x -> (visitCilTerm vis (fst x), snd x)) s.spec_variant; s.spec_terminates <- optMapNoCopy (visitCilIdPredicate vis) s.spec_terminates; (* nothing is done now for behaviors names, no need to visit complete and disjoint behaviors clauses *) s and visitCilSlicePragma vis p = doVisitCil vis id vis#vslice_pragma childrenSlicePragma p and childrenSlicePragma vis p = match p with | SPexpr t -> let t' = visitCilTerm vis t in if t' != t then SPexpr t' else p | SPctrl | SPstmt -> p and visitCilImpactPragma vis p = doVisitCil vis id vis#vimpact_pragma childrenImpactPragma p and childrenImpactPragma vis p = match p with | IPexpr t -> let t' = visitCilTerm vis t in if t' != t then IPexpr t' else p | IPstmt -> p and visitCilLoopPragma vis p = doVisitCil vis id vis#vloop_pragma childrenLoopPragma p and childrenLoopPragma vis p = match p with | Unroll_specs lt -> let lt' = mapNoCopy (visitCilTerm vis) lt in if lt' != lt then Unroll_specs lt' else p | Widen_hints lt -> let lt' = mapNoCopy (visitCilTerm vis) lt in if lt' != lt then Widen_hints lt' else p | Widen_variables lt -> let lt' = mapNoCopy (visitCilTerm vis) lt in if lt' != lt then Widen_variables lt' else p and childrenModelInfo vis m = let field_type = visitCilLogicType vis m.mi_field_type in let base_type = visitCilType vis m.mi_base_type in if field_type != m.mi_field_type || base_type != m.mi_base_type then { mi_name = m.mi_name; mi_field_type = field_type; mi_base_type = base_type; mi_decl = Cil_datatype.Location.copy m.mi_decl; } else m and visitCilModelInfo vis m = let oldloc = CurrentLoc.get () in CurrentLoc.set m.mi_decl; let m' = doVisitCil vis vis#behavior.memo_model_info vis#vmodel_info childrenModelInfo m in CurrentLoc.set oldloc; if m' != m then begin (* reflect changes in the behavior tables for copy visitor. *) vis#behavior.set_model_info m m'; vis#behavior.set_orig_model_info m' m; end; m' and visitCilAnnotation vis a = let oldloc = CurrentLoc.get () in CurrentLoc.set (Global_annotation.loc a); let res = doVisitCil vis id vis#vannotation childrenAnnotation a in CurrentLoc.set oldloc; res and childrenAnnotation vis a = match a with | Dfun_or_pred (li,loc) -> let li' = visitCilLogicInfo vis li in if vis#behavior.is_copy_behavior then Queue.add (fun () -> Logic_env.add_logic_function_gen alphabetafalse li') vis#get_filling_actions; if li' != li then Dfun_or_pred (li',loc) else a | Dtype (ti,loc) -> let ti' = visitCilLogicTypeInfo vis ti in if vis#behavior.is_copy_behavior then Queue.add (fun () -> Logic_env.add_logic_type ti'.lt_name ti') vis#get_filling_actions; if ti' != ti then Dtype (ti',loc) else a | Dlemma(s,is_axiom,labels,tvars,p,loc) -> let p' = visitCilPredicateNamed vis p in if p' != p then Dlemma(s,is_axiom,labels,tvars,p',loc) else a | Dinvariant (p,loc) -> let p' = visitCilLogicInfo vis p in if vis#behavior.is_copy_behavior then Queue.add (fun () -> Logic_env.add_logic_function_gen alphabetafalse p') vis#get_filling_actions; if p' != p then Dinvariant (p',loc) else a | Dtype_annot (ta,loc) -> let ta' = visitCilLogicInfo vis ta in if vis#behavior.is_copy_behavior then Queue.add (fun () -> Logic_env.add_logic_function_gen alphabetafalse ta') vis#get_filling_actions; if ta' != ta then Dtype_annot (ta',loc) else a | Dmodel_annot (mfi,loc) -> let mfi' = visitCilModelInfo vis mfi in if vis#behavior.is_copy_behavior then Queue.add (fun () -> Logic_env.add_model_field mfi') vis#get_filling_actions; if mfi' != mfi then Dmodel_annot (mfi',loc) else a | Dcustom_annot(_c,_n,_loc) -> a | Dvolatile(tset,rvi,wvi,loc) -> let tset' = mapNoCopy (visitCilIdTerm vis) tset in let rvi' = optMapNoCopy (visitCilVarUse vis) rvi in let wvi' = optMapNoCopy (visitCilVarUse vis) wvi in if tset' != tset || rvi' != rvi || wvi' != wvi then Dvolatile(tset',rvi',wvi',loc) else a | Daxiomatic(id,l,loc) -> (* Format.eprintf "cil.visitCilAnnotation on axiomatic %s@." id; *) let l' = mapNoCopy (visitCilAnnotation vis) l in if l' != l then Daxiomatic(id,l',loc) else a and visitCilCodeAnnotation vis ca = doVisitCil vis id vis#vcode_annot childrenCodeAnnot ca and childrenCodeAnnot vis ca = let vPred p = visitCilPredicateNamed vis p in let vTerm t = visitCilTerm vis t in let vSpec s = visitCilFunspec vis s in let change_content annot = { ca with annot_content = annot } in match ca.annot_content with AAssert (behav,p) -> let p' = vPred p in if p' != p then change_content (AAssert (behav,p')) else ca | APragma (Impact_pragma t) -> let t' = visitCilImpactPragma vis t in if t' != t then change_content (APragma (Impact_pragma t')) else ca | APragma (Slice_pragma t) -> let t' = visitCilSlicePragma vis t in if t' != t then change_content (APragma (Slice_pragma t')) else ca | APragma (Loop_pragma p) -> let p' = visitCilLoopPragma vis p in if p' != p then change_content (APragma (Loop_pragma p')) else ca | AStmtSpec (behav,s) -> let s' = vSpec s in if s' != s then change_content (AStmtSpec (behav,s')) else ca | AInvariant(behav,f,p) -> let p' = vPred p in if p' != p then change_content (AInvariant (behav,f,p')) else ca | AVariant ((t,s)) -> let t' = vTerm t in if t != t' then change_content (AVariant ((t',s))) else ca | AAssigns(behav, a) -> let a' = visitCilAssigns vis a in if a != a' then change_content (AAssigns (behav,a')) else ca | AAllocation(behav, fa) -> let fa' = visitCilAllocation vis fa in if fa != fa' then change_content (AAllocation (behav,fa')) else ca and visitCilExpr (vis: cilVisitor) (e: exp) : exp = let oldLoc = CurrentLoc.get () in CurrentLoc.set e.eloc; let res = doVisitCil vis id vis#vexpr childrenExp e in CurrentLoc.set oldLoc; res and childrenExp (vis: cilVisitor) (e: exp) : exp = let vExp e = visitCilExpr vis e in let vTyp t = visitCilType vis t in let vLval lv = visitCilLval vis lv in let new_exp e' = { e with enode = e' } in match (stripInfo e).enode with | Info _ -> assert false | Const c -> let c' = visitCilConst vis c in if c' != c then new_exp (Const c') else e | SizeOf t -> let t'= vTyp t in if t' != t then new_exp (SizeOf t') else e | SizeOfE e1 -> let e1' = vExp e1 in if e1' != e1 then new_exp (SizeOfE e1') else e | SizeOfStr _s -> e | AlignOf t -> let t' = vTyp t in if t' != t then new_exp (AlignOf t') else e | AlignOfE e1 -> let e1' = vExp e1 in if e1' != e1 then new_exp (AlignOfE e1') else e | Lval lv -> let lv' = vLval lv in if lv' != lv then new_exp (Lval lv') else e | UnOp (uo, e1, t) -> let e1' = vExp e1 in let t' = vTyp t in if e1' != e1 || t' != t then new_exp (UnOp(uo, e1', t')) else e | BinOp (bo, e1, e2, t) -> let e1' = vExp e1 in let e2' = vExp e2 in let t' = vTyp t in if e1' != e1 || e2' != e2 || t' != t then new_exp (BinOp(bo, e1',e2',t')) else e | CastE (t, e1) -> let t' = vTyp t in let e1' = vExp e1 in if t' != t || e1' != e1 then new_exp (CastE(t', e1')) else e | AddrOf lv -> let lv' = vLval lv in if lv' != lv then new_exp (AddrOf lv') else e | StartOf lv -> let lv' = vLval lv in if lv' != lv then new_exp (StartOf lv') else e and visitCilInit (vis: cilVisitor) (forglob: varinfo) (atoff: offset) (i: init) : init = let childrenInit (vis: cilVisitor) (i: init) : init = let fExp e = visitCilExpr vis e in let fTyp t = visitCilType vis t in match i with | SingleInit e -> let e' = fExp e in if e' != e then SingleInit e' else i | CompoundInit (t, initl) -> let t' = fTyp t in (* Collect the new initializer list, in reverse. We prefer two * traversals to ensure tail-recursion. *) let newinitl : (offset * init) list ref = ref [] in (* Keep track whether the list has changed *) let hasChanged = ref false in let doOneInit ((o, i) as oi) = let o' = visitCilInitOffset vis o in (* use initializer version *) let i' = visitCilInit vis forglob (addOffset o' atoff) i in let newio = if o' != o || i' != i then begin hasChanged := true; (o', i') end else oi in newinitl := newio :: !newinitl in List.iter doOneInit initl; let initl' = if !hasChanged then List.rev !newinitl else initl in if t' != t || initl' != initl then CompoundInit (t', initl') else i in doVisitCil vis id (vis#vinit forglob atoff) childrenInit i and visitCilLval (vis: cilVisitor) (lv: lval) : lval = doVisitCil vis id vis#vlval childrenLval lv and childrenLval (vis: cilVisitor) (lv: lval) : lval = (* and visit its subexpressions *) let vExp e = visitCilExpr vis e in let vOff off = visitCilOffset vis off in match lv with Var v, off -> let v'= visitCilVarUse vis v in let off' = vOff off in if v' != v || off' != off then Var v', off' else lv | Mem e, off -> let e' = vExp e in let off' = vOff off in if e' != e || off' != off then Mem e', off' else lv and visitCilOffset (vis: cilVisitor) (off: offset) : offset = doVisitCil vis id vis#voffs childrenOffset off and childrenOffset (vis: cilVisitor) (off: offset) : offset = let vOff off = visitCilOffset vis off in match off with Field (f, o) -> let o' = vOff o in let f' = vis#behavior.get_fieldinfo f in if o' != o || f' != f then Field (f', o') else off | Index (e, o) -> let e' = visitCilExpr vis e in let o' = vOff o in if e' != e || o' != o then Index (e', o') else off | NoOffset -> off (* sm: for offsets in initializers, the 'startvisit' will be the * vinitoffs method, but we can re-use the childrenOffset from * above since recursive offsets are visited by voffs. (this point * is moot according to cil.mli which claims the offsets in * initializers will never recursively contain offsets) *) and visitCilInitOffset (vis: cilVisitor) (off: offset) : offset = doVisitCil vis id vis#vinitoffs childrenOffset off and visitCilInstr (vis: cilVisitor) (i: instr) : instr list = let oldloc = CurrentLoc.get () in CurrentLoc.set (Cil_datatype.Instr.loc i); assertEmptyQueue vis; let res = doVisitListCil vis id vis#vinst childrenInstr i in CurrentLoc.set oldloc; (* See if we have accumulated some instructions *) vis#unqueueInstr () @ res and childrenInstr (vis: cilVisitor) (i: instr) : instr = let fExp = visitCilExpr vis in let fLval = visitCilLval vis in match i with | Skip _l -> i | Set(lv,e,l) -> let lv' = fLval lv in let e' = fExp e in if lv' != lv || e' != e then Set(lv',e',l) else i | Call(None,f,args,l) -> let f' = fExp f in let args' = mapNoCopy fExp args in if f' != f || args' != args then Call(None,f',args',l) else i | Call(Some lv,fn,args,l) -> let lv' = fLval lv in let fn' = fExp fn in let args' = mapNoCopy fExp args in if lv' != lv || fn' != fn || args' != args then Call(Some lv', fn', args', l) else i | Asm(sl,isvol,outs,ins,clobs,l) -> let outs' = mapNoCopy (fun ((id,s,lv) as pair) -> let lv' = fLval lv in if lv' != lv then (id,s,lv') else pair) outs in let ins' = mapNoCopy (fun ((id,s,e) as pair) -> let e' = fExp e in if e' != e then (id,s,e') else pair) ins in if outs' != outs || ins' != ins then Asm(sl,isvol,outs',ins',clobs,l) else i | Code_annot (a,l) -> let a' = visitCilCodeAnnotation vis a in if a != a' then Code_annot(a',l) else i (* visit all nodes in a Cil statement tree in preorder *) and visitCilStmt (vis:cilVisitor) (s: stmt) : stmt = let oldloc = CurrentLoc.get () in CurrentLoc.set (Stmt.loc s) ; vis#push_stmt s; (*(vis#behavior.memo_stmt s);*) assertEmptyQueue vis; let toPrepend : instr list ref = ref [] in (* childrenStmt may add to this *) let res = doVisitCil vis vis#behavior.memo_stmt vis#vstmt (childrenStmt toPrepend) s in (* Now see if we have saved some instructions *) toPrepend := !toPrepend @ vis#unqueueInstr (); (match !toPrepend with [] -> () (* Return the same statement *) | _ -> (* Make our statement contain the instructions to prepend *) res.skind <- Block (mkBlock ((List.map (fun i -> mkStmt (Instr i)) !toPrepend) @ [ mkStmt res.skind ] ))); CurrentLoc.set oldloc; vis#pop_stmt s; res and childrenStmt (toPrepend: instr list ref) (vis:cilVisitor) (s:stmt): stmt = let fExp e = (visitCilExpr vis e) in let fBlock b = visitCilBlock vis b in let fInst i = visitCilInstr vis i in let fLoopAnnot a = mapNoCopy (visitCilCodeAnnotation vis) a in (* Just change the statement kind *) let skind' = match s.skind with Break _ | Continue _ | Return (None, _) -> s.skind | UnspecifiedSequence seq -> let seq' = mapNoCopy (function (stmt,modified,writes,reads,calls) as orig-> let stmt' = visitCilStmt vis stmt in (* might make sense for the default to be to just copy the varinfo when using the copy visitor, and not apply vvrbl, i.e. not using vis but generic_visitor ? *) let modified' = mapNoCopy (visitCilLval vis) modified in let writes' = mapNoCopy (visitCilLval vis) writes in let reads' = mapNoCopy (visitCilLval vis) reads in let calls' = if vis#behavior.is_copy_behavior then (* we need new references anyway, no need for mapNoCopy *) List.map (fun x -> ref (vis#behavior.memo_stmt !x)) calls else calls in if stmt' != stmt || writes' != writes || reads' != reads || modified != modified' || calls' != calls then (stmt',modified', writes',reads',calls') else orig) seq in if seq' != seq then UnspecifiedSequence seq' else s.skind | Goto (sr,l) -> if vis#behavior.is_copy_behavior then Goto(ref (vis#behavior.memo_stmt !sr),l) else s.skind | Return (Some e, l) -> let e' = fExp e in if e' != e then Return (Some e', l) else s.skind | Loop (a, b, l, s1, s2) -> let a' = fLoopAnnot a in let b' = fBlock b in if a' != a || b' != b then Loop (a', b', l, s1, s2) else s.skind | If(e, s1, s2, l) -> let e' = fExp e in (*if e queued any instructions, pop them here and remember them so that they are inserted before the If stmt, not in the then block. *) toPrepend := vis#unqueueInstr (); let s1'= fBlock s1 in let s2'= fBlock s2 in (* the stmts in the blocks should have cleaned up after themselves.*) assertEmptyQueue vis; if e' != e || s1' != s1 || s2' != s2 then If(e', s1', s2', l) else s.skind | Switch (e, b, stmts, l) -> let e' = fExp e in toPrepend := vis#unqueueInstr (); (* insert these before the switch *) let b' = fBlock b in let stmts' = mapNoCopy (vis#behavior.get_stmt) stmts in (* the stmts in b should have cleaned up after themselves.*) assertEmptyQueue vis; if e' != e || b' != b || stmts' != stmts then Switch (e', b', stmts', l) else s.skind | Instr i -> begin match fInst i with | [i'] when i' == i -> s.skind | il -> stmt_of_instr_list ~loc:(Cil_datatype.Instr.loc i) il end | Block b -> let b' = fBlock b in if b' != b then Block b' else s.skind | TryFinally (b, h, l) -> let b' = fBlock b in let h' = fBlock h in if b' != b || h' != h then TryFinally(b', h', l) else s.skind | TryExcept (b, (il, e), h, l) -> let b' = fBlock b in assertEmptyQueue vis; (* visit the instructions *) let il' = mapNoCopyList fInst il in (* Visit the expression *) let e' = fExp e in let il'' = let more = vis#unqueueInstr () in if more != [] then il' @ more else il' in let h' = fBlock h in (* Now collect the instructions *) if b' != b || il'' != il || e' != e || h' != h then TryExcept(b', (il'', e'), h', l) else s.skind in if skind' != s.skind then s.skind <- skind'; (* Visit the labels *) let labels' = let fLabel = function Case (e, l) as lb -> let e' = fExp e in if e' != e then Case (e', l) else lb | lb -> lb in mapNoCopy fLabel s.labels in if labels' != s.labels then s.labels <- labels'; s and visitCilBlock (vis: cilVisitor) (b: block) : block = doVisitCil vis vis#behavior.cblock vis#vblock childrenBlock b and childrenBlock (vis: cilVisitor) (b: block) : block = let fStmt s = visitCilStmt vis s in let stmts' = mapNoCopy fStmt b.bstmts in let locals' = mapNoCopy (vis#behavior.get_varinfo) b.blocals in if stmts' != b.bstmts || locals' != b.blocals then { battrs = b.battrs; bstmts = stmts'; blocals = locals' } else b and visitCilType (vis : cilVisitor) (t : typ) : typ = doVisitCil vis id vis#vtype childrenType t and childrenType (vis : cilVisitor) (t : typ) : typ = (* look for types referred to inside t's definition *) let fTyp t = visitCilType vis t in let fAttr a = visitCilAttributes vis a in match t with TPtr(t1, a) -> let t1' = fTyp t1 in let a' = fAttr a in if t1' != t1 || a' != a then TPtr(t1', a') else t | TArray(t1, None, _, a) -> let t1' = fTyp t1 in let a' = fAttr a in if t1' != t1 || a' != a then TArray(t1', None, empty_size_cache (), a') else t | TArray(t1, Some e, _, a) -> let t1' = fTyp t1 in let e' = visitCilExpr vis e in let a' = fAttr a in if t1' != t1 || e' != e || a' != a then TArray(t1', Some e',empty_size_cache (), a') else t (* DON'T recurse into the compinfo, this is done in visitCilGlobal. User can iterate over cinfo.cfields manually, if desired.*) | TComp(cinfo, _, a) -> let cinfo' = vis#behavior.get_compinfo cinfo in let a' = fAttr a in if a != a' || cinfo' != cinfo then TComp(cinfo',empty_size_cache (), a') else t | TFun(rettype, args, isva, a) -> let rettype' = fTyp rettype in (* iterate over formals, as variable declarations *) let argslist = argsToList args in let visitArg ((an,at,aa) as arg) = let at' = fTyp at in let aa' = fAttr aa in if at' != at || aa' != aa then (an,at',aa') else arg in let argslist' = mapNoCopy visitArg argslist in let a' = fAttr a in if rettype' != rettype || argslist' != argslist || a' != a then let args' = if argslist' == argslist then args else Some argslist' in TFun(rettype', args', isva, a') else t | TNamed(t1, a) -> let a' = fAttr a in let t1' = vis#behavior.get_typeinfo t1 in if a' != a || t1' != t1 then TNamed (t1', a') else t | TEnum(enum,a) -> let a' = fAttr a in let enum' = vis#behavior.get_enuminfo enum in if a' != a || enum' != enum then TEnum(enum',a') else t | TVoid _ | TInt _ | TFloat _ | TBuiltin_va_list _ -> (* no nested type. visit only the attributes. *) let a = typeAttrs t in let a' = fAttr a in if a' != a then setTypeAttrs t a' else t (* for declarations, we visit the types inside; but for uses, *) (* we just visit the varinfo node *) and visitCilVarDecl (vis : cilVisitor) (v : varinfo) : varinfo = let oldloc = CurrentLoc.get () in CurrentLoc.set v.vdecl; let res = doVisitCil vis vis#behavior.memo_varinfo vis#vvdec childrenVarDecl v in CurrentLoc.set oldloc; res and childrenVarDecl (vis : cilVisitor) (v : varinfo) : varinfo = v.vtype <- visitCilType vis v.vtype; v.vattr <- visitCilAttributes vis v.vattr; v.vlogic_var_assoc <- optMapNoCopy (visitCilLogicVarDecl vis) v.vlogic_var_assoc; v and visitCilVarUse vis v = doVisitCil vis vis#behavior.get_varinfo vis#vvrbl alphabetabeta v and visitCilAttributes (vis: cilVisitor) (al: attribute list) : attribute list= let al' = mapNoCopyList (doVisitListCil vis id vis#vattr childrenAttribute) al in if al' != al then (* Must re-sort *) addAttributes al' [] else al and childrenAttribute (vis: cilVisitor) (a: attribute) : attribute = let fAttrP a = visitCilAttrParams vis a in match a with | Attr (n, args) -> let args' = mapNoCopy fAttrP args in if args' != args then Attr(n, args') else a | AttrAnnot _ -> a and visitCilAttrParams (vis: cilVisitor) (a: attrparam) : attrparam = doVisitCil vis id vis#vattrparam childrenAttrparam a and childrenAttrparam (vis: cilVisitor) (aa: attrparam) : attrparam = let fTyp t = visitCilType vis t in let fAttrP a = visitCilAttrParams vis a in match aa with AInt _ | AStr _ -> aa | ACons(n, args) -> let args' = mapNoCopy fAttrP args in if args' != args then ACons(n, args') else aa | ASizeOf t -> let t' = fTyp t in if t' != t then ASizeOf t' else aa | ASizeOfE e -> let e' = fAttrP e in if e' != e then ASizeOfE e' else aa | AAlignOf t -> let t' = fTyp t in if t' != t then AAlignOf t' else aa | AAlignOfE e -> let e' = fAttrP e in if e' != e then AAlignOfE e' else aa | AUnOp (uo, e1) -> let e1' = fAttrP e1 in if e1' != e1 then AUnOp (uo, e1') else aa | ABinOp (bo, e1, e2) -> let e1' = fAttrP e1 in let e2' = fAttrP e2 in if e1' != e1 || e2' != e2 then ABinOp (bo, e1', e2') else aa | ADot (ap, s) -> let ap' = fAttrP ap in if ap' != ap then ADot (ap', s) else aa | AStar ap -> let ap' = fAttrP ap in if ap' != ap then AStar ap' else aa | AAddrOf ap -> let ap' = fAttrP ap in if ap' != ap then AAddrOf ap' else aa | AIndex (e1, e2) -> let e1' = fAttrP e1 in let e2' = fAttrP e2 in if e1' != e1 || e2' != e2 then AIndex (e1', e2') else aa | AQuestion (e1, e2, e3) -> let e1' = fAttrP e1 in let e2' = fAttrP e2 in let e3' = fAttrP e3 in if e1' != e1 || e2' != e2 || e3' != e3 then AQuestion (e1', e2', e3') else aa let rec fix_succs_preds_block b block = List.iter (fix_succs_preds b) block.bstmts and fix_succs_preds b stmt = stmt.succs <- mapNoCopy b.get_stmt stmt.succs; stmt.preds <- mapNoCopy b.get_stmt stmt.preds; match stmt.skind with If(_,bthen,belse,_) -> fix_succs_preds_block b bthen; fix_succs_preds_block b belse | Switch(e,cases,stmts,l) -> fix_succs_preds_block b cases; stmt.skind <- Switch(e,cases,List.map b.get_stmt stmts,l) | Loop(annot,block,loc,stmt1,stmt2) -> fix_succs_preds_block b block; let stmt1' = optMapNoCopy b.get_stmt stmt1 in let stmt2' = optMapNoCopy b.get_stmt stmt2 in stmt.skind <- Loop(annot,block,loc,stmt1',stmt2') | Block block -> fix_succs_preds_block b block | TryFinally(block1,block2,_) -> fix_succs_preds_block b block1; fix_succs_preds_block b block2 | TryExcept(block1,_,block2,_) -> fix_succs_preds_block b block1; fix_succs_preds_block b block2 | _ -> () let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec = if debugVisit then Kernel.feedback "Visiting function %s" f.svar.vname ; assertEmptyQueue vis; vis#set_current_func f; let f = vis#behavior.memo_fundec f in f.svar <- vis#behavior.memo_varinfo f.svar; (* hit the function name *) let f = doVisitCil vis id (* copy has already been done *) vis#vfunc childrenFunction f in let toPrepend = vis#unqueueInstr () in if toPrepend <> [] then f.sbody.bstmts <- (List.map (fun i -> mkStmt (Instr i)) toPrepend) @ f.sbody.bstmts; if vis#behavior.is_copy_behavior then begin fix_succs_preds_block vis#behavior f.sbody; f.sallstmts <- List.map vis#behavior.get_stmt f.sallstmts end; vis#reset_current_func (); f and childrenFunction (vis : cilVisitor) (f : fundec) : fundec = f.svar <- visitCilVarDecl vis f.svar; (* hit the function name *) (* visit local declarations *) f.slocals <- mapNoCopy (visitCilVarDecl vis) f.slocals; (* visit the formals *) let newformals = mapNoCopy (visitCilVarDecl vis) f.sformals in (* Make sure the type reflects the formals *) let selection = State_selection.singleton FormalsDecl.self in if vis#behavior.is_copy_behavior || newformals != f.sformals then begin apply_on_project ~selection vis (setFormals f) newformals; end; (* Remember any new instructions that were generated while visiting variable declarations. *) let toPrepend = vis#unqueueInstr () in f.sbody <- visitCilBlock vis f.sbody; (* visit the body *) if toPrepend <> [] then f.sbody.bstmts <- (List.map (fun i -> mkStmt (Instr i)) toPrepend) @ f.sbody.bstmts; if not (is_empty_funspec f.sspec) then f.sspec <- visitCilFunspec vis f.sspec; f let childrenFieldInfo vis fi = fi.fcomp <- vis#behavior.get_compinfo fi.fcomp; fi.ftype <- visitCilType vis fi.ftype; fi.fattr <- visitCilAttributes vis fi.fattr; fi let visitCilFieldInfo vis f = doVisitCil vis vis#behavior.memo_fieldinfo vis#vfieldinfo childrenFieldInfo f let childrenCompInfo vis comp = comp.cfields <- mapNoCopy (visitCilFieldInfo vis) comp.cfields; comp.cattr <- visitCilAttributes vis comp.cattr; comp let visitCilCompInfo vis c = doVisitCil vis vis#behavior.memo_compinfo vis#vcompinfo childrenCompInfo c let childrenEnumItem vis e = e.eival <- visitCilExpr vis e.eival; e.eihost <- vis#behavior.get_enuminfo e.eihost; e let visitCilEnumItem vis e = doVisitCil vis vis#behavior.memo_enumitem vis#venumitem childrenEnumItem e let childrenEnumInfo vis e = e.eitems <- mapNoCopy (visitCilEnumItem vis) e.eitems; e.eattr <- visitCilAttributes vis e.eattr; e let visitCilEnumInfo vis e = doVisitCil vis vis#behavior.memo_enuminfo vis#venuminfo childrenEnumInfo e let rec visitCilGlobal (vis: cilVisitor) (g: global) : global list = let oldloc = CurrentLoc.get () in CurrentLoc.set (Global.loc g) ; currentGlobal := g; let res = doVisitListCil vis id vis#vglob childrenGlobal g in CurrentLoc.set oldloc; res and childrenGlobal (vis: cilVisitor) (g: global) : global = match g with | GFun (f, l) -> let f' = visitCilFunction vis f in if f' != f then GFun (f', l) else g | GType(t, l) -> let t' = vis#behavior.memo_typeinfo t in t'.ttype <- visitCilType vis t'.ttype; if t' != t then GType(t',l) else g | GEnumTagDecl (enum,l) -> let enum' = vis#behavior.memo_enuminfo enum in if enum != enum' then GEnumTagDecl(enum',l) else g (* real visit'll be done in the definition *) | GCompTagDecl (comp,l) -> let comp' = vis#behavior.memo_compinfo comp in if comp != comp' then GCompTagDecl(comp',l) else g | GEnumTag (enum, l) -> let enum' = visitCilEnumInfo vis enum in if enum != enum' then GEnumTag(enum',l) else g | GCompTag (comp, l) -> let comp' = visitCilCompInfo vis comp in if comp != comp' then GCompTag(comp',l) else g | GVarDecl(spec, v, l) -> let form = try Some (getFormalsDecl v) with Not_found -> None in let v' = visitCilVarDecl vis v in let form' = optMapNoCopy (mapNoCopy (visitCilVarDecl vis)) form in let spec' = if isFunctionType v.vtype && not (is_empty_funspec spec) then visitCilFunspec vis spec else begin assert (is_empty_funspec spec); if is_copy_behavior vis#behavior then empty_funspec () else spec (* do not need to change it if it's not a copy visitor. *) end in if v' != v || spec' != spec || form != form' then begin (match form' with | Some formals when vis#behavior.is_copy_behavior || form != form' -> let selection = State_selection.singleton FormalsDecl.self in apply_on_project ~selection vis (unsafeSetFormalsDecl v') formals | Some _ | None -> ()); GVarDecl (spec', v', l) end else g | GVar (v, inito, l) -> let v' = visitCilVarDecl vis v in let inito' = vis#behavior.cinitinfo inito in (match inito'.init with None -> () | Some i -> let i' = visitCilInit vis v NoOffset i in if i' != i then inito'.init <- Some i'); if v' != v || inito' != inito then GVar (v', inito', l) else g | GPragma (a, l) -> begin match visitCilAttributes vis [a] with [a'] -> if a' != a then GPragma (a', l) else g | _ -> Kernel.fatal "visitCilAttributes returns more than one attribute" end | GAnnot (a,l) -> let a' = visitCilAnnotation vis a in if a' != a then GAnnot(a',l) else g | GText _ | GAsm _ -> g (* sm: utility *) let startsWith prefix s = let prefixLen = String.length prefix in String.length s >= prefixLen && String.sub s 0 prefixLen = prefix (* The next compindo identifier to use. Counts up. *) let nextCompinfoKey = let module M = State_builder.SharedCounter(struct let name = "compinfokey" end) in M.next let bytesSizeOfInt (ik: ikind): int = match ik with | IChar | ISChar | IUChar -> 1 | IBool | IInt | IUInt -> theMachine.theMachine.sizeof_int | IShort | IUShort -> theMachine.theMachine.sizeof_short | ILong | IULong -> theMachine.theMachine.sizeof_long | ILongLong | IULongLong -> theMachine.theMachine.sizeof_longlong let bitsSizeOfInt ik = 8 * bytesSizeOfInt ik let intKindForSize (s:int) (unsigned:bool) : ikind = if unsigned then (* Test the most common sizes first *) if s = 1 then IUChar else if s = theMachine.theMachine.sizeof_int then IUInt else if s = theMachine.theMachine.sizeof_long then IULong else if s = theMachine.theMachine.sizeof_short then IUShort else if s = theMachine.theMachine.sizeof_longlong then IULongLong else raise Not_found else (* Test the most common sizes first *) if s = 1 then ISChar else if s = theMachine.theMachine.sizeof_int then IInt else if s = theMachine.theMachine.sizeof_long then ILong else if s = theMachine.theMachine.sizeof_short then IShort else if s = theMachine.theMachine.sizeof_longlong then ILongLong else raise Not_found let floatKindForSize (s:int) = if s = theMachine.theMachine.sizeof_double then FDouble else if s = theMachine.theMachine.sizeof_float then FFloat else if s = theMachine.theMachine.sizeof_longdouble then FLongDouble else raise Not_found (** Returns true if and only if the given integer type is signed. *) let isSigned = function | IUChar | IBool | IUShort | IUInt | IULong | IULongLong -> false | ISChar | IShort | IInt | ILong | ILongLong -> true | IChar -> not theMachine.theMachine.Cil_types.char_is_unsigned let max_signed_number nrBits = let n = nrBits-1 in Integer.pred (Integer.shift_left Integer.one (Integer.of_int n)) let max_unsigned_number nrBits = Integer.pred (Integer.shift_left Integer.one (Integer.of_int nrBits)) let min_signed_number nrBits = let n = nrBits-1 in Integer.neg (Integer.shift_left Integer.one (Integer.of_int n)) let debugTruncation = false (* True if the integer fits within the kind's range *) let fitsInInt k i = let signed = isSigned k in let nrBits = let unsignedbits = 8 * (bytesSizeOfInt k) in if signed then unsignedbits-1 else unsignedbits in let max_strict_bound = Integer.shift_left Integer.one (Integer.of_int nrBits) in let min_bound = if signed then Integer.neg max_strict_bound else Integer.zero in let fits = Integer.le min_bound i && Integer.lt i max_strict_bound in if debugTruncation then Kernel.debug "Fits in %a %a : %b@." !pp_ikind_ref k Datatype.Big_int.pretty i fits; fits (* Represents an integer as for a given kind. Returns a flag saying whether the value was changed during truncation (because it was too large to fit in k). *) let truncateInteger64 (k: ikind) i = if debugTruncation then Kernel.debug "Truncate to %a: %a@." !pp_ikind_ref k Datatype.Big_int.pretty i; if fitsInInt k i then i,false else begin let nrBits = Integer.of_int (8 * (bytesSizeOfInt k)) in let max_strict_bound = Integer.shift_left Integer.one nrBits in let modulo = Integer.pos_rem i max_strict_bound in let signed = isSigned k in if signed then let max_signed_strict_bound = Integer.shift_right max_strict_bound Integer.one in if Integer.ge modulo max_signed_strict_bound then Integer.sub modulo max_strict_bound else if Integer.lt modulo (Integer.neg max_signed_strict_bound) then Integer.add modulo max_strict_bound else modulo else if Integer.lt modulo Integer.zero then Integer.add modulo max_strict_bound else modulo end, true (* Return the smallest kind that will hold the integer's value. The kind will be unsigned if the 2nd argument is true *) let intKindForValue i (unsigned: bool) = if unsigned then if fitsInInt IUChar i then IUChar else if fitsInInt IUShort i then IUShort else if fitsInInt IUInt i then IUInt else if fitsInInt IULong i then IULong else IULongLong else if fitsInInt ISChar i then ISChar else if fitsInInt IShort i then IShort else if fitsInInt IInt i then IInt else if fitsInInt ILong i then ILong else ILongLong (* Construct an integer constant with possible truncation *) let kinteger64_repr ~loc (k: ikind) i repr = if debugTruncation then Kernel.debug "kinteger64_repr %a" Datatype.Big_int.pretty i; let i', truncated = truncateInteger64 k i in if truncated then if debugTruncation then Kernel.debug ~level:3 "Truncating integer %a to %a" Datatype.Big_int.pretty i Datatype.Big_int.pretty i'; new_exp ~loc (Const (CInt64(i' , k, repr))) let kinteger64 ~loc k i = kinteger64_repr ~loc k i None (* Construct an integer of a given kind. *) let kinteger ~loc (k: ikind) (i: int) = kinteger64 ~loc k (Integer.of_int i) (* Construct an integer. Use only for values that fit on 31 bits *) let integer_constant i = CInt64(Integer.of_int i, IInt, None) (* Construct an integer. Use only for values that fit on 31 bits *) let integer ~loc (i: int) = new_exp ~loc (Const (integer_constant i)) let kfloat ~loc k f = new_exp ~loc (Const (CReal(f,k,None))) let zero ~loc = integer ~loc 0 let one ~loc = integer ~loc 1 let mone ~loc = integer ~loc (-1) let integer_lconstant v = TConst (Integer (Integer.of_int v,None)) let lconstant ?(loc=Location.unknown) v = { term_node = TConst (Integer (v,None)); term_loc = loc; term_name = []; term_type = Linteger;} let lzero ?(loc=Location.unknown) () = lconstant ~loc Integer.zero let lone ?(loc=Location.unknown) () = lconstant ~loc Integer.one let lmone ?(loc=Location.unknown) () = lconstant ~loc (Integer.minus_one) (** Given the character c in a (CChr c), sign-extend it to 32 bits. (This is the official way of interpreting character constants, according to ISO C 6.4.4.4.10, which says that character constants are chars cast to ints) Returns CInt64(sign-extened c, IInt, None) *) let charConstToInt (c: char) : constant = let c' = Char.code c in let value = if c' < 128 then Integer.of_int c' else Integer.of_int (c' - 256) in CInt64(value, IInt, None) let rec isInteger e = match e.enode with | Const(CInt64 (n,_,_)) -> Some n | Const(CChr c) -> isInteger (dummy_exp (Const (charConstToInt c))) | Const(CEnum {eival = v}) -> isInteger v | CastE(_, e) -> isInteger e | _ -> None (** Convert a 64-bit int to an OCaml int, or raise an exception if that can't be done. *) let i64_to_int (i: int64) : int = let i': int = Int64.to_int i in (* i.e. i' = i mod 2^31 *) if i = Int64.of_int i' then i' else Kernel.abort "Int constant too large: %Ld\n" i let isZero (e: exp) : bool = match isInteger e with | None -> false | Some i -> Integer.equal i Integer.zero let rec isLogicZero t = match t.term_node with | TConst (Integer (n,_)) -> Integer.equal n Integer.zero | TConst (LChr c) -> Char.code c = 0 | TCastE(_, t) -> isLogicZero t | _ -> false let isLogicNull t = isLogicZero t || (let rec aux t = match t.term_node with | Tnull -> true | TCastE(_, t) -> aux t | _ -> false in aux t) let parseIntAux (str:string) = let hasSuffix str = let l = String.length str in fun s -> let ls = String.length s in l >= ls && s = String.uppercase (String.sub str (l - ls) ls) in let l = String.length str in (* See if it is octal or hex *) let octalhex = (l >= 1 && String.get str 0 = '0') in (* The length of the suffix and a list of possible kinds. See ISO * 6.4.4.1 *) let hasSuffix = hasSuffix str in let suffixlen, kinds = if hasSuffix "ULL" || hasSuffix "LLU" then 3, [IULongLong] else if hasSuffix "LL" then 2, if octalhex then [ILongLong; IULongLong] else [ILongLong] else if hasSuffix "UL" || hasSuffix "LU" then 2, [IULong; IULongLong] else if hasSuffix "L" then 1, if octalhex then [ILong; IULong; ILongLong; IULongLong] else [ILong; ILongLong] else if hasSuffix "U" then 1, [IUInt; IULong; IULongLong] else 0, if octalhex || true (* !!! This is against the ISO but it * is what GCC and MSVC do !!! *) then [IInt; IUInt; ILong; IULong; ILongLong; IULongLong] else [IInt; ILong; IUInt; ILongLong] in (* Convert to integer. To prevent overflow we do the arithmetic * on Big_int and we take care of overflow. We work only with * positive integers since the lexer takes care of the sign *) let rec toInt base (acc: Integer.t) (idx: int) : Integer.t = let doAcc what = let acc' = Integer.add what (Integer.mul base acc) in toInt base acc' (idx + 1) in if idx >= l - suffixlen then begin acc end else let ch = String.get str idx in if ch >= '0' && ch <= '9' then doAcc (Integer.of_int (Char.code ch - Char.code '0')) else if ch >= 'a' && ch <= 'f' then doAcc (Integer.of_int (10 + Char.code ch - Char.code 'a')) else if ch >= 'A' && ch <= 'F' then doAcc (Integer.of_int (10 + Char.code ch - Char.code 'A')) else Kernel.fatal ~current:true "Invalid integer constant: %s" str in let i = if octalhex then if l >= 2 && (let c = String.get str 1 in c = 'x' || c = 'X') then toInt Integer.small_nums.(16) Integer.zero 2 else toInt Integer.small_nums.(8) Integer.zero 1 else toInt Integer.small_nums.(10) Integer.zero 0 in i,kinds let parseInt s = fst (parseIntAux s) let parseIntLogic ~loc str = let i,_= parseIntAux str in { term_node = TConst (Integer (i,Some str)) ; term_loc = loc; term_name = []; term_type = Linteger;} let parseIntExp ~loc (str: string) : exp = try let i,kinds = parseIntAux str in let res = let rec loop = function | k::rest -> if fitsInInt k i then (* i fits in the current type. *) kinteger64_repr ~loc k i (Some str) else loop rest | [] -> Kernel.fatal ~source:(fst loc) "Cannot represent the integer %s" str in loop kinds in res with Failure "" as e -> Kernel.warning "int_of_string %s (%s)\n" str (Printexc.to_string e); zero ~loc let mkStmtCfg ~before ~(new_stmtkind:stmtkind) ~(ref_stmt:stmt) : stmt = let new_ = { skind = new_stmtkind; labels = []; sid = -1; succs = []; preds = []; ghost = false } in new_.sid <- Sid.next (); if before then begin new_.succs <- [ref_stmt]; let old_preds = ref_stmt.preds in ref_stmt.preds <- [new_]; new_.preds <- old_preds; List.iter (fun pred_stmt -> pred_stmt.succs <- (List.map (fun a_succ -> if a_succ.sid = ref_stmt.sid then new_ else a_succ) pred_stmt.succs)) old_preds end else begin let old_succs = ref_stmt.succs in ref_stmt.succs <- [new_]; new_.preds <- [ref_stmt]; new_.succs <- old_succs; List.iter (fun succ_stmt -> succ_stmt.preds <- (List.map (fun a_pred -> if a_pred.sid = ref_stmt.sid then new_ else a_pred) succ_stmt.preds)) old_succs end; new_ let mkStmtCfgBlock sl = let sid = Sid.next () in let n = mkStmt (Block (mkBlock sl)) in n.sid <- sid; match sl with | [] -> n | s::_ -> let old_preds = s.preds in n.succs <- [s]; n.preds <- s.preds; List.iter (fun pred_stmt -> pred_stmt.succs <- (List.map (fun a_succ -> if a_succ.sid = s.sid then n else a_succ) pred_stmt.succs)) old_preds; n let mkEmptyStmt ?ghost ?(loc=Location.unknown) () = mkStmt ?ghost (Instr (Skip loc)) let mkStmtOneInstr ?ghost ?valid_sid i = mkStmt ?ghost ?valid_sid (Instr i) let dummyInstr = Asm([], ["dummy statement!!"], [], [], [], Location.unknown) let dummyStmt = mkStmt (Instr dummyInstr) (** Get the full name of a comp *) let compFullName comp = (if comp.cstruct then "struct " else "union ") ^ comp.cname let missingFieldName = "" (* "___missing_field_name"*) (** Creates a (potentially recursive) composite type. Make sure you add a * GTag for it to the file! **) let mkCompInfo (isstruct: bool) (n: string) ?(norig=n) (* fspec is a function that when given a forward * representation of the structure type constructs the type of * the fields. The function can ignore this argument if not * constructing a recursive type. *) (mkfspec: compinfo -> (string * typ * int option * attribute list * location) list) (a: attribute list) : compinfo = (* make a new name for anonymous structs *) if n = "" then Kernel.fatal "mkCompInfo: missing structure name\n" ; (* Make a new self cell and a forward reference *) let comp = { cstruct = isstruct; corig_name = norig; cname = n; ckey = nextCompinfoKey (); cfields = []; (* fields will be added afterwards. *) cattr = a; creferenced = false; (* Make this compinfo undefined by default *) cdefined = false; } in let flds = List.map (fun (fn, ft, fb, fa, fl) -> { fcomp = comp; ftype = ft; forig_name = fn; fname = fn; fbitfield = fb; fattr = fa; floc = fl; faddrof = false; fsize_in_bits = None; foffset_in_bits = None; fpadding_in_bits = None; }) (mkfspec comp) in comp.cfields <- flds; if flds <> [] then comp.cdefined <- true; comp (** Make a copy of a compinfo, changing the name and the key *) let copyCompInfo (ci: compinfo) (n: string) : compinfo = let ci' = {ci with cname = n; ckey = nextCompinfoKey (); } in (* Copy the fields and set the new pointers to parents *) ci'.cfields <- List.map (fun f -> {f with fcomp = ci'}) ci'.cfields; ci' let rec unrollTypeDeep (t: typ) : typ = let rec withAttrs (al: attributes) (t: typ) : typ = match t with TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype | TPtr(t, a') -> TPtr(unrollTypeDeep t, addAttributes al a') | TArray(t, l, s, a') -> let att_elt, att_typ = splitArrayAttributes al in TArray(arrayPushAttributes att_elt (unrollTypeDeep t), l, s, addAttributes att_typ a') | TFun(rt, args, isva, a') -> TFun (unrollTypeDeep rt, (match args with None -> None | Some argl -> Some (List.map (fun (an,at,aa) -> (an, unrollTypeDeep at, aa)) argl)), isva, addAttributes al a') | x -> typeAddAttributes al x in withAttrs [] t let isVoidType t = match unrollTypeSkel t with TVoid _ -> true | _ -> false let isVoidPtrType t = match unrollTypeSkel t with TPtr(tau,_) when isVoidType tau -> true | _ -> false let isPtrType ct = match unrollTypeSkel ct with TPtr _ -> true | _ -> false let isSignedInteger ty = match unrollTypeSkel ty with | TInt(ik,_) | TEnum ({ekind=ik},_) -> isSigned ik | _ -> false let isUnsignedInteger ty = match unrollTypeSkel ty with | TInt(ik,_) | TEnum ({ekind=ik},_) -> not (isSigned ik) | _ -> false let var vi : lval = (Var vi, NoOffset) (* let assign vi e = Cil_datatype.Instrs(Set (var vi, e), lu) *) let evar ?(loc=Location.unknown) vi = new_exp ~loc (Lval (var vi)) let mkString ~loc s = new_exp ~loc (Const(CStr s)) let mkWhile ~(guard:exp) ~(body: stmt list) : stmt list = (* Do it like this so that the pretty printer recognizes it *) [ mkStmt (Loop ([], mkBlock (mkStmt (If(guard, mkBlock [ mkEmptyStmt () ], mkBlock [ mkStmt (Break guard.eloc)], guard.eloc)) :: body), guard.eloc, None, None)) ] let mkFor ~(start: stmt list) ~(guard: exp) ~(next: stmt list) ~(body: stmt list) : stmt list = (start @ (mkWhile guard (body @ next))) let mkForIncr ~(iter : varinfo) ~(first: exp) ~stopat:(past: exp) ~(incr: exp) ~(body: stmt list) : stmt list = (* See what kind of operator we need *) let compop, nextop = match unrollTypeSkel iter.vtype with TPtr _ -> Lt, PlusPI | _ -> Lt, PlusA in mkFor [ mkStmt (Instr (Set (var iter, first, first.eloc))) ] (new_exp ~loc:past.eloc (BinOp(compop, new_exp ~loc:past.eloc (Lval(var iter)), past, intType))) [ mkStmt (Instr (Set (var iter, (new_exp ~loc:incr.eloc (BinOp(nextop, new_exp ~loc:past.eloc (Lval(var iter)), incr, iter.vtype))), incr.eloc)))] body let block_from_unspecified_sequence us = { battrs = []; bstmts = List.map (fun (x,_,_,_,_) ->x) us; blocals = [] } let rec stripCasts (e: exp) = match e.enode with CastE(_, e') -> stripCasts e' | _ -> e let rec stripCastsAndInfo (e: exp) = match e.enode with Info(e',_) | CastE(_,e') -> stripCastsAndInfo e' | _ -> e let rec stripCastsButLastInfo (e: exp) = match e.enode with Info({enode = (Info _ | CastE _)} as e',_) | CastE(_,e') -> stripCastsButLastInfo e' | _ -> e let rec stripTermCasts (t: term) = match t.term_node with TCastE(_, t') -> stripTermCasts t' | _ -> t let exp_info_of_term t = { exp_type = t.term_type; exp_name = t.term_name;} let term_of_exp_info loc tnode einfo = { term_node = tnode; term_loc = loc; term_type = einfo.exp_type; term_name = einfo.exp_name; } let map_under_info f e = match e.enode with | Info(e,einfo) -> new_exp ~loc:e.eloc (Info(f e,einfo)) | _ -> f e let app_under_info f e = match e.enode with | Info(e,_) -> f e | _ -> f e (* Separate out the storage-modifier name attributes *) let separateStorageModifiers (al: attribute list) = let isstoragemod (Attr(an, _) | AttrAnnot an : attribute) : bool = try match Hashtbl.find attributeHash an with AttrName issm -> issm | _ -> false with Not_found -> false in let stom, rest = List.partition isstoragemod al in if not theMachine.msvcMode then stom, rest else (* Put back the declspec. Put it without the leading __ since these will * be added later *) let stom' = List.map (function | Attr(an, args) -> Attr("declspec", [ACons(an, args)]) | AttrAnnot _ -> assert false) stom in stom', rest let isCharType t = match unrollTypeSkel t with | TInt((IChar|ISChar|IUChar),_) -> true | _ -> false let isShortType t = match unrollTypeSkel t with | TInt((IUShort|IShort),_) -> true | _ -> false let isCharPtrType t = match unrollTypeSkel t with TPtr(tau,_) when isCharType tau -> true | _ -> false let isIntegralType t = match unrollTypeSkel t with (TInt _ | TEnum _) -> true | _ -> false let isLogicIntegralType t = match t with | Ctype t -> isIntegralType t | Linteger -> true | Lreal -> false | Lvar _ | Ltype _ | Larrow _ -> false let isFloatingType t = match unrollTypeSkel t with TFloat _ -> true | _ -> false let isLogicFloatType t = match t with | Ctype t -> isFloatingType t | Linteger -> false | Lreal -> false | Lvar _ | Ltype _ | Larrow _ -> false let isLogicRealOrFloatType t = match t with | Ctype t -> isFloatingType t | Linteger -> false | Lreal -> true | Lvar _ | Ltype _ | Larrow _ -> false let isLogicRealType t = match t with | Ctype _ -> false | Linteger -> false | Lreal -> true | Lvar _ | Ltype _ | Larrow _ -> false let isArithmeticType t = match unrollTypeSkel t with (TInt _ | TEnum _ | TFloat _) -> true | _ -> false let isLogicArithmeticType t = match t with | Ctype t -> isArithmeticType t | Linteger | Lreal -> true | Lvar _ | Ltype _ | Larrow _ -> false let isPointerType t = match unrollTypeSkel t with TPtr _ -> true | _ -> false let isTypeTagType t = match t with Ltype({lt_name = "typetag"},[]) -> true | _ -> false let getReturnType t = match unrollType t with | TFun(rt,_,_,_) -> rt | _ -> Kernel.fatal "getReturnType: not a function type" let setReturnTypeVI (v: varinfo) (t: typ) = match unrollType v.vtype with | TFun (_, args, va, a) -> v.vtype <- TFun (t, args, va, a) | _ -> Kernel.fatal "setReturnType: not a function type" let setReturnType (f:fundec) (t:typ) = setReturnTypeVI f.svar t (** Returns the type pointed by the given type. Asserts it is a pointer type *) let typeOf_pointed typ = match unrollType typ with | TPtr (typ,_) -> typ | _ -> assert false (** Returns the type of the elements of the array. Asserts it is an array type *) let typeOf_array_elem t = match unrollType t with | TArray (ty_elem, _, _, _) -> ty_elem | _ -> assert false (**** Compute the type of an expression ****) let rec typeOf (e: exp) : typ = match (stripInfo e).enode with | Info _ -> assert false | Const(CInt64 (_, ik, _)) -> TInt(ik, []) (* Character constants have type int. ISO/IEC 9899:1999 (E), * section 6.4.4.4 [Character constants], paragraph 10, if you * don't believe me. *) | Const(CChr _) -> intType (* The type of a string is a pointer to characters ! The only case when * you would want it to be an array is as an argument to sizeof, but we * have SizeOfStr for that *) | Const(CStr _s) -> theMachine.stringLiteralType | Const(CWStr _s) -> TPtr(theMachine.wcharType,[]) | Const(CReal (_, fk, _)) -> TFloat(fk, []) | Const(CEnum {eival=v}) -> typeOf v | Lval(lv) -> typeOfLval lv | SizeOf _ | SizeOfE _ | SizeOfStr _ -> theMachine.typeOfSizeOf | AlignOf _ | AlignOfE _ -> theMachine.typeOfSizeOf | UnOp (_, _, t) -> t | BinOp (_, _, _, t) -> t | CastE (t, _) -> t | AddrOf (lv) -> TPtr(typeOfLval lv, []) | StartOf (lv) -> match unrollType (typeOfLval lv) with | TArray (t,_,_, _) -> TPtr(t, []) | _ -> Kernel.fatal ~current:true "typeOf: StartOf on a non-array" and typeOfInit (i: init) : typ = match i with SingleInit e -> typeOf e | CompoundInit (t, _) -> t and typeOfLval = function Var vi, off -> typeOffset vi.vtype off | Mem addr, off -> begin match unrollType (typeOf addr) with | TPtr (t, _) -> typeOffset t off | _ -> Kernel.fatal ~current:true "typeOfLval: Mem on a non-pointer (%a)" !pp_exp_ref addr end and typeOfLhost = function | Var x -> x.vtype | Mem e -> typeOf_pointed (typeOf e) and typeOffset basetyp = function NoOffset -> basetyp | Index (_, o) -> begin match unrollType basetyp with TArray (t, _, _, _baseAttrs) -> typeOffset t o | _ -> Kernel.fatal ~current:true "typeOffset: Index on a non-array" end | Field (fi, o) -> match unrollType basetyp with TComp (_, _,baseAttrs) -> let fieldType = typeOffset fi.ftype o in let attrs = filter_qualifier_attributes baseAttrs in typeAddAttributes attrs fieldType | basetyp -> Kernel.fatal ~current:true "typeOffset: Field %s on a non-compound type '%a'" fi.fname !pp_typ_ref basetyp (**** Compute the type of a term lval ****) let rec typeOfTermLval = function TVar vi, off -> let ty = match vi.lv_origin with | Some v -> Ctype v.vtype | None -> vi.lv_type in typeTermOffset ty off | TResult ty, off -> typeTermOffset (Ctype ty) off | TMem addr, off -> begin let type_of_pointed t = match t with | Ctype typ -> begin match unrollType typ with TPtr (t, _) -> typeTermOffset (Ctype t) off | _ -> Kernel.fatal ~current:true "typeOfTermLval: Mem on a non-pointer" end | Linteger | Lreal -> Kernel.fatal ~current:true "typeOfTermLval: Mem on a logic type" | Ltype (s,_) -> Kernel.fatal ~current:true "typeOfTermLval: Mem on a non-C type (%s)" s.lt_name | Lvar s -> Kernel.fatal ~current:true "typeOfTermLval: Mem on a non-C type ('%s)" s | Larrow _ -> Kernel.fatal ~current:true "typeOfTermLval: Mem on a function type" in Logic_const.transform_element type_of_pointed addr.term_type end and typeTermOffset basetyp = let blendAttributes baseAttrs t = let (_, _, contageous) = partitionAttributes ~default:(AttrName false) baseAttrs in let putAttributes = function | Ctype typ -> Ctype (typeAddAttributes contageous typ) | Linteger | Lreal -> Kernel.fatal ~current:true "typeTermOffset: Attribute on a logic type" | Ltype (s,_) -> Kernel.fatal ~current:true "typeTermOffset: Attribute on a non-C type (%s)" s.lt_name | Lvar s -> Kernel.fatal ~current:true "typeTermOffset: Attribute on a non-C type ('%s)" s | Larrow _ -> Kernel.fatal ~current:true "typeTermOffset: Attribute on a function type" in Logic_const.transform_element putAttributes t in function | TNoOffset -> basetyp | TIndex (e, o) -> begin let elt_type basetyp = match basetyp with | Ctype typ -> begin match unrollType typ with TArray (t, _, _, baseAttrs) -> let elementType = typeTermOffset (Ctype t) o in blendAttributes baseAttrs elementType | _ -> Kernel.fatal ~current:true "typeTermOffset: Index on a non-array" end | Linteger | Lreal -> Kernel.fatal ~current:true "typeTermOffset: Index on a logic type" | Ltype (s,_) -> Kernel.fatal ~current:true "typeTermOffset: Index on a non-C type (%s)" s.lt_name | Lvar s -> Kernel.fatal ~current:true "typeTermOffset: Index on a non-C type ('%s)" s | Larrow _ -> Kernel.fatal ~current:true "typeTermOffset: Index on a function type" in Logic_const.set_conversion (Logic_const.transform_element elt_type basetyp) e.term_type end | TModel (m,o) -> typeTermOffset m.mi_field_type o | TField (fi, o) -> let elt_type basetyp = match basetyp with | Ctype typ -> begin match unrollType typ with TComp (_, _, baseAttrs) -> let fieldType = typeTermOffset (Ctype fi.ftype) o in blendAttributes baseAttrs fieldType | _ -> Kernel.fatal ~current:true "typeTermOffset: Field on a non-compound" end | Linteger | Lreal -> Kernel.fatal ~current:true "typeTermOffset: Field on a logic type" | Ltype (s,_) -> Kernel.fatal ~current:true "typeTermOffset: Field on a non-C type (%s)" s.lt_name | Lvar s -> Kernel.fatal ~current:true "typeTermOffset: Field on a non-C type ('%s)" s | Larrow _ -> Kernel.fatal ~current:true "typeTermOffset: Field on a function type" in Logic_const.transform_element elt_type basetyp (**** Look at at the presence of an attribute in a type ****) let typeHasAttributeDeep a (ty:typ): bool = let f attrs = if hasAttribute a attrs then raise Exit in let rec visit (t: typ) : unit = match t with | TNamed (r, a') -> f a' ; visit r.ttype | TArray(t, _, _, a') -> f a'; visit t | TComp (comp, _, a') -> f a'; List.iter (fun fi -> f fi.fattr; visit fi.ftype) comp.cfields | TVoid a' | TInt (_, a') | TFloat (_, a') | TEnum (_, a') | TFun (_, _, _, a') | TBuiltin_va_list a' | TPtr(_, a') -> f a' in try visit ty; false with Exit -> true (** ** ** MACHINE DEPENDENT PART ** **) exception SizeOfError of string * typ let find_size_in_cache s f = match s.scache with | Not_Computed -> let r = try f () with SizeOfError (msg, typ) as e -> s.scache <- Not_Computable (msg, typ); raise e in s.scache <- Computed r; r | Not_Computable (msg, typ) -> raise (SizeOfError (msg, typ)) | Computed r -> r (* Some basic type utilities *) let rank : ikind -> int = function (* these are just unique numbers representing the integer conversion rank. *) | IBool | IChar | ISChar | IUChar -> 1 | IShort | IUShort -> 2 | IInt | IUInt -> 3 | ILong | IULong -> 4 | ILongLong | IULongLong -> 5 let unsignedVersionOf (ik:ikind): ikind = match ik with | ISChar | IChar -> IUChar | IShort -> IUShort | IInt -> IUInt | ILong -> IULong | ILongLong -> IULongLong | _ -> ik let frank = function | FFloat -> 1 | FDouble -> 2 | FLongDouble -> 3 (* Convert 2 integer constants to integers with the same type, in preparation for a binary operation. See ISO C 6.3.1.8p1 *) let convertInts i1 ik1 i2 ik2 = if ik1 = ik2 then (* nothing to do *) i1, i2, ik1 else begin let r1 = rank ik1 in let r2 = rank ik2 in let ik' = if (isSigned ik1) = (isSigned ik2) then begin (* Both signed or both unsigned. *) if r1 > r2 then ik1 else ik2 end else begin let signedKind, unsignedKind, signedRank, unsignedRank = if isSigned ik1 then ik1, ik2, r1, r2 else ik2, ik1, r2, r1 in (* The rules for signed + unsigned get hairy. (unsigned short + long) is converted to signed long, but (unsigned int + long) is converted to unsigned long.*) if unsignedRank >= signedRank then unsignedKind else if (bytesSizeOfInt signedKind) > (bytesSizeOfInt unsignedKind) then signedKind else unsignedVersionOf signedKind end in let i1',_ = truncateInteger64 ik' i1 in let i2',_ = truncateInteger64 ik' i2 in i1', i2', ik' end (* Local type to compute alignments of struct field. *) type offsetAcc = { oaFirstFree: int; (* The first free bit *) oaLastFieldStart: int; (* Where the previous field started *) oaLastFieldWidth: int; (* The width of the previous field. Might not * be same as FirstFree - FieldStart because * of internal padding *) oaPrevBitPack: (int * ikind * int) option; (* If the previous fields * were packed bitfields, * the bit where packing * has started, the ikind * of the bitfield and the * width of the ikind *) } (* Hack to prevent infinite recursion in alignments *) let ignoreAlignmentAttrs = ref false module CoupleTypOffset = Datatype.Pair_with_collections(Typ)(Offset) (struct let module_name = "Cil.CoupleTypOffset" end) module CacheBitsOffset = State_builder.Hashtbl (CoupleTypOffset.Hashtbl) (Datatype.Pair(Datatype.Int)(Datatype.Int)) (struct let size = 17 let dependencies = [] let name = "Cil.CacheBitsOffset" end) (* Get the minimum aligment in bytes for a given type *) let rec bytesAlignOf t = let alignOfType () = match t with | TInt((IChar|ISChar|IUChar|IBool), _) -> 1 | TInt((IShort|IUShort), _) -> theMachine.theMachine.alignof_short | TInt((IInt|IUInt), _) -> theMachine.theMachine.alignof_int | TInt((ILong|IULong), _) -> theMachine.theMachine.alignof_long | TInt((ILongLong|IULongLong), _) -> theMachine.theMachine.alignof_longlong | TEnum (ei,_) -> bytesAlignOf (TInt(ei.ekind, [])) | TFloat(FFloat, _) -> theMachine.theMachine.alignof_float | TFloat(FDouble, _) -> theMachine.theMachine.alignof_double | TFloat(FLongDouble, _) -> theMachine.theMachine.alignof_longdouble | TNamed (t, _) -> bytesAlignOf t.ttype | TArray (t, _, _, _) -> bytesAlignOf t | TPtr _ | TBuiltin_va_list _ -> theMachine.theMachine.alignof_ptr (* For composite types get the maximum alignment of any field inside *) | TComp (c, _, _) -> (* On GCC the zero-width fields do not contribute to the alignment. On * MSVC only those zero-width that _do_ appear after other * bitfields contribute to the alignment. So we drop those that * do not occur after othe bitfields *) (* This is not correct for Diab-C compiler. *) let rec dropZeros (afterbitfield: bool) = function | f :: rest when f.fbitfield = Some 0 && not afterbitfield -> dropZeros afterbitfield rest | f :: rest -> f :: dropZeros (f.fbitfield <> None) rest | [] -> [] in let fields = dropZeros false c.cfields in List.fold_left (fun sofar f -> (* Bitfields with zero width do not contribute to the alignment in * GCC *) if not theMachine.msvcMode && f.fbitfield = Some 0 then sofar else max sofar (alignOfField f)) 1 fields (* These are some error cases *) | TFun _ when not theMachine.msvcMode -> theMachine.theMachine.alignof_fun | TFun _ as t -> raise (SizeOfError ("Undefined sizeof on a function.", t)) | TVoid _ as t -> raise (SizeOfError ("Undefined sizeof(void).", t)) in match filterAttributes "aligned" (typeAttrs t) with [] -> (* no __aligned__ attribute, so get the default alignment *) alignOfType () | _ when !ignoreAlignmentAttrs -> Kernel.warning "ignoring recursive align attributes on %a" !pp_typ_ref t; alignOfType () | (Attr(_, [a]) as at)::rest -> begin if rest <> [] then Kernel.warning "ignoring duplicate align attributes on %a" !pp_typ_ref t; match intOfAttrparam a with Some n -> n | None -> Kernel.warning "alignment attribute \"%a\" not understood on %a" !pp_attribute_ref at !pp_typ_ref t; alignOfType () end | Attr(_, [])::rest -> (* aligned with no arg means a power of two at least as large as any alignment on the system.*) if rest <> [] then Kernel.warning "ignoring duplicate align attributes on %a" !pp_typ_ref t; theMachine.theMachine.alignof_aligned | at::_ -> Kernel.warning "alignment attribute \"%a\" not understood on %a" !pp_attribute_ref at !pp_typ_ref t; alignOfType () (* alignment of a possibly-packed struct field. *) and alignOfField (fi: fieldinfo) = let fieldIsPacked = hasAttribute "packed" fi.fattr || hasAttribute "packed" fi.fcomp.cattr in if fieldIsPacked then 1 else bytesAlignOf fi.ftype and intOfAttrparam (a:attrparam) : int option = let rec doit a : int = match a with | AInt(n) -> Integer.to_int n | ABinOp(Shiftlt, a1, a2) -> (doit a1) lsl (doit a2) | ABinOp(Div, a1, a2) -> (doit a1) / (doit a2) | ASizeOf(t) -> let bs = bitsSizeOf t in bs / 8 | AAlignOf(t) -> bytesAlignOf t | _ -> raise (SizeOfError ("Cannot convert an attribute to int.", voidType)) in (* Use ignoreAlignmentAttrs here to prevent stack overflow if a buggy program does something like struct s {...} __attribute__((aligned(sizeof(struct s)))) This is too conservative, but it's often enough. *) assert (not !ignoreAlignmentAttrs); ignoreAlignmentAttrs := true; try let n = doit a in ignoreAlignmentAttrs := false; Some n with Failure _ | SizeOfError _ -> (* Can't compile *) ignoreAlignmentAttrs := false; None (* GCC version *) (* Does not use the sofar.oaPrevBitPack *) and offsetOfFieldAcc_GCC (fi: fieldinfo) (sofar: offsetAcc) : offsetAcc = (* field type *) let ftype = unrollType fi.ftype in let ftypeAlign = 8 * alignOfField fi in let ftypeBits = bitsSizeOf ftype in match ftype, fi.fbitfield with (* A width of 0 means that we must end the current packing. It seems that * GCC pads only up to the alignment boundary for the type of this field. * *) | _, Some 0 -> let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in { oaFirstFree = firstFree; oaLastFieldStart = firstFree; oaLastFieldWidth = 0; oaPrevBitPack = None } (* A bitfield cannot span more alignment boundaries of its type than the * type itself *) | _, Some wdthis when (sofar.oaFirstFree + wdthis + ftypeAlign - 1) / ftypeAlign - sofar.oaFirstFree / ftypeAlign > ftypeBits / ftypeAlign -> let start = addTrailing sofar.oaFirstFree ftypeAlign in { oaFirstFree = start + wdthis; oaLastFieldStart = start; oaLastFieldWidth = wdthis; oaPrevBitPack = None } (* Try a simple method. Just put the field down *) | _, Some wdthis -> { oaFirstFree = sofar.oaFirstFree + wdthis; oaLastFieldStart = sofar.oaFirstFree; oaLastFieldWidth = wdthis; oaPrevBitPack = None } (* Non-bitfield *) | _, None -> (* Align this field *) let newStart = addTrailing sofar.oaFirstFree ftypeAlign in { oaFirstFree = newStart + ftypeBits; oaLastFieldStart = newStart; oaLastFieldWidth = ftypeBits; oaPrevBitPack = None; } (* MSVC version *) and offsetOfFieldAcc_MSVC (fi: fieldinfo) (sofar: offsetAcc) : offsetAcc = (* field type *) let ftype = unrollType fi.ftype in let ftypeAlign = 8 * alignOfField fi in let ftypeBits = bitsSizeOf ftype in match ftype, fi.fbitfield, sofar.oaPrevBitPack with (* Ignore zero-width bitfields that come after non-bitfields *) | TInt (_ikthis, _), Some 0, None -> let firstFree = sofar.oaFirstFree in { oaFirstFree = firstFree; oaLastFieldStart = firstFree; oaLastFieldWidth = 0; oaPrevBitPack = None } (* If we are in a bitpack and we see a bitfield for a type with the * different width than the pack, then we finish the pack and retry *) | _, Some _, Some (packstart, _, wdpack) when wdpack != ftypeBits -> let firstFree = if sofar.oaFirstFree = packstart then packstart else packstart + wdpack in offsetOfFieldAcc_MSVC fi { oaFirstFree = addTrailing firstFree ftypeAlign; oaLastFieldStart = sofar.oaLastFieldStart; oaLastFieldWidth = sofar.oaLastFieldWidth; oaPrevBitPack = None } (* A width of 0 means that we must end the current packing. *) | TInt (ikthis, _), Some 0, Some (packstart, _, wdpack) -> let firstFree = if sofar.oaFirstFree = packstart then packstart else packstart + wdpack in let firstFree = addTrailing firstFree ftypeAlign in { oaFirstFree = firstFree; oaLastFieldStart = firstFree; oaLastFieldWidth = 0; oaPrevBitPack = Some (firstFree, ikthis, ftypeBits) } (* Check for a bitfield that fits in the current pack after some other * bitfields *) | TInt(_ikthis, _), Some wdthis, Some (packstart, _ikprev, wdpack) when packstart + wdpack >= sofar.oaFirstFree + wdthis -> { oaFirstFree = sofar.oaFirstFree + wdthis; oaLastFieldStart = sofar.oaFirstFree; oaLastFieldWidth = wdthis; oaPrevBitPack = sofar.oaPrevBitPack } | _, _, Some (packstart, _, wdpack) -> (* Finish up the bitfield pack and * restart. *) let firstFree = if sofar.oaFirstFree = packstart then packstart else packstart + wdpack in offsetOfFieldAcc_MSVC fi { oaFirstFree = addTrailing firstFree ftypeAlign; oaLastFieldStart = sofar.oaLastFieldStart; oaLastFieldWidth = sofar.oaLastFieldWidth; oaPrevBitPack = None } (* No active bitfield pack. But we are seeing a bitfield. *) | TInt(ikthis, _), Some wdthis, None -> let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in { oaFirstFree = firstFree + wdthis; oaLastFieldStart = firstFree; oaLastFieldWidth = wdthis; oaPrevBitPack = Some (firstFree, ikthis, ftypeBits); } (* No active bitfield pack. Non-bitfield *) | _, None, None -> (* Align this field *) let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in { oaFirstFree = firstFree + ftypeBits; oaLastFieldStart = firstFree; oaLastFieldWidth = ftypeBits; oaPrevBitPack = None; } | _, Some _, None -> Kernel.fatal ~current:true "offsetAcc" and offsetOfFieldAcc ~(fi: fieldinfo) ~(sofar: offsetAcc) : offsetAcc = if theMachine.msvcMode then offsetOfFieldAcc_MSVC fi sofar else offsetOfFieldAcc_GCC fi sofar (* The size of a type, in bits. If struct or array then trailing padding is * added *) and bitsSizeOf t = if not (TheMachine.is_computed ()) then Kernel.fatal ~current:true "You did not call Cil.initCIL before using the CIL library" ; match t with | TInt (ik,_) -> 8 * (bytesSizeOfInt ik) | TFloat(FDouble, _) -> 8 * theMachine.theMachine.sizeof_double | TFloat(FLongDouble, _) -> 8 * theMachine.theMachine.sizeof_longdouble | TFloat _ -> 8 * theMachine.theMachine.sizeof_float | TEnum (ei,_) -> bitsSizeOf (TInt(ei.ekind, [])) | TPtr _ -> 8 * theMachine.theMachine.sizeof_ptr | TBuiltin_va_list _ -> 8 * theMachine.theMachine.sizeof_ptr | TNamed (t, _) -> bitsSizeOf t.ttype | TComp (comp, scache, _) when comp.cfields == [] -> find_size_in_cache scache (fun () -> begin (* Empty structs are allowed in msvc mode *) if not comp.cdefined && not theMachine.msvcMode then begin raise (SizeOfError (Format.sprintf "abstract type '%s'" (compFullName comp), t)) end else 0 end) | TComp (comp, scache, _) when comp.cstruct -> (* Struct *) find_size_in_cache scache (fun () -> (* Go and get the last offset *) let startAcc = { oaFirstFree = 0; oaLastFieldStart = 0; oaLastFieldWidth = 0; oaPrevBitPack = None; } in let lastoff = List.fold_left (fun acc fi -> offsetOfFieldAcc ~fi ~sofar:acc) startAcc comp.cfields in if theMachine.msvcMode && lastoff.oaFirstFree = 0 && comp.cfields <> [] then (* On MSVC if we have just a zero-width bitfields then the length * is 32 and is not padded *) 32 else addTrailing lastoff.oaFirstFree (8 * bytesAlignOf t)) | TComp (comp, scache, _) -> (* Union *) find_size_in_cache scache (fun () -> (* Get the maximum of all fields *) let startAcc = { oaFirstFree = 0; oaLastFieldStart = 0; oaLastFieldWidth = 0; oaPrevBitPack = None; } in let max = List.fold_left (fun acc fi -> let lastoff = offsetOfFieldAcc ~fi ~sofar:startAcc in if lastoff.oaFirstFree > acc then lastoff.oaFirstFree else acc) 0 comp.cfields in (* Add trailing by simulating adding an extra field *) addTrailing max (8 * bytesAlignOf t)) | TArray(bt, Some len, scache, _) -> find_size_in_cache scache (fun () -> begin match (constFold true len).enode with Const(CInt64(l,_,_)) -> let sz = Integer.mul (Integer.of_int (bitsSizeOf bt)) l in let sz' = try Integer.to_int sz with Failure "to_int" -> raise (SizeOfError ("Array is so long that its size can't be " ^"represented with an OCaml int.", t)) in sz' (*WAS: addTrailing sz' (8 * bytesAlignOf t)*) | _ -> raise (SizeOfError ("Array with non-constant length.", t)) end) | TVoid _ -> 8 * theMachine.theMachine.sizeof_void | TFun _ -> if not theMachine.msvcMode then (* On GCC the size of a function is defined *) 8 * theMachine.theMachine.sizeof_fun else raise (SizeOfError ("Undefined sizeof on a function.", t)) | TArray (_, None, _, _) -> (* it seems that on GCC the size of such an array is 0 *) (* TODO: msvc case not handled *) 0 and addTrailing nrbits roundto = (nrbits + roundto - 1) land (lnot (roundto - 1)) and sizeOf_int t = (bitsSizeOf t) lsr 3 and sizeOf ~loc t = try integer ~loc ((bitsSizeOf t) lsr 3) with SizeOfError _ -> new_exp ?loc (SizeOf(t)) and bitsOffset (baset: typ) (off: offset) : int * int = CacheBitsOffset.memo (fun (baset, off) -> let rec loopOff (baset: typ) (width: int) (start: int) = function NoOffset -> start, width | Index(e, off) -> begin let ei = match isInteger (constFold true e) with | Some i -> Integer.to_int i | None -> raise (SizeOfError ("Index is not constant", baset)) in let bt = match unrollType baset with | TArray(bt, _, _, _) -> bt | t -> Kernel.fatal ~current:true "bitsOffset: Index on a non-array %a" !pp_typ_ref t in let bitsbt = bitsSizeOf bt in loopOff bt bitsbt (start + ei * bitsbt) off end | Field(f, off) when not f.fcomp.cstruct -> if check_invariants then assert (match unrollType baset with | TComp (ci, _, _) -> ci == f.fcomp | _ -> false); (* All union fields start at offset 0 *) loopOff f.ftype (bitsSizeOf f.ftype) start off | Field(f, off) -> if check_invariants then assert (match unrollType baset with | TComp (ci, _, _) -> ci == f.fcomp | _ -> false); (* Construct a list of fields preceeding and including this one *) let prevflds = let rec loop = function | [] -> Kernel.abort "bitsOffset: Cannot find field %s in %s" f.fname f.fcomp.cname | fi' :: _ when fi' == f -> [ fi' ] | fi' :: rest -> fi' :: loop rest in loop f.fcomp.cfields in let lastoff = List.fold_left (fun acc fi' -> offsetOfFieldAcc ~fi:fi' ~sofar:acc) { oaFirstFree = 0; (* Start at 0 because each struct is done * separately *) oaLastFieldStart = 0; oaLastFieldWidth = 0; oaPrevBitPack = None } prevflds in (* ignore (E.log "Field %s of %s: start=%d, lastFieldStart=%d\n" f.fname f.fcomp.cname start lastoff.oaLastFieldStart); *) loopOff f.ftype lastoff.oaLastFieldWidth (start + lastoff.oaLastFieldStart) off in loopOff baset (bitsSizeOf baset) 0 off ) (baset, off) (** Do constant folding on an expression. If the first argument is true then will also compute compiler-dependent expressions such as sizeof. See also {!Cil.constFoldVisitor}, which will run constFold on all expressions in a given AST node.*) and constFold (machdep: bool) (e: exp) : exp = if debugConstFold then Kernel.debug "ConstFold to %a@." !pp_exp_ref e; let loc = e.eloc in match e.enode with BinOp(bop, e1, e2, tres) -> constFoldBinOp ~loc machdep bop e1 e2 tres | UnOp(unop, e1, tres) -> begin try let tk = match unrollTypeSkel tres with | TInt(ik, _) -> ik | TEnum (ei,_) -> ei.ekind | _ -> raise Not_found (* probably a float *) in let e1c = constFold machdep e1 in match e1c.enode with Const(CInt64(i,_ik,repr)) -> begin match unop with Neg -> let repr = Extlib.opt_map (fun s -> "-" ^ s) repr in kinteger64_repr ~loc tk (Integer.neg i) repr | BNot -> kinteger64 ~loc tk (Integer.lognot i) | LNot -> if Integer.equal i Integer.zero then one ~loc else zero ~loc end | _ -> if e1 == e1c then e else new_exp ~loc (UnOp(unop, e1c, tres)) with Not_found -> e end (* Characters are integers *) | Const(CChr c) -> new_exp ~loc (Const(charConstToInt c)) | Const(CEnum {eival = v}) -> constFold machdep v | Const (CReal _ | CWStr _ | CStr _ | CInt64 _) -> e (* a constant *) | SizeOf t when machdep -> begin try let bs = bitsSizeOf t in kinteger ~loc theMachine.kindOfSizeOf (bs / 8) with SizeOfError _ -> e end | SizeOfE e when machdep -> constFold machdep (new_exp ~loc:e.eloc (SizeOf (typeOf e))) | SizeOfStr s when machdep -> kinteger ~loc theMachine.kindOfSizeOf (1 + String.length s) | AlignOf t when machdep -> kinteger ~loc theMachine.kindOfSizeOf (bytesAlignOf t) | AlignOfE e when machdep -> begin (* The alignment of an expression is not always the alignment of its * type. I know that for strings this is not true *) match e.enode with Const (CStr _) when not theMachine.msvcMode -> kinteger ~loc theMachine.kindOfSizeOf theMachine.theMachine.alignof_str (* For an array, it is the alignment of the array ! *) | _ -> constFold machdep (new_exp ~loc:e.eloc (AlignOf (typeOf e))) end | AlignOfE _ | AlignOf _ | SizeOfStr _ | SizeOfE _ | SizeOf _ -> e (* Depends on machdep. Do not evaluate in this case*) | CastE(it, { enode = AddrOf (Mem ({enode = CastE(TPtr(bt, _), z)}), off)}) when machdep && isZero z -> begin try let start, _width = bitsOffset bt off in if start mod 8 <> 0 then Kernel.error ~current:true "Using offset of bitfield" ; constFold machdep (new_exp ~loc (CastE(it, (integer ~loc (start / 8))))) with SizeOfError _ -> e end | CastE (t, e) -> begin if debugConstFold then Kernel.debug "ConstFold CAST to to %a@." !pp_typ_ref t ; let e = constFold machdep e in match e.enode, unrollType t with (* Might truncate silently *) Const(CInt64(i,_k,_)), TInt(nk,a) (* It's okay to drop a cast to const. If the cast has any other attributes, leave the cast alone. *) when (dropAttributes ["const"] a) = [] -> if debugConstFold then Kernel.debug "ConstFold to %a : %a@." !pp_ikind_ref nk Datatype.Big_int.pretty i; kinteger64 ~loc nk i | _, _ -> new_exp ~loc (CastE (t, e)) end | Lval lv -> new_exp ~loc (Lval (constFoldLval machdep lv)) | AddrOf lv -> new_exp ~loc (AddrOf (constFoldLval machdep lv)) | StartOf lv -> new_exp ~loc (StartOf (constFoldLval machdep lv)) | Info _ -> e (* Deprecated constructor *) and constFoldLval machdep (host,offset) = let newhost = match host with | Mem e -> Mem (constFold machdep e) | Var _ -> host in let rec constFoldOffset machdep = function | NoOffset -> NoOffset | Field (fi,offset) -> Field (fi, constFoldOffset machdep offset) | Index (exp,offset) -> Index (constFold machdep exp, constFoldOffset machdep offset) in (newhost, constFoldOffset machdep offset) and constFoldBinOp ~loc (machdep: bool) bop e1 e2 tres = let e1' = constFold machdep e1 in let e2' = constFold machdep e2 in if isIntegralType tres then begin let newe = let rec mkInt e = let loc = e.eloc in match e.enode with Const(CChr c) -> new_exp ~loc (Const(charConstToInt c)) | Const(CEnum {eival = v}) -> mkInt v | CastE(TInt (ik, ta), e) -> begin let exp = mkInt e in match exp.enode with Const(CInt64(i, _, _)) -> kinteger64 ~loc ik i | _ -> {exp with enode = CastE(TInt(ik, ta), exp)} end | _ -> e in let tk = match unrollTypeSkel tres with TInt(ik, _) -> ik | TEnum (ei,_) -> ei.ekind | _ -> Kernel.fatal ~current:true "constFoldBinOp" in (* See if the result is unsigned *) let isunsigned typ = not (isSigned typ) in let shiftInBounds i2 = (* We only try to fold shifts if the second arg is positive and less than the size of the type of the first argument. Otherwise, the semantics are processor-dependent, so let the compiler sort it out. *) if machdep then try (Integer.ge i2 Integer.zero) && Integer.lt i2 (Integer.of_int (bitsSizeOf (typeOf e1'))) with SizeOfError _ -> false else false in (* Assume that the necessary promotions have been done *) let e1'' = mkInt e1' in let e2'' = mkInt e2' in match bop, e1''.enode, e2''.enode with | PlusA, Const(CInt64(z,_,_)), _ when Integer.equal z Integer.zero -> e2'' | PlusA, _, Const(CInt64(z,_,_)) when Integer.equal z Integer.zero -> e1'' | PlusPI, _, Const(CInt64(z,_,_)) when Integer.equal z Integer.zero -> e1'' | IndexPI, _, Const(CInt64(z,_,_)) when Integer.equal z Integer.zero -> e1'' | MinusPI, _, Const(CInt64(z,_,_)) when Integer.equal z Integer.zero -> e1'' | PlusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> kinteger64 ~loc tk (Integer.add i1 i2) | MinusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> kinteger64 ?loc tk (Integer.sub i1 i2) | Mult, Const(CInt64(i1,ik1,_)), Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> kinteger64 ?loc tk (Integer.mul i1 i2) | Mult, Const(CInt64(z,_,_)), _ when Integer.equal z Integer.zero -> zero ~loc | Mult, Const(CInt64(one,_,_)), _ when Integer.equal one Integer.one -> e2'' | Mult, _, Const(CInt64(z,_,_)) when Integer.equal z Integer.zero -> zero ~loc | Mult, _, Const(CInt64(one,_,_)) when Integer.equal one Integer.one -> e1'' | Div, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin try kinteger64 ?loc tk (Integer.div i1 i2) with Division_by_zero -> new_exp ?loc (BinOp(bop, e1', e2', tres)) end | Div, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when bytesSizeOfInt ik1 = bytesSizeOfInt ik2 -> begin try kinteger64 ?loc tk (Integer.div i1 i2) with Division_by_zero -> new_exp ?loc (BinOp(bop, e1', e2', tres)) end | Div, _, Const(CInt64(one,_,_)) when Integer.equal one Integer.one -> e1'' | Mod, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin try kinteger64 ?loc tk (Integer.rem i1 i2) with Division_by_zero -> new_exp ?loc (BinOp(bop, e1', e2', tres)) end | BAnd, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> kinteger64 ?loc tk (Integer.logand i1 i2) | BAnd, Const(CInt64(z,_,_)), _ when Integer.equal z Integer.zero -> zero ~loc | BAnd, _, Const(CInt64(z,_,_)) when Integer.equal z Integer.zero -> zero ~loc | BOr, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> kinteger64 ?loc tk (Integer.logor i1 i2) | BOr, _, _ when isZero e1' -> e2' | BOr, _, _ when isZero e2' -> e1' | BXor, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> kinteger64 ?loc tk (Integer.logxor i1 i2) | Shiftlt, Const(CInt64(i1,_ik1,_)),Const(CInt64(i2,_,_)) when shiftInBounds i2 -> kinteger64 ?loc tk (Integer.shift_left i1 i2) | Shiftlt, Const(CInt64(z,_,_)), _ when Integer.equal z Integer.zero -> zero ~loc | Shiftlt, _, Const(CInt64(z,_,_)) when Integer.equal z Integer.zero -> e1'' | Shiftrt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,_,_)) when shiftInBounds i2 -> if isunsigned ik1 then kinteger64 ?loc tk (Integer.shift_right_logical i1 i2) else kinteger64 ?loc tk (Integer.shift_right i1 i2) | Shiftrt, Const(CInt64(z,_,_)), _ when Integer.equal z Integer.zero -> zero ~loc | Shiftrt, _, Const(CInt64(z,_,_)) when Integer.equal z Integer.zero -> e1'' | Eq, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) -> let i1', i2', _ = convertInts i1 ik1 i2 ik2 in if Integer.equal i1' i2' then one ~loc else zero ~loc | Ne, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) -> let i1', i2', _ = convertInts i1 ik1 i2 ik2 in if Integer.equal i1' i2' then zero ~loc else one ~loc | Le, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) -> let i1', i2', _ = convertInts i1 ik1 i2 ik2 in if Integer.le i1' i2' then one ~loc else zero ~loc | Ge, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) -> let i1', i2', _ = convertInts i1 ik1 i2 ik2 in if Integer.ge i1' i2' then one ~loc else zero ~loc | Lt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) -> let i1', i2', _ = convertInts i1 ik1 i2 ik2 in if Integer.lt i1' i2' then one ~loc else zero ~loc | Gt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) -> let i1', i2', _ = convertInts i1 ik1 i2 ik2 in if Integer.gt i1' i2' then one ~loc else zero ~loc (* We rely on the fact that LAnd/LOr appear in global initializers and should not have side effects. *) | LAnd, _, _ when isZero e1' || isZero e2' -> zero ~loc | LAnd, _, _ when isInteger e1' <> None -> e2' (* e1' is TRUE *) | LAnd, _, _ when isInteger e2' <> None -> e1' (* e2' is TRUE *) | LOr, _, _ when isZero e1' -> e2' | LOr, _, _ when isZero e2' -> e1' | LOr, _, _ when isInteger e1' <> None || isInteger e2' <> None -> (* One of e1' or e2' is a nonzero constant *) one ~loc | _ -> new_exp ?loc (BinOp(bop, e1', e2', tres)) in if debugConstFold then Format.printf "Folded %a to %a@." !pp_exp_ref (new_exp ?loc (BinOp(bop, e1', e2', tres))) !pp_exp_ref newe; newe end else new_exp ?loc (BinOp(bop, e1', e2', tres)) let () = pbitsSizeOf := bitsSizeOf let intTypeIncluded kind1 kind2 = let bitsize1 = bitsSizeOfInt kind1 in let bitsize2 = bitsSizeOfInt kind2 in match isSigned kind1, isSigned kind2 with | true, true | false, false -> bitsize1 <= bitsize2 | true, false -> false | false, true -> bitsize1 < bitsize2 (* CEA: moved from cabs2cil.ml. See cil.mli for infos *) (* Weimer * multi-character character constants * In MSCV, this code works: * * long l1 = 'abcd'; // note single quotes * char * s = "dcba"; * long * lptr = ( long * )s; * long l2 = *lptr; * assert(l1 == l2); * * We need to change a multi-character character literal into the * appropriate integer constant. However, the plot sickens: we * must also be able to handle things like 'ab\nd' (value = * "d\nba") * and 'abc' (vale = *"cba"). * * First we convert 'AB\nD' into the list [ 65 ; 66 ; 10 ; 68 ], then we * multiply and add to get the desired value. *) (* Given a character constant (like 'a' or 'abc') as a list of 64-bit * values, turn it into a CIL constant. Multi-character constants are * treated as multi-digit numbers with radix given by the bit width of * the specified type (either char or wchar_t). *) let reduce_multichar typ : int64 list -> int64 = let radix = bitsSizeOf typ in List.fold_left (fun acc -> Int64.add (Int64.shift_left acc radix)) Int64.zero let interpret_character_constant char_list = let value = reduce_multichar charType char_list in if value < (Int64.of_int 256) then (* ISO C 6.4.4.4.10: single-character constants have type int *) (CChr(Char.chr (Int64.to_int value))), intType else begin let orig_rep = None (* Some("'" ^ (String.escaped str) ^ "'") *) in if value <= (Int64.of_int32 Int32.max_int) then (CInt64(Integer.of_int64 value,IULong,orig_rep)),(TInt(IULong,[])) else (CInt64(Integer.of_int64 value,IULongLong,orig_rep)),(TInt(IULongLong,[])) end (*/CEA*) let smallest_kind ~signed ~bits_size = try List.find (fun kind -> isSigned kind=signed && bitsSizeOfInt kind = bits_size) [IBool; (* This list is ordered by size of types *) IChar; ISChar; IUChar; IShort; IUShort; IInt; IUInt; ILong; IULong; ILongLong; IULongLong] with Not_found -> Kernel.fatal ~current:true "Could not find a%signed type of size %d" (if signed then " " else "n un") bits_size let uint64_t () = TInt(smallest_kind ~signed:false ~bits_size:64,[]) let uint32_t () = TInt(smallest_kind ~signed:false ~bits_size:32,[]) let uint16_t () = TInt(smallest_kind ~signed:false ~bits_size:16,[]) let invalidStmt = mkStmt (Instr (Skip Location.unknown)) module Builtin_functions = State_builder.Hashtbl (Datatype.String.Hashtbl) (Datatype.Triple(Typ)(Datatype.List(Typ))(Datatype.Bool)) (struct let name = "Builtin_functions" let dependencies = [ TheMachine.self ] let size = 49 end) let () = registerAttribute "FC_BUILTIN" (AttrName true) (* Initialize the builtin functions after the machine has been initialized. *) let initGccBuiltins () : unit = if not (TheMachine.is_computed ()) then Kernel.fatal ~current:true "Call initCIL before initGccBuiltins" ; if Builtin_functions.length () <> 0 then Kernel.fatal ~current:true "builtins already initialized." ; (* See if we have builtin_va_list *) let hasbva = theMachine.theMachine.has__builtin_va_list in let sizeType = theMachine.upointType in let add s t l b = Builtin_functions.add ("__builtin_" ^ s) (t, l, b) in add "__fprintf_chk" intType (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *) [ voidPtrType; intType; charConstPtrType ] true; add "__memcpy_chk" voidPtrType [ voidPtrType; voidConstPtrType; sizeType; sizeType ] false; add "__memmove_chk" voidPtrType [ voidPtrType; voidConstPtrType; sizeType; sizeType ] false; add "__mempcpy_chk" voidPtrType [ voidPtrType; voidConstPtrType; sizeType; sizeType ] false; add "__memset_chk" voidPtrType [ voidPtrType; intType; sizeType; sizeType ] false; add "__printf_chk" intType [ intType; charConstPtrType ] true; add "__snprintf_chk" intType [ charPtrType; sizeType; intType; sizeType; charConstPtrType ] true; add "__sprintf_chk" intType [ charPtrType; intType; sizeType; charConstPtrType ] true; add "__stpcpy_chk" charPtrType [ charPtrType; charConstPtrType; sizeType ] false; add "__strcat_chk" charPtrType [ charPtrType; charConstPtrType; sizeType ] false; add "__strcpy_chk" charPtrType [ charPtrType; charConstPtrType; sizeType ] false; add "__strncat_chk" charPtrType [ charPtrType; charConstPtrType; sizeType; sizeType ] false; add "__strncpy_chk" charPtrType [ charPtrType; charConstPtrType; sizeType; sizeType ] false; add "__vfprintf_chk" intType (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *) [ voidPtrType; intType; charConstPtrType; TBuiltin_va_list [] ] false; add "__vprintf_chk" intType [ intType; charConstPtrType; TBuiltin_va_list [] ] false; add "__vsnprintf_chk" intType [ charPtrType; sizeType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ] false; add "__vsprintf_chk" intType [ charPtrType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ] false; add "alloca" voidPtrType [ sizeType ] false; add "acos" doubleType [ doubleType ] false; add "acosf" floatType [ floatType ] false; add "acosl" longDoubleType [ longDoubleType ] false; add "asin" doubleType [ doubleType ] false; add "asinf" floatType [ floatType ] false; add "asinl" longDoubleType [ longDoubleType ] false; add "atan" doubleType [ doubleType ] false; add "atanf" floatType [ floatType ] false; add "atanl" longDoubleType [ longDoubleType ] false; add "atan2" doubleType [ doubleType; doubleType ] false; add "atan2f" floatType [ floatType; floatType ] false; add "atan2l" longDoubleType [ longDoubleType; longDoubleType ] false; add "ceil" doubleType [ doubleType ] false; add "ceilf" floatType [ floatType ] false; add "ceill" longDoubleType [ longDoubleType ] false; add "cos" doubleType [ doubleType ] false; add "cosf" floatType [ floatType ] false; add "cosl" longDoubleType [ longDoubleType ] false; add "cosh" doubleType [ doubleType ] false; add "coshf" floatType [ floatType ] false; add "coshl" longDoubleType [ longDoubleType ] false; add "clz" intType [ uintType ] false; add "clzl" intType [ ulongType ] false; add "clzll" intType [ ulongLongType ] false; add "constant_p" intType [ intType ] false; add "ctz" intType [ uintType ] false; add "ctzl" intType [ ulongType ] false; add "ctzll" intType [ ulongLongType ] false; add "exp" doubleType [ doubleType ] false; add "expf" floatType [ floatType ] false; add "expl" longDoubleType [ longDoubleType ] false; add "expect" longType [ longType; longType ] false; add "fabs" doubleType [ doubleType ] false; add "fabsf" floatType [ floatType ] false; add "fabsl" longDoubleType [ longDoubleType ] false; add "ffs" intType [ uintType ] false; add "ffsl" intType [ ulongType ] false; add "ffsll" intType [ ulongLongType ] false; add "frame_address" voidPtrType [ uintType ] false; add "floor" doubleType [ doubleType ] false; add "floorf" floatType [ floatType ] false; add "floorl" longDoubleType [ longDoubleType ] false; add "huge_val" doubleType [] false; add "huge_valf" floatType [] false; add "huge_vall" longDoubleType [] false; add "inf" doubleType [] false; add "inff" floatType [] false; add "infl" longDoubleType [] false; add "memcpy" voidPtrType [ voidPtrType; voidConstPtrType; sizeType ] false; add "mempcpy" voidPtrType [ voidPtrType; voidConstPtrType; sizeType ] false; add "memset" voidPtrType [ voidPtrType; intType; intType ] false; add "fmod" doubleType [ doubleType ] false; add "fmodf" floatType [ floatType ] false; add "fmodl" longDoubleType [ longDoubleType ] false; add "frexp" doubleType [ doubleType; intPtrType ] false; add "frexpf" floatType [ floatType; intPtrType ] false; add "frexpl" longDoubleType [ longDoubleType; intPtrType ] false; add "ldexp" doubleType [ doubleType; intType ] false; add "ldexpf" floatType [ floatType; intType ] false; add "ldexpl" longDoubleType [ longDoubleType; intType ] false; add "log" doubleType [ doubleType ] false; add "logf" floatType [ floatType ] false; add "logl" longDoubleType [ longDoubleType ] false; add "log10" doubleType [ doubleType ] false; add "log10f" floatType [ floatType ] false; add "log10l" longDoubleType [ longDoubleType ] false; add "modff" floatType [ floatType; TPtr(floatType,[]) ] false; add "modfl" longDoubleType [ longDoubleType; TPtr(longDoubleType, []) ] false; add "nan" doubleType [ charConstPtrType ] false; add "nanf" floatType [ charConstPtrType ] false; add "nanl" longDoubleType [ charConstPtrType ] false; add "nans" doubleType [ charConstPtrType ] false; add "nansf" floatType [ charConstPtrType ] false; add "nansl" longDoubleType [ charConstPtrType ] false; add "next_arg" (* When we parse builtin_next_arg we drop the second argument *) (if hasbva then TBuiltin_va_list [] else voidPtrType) [] false; add "object_size" sizeType [ voidPtrType; intType ] false; add "parity" intType [ uintType ] false; add "parityl" intType [ ulongType ] false; add "parityll" intType [ ulongLongType ] false; add "popcount" intType [ uintType ] false; add "popcountl" intType [ ulongType ] false; add "popcountll" intType [ ulongLongType ] false; add "powi" doubleType [ doubleType; intType ] false; add "powif" floatType [ floatType; intType ] false; add "powil" longDoubleType [ longDoubleType; intType ] false; add "prefetch" voidType [ voidConstPtrType ] true; add "return" voidType [ voidConstPtrType ] false; add "return_address" voidPtrType [ uintType ] false; add "sin" doubleType [ doubleType ] false; add "sinf" floatType [ floatType ] false; add "sinl" longDoubleType [ longDoubleType ] false; add "sinh" doubleType [ doubleType ] false; add "sinhf" floatType [ floatType ] false; add "sinhl" longDoubleType [ longDoubleType ] false; add "sqrt" doubleType [ doubleType ] false; add "sqrtf" floatType [ floatType ] false; add "sqrtl" longDoubleType [ longDoubleType ] false; add "stpcpy" charPtrType [ charPtrType; charConstPtrType ] false; add "strchr" charPtrType [ charPtrType; intType ] false; add "strcmp" intType [ charConstPtrType; charConstPtrType ] false; add "strcpy" charPtrType [ charPtrType; charConstPtrType ] false; add "strcspn" sizeType [ charConstPtrType; charConstPtrType ] false; add "strncat" charPtrType [ charPtrType; charConstPtrType; sizeType ] false; add "strncmp" intType [ charConstPtrType; charConstPtrType; sizeType ] false; add "strncpy" charPtrType [ charPtrType; charConstPtrType; sizeType ] false; add "strspn" sizeType [ charConstPtrType; charConstPtrType ] false; add "strpbrk" charPtrType [ charConstPtrType; charConstPtrType ] false; (* When we parse builtin_types_compatible_p, we change its interface *) add "types_compatible_p" intType [ theMachine.typeOfSizeOf;(* Sizeof the type *) theMachine.typeOfSizeOf (* Sizeof the type *) ] false; add "tan" doubleType [ doubleType ] false; add "tanf" floatType [ floatType ] false; add "tanl" longDoubleType [ longDoubleType ] false; add "tanh" doubleType [ doubleType ] false; add "tanhf" floatType [ floatType ] false; add "tanhl" longDoubleType [ longDoubleType ] false; if hasbva then begin add "va_end" voidType [ TBuiltin_va_list [] ] false; add "varargs_start" voidType [ TBuiltin_va_list [] ] false; (* When we parse builtin_{va,stdarg}_start, we drop the second argument *) add "va_start" voidType [ TBuiltin_va_list [] ] false; add "stdarg_start" voidType [ TBuiltin_va_list [] ] false; (* When we parse builtin_va_arg we change its interface *) add "va_arg" voidType [ TBuiltin_va_list []; theMachine.typeOfSizeOf;(* Sizeof the type *) voidPtrType (* Ptr to res *) ] false; add "va_copy" voidType [ TBuiltin_va_list []; TBuiltin_va_list [] ] false; end module Frama_c_builtins = State_builder.Hashtbl (Datatype.String.Hashtbl) (Cil_datatype.Varinfo) (struct let name = "Cil.Frama_c_Builtins" let dependencies = [] let size = 3 end) let () = add_ast_dependency Frama_c_builtins.self let is_builtin v = hasAttribute "FC_BUILTIN" v.vattr let is_unused_builtin v = is_builtin v && not v.vreferenced (* [VP] Should we projectify this ?*) let special_builtins_table = ref Datatype.String.Set.empty let special_builtins = Queue.create () let is_special_builtin s = Queue.fold (fun res f -> res || f s) false special_builtins let add_special_builtin_family f = Queue.add f special_builtins let add_special_builtin s = special_builtins_table := Datatype.String.Set.add s !special_builtins_table let () = add_special_builtin_family (fun s -> Datatype.String.Set.mem s !special_builtins_table) let () = List.iter add_special_builtin [ "__builtin_stdarg_start"; "__builtin_va_arg"; "__builtin_va_start"; "__builtin_expect"; "__builtin_next_arg"; ] (** Construct a hash with the builtins *) let initMsvcBuiltins () : unit = if not (TheMachine.is_computed ()) then Kernel.fatal ~current:true "Call initCIL before initMsvcBuiltins" ; if Builtin_functions.length () <> 0 then Kernel.fatal ~current:true "builtins already initialized." ; (** Take a number of wide string literals *) Builtin_functions.add "__annotation" (voidType, [ ], true); () (** This is used as the location of the prototypes of builtin functions. *) let builtinLoc: location = Location.unknown let range_loc loc1 loc2 = fst loc1, snd loc2 (* JS 2012/11/16: probably broken since it may call constFold on some exp: this operation modifies this expression in-place! *) let compareConstant c1 c2 = match c1, c2 with | CEnum e1, CEnum e2 -> e1.einame = e2.einame && e1.eihost.ename = e2.eihost.ename && (match isInteger (constFold true e1.eival), isInteger (constFold true e2.eival) with | Some i1, Some i2 -> Integer.equal i1 i2 | _ -> false) | CInt64 (i1,k1,_), CInt64(i2,k2,_) -> k1 = k2 && Integer.equal i1 i2 | CStr s1, CStr s2 -> s1 = s2 | CWStr l1, CWStr l2 -> (try List.for_all2 (fun x y -> Int64.compare x y = 0) l1 l2 with Invalid_argument _ -> false) | CChr c1, CChr c2 -> c1 = c2 | CReal(f1,k1,_), CReal(f2,k2,_) -> k1 = k2 && f1 = f2 | (CEnum _ | CInt64 _ | CStr _ | CWStr _ | CChr _ | CReal _), _ -> false let compareExp (e1: exp) (e2: exp) : bool = Cil_datatype.ExpStructEq.equal e1 e2 let compareLval (lv1: lval) (lv2: lval) : bool = Cil_datatype.LvalStructEq.equal lv1 lv2 let compareOffset (off1: offset) (off2: offset) : bool = Cil_datatype.OffsetStructEq.equal off1 off2 (* Iterate over all globals, including the global initializer *) let iterGlobals (fl: file) (doone: global -> unit) : unit = let doone' g = CurrentLoc.set (Global.loc g); doone g in List.iter doone' fl.globals; match fl.globinit with | None -> () | Some g -> doone' (GFun(g, Location.unknown)) (* Fold over all globals, including the global initializer *) let foldGlobals (fl: file) (doone: 'a -> global -> 'a) (acc: 'a) : 'a = let doone' acc g = CurrentLoc.set (Global.loc g); doone acc g in let acc' = List.fold_left doone' acc fl.globals in match fl.globinit with | None -> acc' | Some g -> doone' acc' (GFun(g, Location.unknown)) let is_skip = function Instr (Skip _) -> true | _ -> false (** [b_assumes] must be always empty for behavior named [Cil.default_behavior_name] *) let mk_behavior ?(name=default_behavior_name) ?(assumes=[]) ?(requires=[]) ?(post_cond=[]) ?(assigns=WritesAny) ?(allocation=None) ?(extended=[]) () = { b_name = name; b_assumes = assumes; (* must be always empty for default_behavior_name *) b_requires = requires; b_assigns = assigns ; b_allocation = (match allocation with | None -> FreeAllocAny | Some af -> af); b_post_cond = post_cond ; b_extended = extended; } let spare_attributes_for_c_cast = "declspec"::"arraylen"::bitfield_attribute_name::qualifier_attributes let type_remove_attributes_for_c_cast = typeRemoveAttributes spare_attributes_for_c_cast let spare_attributes_for_logic_cast = spare_attributes_for_c_cast let type_remove_attributes_for_logic_type = typeRemoveAttributes spare_attributes_for_logic_cast let () = Cil_datatype.drop_non_logic_attributes := dropAttributes spare_attributes_for_logic_cast let rec same_attributes l1 l2 = match l1,l2 with | [],[] -> true | [],_ | _,[] -> false | a1::l1, a2::l2 -> Cil_datatype.Attribute.equal a1 a2 && same_attributes l1 l2 let need_cast ?(force=false) oldt newt = let oldt = type_remove_attributes_for_c_cast (unrollType oldt) in let newt = type_remove_attributes_for_c_cast (unrollType newt) in not (Cil_datatype.Typ.equal oldt newt) && (force || match (oldt, newt) with | TInt(ik,ai), TEnum(e,ae) | TEnum(e,ae), TInt(ik,ai) when same_attributes ai ae -> ik <> e.ekind | _ -> true) (* Strip the "const" from the type. It is unfortunate that const variables can only be set in initialization. Once we decided to move all declarations to the top of the functions, we have no way of setting a "const" variable. Furthermore, if the type of the variable is an array or a struct we must recursively strip the "const" from fields and array elements. *) let rec stripConstLocalType (t: typ) : typ = let dc a = if hasAttribute "const" a then dropAttribute "const" a else a in match t with | TPtr (bt, a) -> (* We want to be able to detect by pointer equality if the type has * changed. So, don't realloc the type unless necessary. *) let a' = dc a in if a != a' then TPtr(bt, a') else t | TInt (ik, a) -> let a' = dc a in if a != a' then TInt(ik, a') else t | TFloat(fk, a) -> let a' = dc a in if a != a' then TFloat(fk, a') else t | TNamed (ti, a) -> (* We must go and drop the consts from the typeinfo as well ! *) let t' = stripConstLocalType ti.ttype in if t != t' then begin (* ignore (warn "Stripping \"const\" from typedef %s\n" ti.tname); *) ti.ttype <- t' end; let a' = dc a in if a != a' then TNamed(ti, a') else t | TEnum (ei, a) -> let a' = dc a in if a != a' then TEnum(ei, a') else t | TArray(bt, leno, _, a) -> (* We never assign to the array. So, no need to change the const. But * we must change it on the base type *) let bt' = stripConstLocalType bt in if bt' != bt then TArray(bt', leno, empty_size_cache (), a) else t | TComp(ci, _, a) -> (* Must change both this structure as well as its fields *) List.iter (fun f -> let t' = stripConstLocalType f.ftype in if t' != f.ftype then begin Kernel.debug ~level:3 "Stripping \"const\" from field %s of %s\n" f.fname (compFullName ci) ; f.ftype <- t' end) ci.cfields; let a' = dc a in if a != a' then TComp(ci, empty_size_cache (), a') else t (* We never assign functions either *) | TFun(_rt, _args, _va, _a) -> t | TVoid _ -> (* this may happen with temporary used only for their sizeof. *) t | TBuiltin_va_list a -> let a' = dc a in if a != a' then TBuiltin_va_list a' else t let cvar_to_lvar vi = match vi.vlogic_var_assoc with | None -> let lv = { lv_name = vi.vname; lv_id = vi.vid; lv_kind = LVC; lv_type = Ctype vi.vtype ; lv_origin = Some vi} in vi.vlogic_var_assoc <- Some lv; lv | Some lv -> lv let copyVarinfo (vi: varinfo) (newname: string) : varinfo = let vi' = copy_with_new_vid vi in vi'.vname <- newname; (match vi.vlogic_var_assoc with None -> () | Some _ -> vi'.vlogic_var_assoc <- None; ignore(cvar_to_lvar vi')); vi' let rec findUniqueName ?(suffix="") fdec name = let current_name = name ^ suffix in (* Is this check a performance problem? We could bring the old unchecked makeTempVar back as a separate function that assumes the prefix name does not occur in the original program. *) if (List.exists (fun vi -> vi.vname = current_name) fdec.slocals) || (List.exists (fun vi -> vi.vname = current_name) fdec.sformals) then begin fdec.smaxid <- 1 + fdec.smaxid; findUniqueName ~suffix:("_" ^ (string_of_int (1 + fdec.smaxid))) fdec name end else current_name let makeLocal ?(generated=true) ?(formal=false) fdec name typ = (* a helper function *) let name = findUniqueName fdec name in fdec.smaxid <- 1 + fdec.smaxid; let vi = makeVarinfo ~generated false formal name typ in vi (* Make a local variable and add it to a function *) let makeLocalVar fdec ?scope ?(generated=true) ?(insert = true) name typ = let typ = stripConstLocalType typ in let vi = makeLocal ~generated fdec name typ in if insert then begin fdec.slocals <- fdec.slocals @ [vi]; let local_block = match scope with | None -> fdec.sbody | Some b -> b in local_block.blocals <- vi::local_block.blocals end; vi let makeTempVar fdec ?insert ?(name = "__cil_tmp") ?descr ?(descrpure = true) typ : varinfo = let vi = makeLocalVar fdec ?insert name typ in vi.vdescr <- descr; vi.vdescrpure <- descrpure; vi let makePseudoVar = let counter = ref 0 in function ty -> incr counter; let name = "@" ^ (string_of_int !counter) in makeVarinfo ~logic:true (* global= *)false (* formal= *)false name ty (* Set the types of arguments and results as given by the function type * passed as the second argument *) let setFunctionType (f: fundec) (t: typ) = match unrollType t with TFun (_rt, Some args, _va, _a) -> if List.length f.sformals <> List.length args then Kernel.fatal ~current:true "setFunctionType: number of arguments differs from the number of formals" ; (* Change the function type. *) f.svar.vtype <- t; (* Change the sformals and we know that indirectly we'll change the * function type *) List.iter2 (fun (_an,at,aa) f -> f.vtype <- at; f.vattr <- aa) args f.sformals | _ -> Kernel.fatal ~current:true "setFunctionType: not a function type" (* Set the types of arguments and results as given by the function type passed as the second argument *) let setFunctionTypeMakeFormals (f: fundec) (t: typ) = match unrollType t with TFun (_rt, Some args, _va, _a) -> if f.sformals <> [] then Kernel.fatal ~current:true "setFunctionTypMakeFormals called on function %s with some formals already" f.svar.vname ; (* Change the function type. *) f.svar.vtype <- t; f.sformals <- List.map (fun (n,t,_a) -> makeLocal ~formal:true f n t) args; setFunctionType f t | _ -> Kernel.fatal ~current:true "setFunctionTypeMakeFormals: not a function type: %a" !pp_typ_ref t let setMaxId (f: fundec) = f.smaxid <- List.length f.sformals + List.length f.slocals (* Make a formal variable for a function. Insert it in both the sformals * and the type of the function. You can optionally specify where to insert * this one. If where = "^" then it is inserted first. If where = "$" then * it is inserted last. Otherwise where must be the name of a formal after * which to insert this. By default it is inserted at the end. *) let makeFormalVar fdec ?(where = "$") name typ : varinfo = (* Search for the insertion place *) let makeit name = makeLocal ~formal:true fdec name typ in let rec loopFormals acc = function [] -> if where = "$" then let vi = makeit name in vi, List.rev (vi::acc) else Kernel.fatal ~current:true "makeFormalVar: cannot find insert-after formal %s" where | f :: rest when f.vname = where -> let vi = makeit name in vi, List.rev_append acc (f :: vi :: rest) | f :: rest -> loopFormals (f::acc) rest in let vi, newformals = if where = "^" then let vi = makeit name in vi, vi :: fdec.sformals else loopFormals [] fdec.sformals in setFormals fdec newformals; vi (* Make a global variable. Your responsibility to make sure that the name * is unique *) let makeGlobalVar ?logic ?generated name typ = let vi = makeVarinfo ?logic ?generated true false name typ in vi let emptyFunctionFromVI vi = let r = { svar = vi; smaxid = 0; slocals = []; sformals = []; sbody = mkBlock []; smaxstmtid = None; sallstmts = []; sspec = empty_funspec () } in setFormalsDecl r.svar r.svar.vtype; r (* Make an empty function *) let emptyFunction name = let vi = makeGlobalVar ~generated:false name (TFun(voidType, Some [], false,[])) in emptyFunctionFromVI vi let dummyFile = { globals = []; fileName = ""; globinit = None; globinitcalled = false;} (* Take the name of a file and make a valid varinfo name out of it. There are * a few characters that are not valid in varinfos *) let makeValidVarinfoName (s: string) = let s = String.copy s in (* So that we can update in place *) let l = String.length s in for i = 0 to l - 1 do let c = String.get s i in let isinvalid = match c with '-' | '.' -> true | _ -> false in if isinvalid then String.set s i '_'; done; s let rec lastOffset (off: offset) : offset = match off with | NoOffset | Field(_,NoOffset) | Index(_,NoOffset) -> off | Field(_,off) | Index(_,off) -> lastOffset off let isBitfield lval = match lval with | _, off -> let off = lastOffset off in match off with Field({fbitfield=Some _}, _) -> true | _ -> false let addOffsetLval toadd (b, off) : lval = b, addOffset toadd off let rec removeOffset (off: offset) : offset * offset = match off with NoOffset -> NoOffset, NoOffset | Field(_f, NoOffset) -> NoOffset, off | Index(_i, NoOffset) -> NoOffset, off | Field(f, restoff) -> let off', last = removeOffset restoff in Field(f, off'), last | Index(i, restoff) -> let off', last = removeOffset restoff in Index(i, off'), last let removeOffsetLval ((b, off): lval) : lval * offset = let off', last = removeOffset off in (b, off'), last class copyVisitExpr = object inherit genericCilVisitor (copy_visit (Project.current ())) method vexpr e = ChangeDoChildrenPost ({e with eid = Eid.next ()}, fun x -> x) end let copy_exp e = visitCilExpr (new copyVisitExpr) e (** A visitor that does constant folding. If "machdep" is true then we do * machine dependent simplification (e.g., sizeof) *) class constFoldVisitorClass (machdep: bool) : cilVisitor = object inherit nopCilVisitor method vinst i = match i with (* Skip two functions to which we add Sizeof to the type arguments. See the comments for these above. *) Call(_,({enode = Lval (Var vi,NoOffset)}),_,_) when ((vi.vname = "__builtin_va_arg") || (vi.vname = "__builtin_types_compatible_p")) -> SkipChildren | _ -> DoChildren method vexpr (e: exp) = (* Do it bottom up *) ChangeDoChildrenPost (e, constFold machdep) end let constFoldVisitor (machdep: bool) = new constFoldVisitorClass machdep let rec constFoldTermNodeAtTop = function | TSizeOf typ as t -> (try integer_lconstant (sizeOf_int typ) with SizeOfError _ -> t) | TSizeOfStr str -> integer_lconstant (String.length str + 1) | TAlignOf typ -> integer_lconstant (bytesAlignOf typ) | TSizeOfE { term_type= Ctype typ } -> constFoldTermNodeAtTop (TSizeOf typ) | TAlignOfE { term_type= Ctype typ } -> constFoldTermNodeAtTop (TAlignOf typ) | TSizeOfE _ | TAlignOfE _ -> assert false (* sizeof/alignof of logic types are rejected by typing anyway. *) | t -> t let constFoldTerm machdep t = let visitor = object inherit nopCilVisitor method vterm_node t = if machdep then ChangeToPost (t,constFoldTermNodeAtTop) else DoChildren end in visitCilTerm visitor t (** Find a function or function prototype with the given name in the file. * If it does not exist, create a prototype with the given type, and return * the new varinfo. This is useful when you need to call a libc function * whose prototype may or may not already exist in the file. * * Because the new prototype is added to the start of the file, you shouldn't * refer to any struct or union types in the function type.*) let findOrCreateFunc (f:file) (name:string) (t:typ) : varinfo = let rec search glist = match glist with GVarDecl(_,vi,_) :: _rest when vi.vname = name -> if not (isFunctionType vi.vtype) then Kernel.fatal ~current:true "findOrCreateFunc: can't create %s because another global exists with that name." name ; vi | _ :: rest -> search rest (* tail recursive *) | [] -> (*not found, so create one *) let t' = unrollTypeDeep t in let new_decl = makeGlobalVar ~generated:false name t' in setFormalsDecl new_decl t'; f.globals <- GVarDecl(empty_funspec (), new_decl, Location.unknown) :: f.globals; new_decl in search f.globals let childrenFileSameGlobals vis f = let fGlob g = visitCilGlobal vis g in iterGlobals f (fun g -> match fGlob g with [g'] when g' == g || Cil_datatype.Global.equal g' g -> () (* Try to do the pointer check first *) | gl -> Kernel.fatal ~current:true "You used visitCilFileSameGlobals but the global got changed:\n %a\nchanged to %a\n" !pp_global_ref g (Pretty_utils.pp_list ~sep:"@\n" !pp_global_ref) gl ; ); f let post_file vis f = let res = vis#vfile f in let post_action res = vis#fill_global_tables; res in match res with SkipChildren -> ChangeToPost(f, post_action) | JustCopy -> JustCopyPost post_action | JustCopyPost f -> JustCopyPost (fun x -> f (post_action x)) | ChangeTo res -> ChangeToPost(res, post_action) | ChangeToPost (res, f) -> ChangeToPost (res, fun x -> f (post_action x)) | DoChildren -> DoChildrenPost post_action | DoChildrenPost f -> DoChildrenPost (fun x -> f (post_action x)) | ChangeDoChildrenPost(f,post) -> ChangeDoChildrenPost(f, fun x -> post (post_action x)) (* A visitor for the whole file that does not change the globals *) let visitCilFileSameGlobals (vis : cilVisitor) (f : file) : unit = if vis#behavior.is_copy_behavior then Kernel.fatal ~current:true "You used visitCilFileSameGlobals with a copy visitor. Nothing is done" else ignore (doVisitCil vis vis#behavior.cfile (post_file vis) childrenFileSameGlobals f) let childrenFileCopy vis f = let fGlob g = visitCilGlobal vis g in (* Scan the globals. Make sure this is tail recursive. *) let rec loop (acc: global list) = function [] -> f.globals <- List.rev acc | g :: restg -> loop (List.rev_append (fGlob g) acc) restg in loop [] f.globals; (* the global initializer *) (match f.globinit with None -> () | Some g -> f.globinit <- Some (visitCilFunction vis g)); f (* Be careful with visiting the whole file because it might be huge. *) let visitCilFileCopy (vis : cilVisitor) (f : file) : file = if vis#behavior.is_copy_behavior then begin Queue.add Logic_env.prepare_tables vis#get_filling_actions; end; doVisitCil vis vis#behavior.cfile (post_file vis) childrenFileCopy f let visitCilFile vis f = if vis#behavior.is_copy_behavior then Kernel.fatal ~current:true "You used visitCilFile with a copy visitor. Nothing is done" else ignore (visitCilFileCopy vis f) let appears_in_expr v e = let module M = struct exception Found end in let vis = object inherit nopCilVisitor method vvrbl v' = if Cil_datatype.Varinfo.equal v v' then raise M.Found; SkipChildren end in try ignore (visitCilExpr vis e); false with M.Found -> true (** Create or fetch the global initializer. Tries to put a call to the * function with the main_name into it *) let getGlobInit ?(main_name="main") (fl: file) = match fl.globinit with Some f -> f | None -> begin (* Sadly, we cannot use the Filename library because it does not like * function names with multiple . in them *) let f = let len = String.length fl.fileName in (* Find the last path separator and record the first . that we see, * going backwards *) let lastDot = ref len in let rec findLastPathSep i = if i < 0 then -1 else let c = String.get fl.fileName i in if c = '/' || c = '\\' then i else begin if c = '.' && !lastDot = len then lastDot := i; findLastPathSep (i - 1) end in let lastPathSep = findLastPathSep (len - 1) in let basenoext = String.sub fl.fileName (lastPathSep + 1) (!lastDot - lastPathSep - 1) in emptyFunction (makeValidVarinfoName ("__globinit_" ^ basenoext)) in fl.globinit <- Some f; (* Now try to add a call to the global initialized at the beginning of * main *) let inserted = ref false in List.iter (function GFun(m, lm) when m.svar.vname = main_name -> (* Prepend a prototype to the global initializer *) fl.globals <- GVarDecl (empty_funspec (),f.svar, lm) :: fl.globals; m.sbody.bstmts <- mkStmt (Instr (Call(None, new_exp ~loc:f.svar.vdecl (Lval(var f.svar)), [], Location.unknown))) :: m.sbody.bstmts; inserted := true; Kernel.feedback ~level:2 "Inserted the globinit" ; fl.globinitcalled <- true; | _ -> ()) fl.globals; (* YMo: remove useless warning that worries users *) (* if not !inserted then *) (* ignore (E.warn "Cannot find %s to add global initializer %s" *) (* main_name f.svar.vname); *) f end (* Fold over all globals, including the global initializer *) let mapGlobals (fl: file) (doone: global -> global) : unit = fl.globals <- List.map doone fl.globals; (match fl.globinit with None -> () | Some g -> begin match doone (GFun(g, Location.unknown)) with GFun(g', _) -> fl.globinit <- Some g' | _ -> Kernel.fatal ~current:true "mapGlobals: globinit is not a function" end) (***************************************************************************) (* Convert an expression into an attribute, if possible. Otherwise raise NotAnAttrParam *) exception NotAnAttrParam of exp let rec expToAttrParam (e: exp) : attrparam = match (constFold true e).enode with | Const(CInt64(i,k,_)) -> let i', _trunc = truncateInteger64 k i in AInt i' | Const(CEnum ei) -> expToAttrParam ei.eival | Lval (Var v, NoOffset) -> ACons(v.vname, []) | SizeOf t -> ASizeOf t | SizeOfE e' -> ASizeOfE (expToAttrParam e') | UnOp(uo, e', _) -> AUnOp (uo, expToAttrParam e') | BinOp(bo, e1',e2', _) -> ABinOp (bo, expToAttrParam e1', expToAttrParam e2') | _ -> raise (NotAnAttrParam e) (******************** OPTIMIZATIONS *****) let rec peepHole1 (* Process one statement and possibly replace it *) (doone: instr -> instr list option) (* Scan a block and recurse inside nested blocks *) (ss: stmt list) : unit = let rec doInstrList (il: instr list) : instr list = match il with [] -> [] | i :: rest -> begin match doone i with None -> i :: doInstrList rest | Some sl -> doInstrList (sl @ rest) end in List.iter (fun s -> match s.skind with | Instr i -> s.skind <- stmt_of_instr_list (doInstrList [i]) | If (_e, tb, eb, _) -> peepHole1 doone tb.bstmts; peepHole1 doone eb.bstmts | Switch (_e, b, _, _) -> peepHole1 doone b.bstmts | Loop (_, b, _l, _, _) -> peepHole1 doone b.bstmts | Block b -> peepHole1 doone b.bstmts | UnspecifiedSequence seq -> peepHole1 doone (List.map (fun (x,_,_,_,_) -> x) seq) | TryFinally (b, h, _l) -> peepHole1 doone b.bstmts; peepHole1 doone h.bstmts | TryExcept (b, (il, e), h, l) -> peepHole1 doone b.bstmts; peepHole1 doone h.bstmts; s.skind <- TryExcept(b, (doInstrList il, e), h, l); | Return _ | Goto _ | Break _ | Continue _ -> ()) ss (* Process two statements and possibly replace them both *) let rec peepHole2 ~agressive (dotwo: stmt * stmt -> stmt list option) (ss: stmt list) = let rec doStmtList acc (il: stmt list) : stmt list = match il with [] -> List.rev acc | [i] -> process i; List.rev (i::acc) | (i1 :: ((i2 :: rest) as rest2)) -> begin match dotwo (i1,i2) with None -> process i1; doStmtList (i1::acc) rest2 | Some sl -> if agressive then doStmtList acc (sl @ rest) else doStmtList (List.rev_append sl acc) rest end and doUnspecifiedStmtList il = match il with [] -> [] | [ (s,_,_,_,_) ] -> process s; il | ((i1,m1,w1,r1,_) as hd)::(((i2,m2,w2,r2,_)::rest) as rest2) -> begin match dotwo (i1,i2) with None -> process i1; hd :: doUnspecifiedStmtList rest2 | Some [] -> doUnspecifiedStmtList rest | Some (hd::tl) -> let call s = match s.skind with | Instr(Call _ ) -> [ref s] | _ -> [] in let res = (hd, m1@m2, w1 @ w2, r1 @ r2,call hd) :: (List.map (fun x -> x,[],[],[],call x) tl) in if agressive then doUnspecifiedStmtList (res @ rest) else res @ doUnspecifiedStmtList rest end and process s = match s.skind with Instr _i -> () | If (_e, tb, eb, _) -> tb.bstmts <- peepHole2 ~agressive dotwo tb.bstmts; eb.bstmts <- peepHole2 ~agressive dotwo eb.bstmts | Switch (_e, b, _, _) -> b.bstmts <- peepHole2 ~agressive dotwo b.bstmts | Loop (_, b, _l, _, _) -> b.bstmts <- peepHole2 ~agressive dotwo b.bstmts | Block b -> b.bstmts <- doStmtList [] b.bstmts | TryFinally (b, h, _l) -> b.bstmts <- peepHole2 ~agressive dotwo b.bstmts; b.bstmts <- peepHole2 ~agressive dotwo h.bstmts | TryExcept (b, (_il, _e), h, _l) -> b.bstmts <- peepHole2 ~agressive dotwo b.bstmts; h.bstmts <- peepHole2 ~agressive dotwo h.bstmts; () (*s.skind <- TryExcept (b, (doInstrList il, e), h, l)*) | UnspecifiedSequence seq -> s.skind <- UnspecifiedSequence (doUnspecifiedStmtList seq) | Return _ | Goto _ | Break _ | Continue _ -> () in if agressive then List.iter process ss; doStmtList [] ss let dExp: string -> exp = fun d -> new_exp ~loc:Cil_datatype.Location.unknown (Const(CStr(d))) let dInstr: string -> location -> instr = fun d l -> Asm([], [d], [], [], [], l) let dGlobal: string -> location -> global = fun d l -> GAsm(d, l) (* Make an AddrOf. Given an lval of type T will give back an expression of * type ptr(T) *) let mkAddrOf ~loc ((_b, _off) as lval) : exp = (* Never take the address of a register variable *) (match lval with Var vi, _off when vi.vstorage = Register -> vi.vstorage <- NoStorage | _ -> ()); match lval with Mem e, NoOffset -> e | b, Index(z, NoOffset) when isZero z -> new_exp ~loc (StartOf (b, NoOffset)) (* array *) | _ -> new_exp ?loc (AddrOf lval) let mkAddrOfVi vi = mkAddrOf vi.vdecl (var vi) let mkAddrOrStartOf ~loc (lv: lval) : exp = match unrollTypeSkel (typeOfLval lv) with TArray _ -> new_exp ~loc (StartOf lv) | _ -> mkAddrOf ~loc lv let mkMem ~(addr: exp) ~(off: offset) : lval = let res = match addr.enode, off with | AddrOf lv, _ -> addOffsetLval off lv | StartOf lv, _ -> (* Must be an array *) addOffsetLval (Index(zero ~loc:addr.eloc, off)) lv | _, _ -> Mem addr, off in (* ignore (E.log "memof : %a:%a\nresult = %a\n" d_plainexp addr d_plainoffset off d_plainexp res); *) res let mkTermMem ~(addr: term) ~(off: term_offset) : term_lval = let loc = addr.term_loc in let res = match addr.term_node, off with TAddrOf lv, _ -> addTermOffsetLval off lv | TStartOf lv, _ -> (* Must be an array *) addTermOffsetLval (TIndex(lzero ~loc (), off)) lv | _, _ -> TMem addr, off in (* ignore (E.log "memof : %a:%a\nresult = %a\n" d_plainexp addr d_plainoffset off d_plainexp res); *) res let splitFunctionType (ftype: typ) : typ * (string * typ * attributes) list option * bool * attributes = match unrollType ftype with TFun (rt, args, isva, a) -> rt, args, isva, a | _ -> Kernel.fatal ~current:true "splitFunctionType invoked on a non function type %a" !pp_typ_ref ftype let splitFunctionTypeVI (fvi: varinfo) : typ * (string * typ * attributes) list option * bool * attributes = match unrollType fvi.vtype with TFun (rt, args, isva, a) -> rt, args, isva, a | _ -> Kernel.abort "Function %s invoked on a non function type" fvi.vname let rec integralPromotion (t : typ) : typ = (* c.f. ISO 6.3.1.1 *) match unrollType t with | TInt ((IShort|ISChar|IBool), a) -> TInt(IInt, a) | TInt (IChar,a) when isSigned IChar -> TInt(IInt, a) | TInt (IUChar|IUShort as k, a) -> if bitsSizeOfInt k < bitsSizeOf intType then TInt(IInt, a) else TInt(IUInt,a) | TInt (k,a) -> begin match findAttribute bitfield_attribute_name a with | [AInt size] -> (* This attribute always fits in int. *) let size = Integer.to_int size in let sizeofint = bitsSizeOf intType in let attrs = dropAttribute bitfield_attribute_name a in let kind = if size < sizeofint then IInt else if size = sizeofint then if isSigned k then IInt else IUInt else k in TInt(kind,attrs) | [] -> t | _ -> assert false end | TEnum (ei, a) -> integralPromotion (TInt(ei.ekind, a)) (* gcc packed enums can be < int *) | t -> Kernel.fatal ~current:true "integralPromotion: not expecting %a" !pp_typ_ref t let arithmeticConversion t1 t2 = (* c.f. ISO 6.3.1.8 *) let checkToInt _ = () in (* dummies for now *) let checkToFloat _ = () in match unrollTypeSkel t1, unrollTypeSkel t2 with TFloat(FLongDouble, _), _ -> checkToFloat t2; t1 | _, TFloat(FLongDouble, _) -> checkToFloat t1; t2 | TFloat(FDouble, _), _ -> checkToFloat t2; t1 | _, TFloat (FDouble, _) -> checkToFloat t1; t2 | TFloat(FFloat, _), _ -> checkToFloat t2; t1 | _, TFloat (FFloat, _) -> checkToFloat t1; t2 | _, _ -> begin let t1' = integralPromotion t1 in let t2' = integralPromotion t2 in match unrollTypeSkel t1', unrollTypeSkel t2' with TInt(IULongLong, _), _ -> checkToInt t2'; t1' | _, TInt(IULongLong, _) -> checkToInt t1'; t2' | TInt(ILongLong,_), _ when bitsSizeOf t1' <= bitsSizeOf t2' && (not (isSignedInteger t2')) -> TInt(IULongLong,[]) | _, TInt(ILongLong,_) when bitsSizeOf t2' <= bitsSizeOf t1' && (not (isSignedInteger t1')) -> TInt(IULongLong,[]) | TInt(ILongLong, _), _ -> checkToInt t2'; t1' | _, TInt(ILongLong, _) -> checkToInt t1'; t2' | TInt(IULong, _), _ -> checkToInt t2'; t1' | _, TInt(IULong, _) -> checkToInt t1'; t2' | TInt(ILong,_), TInt(IUInt,_) when bitsSizeOf t1' <= bitsSizeOf t2' -> TInt(IULong,[]) | TInt(IUInt,_), TInt(ILong,_) when bitsSizeOf t2' <= bitsSizeOf t1' -> TInt(IULong,[]) | TInt(ILong, _), _ -> checkToInt t2'; t1' | _, TInt(ILong, _) -> checkToInt t1'; t2' | TInt(IUInt, _), _ -> checkToInt t2'; t1' | _, TInt(IUInt, _) -> checkToInt t1'; t2' | TInt(IInt, _), TInt (IInt, _) -> t1' | t1, t2 -> Kernel.fatal ~current:true "arithmeticConversion %a -> %a@." !pp_typ_ref t1 !pp_typ_ref t2 end let isArrayType t = match unrollTypeSkel t with | TArray _ -> true | _ -> false let isCharArrayType t = match unrollTypeSkel t with | TArray(tau,_,_,_) when isCharType tau -> true | _ -> false let isStructOrUnionType t = match unrollTypeSkel t with | TComp _ -> true | _ -> false let isVariadicListType t = match unrollTypeSkel t with | TBuiltin_va_list _ -> true | _ -> false let rec isConstantGen f e = match (stripInfo e).enode with | Info _ -> assert false | Const c -> f c | UnOp (_, e, _) -> isConstantGen f e | BinOp (_, e1, e2, _) -> isConstantGen f e1 && isConstantGen f e2 | Lval (Var vi, NoOffset) -> (vi.vglob && isArrayType vi.vtype || isFunctionType vi.vtype) | Lval _ -> false | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> true (* see ISO 6.6.6 *) | CastE(t,{ enode = Const(CReal _)}) when isIntegralType t -> true | CastE (_, e) -> isConstantGen f e | AddrOf (Var vi, off) | StartOf (Var vi, off) -> vi.vglob && isConstantOffsetGen f off | AddrOf (Mem e, off) | StartOf(Mem e, off) -> isConstantGen f e && isConstantOffsetGen f off and isConstantOffsetGen f = function NoOffset -> true | Field(_fi, off) -> isConstantOffsetGen f off | Index(e, off) -> isConstantGen f e && isConstantOffsetGen f off let isConstant e = isConstantGen alphatrue e let isConstantOffset o = isConstantOffsetGen alphatrue o let isIntegerConstant e = isConstantGen (function | CInt64 _ | CChr _ | CEnum _ -> true | CStr _ | CWStr _ | CReal _ -> false) e let getCompField cinfo fieldName = List.find (fun fi -> fi.fname = fieldName) cinfo.cfields let mkCastT ?(force=false) ~(e: exp) ~(oldt: typ) ~(newt: typ) = let loc = e.eloc in if need_cast ~force oldt newt then begin let mk_cast exp = (* to new type [newt] *) new_exp ~loc (CastE((type_remove_attributes_for_c_cast newt),exp)) in (* Watch out for constants and cast of cast to pointer *) match unrollType newt, e.enode with (* In the case were we have a representation for the literal, explicitly add the cast. *) | TInt(newik, []), Const(CInt64(i, _, None)) -> kinteger64 ~loc newik i | TPtr _, CastE (_, e') -> (match unrollType (typeOf e') with | (TPtr _ as typ'') -> (* Old cast can be removed...*) if need_cast ~force newt typ'' then mk_cast e' else (* In fact, both casts can be removed. *) e' | _ -> mk_cast e) | _ -> (* Do not remove old casts because they are conversions !!! *) mk_cast e end else e let mkCast ?force ~(e: exp) ~(newt: typ) = mkCastT ?force ~e ~oldt:(typeOf e) ~newt (* TODO: unify this with doBinOp in Cabs2cil. *) let mkBinOp ~loc op e1 e2 = let t1 = typeOf e1 in let t2 = typeOf e2 in let machdep = false in let make_expr common_type res_type = constFoldBinOp ~loc machdep op (mkCastT e1 t1 common_type) (mkCastT e2 t2 common_type) res_type in let doArithmetic () = let tres = arithmeticConversion t1 t2 in make_expr tres tres in let doArithmeticComp () = let tres = arithmeticConversion t1 t2 in make_expr tres intType in let doIntegralArithmetic () = let tres = arithmeticConversion t1 t2 in if isIntegralType tres then make_expr tres tres else Kernel.fatal ~current:true "mkBinOp: %a" !pp_exp_ref (dummy_exp(BinOp(op,e1,e2,intType))) in match op with (Mult|Div) -> doArithmetic () | (Mod|BAnd|BOr|BXor|LAnd|LOr) -> doIntegralArithmetic () | (Shiftlt|Shiftrt) -> (* ISO 6.5.7. Only integral promotions. The result * has the same type as the left hand side *) if theMachine.msvcMode then (* MSVC has a bug. We duplicate it here *) doIntegralArithmetic () else let t1' = integralPromotion t1 in let t2' = integralPromotion t2 in constFoldBinOp ~loc machdep op (mkCastT e1 t1 t1') (mkCastT e2 t2 t2') t1' | (PlusA|MinusA) when isArithmeticType t1 && isArithmeticType t2 -> doArithmetic () | (PlusPI|MinusPI|IndexPI) when isPointerType t1 && isIntegralType t2 -> constFoldBinOp ~loc machdep op e1 e2 t1 | MinusPP when isPointerType t1 && isPointerType t2 -> (* NB: Same as cabs2cil. Check if this is really what the standard says*) constFoldBinOp ~loc machdep op e1 (mkCastT e2 t2 t1) intType | (Eq|Ne|Lt|Le|Ge|Gt) when isArithmeticType t1 && isArithmeticType t2 -> doArithmeticComp () | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isPointerType t2 -> constFoldBinOp ~loc machdep op (mkCastT e1 t1 theMachine.upointType) (mkCastT e2 t2 theMachine.upointType) intType | (Eq|Ne) when isPointerType t1 && isZero e2 -> constFoldBinOp ~loc machdep op e1 (mkCastT (zero ~loc)theMachine.upointType t1) intType | (Eq|Ne) when isPointerType t2 && isZero e1 -> constFoldBinOp ~loc machdep op (mkCastT (zero ~loc)theMachine.upointType t2) e2 intType | (Eq|Ne) when isVariadicListType t1 && isZero e2 -> Kernel.debug ~level:3 "Comparison of va_list and zero"; constFoldBinOp ~loc machdep op e1 (mkCastT (zero ~loc)theMachine.upointType t1) intType | (Eq|Ne) when isVariadicListType t2 && isZero e1 -> Kernel.debug ~level:3 "Comparison of zero and va_list"; constFoldBinOp ~loc machdep op (mkCastT (zero ~loc)theMachine.upointType t2) e2 intType | _ -> Kernel.fatal ~current:true "mkBinOp: %a" !pp_exp_ref (dummy_exp(BinOp(op,e1,e2,intType))) type existsAction = ExistsTrue (* We have found it *) | ExistsFalse (* Stop processing this branch *) | ExistsMaybe (* This node is not what we are * looking for but maybe its * successors are *) let existsType (f: typ -> existsAction) (t: typ) : bool = let memo : (int, unit) Hashtbl.t = Hashtbl.create 17 in (* Memo table *) let rec loop t = match f t with ExistsTrue -> true | ExistsFalse -> false | ExistsMaybe -> (match t with TNamed (t', _) -> loop t'.ttype | TComp (c, _,_) -> loopComp c | TArray (t', _, _, _) -> loop t' | TPtr (t', _) -> loop t' | TFun (rt, args, _, _) -> (loop rt || List.exists (fun (_, at, _) -> loop at) (argsToList args)) | _ -> false) and loopComp c = if Hashtbl.mem memo c.ckey then (* We are looping, the answer must be false *) false else begin Hashtbl.add memo c.ckey (); List.exists (fun f -> loop f.ftype) c.cfields end in loop t (* Try to do an increment, with constant folding *) let increm (e: exp) (i: int) = let e' = constFold false e in let et = typeOf e' in let bop = if isPointerType et then PlusPI else PlusA in let i = match et with | TInt (k, _) | TEnum ({ekind = k },_) -> kinteger k ~loc:e.eloc i | _ -> integer ~loc:e.eloc i in constFoldBinOp ~loc:e.eloc false bop e' i et (* Try to do an increment, with constant folding *) let increm64 (e: exp) i = let et = typeOf e in let bop = if isPointerType et then PlusPI else PlusA in constFold false (new_exp ~loc:e.eloc (BinOp(bop, e, kinteger64 ~loc:e.eloc IULongLong i, et))) exception LenOfArray let lenOfArray64 eo = match eo with None -> raise LenOfArray | Some e -> begin match (constFold true e).enode with | Const(CInt64(ni, _, _)) when Integer.ge ni Integer.zero -> ni | _ -> raise LenOfArray end let lenOfArray eo = Integer.to_int (lenOfArray64 eo) (*** Make an initializer for zeroe-ing a data type ***) let rec makeZeroInit ~loc (t: typ) : init = match unrollType t with TInt (ik, _) -> SingleInit (new_exp ~loc (Const(CInt64(Integer.zero, ik, None)))) | TFloat(fk, _) -> SingleInit(new_exp ~loc (Const(CReal(0.0, fk, None)))) | TEnum _ -> SingleInit (zero ~loc) | TComp (comp, _, _) as t' when comp.cstruct -> let inits = List.fold_right (fun f acc -> if f.fname <> missingFieldName then (Field(f, NoOffset), makeZeroInit ~loc f.ftype) :: acc else acc) comp.cfields [] in CompoundInit (t', inits) | TComp (comp, _, _) when not comp.cstruct -> let fstfield, _rest = match comp.cfields with f :: rest -> f, rest | [] -> Kernel.fatal ~current:true "Cannot create init for empty union" in let fieldToInit = (* ISO C99 [6.7.8.10] says that the first field of the union is the one we should initialize. *) fstfield in CompoundInit(t, [(Field(fieldToInit, NoOffset), makeZeroInit ~loc fieldToInit.ftype)]) | TArray(bt, Some len, _, _) as t' -> let n = match (constFold true len).enode with Const(CInt64(n, _, _)) -> Integer.to_int n | _ -> Kernel.fatal ~current:true "Cannot understand length of array" in let initbt = makeZeroInit ~loc bt in let rec loopElems acc i = if i < 0 then acc else loopElems ((Index(integer ~loc i, NoOffset), initbt) :: acc) (i - 1) in CompoundInit(t', loopElems [] (n - 1)) | TArray (_bt, None, _, _) as t' -> (* Unsized array, allow it and fill it in later * (see cabs2cil.ml, collectInitializer) *) CompoundInit (t', []) | TPtr _ as t -> SingleInit( if theMachine.insertImplicitCasts then mkCast (zero ~loc) t else zero ~loc) | x -> Kernel.fatal ~current:true "Cannot initialize type: %a" !pp_typ_ref x (** Fold over the list of initializers in a Compound (not also the nested * ones). [doinit] is called on every present initializer, even if it is of * compound type. The parameters of [doinit] are: the offset in the compound * (this is [Field(f,NoOffset)] or [Index(i,NoOffset)]), the initializer * value, expected type of the initializer value, accumulator. In the case of * arrays there might be missing zero-initializers at the end of the list. * These are scanned only if [implicit] is true. This is much like * [List.fold_left] except we also pass the type of the initializer. *) let foldLeftCompound ~(implicit: bool) ~(doinit: offset -> init -> typ -> 'a -> 'a) ~(ct: typ) ~(initl: (offset * init) list) ~(acc: 'a) : 'a = match unrollType ct with TArray(bt, leno, _, _) -> begin (* Scan the existing initializer *) let part = List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl in (* See how many more we have to do *) match leno with Some lene when implicit -> begin match (constFold true lene).enode with Const(CInt64(i, _, _)) -> let len_array = Integer.to_int i in let len_init = List.length initl in if len_array > len_init then (*TODO : find a proper loc*) let loc = Cil_datatype.Location.unknown in let zi = makeZeroInit ~loc bt in let rec loop acc i = if i >= len_array then acc else loop (doinit (Index(integer ~loc i, NoOffset)) zi bt acc) (i + 1) in loop part len_init else part | _ -> Kernel.fatal ~current:true "foldLeftCompoundAll: array with initializer and non-constant length" end | _ when not implicit -> part | _ -> Kernel.fatal ~current:true "foldLeftCompoundAll: TArray with initializer and no length" end | TComp (_comp, _, _) -> let getTypeOffset = function Field(f, NoOffset) -> f.ftype | _ -> Kernel.fatal ~current:true "foldLeftCompound: malformed initializer" in List.fold_left (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl | _ -> Kernel.fatal ~current:true "Type of Compound is not array or struct or union" let rec isCompleteType t = match unrollType t with | TArray(_t, None, _, _) -> false | TArray(_t, Some z, _, _) when isZero z -> false | TComp (comp, _, _) -> (* Struct or union *) List.for_all (fun fi -> isCompleteType fi.ftype) comp.cfields | _ -> true module A = Alpha (** Uniquefy the variable names *) let uniqueVarNames (f: file) : unit = (* Setup the alpha conversion table for globals *) let gAlphaTable : (string, location A.alphaTableData ref) Hashtbl.t = Hashtbl.create 113 in (* Keep also track of the global names that we have used. Map them to the variable ID. We do this only to check that we do not have two globals with the same name. *) let globalNames: (string, int) Hashtbl.t = Hashtbl.create 113 in (* Scan the file and add the global names to the table *) iterGlobals f (function GVarDecl(_,vi, _) | GVar(vi, _, _) | GFun({svar = vi}, _) -> (* See if we have used this name already for something else *) (try let oldid = Hashtbl.find globalNames vi.vname in if oldid <> vi.vid && not vi.vinline then Kernel.warning "The name %s is used for two distinct globals" vi.vname (* Here if we have used this name already. Go ahead *) with Not_found -> begin (* Here if this is the first time we define a name *) Hashtbl.add globalNames vi.vname vi.vid; (* And register it *) A.registerAlphaName gAlphaTable None vi.vname (CurrentLoc.get ()) end) | _ -> ()); (* Now we must scan the function bodies and rename the locals *) iterGlobals f (function GFun(fdec, l) -> begin CurrentLoc.set l; (* Setup an undo list to be able to revert the changes to the * global alpha table *) let undolist = ref [] in (* Process one local variable *) let processLocal (v: varinfo) = let newname, oldloc = A.newAlphaName gAlphaTable (Some undolist) v.vname (CurrentLoc.get ()) in if false && newname <> v.vname then (* Disable this warning *) Kernel.warning "Changing the name of local %s in %s to %s \ (due to duplicate at %a)" v.vname fdec.svar.vname newname Location.pretty oldloc ; v.vname <- newname in (* Do the formals first *) List.iter processLocal fdec.sformals; (* Fix the type again *) setFormals fdec fdec.sformals; (* And now the locals *) List.iter processLocal fdec.slocals; (* Undo the changes to the global table *) A.undoAlphaChanges gAlphaTable !undolist; () end | _ -> ()); () let is_case_label l = match l with | Case _ | Default _ -> true | _ -> false let init_builtins () = if theMachine.msvcMode then initMsvcBuiltins () else initGccBuiltins () module type Machdeps = sig val gcc : Cil_types.mach val msvc : Cil_types.mach end let initCIL ~initLogicBuiltins machdep = if not (TheMachine.is_computed ()) then begin (* Set the machine *) let module Mach = (val machdep: Machdeps) in theMachine.theMachine <- if theMachine.msvcMode then Mach.msvc else Mach.gcc; (* Pick type for string literals *) theMachine.stringLiteralType <- if theMachine.theMachine.const_string_literals then charConstPtrType else charPtrType; (* Find the right ikind given the size *) let findIkindSz (unsigned: bool) (sz: int) : ikind = (* Test the most common sizes first *) if sz = theMachine.theMachine.sizeof_int then if unsigned then IUInt else IInt else if sz = theMachine.theMachine.sizeof_long then if unsigned then IULong else ILong else if sz = 1 then if unsigned then IUChar else IChar else if sz = theMachine.theMachine.sizeof_short then if unsigned then IUShort else IShort else if sz = theMachine.theMachine.sizeof_longlong then if unsigned then IULongLong else ILongLong else Kernel.fatal ~current:true "initCIL: cannot find the right ikind for size %d\n" sz in (* Find the right ikind given the name *) let findIkindName (name: string) : ikind = (* Test the most common sizes first *) if name = "int" then IInt else if name = "unsigned int" then IUInt else if name = "long" then ILong else if name = "unsigned long" then IULong else if name = "short" then IShort else if name = "unsigned short" then IUShort else if name = "char" then IChar else if name = "unsigned char" then IUChar else Kernel.fatal ~current:true "initCIL: cannot find the right ikind for type %s\n" name in theMachine.upointKind <- findIkindSz true theMachine.theMachine.sizeof_ptr; theMachine.upointType <- TInt(theMachine.upointKind, []); theMachine.kindOfSizeOf <- findIkindName theMachine.theMachine.size_t; theMachine.typeOfSizeOf <- TInt(theMachine.kindOfSizeOf, []); theMachine.wcharKind <- findIkindName theMachine.theMachine.wchar_t; theMachine.wcharType <- TInt(theMachine.wcharKind, []); theMachine.ptrdiffKind <- findIkindName theMachine.theMachine.ptrdiff_t; theMachine.ptrdiffType <- TInt(theMachine.ptrdiffKind, []); theMachine.underscore_name <- theMachine.theMachine.Cil_types.underscore_name; theMachine.useLogicalOperators <- false (* do not use lazy LAND and LOR *); (*nextGlobalVID <- 1 ; nextCompinfoKey <- 1;*) (* Have to be marked before calling [init*Builtins] below. *) TheMachine.mark_as_computed (); (* projectify theMachine *) copyMachine theMachine !theMachineProject; init_builtins (); Logic_env.Builtins.extend initLogicBuiltins; end (* We want to bring all type declarations before the data declarations. This * is needed for code of the following form: int f(); // Prototype without arguments typedef int FOO; int f(FOO x) { ... } In CIL the prototype also lists the type of the argument as being FOO, which is undefined. There is one catch with this scheme. If the type contains an array whose length refers to variables then those variables must be declared before the type *) let pullTypesForward = true (* Scan a type and collect the variables that are refered *) class getVarsInGlobalClass (pacc: varinfo list ref) = object inherit nopCilVisitor method vvrbl (vi: varinfo) = pacc := vi :: !pacc; SkipChildren method vglob = function GType _ | GCompTag _ -> DoChildren | _ -> SkipChildren end let getVarsInGlobal (g : global) : varinfo list = let pacc : varinfo list ref = ref [] in let v : cilVisitor = new getVarsInGlobalClass pacc in ignore (visitCilGlobal v g); !pacc let pushGlobal (g: global) ~(types:global list ref) ~(variables: global list ref) = if not pullTypesForward then variables := g :: !variables else begin (* Collect a list of variables that are refered from the type. Return * Some if the global should go with the types and None if it should go * to the variables. *) let varsintype : (varinfo list * location) option = match g with GType (_, l) | GCompTag (_, l) -> Some (getVarsInGlobal g, l) | GEnumTag (_, l) | GPragma (Attr("pack", _), l) | GCompTagDecl (_, l) | GEnumTagDecl (_, l) -> Some ([], l) (** Move the warning pragmas early | GPragma(Attr(s, _), l) when hasPrefix "warning" s -> Some ([], l) *) | _ -> None (* Does not go with the types *) in match varsintype with None -> variables := g :: !variables | Some (vl, loc) -> types := (* insert declarations for referred variables ('vl'), before * the type definition 'g' itself *) g :: (List.fold_left (fun acc v -> GVarDecl(empty_funspec (),v, loc) :: acc) !types vl) end type formatArg = Fe of exp | Feo of exp option (** For array lengths *) | Fu of unop | Fb of binop | Fk of ikind | FE of exp list (** For arguments in a function call *) | Ff of (string * typ * attributes) (** For a formal argument *) | FF of (string * typ * attributes) list (* For formal argument lists *) | Fva of bool (** For the ellipsis in a function type *) | Fv of varinfo | Fl of lval | Flo of lval option (** For the result of a function call *) | Fo of offset | Fc of compinfo | Fi of instr | FI of instr list | Ft of typ | Fd of int | Fg of string | Fs of stmt | FS of stmt list | FA of attributes | Fp of attrparam | FP of attrparam list | FX of string let d_formatarg fmt = function Fe e -> fprintf fmt "Fe(%a)" !pp_exp_ref e | Feo None -> fprintf fmt "Feo(None)" | Feo (Some e) -> fprintf fmt "Feo(%a)" !pp_exp_ref e | FE _ -> fprintf fmt "FE()" | Fk _ik -> fprintf fmt "Fk()" | Fva b -> fprintf fmt "Fva(%b)" b | Ff (an, _, _) -> fprintf fmt "Ff(%s)" an | FF _ -> fprintf fmt "FF(...)" | FA _ -> fprintf fmt "FA(...)" | Fu _uo -> fprintf fmt "Fu()" | Fb _bo -> fprintf fmt "Fb()" | Fv v -> fprintf fmt "Fv(%s)" v.vname | Fl l -> fprintf fmt "Fl(%a)" !pp_lval_ref l | Flo None -> fprintf fmt "Flo(None)" | Flo (Some l) -> fprintf fmt "Flo(%a)" !pp_lval_ref l | Fo _o -> fprintf fmt "Fo" | Fc ci -> fprintf fmt "Fc(%s)" ci.cname | Fi _i -> fprintf fmt "Fi(...)" | FI _i -> fprintf fmt "FI(...)" | Ft t -> fprintf fmt "Ft(%a)" !pp_typ_ref t | Fd n -> fprintf fmt "Fd(%d)" n | Fg s -> fprintf fmt "Fg(%s)" s | Fp _ -> fprintf fmt "Fp(...)" | FP _n -> fprintf fmt "FP(...)" | Fs _ -> fprintf fmt "FS" | FS _ -> fprintf fmt "FS" | FX _ -> fprintf fmt "FX()" let make_temp_logic_var = let counter = ref 0 in fun ty -> incr counter; let name = "__framac_tmp" ^ (string_of_int !counter) in make_logic_var_local name ty let extract_varinfos_from_exp vexp = let visitor = object inherit nopCilVisitor val mutable varinfos = Varinfo.Set.empty; method varinfos = varinfos method vvrbl (symb:varinfo) = varinfos <- Varinfo.Set.add symb varinfos; SkipChildren end in ignore (visitCilExpr (visitor :> nopCilVisitor) vexp) ; visitor#varinfos let extract_varinfos_from_lval vlval = let visitor = object inherit nopCilVisitor val mutable varinfos = Varinfo.Set.empty; method varinfos = varinfos method vvrbl (symb:varinfo) = varinfos <- Varinfo.Set.add symb varinfos; SkipChildren end in ignore (visitCilLval (visitor :> nopCilVisitor) vlval) ; visitor#varinfos let rec free_vars_term bound_vars t = match t.term_node with | TConst _ | TSizeOf _ | TSizeOfStr _ | TAlignOf _ | Tnull | Ttype _ -> Logic_var.Set.empty | TLval lv | TAddrOf lv | TStartOf lv -> free_vars_lval bound_vars lv | TSizeOfE t | TAlignOfE t | TUnOp (_,t) | TCastE (_,t) | Tat (t,_) | Toffset (_,t) | Tbase_addr (_,t) | Tblock_length (_,t) | TCoerce (t,_) | Ttypeof t -> free_vars_term bound_vars t | TBinOp (_,t1,t2) | TCoerceE (t1,t2) -> Logic_var.Set.union (free_vars_term bound_vars t1) (free_vars_term bound_vars t2) | TUpdate (t1,toff,t2) -> Logic_var.Set.union (Logic_var.Set.union (free_vars_term bound_vars t1) (free_vars_term_offset bound_vars toff)) (free_vars_term bound_vars t2) | Tif (t1,t2,t3) -> Logic_var.Set.union (free_vars_term bound_vars t1) (Logic_var.Set.union (free_vars_term bound_vars t2) (free_vars_term bound_vars t3)) | TDataCons(_,t) | Tapp (_,_,t) -> List.fold_left (fun acc t -> Logic_var.Set.union (free_vars_term bound_vars t) acc) Logic_var.Set.empty t | Tlambda(prms,expr) -> let bound_vars = List.fold_left (Extlib.swap Logic_var.Set.add) bound_vars prms in free_vars_term bound_vars expr | Trange(i1,i2) -> let fv = match i1 with | None -> Logic_var.Set.empty | Some i -> free_vars_term bound_vars i in (match i2 with | None -> fv | Some i -> Logic_var.Set.union fv (free_vars_term bound_vars i)) | Tempty_set -> Logic_var.Set.empty | Tunion l | Tinter l -> List.fold_left (fun acc t -> Logic_var.Set.union (free_vars_term bound_vars t) acc) Logic_var.Set.empty l | Tcomprehension(t,q,p) -> let new_bv = List.fold_left (fun acc v -> Logic_var.Set.add v acc) bound_vars q in let fv = free_vars_term new_bv t in (match p with | None -> fv | Some p -> Logic_var.Set.union fv (free_vars_predicate new_bv p)) | Tlet(d,b) -> let fvd = match d.l_body with | LBterm term -> free_vars_term bound_vars term | LBpred p -> free_vars_predicate bound_vars p | LBnone | LBreads _ | LBinductive _ -> Kernel.fatal ~current:true "definition of local variable %s is not a term or a predicate" d.l_var_info.lv_name in let fvb = free_vars_term (Logic_var.Set.add d.l_var_info bound_vars) b in Logic_var.Set.union fvd fvb | TLogic_coerce(_,t) -> free_vars_term bound_vars t and free_vars_lval bv (h,o) = Logic_var.Set.union (free_vars_lhost bv h) (free_vars_term_offset bv o) and free_vars_lhost bv = function | TVar log_v -> if Logic_var.Set.mem log_v bv then Logic_var.Set.empty else Logic_var.Set.singleton log_v | TResult _ -> Logic_var.Set.empty | TMem t -> free_vars_term bv t and free_vars_term_offset bv = function | TNoOffset -> Logic_var.Set.empty | TField (_,o) | TModel(_,o) -> free_vars_term_offset bv o | TIndex (t,o) -> Logic_var.Set.union (free_vars_term bv t) (free_vars_term_offset bv o) and free_vars_predicate bound_vars p = match p.content with | Pfalse | Ptrue -> Logic_var.Set.empty | Papp (_,_,tl) -> List.fold_left (fun acc t -> Logic_var.Set.union (free_vars_term bound_vars t) acc) Logic_var.Set.empty tl | Pallocable (_,t) | Pfreeable (_,t) | Pvalid (_,t) | Pvalid_read (_,t) | Pinitialized (_,t) -> free_vars_term bound_vars t | Pseparated seps -> List.fold_left (fun free_vars tset -> Logic_var.Set.union (free_vars_term bound_vars tset) free_vars) Logic_var.Set.empty seps | Pfresh (_,_,t1,t2) | Prel (_,t1,t2) | Psubtype (t1,t2) -> Logic_var.Set.union (free_vars_term bound_vars t1) (free_vars_term bound_vars t2) | Pand (p1,p2) | Por (p1,p2) | Pxor (p1,p2) | Pimplies (p1,p2) | Piff (p1,p2) -> Logic_var.Set.union (free_vars_predicate bound_vars p1) (free_vars_predicate bound_vars p2) | Pnot p | Pat (p,_) (* | Pnamed (_,p) *) -> free_vars_predicate bound_vars p | Pif (t,p1,p2) -> Logic_var.Set.union (free_vars_term bound_vars t) (Logic_var.Set.union (free_vars_predicate bound_vars p1) (free_vars_predicate bound_vars p2)) | Plet (d, p) -> let fvd = match d.l_body with | LBterm t -> free_vars_term bound_vars t | LBpred p -> free_vars_predicate bound_vars p | LBnone | LBreads _ | LBinductive _ -> Kernel.fatal ~current:true "Local logic var %s is not a defined term or predicate" d.l_var_info.lv_name in let new_bv = Logic_var.Set.add d.l_var_info bound_vars in Logic_var.Set.union fvd (free_vars_predicate new_bv p) | Pforall (lvs,p) | Pexists (lvs,p) -> let new_bv = List.fold_left (Extlib.swap Logic_var.Set.add) bound_vars lvs in free_vars_predicate new_bv p let extract_free_logicvars_from_term t = free_vars_term Logic_var.Set.empty t let extract_free_logicvars_from_predicate p = free_vars_predicate Logic_var.Set.empty p let extract_labels_from_annot annot = let visitor = object inherit nopCilVisitor val mutable labels = Logic_label.Set.empty; method labels = labels method vlogic_label (label:logic_label) = labels <- Logic_label.Set.add label labels; SkipChildren end in ignore (visitCilCodeAnnotation (visitor :> nopCilVisitor) annot) ; visitor#labels let extract_labels_from_term term = let visitor = object inherit nopCilVisitor val mutable labels = Logic_label.Set.empty; method labels = labels method vlogic_label (label:logic_label) = labels <- Logic_label.Set.add label labels; SkipChildren end in ignore (visitCilTerm (visitor :> nopCilVisitor) term) ; visitor#labels let extract_labels_from_pred pred = let visitor = object inherit nopCilVisitor val mutable labels = Logic_label.Set.empty; method labels = labels method vlogic_label (label:logic_label) = labels <- Logic_label.Set.add label labels; SkipChildren end in ignore (visitCilPredicateNamed (visitor :> nopCilVisitor) pred) ; visitor#labels let extract_stmts_from_labels labels = Logic_label.Set.fold (fun l a -> match l with | StmtLabel (stmt) -> Stmt.Set.add !stmt a | LogicLabel (Some (stmt), _str) -> Stmt.Set.add stmt a | LogicLabel (None, _str) -> a) labels Stmt.Set.empty let close_predicate p = let free_vars = free_vars_predicate Logic_var.Set.empty p in if Logic_var.Set.is_empty free_vars then p else { name = []; loc = p.loc; content = Pforall (Logic_var.Set.elements free_vars, p)} class alpha_conv tbl ltbl = object inherit nopCilVisitor method vvrbl v = try let v' = Hashtbl.find tbl v.vid in ChangeTo v' with Not_found -> DoChildren method vlogic_var_use v = try let v' = Hashtbl.find ltbl v.lv_id in ChangeTo v' with Not_found -> DoChildren end let create_alpha_renaming old_args new_args = let conversion = Hashtbl.create 7 in let lconversion = Hashtbl.create 7 in List.iter2 (fun old_vi new_vi -> Hashtbl.add conversion old_vi.vid new_vi; match old_vi.vlogic_var_assoc, new_vi.vlogic_var_assoc with | None, _ -> () (* nothing to convert in logic spec. *) | Some old_lv, Some new_lv -> Hashtbl.add lconversion old_lv.lv_id new_lv | Some old_lv, None -> Hashtbl.add lconversion old_lv.lv_id (cvar_to_lvar new_vi)) old_args new_args; new alpha_conv conversion lconversion (** Returns [true] whenever the type contains only arithmetic types *) let is_fully_arithmetic ty = not (existsType (fun typ -> match typ with | TNamed _ | TComp _ | TArray _ -> ExistsMaybe | TPtr _ | TBuiltin_va_list _ | TFun _ | TVoid _ -> ExistsTrue | TEnum _ |TFloat _ | TInt _ -> ExistsFalse) ty) (** Provided [s] is a switch, [separate_switch_succs s] returns the subset of [s.succs] that correspond to the labels of [s], and an optional statement that is [None] if the switch has a default label, or [Some s'] where [s'] is the syntactic successor of [s] otherwise *) let separate_switch_succs s = match s.skind with | Switch (_, _, cases, _) -> let to_set = List.fold_left (fun s stmt -> Stmt.Set.add stmt s) Stmt.Set.empty in let s_succs = to_set s.succs in let s_cases = to_set cases in let diff = Stmt.Set.diff s_succs s_cases in let cases = Stmt.Set.elements (Stmt.Set.inter s_succs s_cases) in (match Stmt.Set.elements diff with | [] -> cases, None | [s] -> cases, Some s | _ :: _ :: _ -> Kernel.fatal ~current:true "Bad CFG: switch with multiple non-case successors." ) | _ -> raise (Invalid_argument "separate_switch_succs") module Switch_cases = State_builder.Hashtbl (Stmt.Hashtbl) (Datatype.Pair(Datatype.List(Stmt))(Datatype.Option(Stmt))) (struct let name = "Switch_cases" let dependencies = [] let size = 49 end) let () = add_ast_dependency Switch_cases.self let () = add_ast_dependency CacheBitsOffset.self let separate_switch_succs = Switch_cases.memo separate_switch_succs class dropAttributes ?select () = object inherit genericCilVisitor (copy_visit (Project.current ())) method vattr a = match select with | None -> ChangeTo [] | Some l -> (match a with | (Attr (s,_) | AttrAnnot s) when List.mem s l -> ChangeTo [] | Attr _ | AttrAnnot _ -> DoChildren) method vtype ty = match ty with | TNamed (ty, attrs) -> ChangeDoChildrenPost (typeAddAttributes attrs ty.ttype, fun x -> x) | TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _ | TComp _ | TEnum _ | TBuiltin_va_list _ -> DoChildren end let typeDeepDropAttributes select t = let vis = new dropAttributes ~select () in visitCilType vis t let typeDeepDropAllAttributes t = let vis = new dropAttributes () in visitCilType vis t (** {1 Deprecated} *) let lastTermOffset = Kernel.deprecated "Cil.lastTermOffset" ~now:"Logic_const.lastTermOffset" Logic_const.lastTermOffset let addTermOffset = Kernel.deprecated "Cil.addTermOffset" ~now:"Logic_const.addTermOffset" Logic_const.addTermOffset let addTermOffsetLval = Kernel.deprecated "Cil.addTermOffsetLval" ~now:"Logic_const.addTermOffsetLval" Logic_const.addTermOffsetLval (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/cil/src/cil_datatype.mli0000644000175000017500000002667412155630367020527 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Datatypes of some useful CIL types. @plugin development guide *) open Cil_types open Datatype (**************************************************************************) (** {3 Localisations} *) (**************************************************************************) (** Single position in a file. @since Nitrogen-20111001 *) module Position: S_with_collections with type t = Lexing.position (** Cil locations. *) module Location: sig include S_with_collections with type t = location val unknown: t val pretty_long : t Pretty_utils.formatter (** Pretty the location under the form [file , line ], without the full-path to the file. The default pretty-printer [pretty] echoes [:] *) val pretty_line: t Pretty_utils.formatter (** Prints only the line of the location *) end module Localisation: Datatype.S with type t = localisation (**************************************************************************) (** {3 Cabs types} *) (**************************************************************************) module Cabs_file: S with type t = Cabs.file (**************************************************************************) (** {3 C types} Sorted by alphabetic order. *) (**************************************************************************) module Block: sig include S with type t = block (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref (**/**) end module Compinfo: S_with_collections with type t = compinfo module Enuminfo: S_with_collections with type t = enuminfo module Enumitem: S_with_collections with type t = enumitem (** @since Fluorine-20130401 *) module Wide_string: S_with_collections with type t = int64 list (** @since Oxygen-20120901 *) module Constant: sig include S_with_collections with type t = constant (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref (**/**) end (** Note that the equality is based on eid. For structural equality, use {!ExpStructEq} *) module Exp: sig include S_with_collections with type t = exp val dummy: exp (** @since Nitrogen-20111001 *) (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref (**/**) end module ExpStructEq: S_with_collections with type t = exp module Fieldinfo: S_with_collections with type t = fieldinfo module File: S with type t = file module Global: sig include S_with_collections with type t = global val loc: t -> location end module Initinfo: S with type t = initinfo module Instr: sig include S with type t = instr val loc: t -> location val pretty_ref: (Format.formatter -> t -> unit) ref end module Kinstr: sig include S_with_collections with type t = kinstr val kinstr_of_opt_stmt: stmt option -> kinstr (** @since Nitrogen-20111001. *) val loc: t -> location end module Label: S_with_collections with type t = label (** Note that the equality is based on eid (for sub-expressions). For structural equality, use {!LvalStructEq} *) module Lval: sig include S_with_collections with type t = lval (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref end (** @since Oxygen-20120901 *) module LvalStructEq: S_with_collections with type t = lval (** Same remark as for Lval. For structural equality, use {!OffsetStructEq}. *) module Offset: sig include S_with_collections with type t = offset (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref end (** @since Oxygen-20120901 *) module OffsetStructEq: S_with_collections with type t = offset module Stmt: sig include S_with_collections with type t = stmt module Hptset: sig include Hptset.S with type elt = stmt val self: State.t end val loc: t -> location val pretty_sid: Format.formatter -> t -> unit (** Pretty print the sid of the statement @since Nitrogen-20111001 *) (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref end module Attribute: sig include S_with_collections with type t = attribute (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref end (**/**) val pretty_typ_ref: (Format.formatter -> Cil_types.typ -> unit) ref (**/**) (** Types, with comparison over struct done by key and unrolling of typedefs. *) module Typ: sig include S_with_collections with type t = typ end (** Types, with comparison over struct done by name and no unrolling. *) module TypByName: sig include S_with_collections with type t = typ end (** Types, with comparison over struct done by key and no unrolling @since Fluorine-20130401 *) module TypNoUnroll: sig include S_with_collections with type t = typ end (**/**) (* Forward declarations from Cil *) val pbitsSizeOf : (typ -> int) ref val punrollType: (typ -> typ) ref (**/**) module Typeinfo: S_with_collections with type t = typeinfo (** @plugin development guide *) module Varinfo: sig include S_with_collections with type t = varinfo module Hptset: sig include Hptset.S with type elt = t val self: State.t end val dummy: t val pretty_vname: Format.formatter -> t -> unit (** Pretty print the name of the varinfo. @since Nitrogen-20111001 *) (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref val internal_pretty_code_ref: (Type.precedence -> Format.formatter -> t -> unit) ref end module Kf: sig include Datatype.S_with_collections with type t = kernel_function val vi: t -> varinfo val id: t -> int (**/**) val set_formal_decls: (varinfo -> varinfo list -> unit) ref (**/**) end (**************************************************************************) (** {3 ACSL types} Sorted by alphabetic order. *) (**************************************************************************) module Builtin_logic_info: S_with_collections with type t = builtin_logic_info module Code_annotation: sig include S_with_collections with type t = code_annotation val loc: t -> location option (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref end module Funspec: S with type t = funspec (** @since Fluorine-20130401 *) module Fundec: S_with_collections with type t = fundec module Global_annotation: sig include S_with_collections with type t = global_annotation val loc: t -> location end module Identified_term: S_with_collections with type t = identified_term module Logic_ctor_info: S_with_collections with type t = logic_ctor_info module Logic_info: S_with_collections with type t = logic_info module Logic_constant: S_with_collections with type t = logic_constant module Logic_label: S_with_collections with type t = logic_label (**/**) val pretty_logic_type_ref: (Format.formatter -> logic_type -> unit) ref (**/**) (** Logic_type. See the various [Typ*] modules for the distinction between those modules *) module Logic_type: S_with_collections with type t = logic_type module Logic_type_ByName: S_with_collections with type t = logic_type module Logic_type_NoUnroll: S_with_collections with type t = logic_type module Logic_type_info: S_with_collections with type t = logic_type_info module Logic_var: sig include S_with_collections with type t = logic_var (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref end (** @since Oxygen-20120901 *) module Model_info: sig include S_with_collections with type t = model_info (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref end module Term: sig include S_with_collections with type t = term (**/**) val pretty_ref: (Format.formatter -> t -> unit) ref end module Term_lhost: S_with_collections with type t = term_lhost module Term_offset: S_with_collections with type t = term_offset module Term_lval: S_with_collections with type t = term_lval module Predicate_named: S with type t = predicate named (**************************************************************************) (** {3 Logic_ptree} Sorted by alphabetic order. *) (**************************************************************************) module Lexpr: S with type t = Logic_ptree.lexpr (**/**) (* ****************************************************************************) (** {2 Internal API} *) (* ****************************************************************************) val drop_non_logic_attributes : (attributes -> attributes) ref val clear_caches: unit -> unit (**/**) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/cil/src/machdep_ppc_32.ml0000644000175000017500000001216612155630367020452 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* This module was generated automatically by code in Makefile and machdep.c *) open Cil_types let gcc = { (* Generated by code in cil/src/machdep.c *) version_major = 4; version_minor = 0; version = "4.0.1 (Apple Computer, Inc. build 5367)"; sizeof_short = 2; sizeof_int = 4; sizeof_long = 4; sizeof_longlong = 8; sizeof_ptr = 4; sizeof_float = 4; sizeof_double = 8; sizeof_longdouble = 16; sizeof_void = 1; sizeof_fun = 1; size_t = "unsigned long"; wchar_t = "int"; ptrdiff_t = "int"; alignof_short = 2; alignof_int = 4; alignof_long = 4; alignof_longlong = 4; alignof_ptr = 4; alignof_float = 4; alignof_double = 4; alignof_longdouble = 16; alignof_str = 1; alignof_fun = 4; alignof_aligned= 16; char_is_unsigned = false; const_string_literals = true; little_endian = false; underscore_name = false ; has__builtin_va_list = true; __thread_is_keyword = true; } let msvc = { (* Generated by code in cil/src/machdep.c *) version_major = 4; version_minor = 0; version = "4.0.1 (Apple Computer, Inc. build 5367)"; sizeof_short = 2; sizeof_int = 4; sizeof_long = 4; sizeof_longlong = 8; sizeof_ptr = 4; sizeof_float = 4; sizeof_double = 8; sizeof_longdouble = 16; sizeof_void = 1; sizeof_fun = 1; size_t = "unsigned long"; wchar_t = "int"; ptrdiff_t = "int"; alignof_short = 2; alignof_int = 4; alignof_long = 4; alignof_longlong = 4; alignof_ptr = 4; alignof_float = 4; alignof_double = 4; alignof_longdouble = 16; alignof_str = 1; alignof_fun = 4; alignof_aligned= 16; char_is_unsigned = false; const_string_literals = true; little_endian = false; underscore_name = true ; has__builtin_va_list = false; __thread_is_keyword = false; } frama-c-Fluorine-20130601/cil/src/machdep_x86_32.mli0000644000175000017500000000645212155630367020467 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) val gcc : Cil_types.mach val msvc : Cil_types.mach frama-c-Fluorine-20130601/cil/src/logic/0000755000175000017500000000000012155634040016430 5ustar mehdimehdiframa-c-Fluorine-20130601/cil/src/logic/logic_ptree.mli0000644000175000017500000003073412155630366021445 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (* Logic parse trees *) open Cil_types (** logic constants. *) type constant = IntConstant of string (** integer constant *) | FloatConstant of string (** real constant *) | StringConstant of string (** string constant *) | WStringConstant of string (** wide string constant *) (** logic types. *) type logic_type = | LTvoid (** C void *) | LTinteger (** mathematical integers. *) | LTreal (** mathematical real. *) | LTint of ikind (** C integral type.*) | LTfloat of fkind (** C floating-point type *) | LTarray of logic_type * constant option (** C array *) | LTpointer of logic_type (** C pointer *) | LTenum of string (** C enum *) | LTstruct of string (** C struct *) | LTunion of string (** C union *) | LTnamed of string * logic_type list (** declared logic type. *) | LTarrow of logic_type list * logic_type (** quantifier-bound variables *) type quantifiers = (logic_type * string) list (** comparison operators. *) type relation = Lt | Gt | Le | Ge | Eq | Neq (** arithmetic and logic binary operators. *) type binop = Badd | Bsub | Bmul | Bdiv | Bmod | Bbw_and | Bbw_or | Bbw_xor | Blshift | Brshift (** unary operators. *) type unop = Uminus | Ustar | Uamp | Ubw_not (** logical expression. The distinction between locations, terms and predicate is done during typing. *) type lexpr = { lexpr_node : lexpr_node; (** kind of expression. *) lexpr_loc : location (** position in the source code. *) } (* PL is for Parsed Logic *) (** kind of expression. *) and path_elt = (** construct inside a functional update. *) | PLpathField of string | PLpathIndex of lexpr and update_term = | PLupdateTerm of lexpr | PLupdateCont of ((path_elt list) * update_term) list and lexpr_node = (* both terms and predicates *) | PLvar of string (** a variable *) | PLapp of string * string list * lexpr list (** an application. *) (* terms *) | PLlambda of quantifiers * lexpr (** a lambda abstraction. *) | PLlet of string * lexpr * lexpr (** local binding. *) | PLconstant of constant (** a constant. *) | PLunop of unop * lexpr (** unary operator. *) | PLbinop of lexpr * binop * lexpr (** binary operator. *) | PLdot of lexpr * string (** field access ({t a.x}) *) | PLarrow of lexpr * string (** field access ({t a->x})*) | PLarrget of lexpr * lexpr (** array access. *) | PLold of lexpr (** expression refers to pre-state of a function. *) | PLat of lexpr * string (** expression refers to a given program point. *) | PLresult (** value returned by a function. *) | PLnull (** null pointer. *) | PLcast of logic_type * lexpr (** cast. *) | PLrange of lexpr option * lexpr option (** interval of integers. *) | PLsizeof of logic_type (** sizeof a type. *) | PLsizeofE of lexpr (** sizeof the type of an expression. *) | PLcoercion of lexpr * logic_type (** coercion of an expression in a given type. *) | PLcoercionE of lexpr * lexpr (** coercion of the first expression into the type of the second one. *) | PLupdate of lexpr * (path_elt list) * update_term (** functional update of the field of a structure. *) | PLinitIndex of (lexpr * lexpr) list (** array constructor. *) | PLinitField of (string * lexpr) list (** struct/union constructor. *) | PLtypeof of lexpr (** type tag for an expression. *) | PLtype of logic_type (** type tag for a C type. *) (* predicates *) | PLfalse (** false (either as a term or a predicate. *) | PLtrue (** true (either as a term or a predicate. *) | PLrel of lexpr * relation * lexpr (** comparison operator. *) | PLand of lexpr * lexpr (** conjunction. *) | PLor of lexpr * lexpr (** disjunction. *) | PLxor of lexpr * lexpr (** logical xor. *) | PLimplies of lexpr * lexpr (** implication. *) | PLiff of lexpr * lexpr (** equivalence. *) | PLnot of lexpr (** negation. *) | PLif of lexpr * lexpr * lexpr (** conditional operator. *) | PLforall of quantifiers * lexpr (** universal quantification. *) | PLexists of quantifiers * lexpr (** existential quantification. *) | PLbase_addr of string option * lexpr (** base address of a pointer. *) | PLoffset of string option * lexpr (** base address of a pointer. *) | PLblock_length of string option * lexpr (** length of the block pointed to by an expression. *) | PLvalid of string option * lexpr (** pointer is valid. *) | PLvalid_read of string option * lexpr (** pointer is valid for reading. *) | PLallocable of string option * lexpr (** pointer is valid for malloc. *) | PLfreeable of string option * lexpr (** pointer is valid for free. *) | PLinitialized of string option * lexpr (** l-value is guaranteed to be initalized *) | PLfresh of (string * string) option * lexpr * lexpr (** expression points to a newly allocated block. *) | PLseparated of lexpr list (** separation predicate. *) | PLnamed of string * lexpr (** named expression. *) | PLsubtype of lexpr * lexpr (** first type tag is a subtype of second one. *) (* tsets *) | PLcomprehension of lexpr * quantifiers * lexpr option (** set of expression defined in comprehension ({t \{ e | integer i; P(i)\}})*) | PLsingleton of lexpr (** singleton sets. *) | PLunion of lexpr list (** union of sets. *) | PLinter of lexpr list (** intersection of sets. *) | PLempty (** empty set. *) (** type invariant. *) type type_annot = {inv_name: string; this_type : logic_type; this_name: string; (** name of its argument. *) inv: lexpr } (** model field. *) type model_annot = {model_for_type: logic_type; model_type : logic_type; model_name: string; (** name of the model field. *) } (** Concrete type definition. *) type typedef = | TDsum of (string * logic_type list) list (** sum type, list of constructors *) | TDsyn of logic_type (** synonym of an existing type *) (** global declarations. *) type decl = { decl_node : decl_node; (** kind of declaration. *) decl_loc : location (** position in the source code. *) } and decl_node = | LDlogic_def of string * string list * string list * logic_type * (logic_type * string) list * lexpr (** [LDlogic_def(name,labels,type_params, return_type, parameters, definition)] represents the definition of a logic function [name] whose return type is [return_type] and arguments are [parameters]. Its label arguments are [labels]. Polymorphic functions have their type parameters in [type_params]. [definition] is the body of the defined function.*) | LDlogic_reads of string * string list * string list * logic_type * (logic_type * string) list * lexpr list option (** [LDlogic_reads(name,labels,type_params, return_type, parameters, reads_tsets)] represents the declaration of logic function. It has the same arguments as [LDlogic_def], except that the definition is abstracted to a set of read accesses in [read_tsets]. *) | LDtype of string * string list * typedef option (** new logic type and its parameters, optionally followed by its definition. *) | LDpredicate_reads of string * string list * string list * (logic_type * string) list * lexpr list option (** [LDpredicate_reads(name,labels,type_params, parameters, reads_tsets)] represents the declaration of a new predicate. It is similar to [LDlogic_reads] except that it has no [return_type]. *) | LDpredicate_def of string * string list * string list * (logic_type * string) list * lexpr (** [LDpredicate_def(name,labels,type_params, parameters, def)] represents the definition of a new predicate. It is similar to [LDlogic_def] except that it has no [return_type]. *) | LDinductive_def of string * string list * string list * (logic_type * string) list * (string * string list * string list * lexpr) list (** [LDinductive_def(name,labels,type_params, parameters, indcases)] represents an inductive definition of a new predicate. *) | LDlemma of string * bool * string list * string list * lexpr (** LDlemma(name,is_axiom,labels,type_params,property) represents a lemma or an axiom [name]. [is_axiom] is true for an axiom and false for a lemma. [labels] is the list of label arguments and [type_params] the list of type parameters. Last, [property] is the statement of the lemma. *) | LDaxiomatic of string * decl list (** [LDaxiomatic(id,decls)] represents a block of axiomatic definitions.*) | LDinvariant of string * lexpr (** global invariant. *) | LDtype_annot of type_annot (** type invariant. *) | LDmodel_annot of model_annot (** model field. *) | LDvolatile of lexpr list * (string option * string option) (** volatile clause read/write. *) and deps = lexpr Cil_types.deps (** C locations. *) (** specification of a C function. *) type spec = (lexpr, lexpr, lexpr) Cil_types.spec type code_annot = (lexpr, lexpr, lexpr, lexpr) Cil_types.code_annot (** assignment performed by a C function. *) type assigns = lexpr Cil_types.assigns (** variant for loop or recursive function. *) type variant = lexpr Cil_types.variant (** custom trees *) type custom_tree = | CustomType of logic_type | CustomLexpr of lexpr | CustomOther of string * (custom_tree list) (** all kind of annotations*) type annot = | Adecl of decl list (** global annotation. *) | Aspec (* the real spec is parsed afterwards. See cparser.mly (grammar rules involving SPEC) for more details. *) (** function specification. *) | Acode_annot of location * code_annot (** code annotation. *) | Aloop_annot of location * code_annot list (** loop annotation. *) | Aattribute_annot of location * string (** attribute annotation. *) | Acustom of location * string * custom_tree (** ACSL extension for external spec file **) type ext_decl = | Ext_decl of decl (* decl contains a location *) | Ext_macro of string * lexpr (* lexpr contains a location *) | Ext_include of bool * string * location type ext_function = | Ext_spec of spec * location (* function spec *) | Ext_loop_spec of string * annot * location (* loop annotation or code annotation relative to the loop body. *) | Ext_stmt_spec of string * annot * location (* code annotation. *) | Ext_glob of ext_decl type ext_module = string * ext_decl list * ((string * location) * ext_function list) list type ext_spec = ext_module list (* Local Variables: compile-command: "LC_ALL=C make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/logic_typing.ml0000644000175000017500000043134212155630366021467 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) open Cil_types open Cil open Logic_ptree open Logic_const open Logic_utils open Format exception Backtrack let ($) = Extlib.($) let error (source,_ as loc) fstring = CurrentLoc.set loc; (if Kernel.ContinueOnAnnotError.get() then Kernel.with_warning (fun _ -> raise Exit) else Kernel.abort) ~source (fstring ^^ " in annotation.") let loc_join (b,_) (_,e) = (b,e) let unescape s = let b = Buffer.create (String.length s) in Logic_lexer.chr b (Lexing.from_string s) let wcharlist_of_string s = let res = ref [] in let i = ref 0 in let rec treat_escape_octal n nb_pass = if nb_pass > 2 then res:= n::!res else if !i >= String.length s then res:= n::!res else match s.[!i] with x when '0' <= x && x <= '9' -> incr i; treat_escape_octal (Int64.add (Int64.mul (Int64.of_int 8) n) (Int64.of_int (Char.code x - Char.code '0'))) (nb_pass + 1) | _ -> res:= n::!res in let rec treat_escape_hexa n = if !i >= String.length s then res:= n::!res else match s.[!i] with x when '0' <= x && x <= '9' -> incr i; treat_escape_hexa (Int64.add (Int64.mul (Int64.of_int 16) n) (Int64.of_int (Char.code x - Char.code '0'))) | x when 'A' <= x && x <= 'F' -> incr i; treat_escape_hexa (Int64.add (Int64.mul (Int64.of_int 16) n) (Int64.of_int (Char.code x - Char.code 'A' + 10))) | x when 'a' <= x && x <= 'f' -> incr i; treat_escape_hexa (Int64.add (Int64.mul (Int64.of_int 16) n) (Int64.of_int (Char.code x - Char.code 'a' + 10))) | _ -> res:= n::!res in let treat_escape_sequence () = if !i >= String.length s then Kernel.warning ~current:true "Ill-formed escape sequence in wide string" else begin match s.[!i] with x when '0' <= x && x <= '9' -> treat_escape_octal Int64.zero 0 | 'x' -> incr i; treat_escape_hexa Int64.zero | 'a' -> incr i; res:= Int64.of_int 7::!res | 'b' -> incr i; res:= Int64.of_int 8::!res | 'f' -> incr i; res:= Int64.of_int 12::!res | 'n' -> incr i; res:= Int64.of_int (Char.code '\n') :: !res | 'r' -> incr i; res:=Int64.of_int (Char.code '\r')::!res | 't' -> incr i; res:= Int64.of_int (Char.code '\t') ::!res | '\'' -> incr i; res:=Int64.of_int (Char.code '\'')::!res | '"' -> incr i; res:= Int64.of_int (Char.code '"') ::!res | '?' -> incr i; res:= Int64.of_int (Char.code '?') ::!res | '\\' -> incr i; res:= Int64.of_int (Char.code '\\')::!res | c -> incr i; Kernel.warning ~current:true "Ill-formed escape sequence in wide string"; res:= Int64.of_int (Char.code c) :: !res end in while (!i < String.length s) do match s.[!i] with | '\\' -> incr i; treat_escape_sequence () | c -> res := Int64.of_int (Char.code c)::!res; incr i done; List.rev (!res) let lift_set f loc = let rec aux loc = match loc.term_node with Tcomprehension(t,q,p) -> { loc with term_node = Tcomprehension(aux t,q,p)} | Tunion l -> {loc with term_node = Tunion(List.map aux l)} | Tinter l -> {loc with term_node = Tinter(List.map aux l)} | Tempty_set -> loc | _ -> f loc in aux loc let is_same_type t1 t2 = Cil_datatype.Logic_type.equal (Logic_utils.unroll_type t1) (Logic_utils.unroll_type t2) let type_rel = function | Eq -> Cil_types.Req | Neq -> Cil_types.Rneq | Lt -> Cil_types.Rlt | Le -> Cil_types.Rle | Gt -> Cil_types.Rgt | Ge -> Cil_types.Rge let type_binop = function | Badd -> PlusA | Bsub -> MinusA | Bmul -> Mult | Bdiv -> Div | Bmod -> Mod | Bbw_and -> BAnd | Bbw_or -> BOr | Bbw_xor -> BXor | Blshift -> Shiftlt | Brshift -> Shiftrt let binop_of_rel = function | Eq -> Cil_types.Eq | Neq -> Cil_types.Ne | Ge -> Cil_types.Ge | Gt -> Cil_types.Gt | Le -> Cil_types.Le | Lt -> Cil_types.Lt (* Logical environments *) module Lenv = struct (* locals: logic variables (e.g. quantified variables in \forall, \exists) *) module Smap = Map.Make(String) type t = { local_vars: Cil_types.logic_var Smap.t; local_logic_info: Cil_types.logic_info Smap.t; type_vars: Cil_types.logic_type Smap.t; logic_labels: Cil_types.logic_label Smap.t; current_logic_label: Cil_types.logic_label option; is_post_state: Cil_types.termination_kind option; is_funspec: bool; enclosing_post_state: Cil_types.termination_kind option; (* to determine in which post-state we should go in case of nested \at(\at(...,Post),Pre) *) } let fresh_var env name kind typ = let name = let exists name = Smap.mem name env.local_vars || Smap.mem name env.local_logic_info || (Logic_env.find_all_logic_functions name <> []) in let rec aux i = if i < 0 then Kernel.fatal ~current:true "Out of indexes for temp logic var"; let name' = name ^ "_" ^ (string_of_int i) in if exists name' then aux (i+1) else name' in if exists name then aux 0 else name in Cil_const.make_logic_var_kind name kind typ let no_label env = Smap.is_empty env.logic_labels let enter_post_state env kind = let real_kind = match kind, env.enclosing_post_state with | _, None -> kind | Normal, Some kind -> kind | _, Some _ -> Kernel.fatal ~current:true "Inconsistent logic labels env stack" in { env with is_post_state = Some real_kind; enclosing_post_state = Some real_kind } let exit_post_state env = { env with is_post_state = None } let current_post_state env = env.is_post_state let add_var v var env = { env with local_vars = Smap.add v var env.local_vars } let find_var v env = Smap.find v env.local_vars let add_type_var v typ env = { env with type_vars = Smap.add v typ env.type_vars } let find_type_var v env = Smap.find v env.type_vars let add_logic_info v li env = let env = { env with local_logic_info = Smap.add v li env.local_logic_info } in add_var v li.l_var_info env let find_logic_info v env = Smap.find v env.local_logic_info (* logic labels *) let add_logic_label l lab env = { env with logic_labels = Smap.add l lab env.logic_labels } let find_logic_label l env = Smap.find l env.logic_labels let set_current_logic_label lab env = let env = { env with current_logic_label = Some lab } in match lab with LogicLabel (_,"Post") -> enter_post_state env Normal | LogicLabel (_,("Pre" | "Old")) | StmtLabel _ -> exit_post_state env | LogicLabel (_,"Here") -> env | LogicLabel _ -> exit_post_state env let default_label = ref None let empty () = default_label := None; { local_vars = Smap.empty; local_logic_info = Smap.empty; type_vars = Smap.empty; logic_labels = Smap.empty; current_logic_label = None; is_post_state = None; enclosing_post_state=None; is_funspec=false } let funspec () = let empty = empty () in { empty with is_funspec = true } end let append_here_label env = let env = Lenv.add_logic_label "Here" Logic_const.here_label env in Lenv.set_current_logic_label Logic_const.here_label env let append_pre_label env = Lenv.add_logic_label "Pre" Logic_const.pre_label env let append_old_and_post_labels env = Lenv.add_logic_label "Post" Logic_const.post_label (Lenv.add_logic_label "Old" Logic_const.old_label env) let append_loop_labels env = Lenv.add_logic_label "LoopEntry" Logic_const.loop_entry_label (Lenv.add_logic_label "LoopCurrent" Logic_const.loop_current_label env) let add_var var info env = Lenv.add_var var info env let add_result env typ = if Logic_utils.isLogicVoidType typ then env else let v = Cil_const.make_logic_var_kind "\\result" LVC typ in Lenv.add_var "\\result" v env let add_exit_status env = let v = Cil_const.make_logic_var_global "\\exit_status" Linteger in Lenv.add_var "\\exit_status" v env let enter_post_state env kind = Lenv.enter_post_state env kind let post_state_env kind typ = let env = Lenv.funspec () in let env = append_here_label env in let env = append_old_and_post_labels env in (* NB: this allows to have \result and Exits as termination kind *) let env = add_result env typ in let env = add_exit_status env in let env = enter_post_state env kind in env type typing_context = { is_loop: unit -> bool; anonCompFieldName : string; conditionalConversion : typ -> typ -> typ; find_macro : string -> lexpr; find_var : string -> logic_var; find_enum_tag : string -> exp * typ; find_comp_type : kind:string -> string -> typ; find_comp_field: compinfo -> string -> offset; find_type : string -> typ; find_label : string -> stmt ref; remove_logic_function : string -> unit; remove_logic_type: string -> unit; remove_logic_ctor: string -> unit; add_logic_function: logic_info -> unit; add_logic_type: string -> logic_type_info -> unit; add_logic_ctor: string -> logic_ctor_info -> unit; find_all_logic_functions: string -> logic_info list; find_logic_type: string -> logic_type_info; find_logic_ctor: string -> logic_ctor_info; pre_state:Lenv.t; post_state:Cil_types.termination_kind list -> Lenv.t; assigns_env:Lenv.t; type_predicate:Lenv.t -> Logic_ptree.lexpr -> predicate named; type_term:Lenv.t -> Logic_ptree.lexpr -> term; type_assigns: accept_formal:bool -> Lenv.t -> Logic_ptree.lexpr Cil_types.assigns -> identified_term Cil_types.assigns; error: 'a. location -> ('a,formatter,unit) format -> 'a } module Extensions = struct let typer_tbl = Hashtbl.create 5 let find_typer name= Hashtbl.find typer_tbl name let register name typer = Logic_utils.register_extension name; Hashtbl.add typer_tbl name typer let typer name ~typing_context:typing_context ~loc bhv p = try let typ = find_typer name in typ ~typing_context ~loc bhv p with Not_found -> error loc "unsupported clause of name '%s'" name end let register_behavior_extension = Extensions.register let rec arithmetic_conversion ty1 ty2 = match unroll_type ty1, unroll_type ty2 with | Ctype ty1, Ctype ty2 -> if isIntegralType ty1 && isIntegralType ty2 then Linteger else Lreal | (Linteger, Ctype t | Ctype t, Linteger) when isIntegralType t -> Linteger | (Linteger, Ctype t | Ctype t , Linteger) when isArithmeticType t-> Lreal | (Lreal, Ctype ty | Ctype ty, Lreal) when isArithmeticType ty -> Lreal | Linteger, Linteger -> Linteger | (Lreal | Linteger) , (Lreal | Linteger) -> Lreal | Ltype ({lt_name="set"} as lt,[t1]), Ltype ({lt_name="set"},[t2]) -> Ltype(lt,[arithmetic_conversion t1 t2]) | _ -> Kernel.fatal "arithmetic conversion between non arithmetic types %a and %a" Cil_printer.pp_logic_type ty1 Cil_printer.pp_logic_type ty2 let plain_arithmetic_type t = match unroll_type t with | Ctype ty -> Cil.isArithmeticType ty | Linteger | Lreal -> true | Ltype _ | Lvar _ | Larrow _ -> false let plain_integral_type t = match unroll_type t with | Ctype ty -> Cil.isIntegralType ty | Linteger -> true | Ltype _ | Lreal | Lvar _ | Larrow _ -> false let plain_boolean_type t = match unroll_type t with | Ctype ty -> isIntegralType ty | Linteger -> true | Ltype ({lt_name = name},[]) -> name = Utf8_logic.boolean | Lreal | Ltype _ | Lvar _ | Larrow _ -> false let plain_non_void_ptr loc typ = match unroll_type typ with Ctype (TPtr(ty,_) | TArray(ty,_,_,_)) -> not (Cil.isVoidType ty) | _ -> error loc "not a pointer or array type" let is_arithmetic_type = plain_or_set plain_arithmetic_type let is_integral_type = plain_or_set plain_integral_type let is_non_void_ptr loc = plain_or_set (plain_non_void_ptr loc) let check_non_void_ptr loc typ = if not (is_non_void_ptr loc typ) then error loc "expecting a non-void pointer" let rec add_offset toadd = function | TNoOffset -> toadd | TField(fid', offset) -> TField(fid', add_offset toadd offset) | TModel(mf,offset) -> TModel(mf,add_offset toadd offset) | TIndex(e, offset) -> TIndex(e, add_offset toadd offset) let add_offset_lval toadd (b, off) = b, add_offset toadd off let rec type_of_pointed t = match unroll_type t with Ctype ty when isPointerType ty -> Ctype (Cil.typeOf_pointed ty) | Ltype ({lt_name = "set"} as lt,[t]) -> Ltype(lt,[type_of_pointed t]) | _ -> Kernel.fatal "type %a is not a pointer type" Cil_printer.pp_logic_type t let rec ctype_of_pointed t = match unroll_type t with Ctype ty when isPointerType ty -> Cil.typeOf_pointed ty | Ltype ({lt_name = "set"},[t]) -> ctype_of_pointed t | _ -> Kernel.fatal "type %a is not a pointer type" Cil_printer.pp_logic_type t let type_of_array_elem = plain_or_set (fun t -> match unroll_type t with Ctype ty when isArrayType ty -> Ctype (Cil.typeOf_array_elem ty) | _ -> error (CurrentLoc.get()) "type %a is not an array type" Cil_printer.pp_logic_type t) let rec ctype_of_array_elem t = match unroll_type t with | Ctype ty when isArrayType ty -> Cil.typeOf_array_elem ty | Ltype ({lt_name = "set"},[t]) -> ctype_of_array_elem t | _ -> Kernel.fatal "type %a is not a pointer type" Cil_printer.pp_logic_type t let type_of_set_elem t = match unroll_type t with | Ltype ({lt_name = "set"},[t]) -> t | _ -> Kernel.fatal "type %a is not a set type" Cil_printer.pp_logic_type t let plain_mk_mem ?loc t ofs = match t.term_node with | TAddrOf lv -> add_offset_lval ofs lv | TStartOf lv -> add_offset_lval (TIndex (Cil.lzero ?loc (), ofs)) lv | _ -> TMem t, ofs let mk_mem ?loc t ofs = lift_set (fun t -> term ?loc (TLval (plain_mk_mem ?loc t ofs)) (type_of_pointed t.term_type)) t let is_set_type t = match unroll_type t with | Ltype ({lt_name = "set"},[_]) -> true | _ -> false let is_plain_array_type t = match unroll_type t with | Ctype ct -> Cil.isArrayType ct | _ -> false let is_plain_pointer_type t = match unroll_type t with | Ctype ct -> Cil.isPointerType ct | _ -> false let is_array_type = plain_or_set is_plain_array_type let is_pointer_type = plain_or_set is_plain_pointer_type module Make (C: sig val is_loop: unit -> bool val anonCompFieldName : string val conditionalConversion : typ -> typ -> typ val find_macro : string -> lexpr val find_var : string -> logic_var val find_enum_tag : string -> exp * typ val find_comp_type : kind:string -> string -> typ val find_comp_field: compinfo -> string -> offset val find_type : string -> typ val find_label : string -> stmt ref val remove_logic_function : string -> unit val remove_logic_type: string -> unit val remove_logic_ctor: string -> unit val add_logic_function: logic_info -> unit val add_logic_type: string -> logic_type_info -> unit val add_logic_ctor: string -> logic_ctor_info -> unit val find_all_logic_functions: string -> logic_info list val find_logic_type: string -> logic_type_info val find_logic_ctor: string -> logic_ctor_info val integral_cast: Cil_types.typ -> Cil_types.term -> Cil_types.term end) = struct let make_typing_context ~pre_state ~post_state ~assigns_env ~type_predicate ~type_term ~type_assigns = { is_loop = C.is_loop; pre_state=pre_state; post_state=post_state; assigns_env=assigns_env; type_predicate= type_predicate; type_term= type_term; type_assigns = type_assigns; anonCompFieldName = C.anonCompFieldName; conditionalConversion = C.conditionalConversion; find_macro = C.find_macro; find_var = C.find_var; find_enum_tag = C.find_enum_tag; find_comp_type = C.find_comp_type; find_comp_field = C.find_comp_field; find_type = C.find_type ; find_label = C.find_label; remove_logic_function = C.remove_logic_function; remove_logic_type = C.remove_logic_type; remove_logic_ctor = C.remove_logic_ctor; add_logic_function = C.add_logic_function; add_logic_type = C.add_logic_type; add_logic_ctor = C.add_logic_ctor; find_all_logic_functions = C.find_all_logic_functions; find_logic_type = C.find_logic_type; find_logic_ctor = C.find_logic_ctor; error = error; } let has_field f ty = try ignore (Logic_env.find_model_field f ty); true with Not_found -> (match Cil.unrollType ty with | TComp(comp,_,_) -> List.exists (fun x -> x.fname = f) comp.cfields | _ -> false) let plain_type_of_c_field loc f ty = match Cil.unrollType ty with | TComp (comp, _, attrs) -> (try let attrs = Cil.filter_qualifier_attributes attrs in let field = C.find_comp_field comp f in let typ = Cil.typeOffset ty field in Logic_utils.offset_to_term_offset ~cast:false field, Ctype (Cil.typeAddAttributes attrs typ) with Not_found -> error loc "cannot find field %s" f) | _ -> error loc "expected a struct with field %s" f let plain_type_of_field loc f = function | Ctype ty -> (try let mf = Logic_env.find_model_field f ty in TModel(mf,TNoOffset), mf.mi_field_type with Not_found -> plain_type_of_c_field loc f ty) | _ -> error loc "expected a struct with field %s" f let type_of_field loc f = function | Ltype ({lt_name = "set"} as lt,[t]) -> let offs,typ = plain_type_of_field loc f t in offs, Ltype(lt,[typ]) | t -> plain_type_of_field loc f t let c_void_star = Ctype (TPtr (TVoid [], [])) (* keep in sync with fresh_type below *) let generated_var s = String.contains s '#' (* keep in sync with generated_var above*) class fresh_type_var = object(self) inherit Cil.nopCilVisitor val alpha_rename = Hashtbl.create 7 val mutable count = 0 method private fresh_s s = count <- succ count; Printf.sprintf "%s#%d" s count method vlogic_type = function Lvar s when Hashtbl.mem alpha_rename s -> Cil.ChangeTo (Lvar (Hashtbl.find alpha_rename s)) | Lvar s -> let s' = self#fresh_s s in Hashtbl.add alpha_rename s s'; Cil.ChangeTo (Lvar s') | _ -> Cil.DoChildren method reset_count () = count <- 0 method reset () = Hashtbl.clear alpha_rename end let fresh_type = new fresh_type_var let fresh typ = visitCilLogicType (fresh_type :> cilVisitor) typ let instantiate env ty = let obj = object inherit Cil.nopCilVisitor method vlogic_type t = match t with Lvar s when generated_var s -> (try Cil.ChangeDoChildrenPost (Lenv.find_type_var s env, fun x -> x) with Not_found -> Cil.DoChildren (* assert false *) (*FIXME: All type variables are supposed to be bound somewhere. However, there is currently no syntax to force an instantiation, e.g. for axiom foo: length(Nil) == 0; (where length takes list and Nil is list): we don't equal A nor B to C, and can't write length nor Nil) *) ) | _ -> Cil.DoChildren end in Cil.visitCilLogicType obj ty let rec logic_type loc env = function | LTvoid -> Ctype (TVoid []) | LTint ikind -> Ctype (TInt (ikind, [])) | LTfloat fkind -> Ctype (TFloat (fkind, [])) | LTarray (ty,length) -> let size = match length with Some (IntConstant s) -> Some (parseIntExp ~loc s) | Some (FloatConstant _ | StringConstant _ | WStringConstant _) -> error loc "size of array must be an integral value" | None -> None in Ctype (TArray (c_logic_type loc env ty, size, Cil.empty_size_cache (),[])) | LTpointer ty -> Ctype (TPtr (c_logic_type loc env ty, [])) | LTenum e -> (try Ctype (C.find_comp_type "enum" e) with Not_found -> error loc "no such enum %s" e) | LTstruct s -> (try Ctype (C.find_comp_type "struct" s) with Not_found -> error loc "no such struct %s" s) | LTunion u -> (try Ctype (C.find_comp_type "union" u) with Not_found -> error loc "no such union %s" u) | LTarrow (prms,rt) -> (* For now, our only function types are C function pointers. *) let prms = List.map (fun x -> "", c_logic_type loc env x, []) prms in let rt = c_logic_type loc env rt in (match prms with [] -> Ctype (TFun(rt,None,false,[])) | _ -> Ctype (TFun(rt,Some prms,false,[]))) | LTnamed (id,[]) -> (try Lenv.find_type_var id env with Not_found -> try Ctype (C.find_type id) with Not_found -> try let info = C.find_logic_type id in if info.lt_params <> [] then error loc "wrong number of parameter for type %s" id else Ltype (info,[]) with Not_found -> error loc "no such type %s" id) | LTnamed(id,l) -> (try let info = C.find_logic_type id in if List.length info.lt_params <> List.length l then error loc "wrong number of parameter for type %s" id else Ltype (info,List.map (logic_type loc env) l) with Not_found -> error loc "no such type %s" id) | LTinteger -> Linteger | LTreal -> Lreal and c_logic_type loc env t = match logic_type loc env t with | Ctype t -> t | Ltype _ | Linteger | Lreal | Lvar _ | Larrow _ -> error loc "not a C type" let mk_logic_access env t = match t.term_node with TLval _ -> t | _ -> let var = Lenv.fresh_var env "tmp" LVLocal t.term_type in let info = { l_var_info = var; l_labels = []; l_tparams = []; l_type = Some t.term_type; l_profile = []; l_body = LBterm t } in { t with term_node = Tlet(info,{ t with term_node = TLval(TVar var,TNoOffset) }) } let mk_dot env loc f_ofs f_type t = let rec t_dot_x t = match t.term_node with | TLval lv -> Logic_const.term ~loc (TLval (add_offset_lval f_ofs lv)) f_type | Tat (t1,l) -> Logic_const.term ~loc (Tat (t_dot_x t1,l)) f_type | _ -> let var = Lenv.fresh_var env "tmp" LVLocal t.term_type in let info = { l_var_info = var; l_labels = []; l_tparams = []; l_type = Some t.term_type; l_profile = []; l_body = LBterm t } in Logic_const.term ~loc (Tlet(info,{ t with term_node = TLval(TVar var,f_ofs) ; term_type = f_type })) f_type in t_dot_x t let mk_at_here idx = let rec needs_at idx = match idx.term_node with | TConst _ | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ | Tat _ | Ttypeof _ | Ttype _ | Tempty_set | Tbase_addr _ | Toffset _ | Tblock_length _ | Tnull -> false | TLval _ -> true | TUnOp(_,t) -> needs_at t | TBinOp(_,t1,t2) -> needs_at t1 || needs_at t2 | TCastE(_,t) -> needs_at t | TAddrOf (_,o) -> needs_at_offset o | TStartOf (_,o) -> needs_at_offset o | Tapp(_,_,l) | TDataCons(_,l) -> List.exists needs_at l | Tlambda(_,t) -> needs_at t | TCoerce(t,_) -> needs_at t | TCoerceE(t,_) -> needs_at t | TUpdate(t1,o,t2) -> needs_at t1 || needs_at_offset o || needs_at t2 | Tunion l | Tinter l -> List.exists needs_at l | Tcomprehension(t,_,None) -> needs_at t | Tcomprehension(t,_,Some p) -> needs_at t || needs_at_pred p | Trange (None, None) -> false | Trange (None, Some t) | Trange(Some t, None) -> needs_at t | Trange (Some t1, Some t2) -> needs_at t1 || needs_at t2 | Tlet(_,t) -> needs_at t | Tif(t1,t2,t3) -> needs_at t1 || needs_at t2 || needs_at t3 | TLogic_coerce(_,t) -> needs_at t and needs_at_offset = function | TNoOffset -> false | TIndex (t,o) -> needs_at t || needs_at_offset o | TField(_,o) | TModel(_,o) -> needs_at_offset o and needs_at_pred p = match p.content with | Pfalse | Ptrue | Pat _ -> false | Papp(_,_,t) | Pseparated t -> List.exists needs_at t | Prel(_,t1,t2) -> needs_at t1 || needs_at t2 | Pand(p1,p2) | Por(p1,p2) | Pxor(p1,p2) | Pimplies(p1,p2) | Piff(p1,p2) -> needs_at_pred p1 || needs_at_pred p2 | Pnot p | Plet (_,p) | Pforall(_,p) | Pexists(_,p) -> needs_at_pred p | Pif(t,p1,p2) -> needs_at t || needs_at_pred p1 || needs_at_pred p2 | Pvalid (_,t) | Pvalid_read (_,t) | Pinitialized (_,t) | Pallocable(_,t) | Pfreeable(_,t)-> needs_at t | Pfresh (_,_,t,n) -> (needs_at t) && (needs_at n) | Psubtype _ -> false in if needs_at idx then tat ~loc:idx.term_loc (idx,here_label) else idx let mk_shift loc env idx t_elt t = let add_offset array idx = Logic_const.term ~loc (TLval (add_offset_lval (TIndex (idx, TNoOffset)) array)) t_elt in let here_idx = mk_at_here idx in match t.term_node with | TStartOf array -> add_offset array idx | TLval array when is_array_type t.term_type -> add_offset array idx | Tlet (def, ({ term_node = TLval array} as t)) when is_array_type t.term_type -> Logic_const.term ~loc (Tlet (def, add_offset array idx)) t_elt | Tat({term_node = TStartOf (TVar { lv_origin = Some v},_ as lv)},lab) when v.vformal && lab = old_label && env.Lenv.is_funspec -> Logic_const.tat ~loc (add_offset lv here_idx,lab) | Tat({term_node = TLval (TVar { lv_origin = Some v},_ as lv)},lab) when v.vformal && lab = old_label && env.Lenv.is_funspec && is_array_type t.term_type -> Logic_const.tat ~loc (add_offset lv here_idx,lab) | _ -> let b = { term_node = TBinOp (IndexPI, t, idx); term_name = []; term_loc = loc; term_type = set_conversion t.term_type idx.term_type } in mk_mem b TNoOffset (* Make an AddrOf. Given an lval of type T will give back an expression of * type ptr(T) *) let mk_AddrOf lval t = let loc = t.term_loc in match lval with TMem e, TNoOffset -> term ~loc e.term_node e.term_type | b, TIndex(z, TNoOffset) when isLogicZero z -> term ~loc (TStartOf (b, TNoOffset)) (Ctype (TPtr (logicCType t.term_type,[]))) (* array *) | _ -> term ~loc (TAddrOf lval) (Ctype (TPtr (logicCType t.term_type,[]))) let mkAddrOfAndMark loc (b,off as lval) t = (* Mark the vaddrof flag if b is a variable *) begin match lastTermOffset off with | TNoOffset -> (match b with TVar vi -> begin match vi.lv_origin with None -> () | Some vi -> vi.vaddrof <- true end | _ -> ()) | TIndex _ -> () | TModel (mf,_) -> error loc "Cannot take the address of model field %s" mf.mi_name | TField(fi,_) -> fi.faddrof <- true end; mk_AddrOf lval t (* Compare the two types as logic types, ie by dismissing some irrelevant qualifiers and attributes *) let is_same_c_type ctyp1 ctyp2 = Cil_datatype.Logic_type.equal (Ctype ctyp1) (Ctype ctyp2) let c_mk_cast e oldt newt = if is_same_c_type oldt newt then e else begin (* Watch out for constants *) if isPointerType newt && isLogicNull e && not (isLogicZero e) then e else if isPointerType newt && isArrayType oldt && is_C_array e then mk_logic_StartOf e else match Cil.unrollType newt, e.term_node with | TEnum (ei,[]), TConst (LEnum { eihost = ei'}) when ei.ename = ei'.ename -> e | _ -> { e with term_node = (Logic_utils.mk_cast newt e).term_node; term_type = Ctype newt } end let is_same_ptr_type ctyp1 ctyp2 = (isPointerType ctyp1) && (isPointerType ctyp2) && (is_same_c_type (typeOf_pointed ctyp1) (typeOf_pointed ctyp2)) let is_same_array_type ctyp1 ctyp2 = (isArrayType ctyp1) && (isArrayType ctyp2) && (is_same_c_type (typeOf_array_elem ctyp1) (typeOf_array_elem ctyp2)) let is_same_logic_ptr_type ty1 ty2 = match (ty1,ty2) with Ctype t1, Ctype t2 -> is_same_ptr_type t1 t2 | _ -> false let is_same_logic_array_type ty1 ty2 = match (ty1,ty2) with Ctype t1, Ctype t2 -> is_same_array_type t1 t2 | _ -> false let is_function_pointer ty = try Cil.isFunctionType (Cil.typeOf_pointed ty) with Assert_failure _ -> false let is_implicit_pointer_conversion term ctyp1 ctyp2 = let same_pointed () = is_same_c_type (typeOf_pointed ctyp1) (typeOf_pointed ctyp2) in let same_array_elt () = is_same_c_type (typeOf_array_elem ctyp1) (typeOf_array_elem ctyp2) in let compatible_pointed () = same_pointed () || (isVoidPtrType ctyp2 && not (is_function_pointer ctyp1)) in (isArrayType ctyp1 && isArrayType ctyp2 && same_array_elt ()) || (isPointerType ctyp1 && isPointerType ctyp2 && (compatible_pointed() || isLogicNull term)) let is_enum_cst e t = match e.term_node with | TConst (LEnum ei) -> is_same_type (Ctype (TEnum (ei.eihost,[]))) t | _ -> false let logic_coerce t e = let set = make_set_type t in let rec aux e = match e.term_node with | Tcomprehension(e,q,p) -> { e with term_type = set; term_node = Tcomprehension (aux e,q,p) } | Tunion l -> { e with term_type = set; term_node = Tunion (List.map aux l) } | Tinter l -> { e with term_type = set; term_node = Tinter (List.map aux l) } | Tempty_set -> { e with term_type = set } | TLogic_coerce(_,e) -> { e with term_type = t; term_node = TLogic_coerce(t,e) } | _ -> { e with term_type = t; term_node = TLogic_coerce(t,e) } in if is_same_type e.term_type t then e else aux e let location_to_char_ptr t = let convert_one_location t = let ptd_type = type_of_pointed t.term_type in if isLogicCharType ptd_type then t else if isLogicVoidType ptd_type then error t.term_loc "can not have a set of void pointers" else let loc = t.term_loc in let sizeof = term ~loc (TSizeOf (logicCType ptd_type)) Linteger in let range = trange ~loc (Some (lzero ~loc ()), Some sizeof) in let converted_type = set_conversion (Ctype Cil.charPtrType) t.term_type in let cast = term ~loc (TCastE(Cil.charPtrType, t)) converted_type in term ~loc (TBinOp(PlusPI,cast,range)) (make_set_type converted_type) in lift_set convert_one_location t let rec mk_cast e newt = let loc = e.term_loc in if is_same_type e.term_type newt then e else if is_enum_cst e newt then e else begin match (unroll_type e.term_type), (* If any, use the typedef itself in the inserted cast *) (unroll_type ~unroll_typedef:false newt) with | Ctype oldt, Ctype newt -> c_mk_cast e oldt newt | t1, Ltype ({lt_name = name},[]) when name = Utf8_logic.boolean && is_integral_type t1 -> { e with term_node = TBinOp(Cil_types.Ne, mk_cast e Linteger, lzero ~loc ()); term_type = Ltype(C.find_logic_type Utf8_logic.boolean,[]) } | ty1, Ltype({lt_name="set"},[ty2]) when is_pointer_type ty1 && is_plain_pointer_type ty2 && isLogicCharType (type_of_pointed ty2) -> location_to_char_ptr e | Ltype({lt_name = "set"},[ty1]), Ltype({lt_name="set"},[ty2]) -> let e = mk_cast {e with term_type = ty1} ty2 in { e with term_type = make_set_type e.term_type} | ty1 , Ltype({lt_name = "set"},[ ty2 ]) -> let e = mk_cast e ty2 in { e with term_type = make_set_type ty1} | Linteger, Linteger | Lreal, Lreal -> e | Linteger, Ctype t when isLogicPointerType newt && isLogicNull e -> c_mk_cast e intType t | Linteger, Ctype t when isIntegralType t -> (try C.integral_cast t e with Failure s -> error loc "%s" s) | Linteger, Ctype _ | Lreal, Ctype _ -> error loc "invalid implicit cast from %a to C type %a" Cil_printer.pp_logic_type e.term_type Cil_printer.pp_logic_type newt | Ctype t, Linteger when Cil.isIntegralType t -> logic_coerce Linteger e | Ctype t, Lreal when isArithmeticType t -> logic_coerce Lreal e | Ctype _, (Lreal | Linteger) -> error loc "invalid implicit cast from %a to logic type %a" Cil_printer.pp_logic_type e.term_type Cil_printer.pp_logic_type newt | Linteger, Lreal -> logic_coerce Lreal e | Lreal, Linteger -> error loc "invalid cast from real to integer. \ Use conversion functions instead" | Ltype _, _ | _, Ltype _ | Lvar _,_ | _,Lvar _ | Larrow _,_ | _,Larrow _ -> error loc "invalid cast from %a to %a" Cil_printer.pp_logic_type e.term_type Cil_printer.pp_logic_type newt end let rec c_cast_to ot nt e = if is_same_c_type ot nt then (ot, e) else begin let result = (nt, mk_cast e (Ctype nt)) in match ot, nt with | TNamed(r, _), _ -> c_cast_to r.ttype nt e | _, TNamed(r, _) -> c_cast_to ot r.ttype e | TInt(_ikindo,_), TInt(_ikindn,_) -> result | TInt _, TPtr _ -> result | TPtr _, TInt _ -> result | ((TArray (told,_,_,_) | TPtr (told,_)), (TPtr (tnew,_) | TArray(tnew,_,_,_))) when is_same_c_type told tnew -> result | (TPtr _ | TArray _), (TPtr _ | TArray _) when isLogicNull e -> result | TPtr _, TPtr _ when isVoidPtrType nt -> (nt, e) | TEnum _, TInt _ -> result | TFloat _, (TInt _|TEnum _) -> result | (TInt _|TEnum _), TFloat _ -> result | TFloat _, TFloat _ -> result | TInt _, TEnum _ -> result | TEnum _, TEnum _ -> result | TEnum _, TPtr _ -> result | TBuiltin_va_list _, (TInt _ | TPtr _) -> result | (TInt _ | TPtr _), TBuiltin_va_list _ -> Kernel.debug ~level:3 "Casting %a to __builtin_va_list" Cil_printer.pp_typ ot; result | TPtr _, TEnum _ -> Kernel.debug ~level:3 "Casting a pointer into an enumeration type"; result | (TInt _ | TEnum _ | TPtr _ ), TVoid _ -> (ot, e) | TComp (comp1, _, _), TComp (comp2, _, _) when comp1.ckey = comp2.ckey -> nt, e | _ -> Kernel.fatal ~current:true "Logic_typing.c_cast_to: %a -> %a@." Cil_printer.pp_typ ot Cil_printer.pp_typ nt end (* for overloading: raised when an arguments list does not fit a formal parameter list *) exception Not_applicable (* convert term [oterm] of type [ot] to type [nt]. when overloaded is true, raise exception Not_applicable if conversion not possible, otherwise print an error message with location [loc] *) let rec implicit_conversion ~overloaded loc oterm ot nt = match (unroll_type ot), (unroll_type nt) with | Ctype ty1, Ctype ty2 -> if is_same_c_type ty1 ty2 then ot, oterm else let sz1 = bitsSizeOf ty1 in let sz2 = bitsSizeOf ty2 in if (isIntegralType ty1 && isIntegralType ty2 && (sz1 < sz2 || (sz1 = sz2 && (isSignedInteger ty1 = isSignedInteger ty2)) || is_enum_cst oterm nt )) || is_implicit_pointer_conversion oterm ty1 ty2 || (match unrollType ty1, unrollType ty2 with | (TFloat (f1,_), TFloat (f2,_)) -> f1 <= f2 (*[BM] relies on internal representation of OCaml constant constructors.*) | _ -> false) then begin let t,e = c_cast_to ty1 ty2 oterm in Ctype t, e end else if overloaded then raise Not_applicable else if isArrayType ty1 && isPointerType ty2 && is_same_c_type (typeOf_array_elem ty1) (typeOf_pointed ty2) then (if overloaded then raise Not_applicable else if Logic_utils.is_C_array oterm then error loc "In ACSL, there is no implicit conversion between \ a C array and a pointer. Either introduce an explicit \ cast or take the address of the first element of %a" Cil_printer.pp_term oterm else error loc "%a is a logic array. Only C arrays can be \ converted to pointers, and this conversion must be \ explicit (cast or take the address of the first element)" Cil_printer.pp_term oterm) else error loc "invalid implicit conversion from '%a' to '%a'" Cil_printer.pp_typ ty1 Cil_printer.pp_typ ty2 | Ctype ty, Linteger when Cil.isIntegralType ty -> Linteger, oterm | Ctype ty, Lreal when Cil.isArithmeticType ty -> Lreal, oterm | Linteger, Lreal -> Lreal, oterm (* Integer 0 is also a valid pointer. *) | Linteger, Ctype ty when Cil.isPointerType ty && isLogicNull oterm -> nt, { oterm with term_node = TCastE(ty,oterm); term_type = nt } | Linteger, Ctype ty when Cil.isIntegralType ty -> (try nt, C.integral_cast ty oterm with Failure s -> if overloaded then raise Not_applicable else error loc "%s" s) | t1, Ltype ({lt_name = "set"},[t2]) when is_pointer_type t1 && is_plain_pointer_type t2 && isLogicCharType (type_of_pointed t2) -> nt, location_to_char_ptr oterm (* can convert implicitly a singleton into a set, but not the reverse. *) | Ltype (t1,l1), Ltype (t2,l2) when t1.lt_name = t2.lt_name -> (* not sure this is really what we want: can foo be implicitly converted into foo ? *) let l = List.map2 (fun x y -> fst (implicit_conversion ~overloaded loc oterm x y)) l1 l2 in Ltype(t1,l),oterm | t1, Ltype ({lt_name = "set"},[t2]) -> let typ, term = implicit_conversion ~overloaded loc oterm t1 t2 in make_set_type typ, term | Linteger, Linteger | Lreal, Lreal -> ot, oterm | Lvar s1, Lvar s2 when s1 = s2 -> ot, oterm | Larrow(args1,rt1), Larrow(args2,rt2) when List.length args1 = List.length args2 -> (* contravariance. *) let args = List.map2 (fun x y -> fst (implicit_conversion ~overloaded loc oterm x y)) args2 args1 in let rt,_ = implicit_conversion ~overloaded loc oterm rt1 rt2 in Larrow(args,rt), oterm | ((Ctype _| Linteger | Lreal | Ltype _ | Lvar _ | Larrow _), (Ctype _| Linteger | Lreal | Ltype _ | Lvar _ | Larrow _)) -> if overloaded then raise Not_applicable else error loc "invalid implicit conversion from %a to %a" Cil_printer.pp_logic_type ot Cil_printer.pp_logic_type nt let rec find_supertype ~overloaded loc t ot nt = match unroll_type ot, unroll_type nt with | Ctype ot, Ctype nt -> if is_same_c_type ot nt then Ctype ot else if Cil.isIntegralType ot && Cil.isIntegralType nt then Linteger else if Cil.isArithmeticType ot && Cil.isArithmeticType nt then Lreal else if is_implicit_pointer_conversion t ot nt then let res,_ = c_cast_to ot nt t in Ctype res else if overloaded then raise Not_applicable else error loc "incompatible types %a and %a@." Cil_printer.pp_typ ot Cil_printer.pp_typ nt | Ctype ot, (Ltype({lt_name = n},[]) as nt) when n = Utf8_logic.boolean && Cil.isIntegralType ot -> nt | Ltype({lt_name = n},[]) as ot, Ctype nt when n = Utf8_logic.boolean && Cil.isIntegralType nt -> ot | (Linteger, (Ltype({lt_name = n},[]) as t) | (Ltype({lt_name = n},[]) as t), Linteger) when n = Utf8_logic.boolean -> t | Ltype(ot,oprms), Ltype(nt,nprms) when ot == nt -> let res = List.map2 (find_supertype ~overloaded loc t) oprms nprms in Ltype(ot,res) | Lvar s1, Lvar s2 when s1 = s2 -> ot | Linteger, Ctype nt when Cil.isIntegralType nt -> Linteger | Linteger, Ctype nt when Cil.isPointerType nt && isLogicNull t -> Ctype nt | Ctype ot, Linteger when Cil.isIntegralType ot -> Linteger | Ctype ot, Linteger when Cil.isPointerType ot && isLogicNull t -> Ctype ot | Linteger, Linteger -> Linteger | Linteger, Lreal -> Lreal | Linteger, Ctype nt when Cil.isArithmeticType nt -> Lreal | Ctype ot, Linteger when Cil.isArithmeticType ot -> Lreal | Lreal, Linteger -> Lreal | Lreal, Lreal -> Lreal | Lreal, Ctype nt when Cil.isArithmeticType nt -> Lreal | Ctype nt, Lreal when Cil.isArithmeticType nt -> Lreal | Larrow(oargs,oret), Larrow(nargs,nret) when List.length oargs = List.length nargs -> let ret = find_supertype ~overloaded loc t oret nret in let args = List.map2 (find_supertype ~overloaded loc t) nargs oargs in Larrow(args,ret) | (Ctype _ | Ltype _ | Lvar _ | Linteger | Lreal | Larrow _), _ -> if overloaded then raise Not_applicable else error loc "incompatible types %a and %a" Cil_printer.pp_logic_type ot Cil_printer.pp_logic_type nt let rec partial_unif ~overloaded loc term ot nt env = match (unroll_type ot),(unroll_type nt) with | Lvar s1, Lvar s2 -> if generated_var s1 then try let ot = Lenv.find_type_var s1 env in partial_unif ~overloaded loc term ot nt env with Not_found -> if generated_var s2 then try let nt = Lenv.find_type_var s2 env in partial_unif ~overloaded loc term ot nt env with Not_found -> if s1 < s2 then Lenv.add_type_var s2 ot env,ot,ot else if s2 < s1 then Lenv.add_type_var s1 nt env,nt,nt else env,ot,ot (* same type anyway *) else Lenv.add_type_var s1 nt env, nt, nt else if generated_var s2 then try let nt = Lenv.find_type_var s2 env in partial_unif ~overloaded loc term ot nt env with Not_found -> Lenv.add_type_var s2 ot env, ot, ot else if s1 = s2 then env, ot, ot (* same type *) else error loc "implicit unification of type variables %s and %s" s1 s2 | Lvar s1, _ when generated_var s1 -> (try let ot = Lenv.find_type_var s1 env in let env,ot,nt = partial_unif ~overloaded loc term ot nt env in let st = find_supertype ~overloaded loc term ot nt in let env = if is_same_type ot st then env else Lenv.add_type_var s1 st env in env, ot, st with Not_found -> Lenv.add_type_var s1 nt env, nt, nt) | _, Lvar s2 when generated_var s2 -> (try let nt = Lenv.find_type_var s2 env in let env, ot, nt = partial_unif ~overloaded loc term ot nt env in let st = find_supertype ~overloaded loc term ot nt in let env = if is_same_type nt st then env else Lenv.add_type_var s2 st env in env, ot, st with Not_found -> Lenv.add_type_var s2 ot env, ot, ot) | Ltype(t1,l1), Ltype(t2,l2) when t1.lt_name = t2.lt_name -> let env = List.fold_right2 (fun ot nt env -> let (env,_,_) = partial_unif ~overloaded loc term ot nt env in env) l1 l2 env in let l1 = List.map (instantiate env) l1 in let l2 = List.map (instantiate env) l2 in env,Ltype(t1,l1),Ltype(t2,l2) | Larrow(args1,rt1), Larrow(args2,rt2) when List.length args1 = List.length args2 -> let env = List.fold_right2 (fun ot nt env -> let env,_,_ = partial_unif ~overloaded loc term ot nt env in env) args1 args2 env in let env, _, _ = partial_unif ~overloaded loc term rt1 rt2 env in let rt1 = instantiate env rt1 in let rt2 = instantiate env rt2 in let args1 = List.map (instantiate env) args1 in let args2 = List.map (instantiate env) args2 in env, Larrow(args1,rt1), Larrow(args2,rt2) | t1, Ltype ({lt_name = "set"},[t2]) -> let (env,ot,nt) = partial_unif ~overloaded loc term t1 t2 env in env, make_set_type ot, make_set_type nt | t1,t2 when plain_boolean_type t1 && plain_boolean_type t2 -> env,ot,nt | ((Ctype _ | Linteger | Lreal | Ltype ({lt_name = "boolean"},[])), (Ctype _ | Linteger | Lreal | Ltype ({ lt_name = "boolean"},[]))) -> env,ot,nt | (Ltype _|Larrow _|Lvar _), _ | _, (Larrow _| Ltype _|Lvar _) -> if overloaded then raise Not_applicable else error loc "incompatible types %a and %a" Cil_printer.pp_logic_type ot Cil_printer.pp_logic_type nt let instantiate_app ~overloaded loc oterm nt env = let ot = oterm.term_type in let env, ot, nt = partial_unif ~overloaded loc oterm ot nt env in let t,e = implicit_conversion ~overloaded loc { oterm with term_type = ot} ot nt in env, t, e let convertible (t1,t) (t2,_) = let res = try let _ = implicit_conversion ~overloaded:true Cil_datatype.Location.unknown t t1 t2 in true with Not_applicable -> false in Kernel.debug ~level:4 "Checking conversion between %a and %a: %B@." Cil_printer.pp_logic_type t1 Cil_printer.pp_logic_type t2 res; res let convertible_non_null (ty1,t as t1) (ty2,_ as t2) = match (unroll_type ty1, unroll_type ty2) with | Ctype ty1, Ctype ty2 when isPointerType ty1 && isPointerType ty2 && isLogicNull t -> isVoidPtrType ty2 | _ -> convertible t1 t2 (* TODO: filter on signatures, not on type-checked actual arguments !!!!!! *) let filter_non_minimal_arguments l ((_,_,tl,_) as p) = let rec aux acc l = match l with | [] -> p::acc | ((_,_,tl',_) as p')::r -> if List.for_all2 convertible tl tl' then if List.for_all2 convertible tl' tl then (* Both are equivalent. This might come from arbitrary conversions of null pointer. Let's see if one of the list subsumes the other without relying on null ptr. *) if not (List.for_all2 convertible_non_null tl tl') then if not (List.for_all2 convertible_non_null tl' tl) then (* Both have null pointers converted to other type. Just don't choose a representative. *) aux (p'::acc) r else (* just use tl, it has less conversion than tl'. *) aux acc r else (* tl' has less conversion than tl, we can discard the new entry *) List.rev_append acc l else (* tl subtype of tl' *) aux acc r else if List.for_all2 convertible tl' tl then (* tl' subtype of tl *) List.rev_append acc l else aux (p'::acc) r in let l = aux [] l in assert (l <> []); l let rec logic_arithmetic_promotion t = match unroll_type t with | Ctype ty when Cil.isIntegralType ty -> Linteger | Linteger -> Linteger | Lreal -> Lreal | Ctype ty -> (match Cil.unrollType ty with TFloat _ -> Lreal | _ -> Kernel.fatal "logic arithmetic promotion on non-arithmetic type %a" Cil_printer.pp_logic_type t) | Ltype ({lt_name="set"} as lt,[t]) -> Ltype(lt,[logic_arithmetic_promotion t]) | Ltype _ | Lvar _ | Larrow _ -> Kernel.fatal "logic arithmetic promotion on non-arithmetic type %a" Cil_printer.pp_logic_type t let rec integral_promotion t = match unroll_type t with | Ctype ty when isIntegralType ty -> Linteger | Linteger -> Linteger | Ltype ({lt_name="set"} as lt,[t]) -> Ltype(lt,[integral_promotion t]) | Ltype _ | Lreal | Lvar _ | Larrow _ | Ctype _ -> Kernel.fatal "logic integral promotion on non-integral type %a" Cil_printer.pp_logic_type t let conditional_conversion loc env t1 t2 = (* a comparison is mainly a function of type 'a -> 'a -> Bool/Prop. performs the needed unifications on both sides.*) let var = fresh (Lvar "cmp") in let env,_,_ = partial_unif ~overloaded:false loc t1 t1.term_type var env in let env,ty2,_ = partial_unif ~overloaded:false loc t2 t2.term_type var env in (* in case first partial unification did not instantiate all variables we do another pass on t1 with information from t2. *) let env,ty1,_ = partial_unif ~overloaded:false loc t1 t1.term_type var env in let rec aux t1 t2 = match (unroll_type t1), (unroll_type t2) with | t1, t2 when is_same_type t1 t2 -> t1 | Ctype ty1, Ctype ty2 -> if isIntegralType ty1 && isIntegralType ty2 then if (isSignedInteger ty1) <> (isSignedInteger ty2) then (* in ACSL, the comparison between 0xFFFFFFFF seen as int and unsigned int is not true: we really have to operate at the integer level. *) Linteger else Ctype (C.conditionalConversion ty1 ty2) else if isArithmeticType ty1 && isArithmeticType ty2 then Lreal else if is_same_ptr_type ty1 ty2 || is_same_array_type ty1 ty2 then Ctype (C.conditionalConversion ty1 ty2) else if (isPointerType ty1 || isArrayType ty1) && (isPointerType ty2 || isArrayType ty2) then error loc "types %a and %a are not convertible" Cil_printer.pp_typ ty1 Cil_printer.pp_typ ty2 else (* pointer to integer conversion *) Ctype (C.conditionalConversion ty1 ty2) | (Linteger, Ctype t | Ctype t, Linteger) when Cil.isIntegralType t -> Linteger | (Linteger, Ctype t | Ctype t, Linteger) when Cil.isArithmeticType t -> Lreal | (Ltype({lt_name = name},[]), t | t, Ltype({lt_name = name},[])) when is_integral_type t && name = Utf8_logic.boolean -> Ltype(C.find_logic_type Utf8_logic.boolean,[]) | Lreal, Ctype ty | Ctype ty, Lreal when isArithmeticType ty -> Lreal | Ltype (s1,l1), Ltype (s2,l2) when s1.lt_name = s2.lt_name && List.for_all2 is_same_type l1 l2 -> t1 | Lvar s1, Lvar s2 when s1 = s2 -> t1 | Linteger, Linteger -> Linteger | (Lreal | Linteger) , (Lreal | Linteger) -> Lreal | Ltype ({lt_name = "set"} as lt,[t1]), Ltype({lt_name="set"},[t2]) -> Ltype(lt,[aux t1 t2]) (* implicit conversion to set *) | Ltype ({lt_name = "set"} as lt,[t1]), t2 | t1, Ltype({lt_name="set"} as lt,[t2]) -> Ltype(lt,[aux t1 t2]) | _ -> error loc "types %a and %a are not convertible" Cil_printer.pp_logic_type t1 Cil_printer.pp_logic_type t2 in let rt = aux ty1 ty2 in env,rt,ty1,ty2 type conversion = NoConv | ArithConv | IntegralConv | PointerConv let location_set_conversion loc transform_pointer_set t ot nt env = let ot = set_conversion ot nt in if is_same_type ot nt then transform_pointer_set, ot else if is_integral_type ot && is_integral_type nt then let typ = arithmetic_conversion ot nt in IntegralConv, typ else if is_arithmetic_type ot && is_arithmetic_type nt then let typ = arithmetic_conversion ot nt in ArithConv, typ else if is_pointer_type ot && is_pointer_type nt then PointerConv, make_set_type (Ctype Cil.charPtrType) else let _,_,t = partial_unif ~overloaded:false loc t ot nt env in transform_pointer_set,t let make_set_conversion conv t = match conv with | NoConv -> t | ArithConv -> logic_coerce Lreal t | IntegralConv -> logic_coerce Linteger t | PointerConv -> location_to_char_ptr t (* Typing terms *) let parseInt loc s = let explode s = let l = ref [] in String.iter (fun c -> l:=Int64.of_int (Char.code c) :: !l) s; List.rev !l in match s.[0] with | 'L' -> (* L'wide_char' *) let content = String.sub s 2 (String.length s - 3) in let tokens = explode content in let value = Cil.reduce_multichar Cil.theMachine.Cil.wcharType tokens in tinteger_s64 ~loc value | '\'' -> (* 'char' *) let content = String.sub s 1 (String.length s - 2) in let tokens = explode content in let value,_= Cil.interpret_character_constant tokens in term ~loc (TConst (constant_to_lconstant value)) Linteger | _ -> Cil.parseIntLogic ~loc s let find_logic_label loc env l = try Lenv.find_logic_label l env with Not_found -> (* look for a C label *) try let lab = C.find_label l in StmtLabel lab with Not_found -> error loc "logic label `%s' not found" l let find_old_label loc env = try Lenv.find_logic_label "Old" env with Not_found -> error loc "\\old undefined in this context" let default_inferred_label = LogicLabel (None, "L") let find_current_label loc env = match env.Lenv.current_logic_label with | Some lab -> lab | None -> if Lenv.no_label env then begin match !Lenv.default_label with None -> let lab = default_inferred_label in Lenv.default_label := Some lab; lab | Some lab -> lab end else error loc "no label in the context. (\\at or explicit label missing?)" let find_current_logic_label loc env = function | None -> find_current_label loc env | Some l -> find_logic_label loc env l let check_current_label loc env = ignore (find_current_label loc env) let labels_assoc loc id env fun_labels effective_labels = match fun_labels, effective_labels with [lf], [] -> [lf, find_current_label loc env] | _ -> try List.map2 (fun l1 l2 -> (l1,l2)) fun_labels effective_labels with Invalid_argument _ -> error loc "wrong number of labels for %s" id let add_quantifiers loc q env = let (tq,env) = List.fold_left (fun (tq,env) (ty, id) -> let ty = unroll_type (logic_type loc env ty) in let v = Cil_const.make_logic_var_quant id ty in (v::tq, Lenv.add_var id v env)) ([],env) q in (List.rev tq,env) class rename_variable v1 v2 = object inherit Cil.nopCilVisitor method vlogic_var_use v = if v.lv_id = v1.lv_id then ChangeTo v2 else SkipChildren end (* rename v1 into v2 in t *) let rename_variable t v1 v2 = visitCilTerm (new rename_variable v1 v2) t let find_logic_info v env = try Lenv.find_logic_info v.lv_name env with Not_found -> let l = C.find_all_logic_functions v.lv_name in (* Data constructors can not be in eta-reduced form. v must be a logic function, so that List.find can not fail here. *) List.find (fun x -> x.l_var_info.lv_id = v.lv_id) l let eta_expand loc names env v = match (unroll_type v.lv_type) with Larrow(args,rt) -> let (_,vars) = List.fold_right (fun x (i,l) -> i+1, Cil_const.make_logic_var_quant ("x_" ^ (string_of_int i)) x ::l) args (0,[]) in let args = List.map (fun x -> {term_name = []; term_loc = loc; term_node = TLval(TVar x,TNoOffset); term_type = x.lv_type; }) vars in { term_loc = loc; term_name = names; term_node = Tlambda(vars,{term_name = []; term_loc = loc; term_node = (* For now, it is not possible to have labels appended to plain variable, so we have to suppose that v has no label (this is checked when type-checking v as a variable) *) Tapp(find_logic_info v env,[],args); term_type = rt}); term_type = v.lv_type} | _ -> { term_loc = loc; term_name = names; term_node = TLval(TVar v, TNoOffset); term_type = v.lv_type } let fresh_vars known_vars v = if List.mem v.lv_name known_vars then begin let i = ref 0 in while List.mem (v.lv_name ^ "_" ^ string_of_int !i) known_vars do incr i; done; v.lv_name <- v.lv_name ^ "_" ^ string_of_int !i end let normalize_lambda_term env term = let add_binders quants term = match term.term_node, (unroll_type term.term_type) with | Tlambda(quants',term), Larrow (args,rt_typ) -> let args = List.fold_right (fun x l -> x.lv_type :: l) quants args in { term with term_node = Tlambda (quants @ quants', term); term_type = Larrow (args,rt_typ) } | Tlambda _ , _ -> Kernel.fatal ~current:true "\\lambda with a non-arrow type" | _,typ -> { term with term_node = Tlambda(quants, term); term_type = Larrow(List.map (fun x -> x.lv_type) quants,typ) } in let rec aux known_vars kont term = match term.term_node with | TLval(TVar v, TNoOffset) -> known_vars, kont (eta_expand term.term_loc term.term_name env v) | TConst _ | TLval _ | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ | TUnOp _ | TBinOp _ | TCastE _ | TAddrOf _ | TStartOf _ | Tapp _ | TDataCons _ | Tbase_addr _ | Toffset _ | Tblock_length _ | Tnull | TCoerce _ | TCoerceE _ | TUpdate _ | Ttypeof _ | Ttype _ | Tempty_set (* [VP] I suppose that an union of functions is theoretically possible but I'm not sure that we want to lift the lambda anyway, even though this contradicts the idea that you can always replace a term by a set of terms *) | Tunion _ | Tinter _ | Tcomprehension _ | Trange _ | TLogic_coerce _ -> known_vars, kont term | Tlambda (quants,term) -> List.iter (fresh_vars known_vars) quants; let known_vars = List.fold_left (fun l x -> x.lv_name :: l) known_vars quants in aux known_vars (kont $ (add_binders quants)) term | Tif (cond, ttrue, tfalse) -> let known_vars, ttrue = aux known_vars (fun x -> x) ttrue in let known_vars, tfalse = aux known_vars (fun x -> x) tfalse in let term = match ttrue.term_node, tfalse.term_node with | Tlambda(quants1,term1), Tlambda(quants2,term2) -> assert( Kernel.verify(List.length quants1 = List.length quants2) "Branches of conditional have different number \ of \\lambda"); let term2 = List.fold_left2 rename_variable term2 quants2 quants1 in { term with term_node = Tlambda(quants1, {term with term_node = Tif(cond,term1,term2); term_type = term1.term_type}); term_type = ttrue.term_type } | Tlambda _, _ | _, Tlambda _ -> Kernel.fatal ~current:true "Branches of conditional have different number of \\lambda" | _,_ -> term in known_vars, kont term | Tat (t,lab) -> let push_at t = match t.term_node with Tlambda(quants,t) -> { term with term_node = Tlambda(quants, {t with term_node = Tat (t,lab)})} | _ -> term in aux known_vars (kont $ push_at) t | Tlet(v,body) -> fresh_vars known_vars v.l_var_info; let known_vars = v.l_var_info.lv_name :: known_vars in let push_let t = match t.term_node with Tlambda(quants, t) -> { term with term_node = Tlambda(quants, { t with term_node = Tlet(v,t) } ); } | _ -> term in aux known_vars (kont $ push_let) body in snd (aux [] (fun x -> x) term) let has_extra_offset_to_TField loc t_type = function (* used for functional update of field under anonymous type *) | PLpathField f -> let f_ofs, _ = plain_type_of_c_field loc f t_type in let result = match f_ofs with | TField (_,TNoOffset) -> false | TField _ -> true ; | _ -> assert false in result | PLpathIndex _ -> false let updated_offset_term idx_typing check_type mk_field mk_idx loc t_type = function | PLpathField f -> let f_ofs, ofs_type = plain_type_of_c_field loc f t_type in let f_ofs, ofs_type = match f_ofs with | TField (f,TNoOffset) ->( mk_field f),ofs_type | TField (f,_) -> (mk_field f), (* f is an anonymous field, find its type *) Ctype (Cil.typeOffset t_type (Field (f,NoOffset))) | _ -> assert false in f_ofs,ofs_type | PLpathIndex idx -> let idx = idx_typing idx in let ofs_type = if Cil.isArrayType t_type && check_type idx.term_type then Ctype (Cil.typeOf_array_elem t_type) else error loc "subscripted value is not an array" in mk_idx idx, ofs_type let normalize_updated_offset_term idx_typing env loc t normalizing_cont toff = let t_type = try Logic_utils.logicCType t.term_type with Failure _ -> error loc "Trying to update field on a non struct type %a" Cil_printer.pp_logic_type t.term_type in let mk_let_info name t t_off2 type2 = match t with | { term_node = TConst _} -> (* just a copy *) assert (t_off2 = TNoOffset) ; (fun id -> id), t, { t with term_node = t.term_node } | { term_node = TLval((TVar _,_) as lv)} -> (* just a copy *) (fun id -> id), t, { t with term_node = TLval(add_offset_lval t_off2 lv); term_type = type2} | _ -> (* to build a let *) let var = Lenv.fresh_var env name LVLocal t.term_type in let info = { l_var_info = var; l_labels = []; l_tparams = []; l_type = Some t.term_type; l_profile = []; l_body = LBterm t } in (fun body -> Tlet(info, { t with term_node = body})), { t with term_node = TLval(TVar var,TNoOffset)}, { t with term_node = TLval(TVar var,t_off2); term_type = type2} in let (toff, t_off2, opt_idx_let), ofs_type = let check_type typ = plain_integral_type typ || error loc "range is only allowed for last offset" and mk_field f = TField(f,TNoOffset),TField(f,TNoOffset),(fun x -> x) and mk_idx idx = let mk_idx_let, idx, idx2 = mk_let_info "idx" idx TNoOffset idx.term_type in TIndex(idx,TNoOffset),TIndex(idx2,TNoOffset),mk_idx_let in updated_offset_term idx_typing check_type mk_field mk_idx loc t_type toff in let mk_let, t, t2 = mk_let_info "tmp" t t_off2 ofs_type in let v, v_type = normalizing_cont t2 in let v = Logic_const.term ~loc v v_type in let v = mk_cast v ofs_type in let updated = mk_let (opt_idx_let (TUpdate(t,toff,v))) in updated, t.term_type let update_term_wrt_default_label t = match !Lenv.default_label with | None -> t | Some lab -> match t.term_node with | TConst _ | TLval (TVar _ ,_) | Tat _ -> t | _ -> { t with term_node = Tat(t,lab) } let update_info_wrt_default_label info = match info.l_labels with | [] -> ( match !Lenv.default_label with | None -> () | Some lab -> info.l_labels <- [ lab ] ) | _ -> () let update_predicate_wrt_default_label p = match !Lenv.default_label with | None -> p | Some lab -> { p with content = Pat(p,lab) } let update_predicate_wrt_label p lab = match p.content with | Pat(_,lab') when lab = lab' -> p | _ -> { p with content = Pat(p,lab) } let rec term ?(silent=false) env t = match t.lexpr_node with | PLnamed(name,t) -> let t = term ~silent env t in { t with term_name = name :: t.term_name } | _ -> let t', ty = term_node ~silent env t.lexpr_loc t.lexpr_node in { term_node = t'; term_loc=t.lexpr_loc; term_type=ty; term_name = [] } and normalize_update_term env loc t v = function (* Transform terms like {x \with .c[idx] = v} into {x \with .c = {x.c \with [idx] = v}}. \let expressions can be introduced. *) | [] -> assert false (* parsing invariant *) | (toff::tail) as offs -> begin let t_type = try Logic_utils.logicCType t.term_type with Failure _ -> error loc "Update field on a non-struct type %a" Cil_printer.pp_logic_type t.term_type in let tail = if has_extra_offset_to_TField loc t_type toff then offs (* fields under an anonymous field are not removed *) else tail in match tail with | [] -> let toff, ofs_type = let mk_field f = TField (f, TNoOffset) and mk_idx idx = TIndex(idx,TNoOffset) and idx_typing idx = term env idx in updated_offset_term idx_typing is_integral_type mk_field mk_idx loc t_type toff in let v = term env v in let v = mk_cast v ofs_type in let updated = TUpdate(t,toff,v) in updated, t.term_type | toffs -> let idx_typing idx = term env idx and normalizing_cont t2 = normalize_update_term env loc t2 v toffs in normalize_updated_offset_term idx_typing env loc t normalizing_cont toff end and normalize_update_cont env loc t = function | [],_ -> assert false (* parsing invariant *) | _,[] -> assert false (* parsing invariant *) | ((contoffs,PLupdateTerm v)::[]),toffs -> (* {x \with .c1 = {\with .c2 = v}} = {x \with .c1.c2 = v} *) normalize_update_term env loc t v (toffs@contoffs) | ((contoffs,PLupdateCont v)::[]),toffs -> (* {x \with .c1 = {\with .c2 = {\with...}}} = {x \with .c1.c2 = {\with...}} *) normalize_update_cont env loc t (v,(toffs@contoffs)) | (cont::conts),toff::[] -> (* {x \with .c1 = {\with .c2 = v2, ..., c22 = v22}} = {x \with .c1 = {...{x.c1 \with .c2 = v2} .. \with c22 = v22} *) let idx_typing idx = term env idx in let normalizing_cont t2 = let normalize t = function | contoffs,PLupdateTerm v -> normalize_update_term env loc t v contoffs | contoffs,PLupdateCont cont -> normalize_update_cont env loc t (cont, contoffs) in let normalize_folding (tn,typ) cont = normalize (Logic_const.term ~loc tn typ) cont in List.fold_left normalize_folding (normalize t2 cont) conts in normalize_updated_offset_term idx_typing env loc t normalizing_cont toff | cont,toff::toffs -> (* {x \with .c1.c2 = {\with...}} = {x \with .c1 = { x.c1 \with .c2 = {\with...}}} *) let idx_typing idx = term env idx and normalizing_cont t2 = normalize_update_cont env loc t2 (cont,toffs) in normalize_updated_offset_term idx_typing env loc t normalizing_cont toff and term_node ?(silent=false) env loc pl = match pl with | PLinitIndex _ -> error loc "unsupported aggregated array construct" | PLinitField _ -> error loc "unsupported aggregated field construct" | PLupdate (t, toff, PLupdateCont cont) -> let t = term env t in normalize_update_cont env loc t (cont, toff) | PLupdate (t, toff, PLupdateTerm v) -> let t = term env t in normalize_update_term env loc t v toff | PLsizeof typ -> (match Logic_utils.unroll_type ~unroll_typedef:false (logic_type loc env typ) with Ctype t -> TSizeOf t,Linteger | _ -> error loc "sizeof can only handle C types") (* NB: don't forget to add the case of literal string when they are authorized in the logic *) | PLsizeofE { lexpr_node = PLconstant (StringConstant s | WStringConstant s) } -> TSizeOfStr s, Linteger | PLsizeofE lexpr -> let t = term env lexpr in let typ = Logic_utils.unroll_type ~unroll_typedef:false t.term_type in (match typ with | Ctype _ -> TSizeOfE t, Linteger | _ -> error loc "sizeof can only handle C types") | PLnamed _ -> assert false (* should be captured by term *) | PLconstant (IntConstant s) -> begin match (parseInt loc s).term_node with | TConst (Integer _ as c) -> TConst c, Linteger | TConst ((LChr _) as c) -> (* a char literal has type int *) TConst c, Linteger | _ -> assert false end | PLconstant (FloatConstant str) -> TConst (Logic_utils.string_to_float_lconstant str), Lreal | PLconstant (StringConstant s) -> TConst (LStr (unescape s)), Ctype Cil.charPtrType | PLconstant (WStringConstant s) -> TConst (LWStr (wcharlist_of_string s)), Ctype (TPtr(Cil.theMachine.wcharType,[])) | PLvar x -> let old_val info = let term = TLval (TVar info, TNoOffset) in if env.Lenv.is_funspec then begin let term = match Lenv.current_post_state env with None -> term | Some _ -> (match info.lv_origin with Some v when v.vformal -> Tat(Logic_const.term ~loc term info.lv_type, find_logic_label loc env "Old") | Some _ | None -> term) in term, info.lv_type end else term, info.lv_type in begin try let def = C.find_macro x in term_node ~silent env loc def.lexpr_node with Not_found -> try (* NB: In the current implementation and ACSL format, \let can not take a label parameter. If this ever change, we need to check the labelling here as well (see below for globals) *) let lv = Lenv.find_var x env in (match lv.lv_type with | Ctype (TVoid _)-> if silent then raise Backtrack; error (CurrentLoc.get()) "Variable %s is bound to a predicate, not a term" x | _ -> old_val lv) with Not_found -> try let info = C.find_var x in (match info.lv_origin with | Some lv -> check_current_label loc env; (* access to C variable need a current label *) lv.vreferenced <- true | None -> ()); old_val info with Not_found -> try let e,t = C.find_enum_tag x in begin match e.enode with | Const c -> TConst (Logic_utils.constant_to_lconstant c), Ctype t | _ -> assert false end with Not_found -> try fresh_type#reset (); let info = C.find_logic_ctor x in match info.ctor_params with [] -> TDataCons(info,[]), Ltype(info.ctor_type, List.map (fun x -> fresh (Lvar x)) info.ctor_type.lt_params) | _ -> error loc "Data constructor %s needs arguments" info.ctor_name with Not_found -> (* We have a global logic variable. It may depend on a single state (multiple labels need to be explicitly instantiated and are treated as PLapp below). NB: for now, if we have a real function (with parameters other than labels) and a label, we end up with a Tapp with no argument, which is not exactly good. Either TVar should take an optional label for this particular case, or we should definitely move to partial app everywhere (since we have support for \lambda, this is not a very big step anyway) *) let make_expr f = let typ = match f.l_type, f.l_profile with | Some t, [] -> t | Some t, l -> fresh (Larrow (List.map (fun x -> x.lv_type) l, t)) | None, _ -> if silent then raise Backtrack; error loc "%s is not a logic variable" x in match f.l_labels with [] -> TLval (TVar(f.l_var_info),TNoOffset), typ | [l] -> let curr = find_current_label loc env in Tapp(f,[l,curr],[]), typ | _ -> error loc "%s labels must be explicitly instantiated" x in match C.find_all_logic_functions x with [] -> error loc "unbound logic variable %s" x | [f] -> make_expr f | l -> (try let f = List.find (fun info -> info.l_profile = []) l in make_expr f with Not_found -> error loc "invalid use of overloaded function \ %s as constant" x) end | PLapp (f, labels, tl) -> fresh_type#reset (); let ttl = List.map (term env) tl in begin try let info = C.find_logic_ctor f in if labels <> [] then error loc "symbol %s is a data constructor. \ It cannot have logic labels" f; let params = List.map fresh info.ctor_params in let env, tl = type_arguments ~overloaded:false env loc params ttl in let t = Ltype(info.ctor_type, List.map (fun x -> fresh (Lvar x)) info.ctor_type.lt_params) in let t = instantiate env t in TDataCons(info,tl), t with Not_found -> let info, label_assoc, tl, t = type_logic_app env loc f labels ttl in match t with | None -> if silent then raise Backtrack; error loc "symbol %s is a predicate, not a function" f | Some t -> Tapp(info, label_assoc, tl), t end | PLunop (Ubw_not, t) -> let t = type_int_term env t in TUnOp (BNot, t), logic_arithmetic_promotion t.term_type | PLunop (Uminus, t) -> let t = type_num_term env t in TUnOp (Neg, t), logic_arithmetic_promotion t.term_type | PLunop (Ustar, t) -> check_current_label loc env; (* memory access need a current label to have some semantics *) let t = term env t in if isLogicPointer t then begin let t = mk_logic_pointer_or_StartOf t in check_non_void_ptr loc t.term_type; let t = mk_mem t TNoOffset in t.term_node, t.term_type end else begin error loc "invalid type %a for `unary *'" Cil_printer.pp_logic_type t.term_type end | PLunop (Uamp, t) -> check_current_label loc env; (* &x need a current label to have some semantics *) let t = term_lval (mkAddrOfAndMark loc) (term env t) in t.term_node, t.term_type | PLbinop (t1, (Badd | Bsub | Bmul | Bdiv | Bmod | Bbw_and | Bbw_or | Bbw_xor | Blshift | Brshift as op), t2) -> let t1 = term env t1 in let ty1 = t1.term_type in let t2 = term env t2 in let ty2 = t2.term_type in let binop op tr = TBinOp (op, mk_cast t1 tr, mk_cast t2 tr), logic_arithmetic_promotion tr in begin match op with | Bmul | Bdiv when is_arithmetic_type ty1 && is_arithmetic_type ty2 -> binop (type_binop op) (arithmetic_conversion ty1 ty2) | Bmod when is_integral_type ty1 && is_integral_type ty2 -> binop (type_binop op) (arithmetic_conversion ty1 ty2) | Badd | Bsub when is_arithmetic_type ty1 && is_arithmetic_type ty2 -> binop (type_binop op) (arithmetic_conversion ty1 ty2) | Bbw_and | Bbw_or | Bbw_xor when is_integral_type ty1 && is_integral_type ty2 -> binop (type_binop op) (arithmetic_conversion ty1 ty2) | Blshift | Brshift when is_integral_type ty1 && is_integral_type ty2 -> binop (type_binop op) (arithmetic_conversion ty1 ty2) | Badd when isLogicPointer t1 && is_integral_type ty2 -> let t1 = mk_logic_pointer_or_StartOf t1 in let ty1 = t1.term_type in (match t1.term_node with | TStartOf lv -> TAddrOf (Logic_const.addTermOffsetLval (TIndex (t2,TNoOffset)) lv) | _ -> TBinOp (PlusPI, t1, mk_cast t2 (integral_promotion ty2))), set_conversion ty1 ty2 | Badd when is_integral_type ty1 && isLogicPointer t2 -> let t2 = mk_logic_pointer_or_StartOf t2 in let ty2 = t2.term_type in assert (isLogicPointerType t2.term_type); (match t2.term_node with | TStartOf lv -> TAddrOf (Logic_const.addTermOffsetLval (TIndex(t1,TNoOffset)) lv) | _ -> TBinOp (PlusPI, t2, mk_cast t1 (integral_promotion ty1))), set_conversion ty2 ty1 | Bsub when isLogicPointer t1 && is_integral_type ty2 -> let t1 = mk_logic_pointer_or_StartOf t1 in TBinOp (MinusPI, t1, mk_cast t2 (integral_promotion ty2)), set_conversion ty1 ty2 | Bsub when isLogicPointer t1 && isLogicPointer t2 -> let t1 = mk_logic_pointer_or_StartOf t1 in let t2 = mk_logic_pointer_or_StartOf t2 in TBinOp (MinusPP, t1, mk_cast t2 ty1), Linteger | _ -> error loc "invalid operands to binary %a; unexpected %a and %a" Cil_printer.pp_binop (type_binop op) Cil_printer.pp_logic_type ty1 Cil_printer.pp_logic_type ty2 end | PLdot (t, f) -> let t = term env t in let f_ofs, f_type = type_of_field loc f t.term_type in let t = lift_set (mk_dot env loc f_ofs f_type) t in t.term_node, t.term_type | PLarrow (t, f) -> check_current_label loc env; (* memory access need a current label to have some semantics *) let t = term env t in if not (isLogicPointer t) then error loc "%a is not a pointer" Cil_printer.pp_term t; let t = mk_logic_pointer_or_StartOf t in let struct_type = type_of_pointed t.term_type in let f_ofs, f_type = type_of_field loc f struct_type in (mk_mem ~loc t f_ofs).term_node, f_type | PLarrget (t1, t2) -> let t1 = term env t1 in let t2 = term env t2 in (* access to a C value (either array or pointer) *) let t'1, t'2, tres = if isLogicPointer t1 && is_integral_type t2.term_type then begin check_current_label loc env; (* memory access need a current label to have some semantics *) let t1 = mk_logic_pointer_or_StartOf t1 in check_non_void_ptr t1.term_loc t1.term_type; (t1, t2, set_conversion (type_of_pointed t1.term_type) t2.term_type) end else if is_integral_type t1.term_type && isLogicPointer t2 then begin check_current_label loc env; (* memory access need a current label to have some semantics *) let t2 = mk_logic_pointer_or_StartOf t2 in check_non_void_ptr t2.term_loc t2.term_type; (t2, t1, set_conversion (type_of_pointed t2.term_type) t1.term_type) end else if (* purely logical array access. *) isLogicArrayType t1.term_type && is_integral_type t2.term_type then mk_logic_access env t1, t2, type_of_array_elem t1.term_type else if isLogicArrayType t2.term_type && is_integral_type t1.term_type then mk_logic_access env t2, t1, type_of_array_elem t2.term_type else (* error *) if isLogicArrayType t1.term_type || isLogicArrayType t2.term_type then error loc "subscript is not an integer range" else error loc "subscripted value is neither array nor pointer" in let t = lift_set (mk_shift loc env t'2 tres) t'1 in t.term_node, t.term_type | PLif (t1, t2, t3) -> let t1 = type_bool_term ~silent env t1 in let t2 = term ~silent env t2 in let t3 = term ~silent env t3 in let env,ty,ty2,ty3 = conditional_conversion loc env t2 t3 in let t2 = { t2 with term_type = instantiate env t2.term_type } in let _,t2 = implicit_conversion ~overloaded:false loc t2 t2.term_type ty2 in let t3 = { t3 with term_type = instantiate env t3.term_type } in let _,t3 = implicit_conversion ~overloaded:false loc t3 t3.term_type ty3 in Tif (t1, mk_cast t2 ty, mk_cast t3 ty), ty | PLold t -> let lab = find_old_label loc env in let env = Lenv.set_current_logic_label lab env in let t = term ~silent env t in (* could be Tat(t,lab) *) Tat (t, Logic_const.old_label), t.term_type | PLat (t, l) -> let lab = find_logic_label loc env l in let env = Lenv.set_current_logic_label lab env in let t = term ~silent env t in Tat (t, lab), t.term_type | PLbase_addr (l, t) -> (* base_addr need a current label to have some semantics *) let l = find_current_logic_label loc env l in let t = term env t in if isLogicPointer t then let t = lift_set (fun t -> Logic_const.term (Tbase_addr (l,t)) (Ctype Cil.charPtrType)) (mk_logic_pointer_or_StartOf t) in t.term_node, t.term_type else error loc "subscripted value is neither array nor pointer" | PLoffset (l, t) -> (* offset need a current label to have some semantics *) let l = find_current_logic_label loc env l in let t = term env t in if isLogicPointer t then let t = lift_set (fun t -> Logic_const.term (Toffset (l,t)) Linteger) (mk_logic_pointer_or_StartOf t) in t.term_node, t.term_type else error loc "subscripted value is neither array nor pointer" | PLblock_length (l, t) -> (* block_length need a current label to have some semantics *) let l = find_current_logic_label loc env l in let t = term env t in if isLogicPointer t then let t = lift_set (fun t -> Logic_const.term (Tblock_length (l,t)) Linteger) (mk_logic_pointer_or_StartOf t) in t.term_node, t.term_type else error loc "subscripted value is neither array nor pointer" | PLresult -> (try let t = Lenv.find_var "\\result" env in match t.lv_type with Ctype ty -> TLval(TResult ty,TNoOffset), t.lv_type | _ -> Kernel.fatal "\\result associated to non-C type" (* \\result is the value returned by a C function. It has always a C type *) with Not_found -> error loc "\\result meaningless") | PLnull -> Tnull, c_void_star | PLcast (ty, t) -> let t = term env t in (* no casts of tsets in grammar *) (match unroll_type ~unroll_typedef:false (logic_type loc env ty) with | (Ctype tnew) as ctnew -> (match t.term_type with | Ctype told -> if isPointerType tnew && isArrayType told && not (is_C_array t) then error loc "cannot cast logic array to pointer type"; (c_mk_cast t told tnew).term_node , ctnew | _ -> (Logic_utils.mk_cast tnew t).term_node, ctnew) | Linteger | Lreal | Ltype _ | Lvar _ | Larrow _ -> error loc "cannot cast to logic type") | PLcoercion (t,ty) -> let t = term env t in (match unroll_type ~unroll_typedef:false (logic_type loc env ty) with | Ctype ty as cty -> TCoerce (t, ty), cty | Linteger | Lreal | Ltype _ | Lvar _ | Larrow _ -> error loc "cannot cast to logic type") | PLcoercionE (t,tc) -> let t = term env t in let tc = term env tc in TCoerceE (t, tc), tc.term_type | PLrel (t1, (Eq | Neq | Lt | Le | Gt | Ge as op), t2) -> let loc1 = t1.lexpr_loc in let loc2 = t2.lexpr_loc in let loc = loc_join t1.lexpr_loc t2.lexpr_loc in let conditional_conversion t1 t2 = let env,t,ty1,ty2 = conditional_conversion loc env t1 t2 in let t1 = { t1 with term_type = instantiate env t1.term_type } in let _,t1 = implicit_conversion ~overloaded:false loc1 t1 t1.term_type ty1 in let t2 = { t2 with term_type = instantiate env t2.term_type } in let _,t2 = implicit_conversion ~overloaded:false loc2 t2 t2.term_type ty2 in TBinOp (binop_of_rel op, mk_cast t1 t, mk_cast t2 t) in let t1 = term ~silent env t1 in let ty1 = t1.term_type in let t2 = term ~silent env t2 in let ty2 = t2.term_type in if not (is_plain_type ty1) || not (is_plain_type ty2) then error loc "comparison of incompatible types %a and %a" Cil_printer.pp_logic_type ty1 Cil_printer.pp_logic_type ty2 else let expr = match op with | _ when plain_arithmetic_type ty1 && plain_arithmetic_type ty2 -> conditional_conversion t1 t2 | Eq | Neq when isLogicPointer t1 && isLogicNull t2 -> let t1 = mk_logic_pointer_or_StartOf t1 in TBinOp (binop_of_rel op, t1, mk_cast t2 t1.term_type) | Eq | Neq when isLogicPointer t2 && isLogicNull t1 -> let t2 = mk_logic_pointer_or_StartOf t2 in TBinOp (binop_of_rel op, mk_cast t1 t2.term_type, t2) | Eq | Neq when isLogicArrayType t1.term_type && isLogicArrayType t2.term_type -> if is_same_logic_array_type t1.term_type t2.term_type then TBinOp(binop_of_rel op, t1,t2) else error loc "comparison of incompatible types %a and %a" Cil_printer.pp_logic_type t1.term_type Cil_printer.pp_logic_type t2.term_type | _ when isLogicPointer t1 && isLogicPointer t2 -> let t1 = mk_logic_pointer_or_StartOf t1 in let t2 = mk_logic_pointer_or_StartOf t2 in if is_same_logic_ptr_type t1.term_type t2.term_type then TBinOp (binop_of_rel op, t1, t2) else if (op = Eq || op = Neq) && (isLogicVoidPointerType t1.term_type || isLogicVoidPointerType t2.term_type) then TBinOp (binop_of_rel op, t1, t2) else if (op = Eq || op = Neq) then conditional_conversion t1 t2 else error loc "comparison of incompatible types %a and %a" Cil_printer.pp_logic_type ty1 Cil_printer.pp_logic_type ty2 | Eq | Neq -> conditional_conversion t1 t2 | _ -> error loc "comparison of incompatible types %a and %a" Cil_printer.pp_logic_type ty1 Cil_printer.pp_logic_type ty2 in expr, Ltype(C.find_logic_type Utf8_logic.boolean,[]) | PLtrue -> let ctrue = C.find_logic_ctor "\\true" in TDataCons(ctrue,[]), Ltype(ctrue.ctor_type,[]) | PLfalse -> let cfalse = C.find_logic_ctor "\\false" in TDataCons(cfalse,[]), Ltype(cfalse.ctor_type,[]) | PLlambda(prms,e) -> let (prms, env) = add_quantifiers loc prms env in let e = term ~silent env e in Tlambda(prms,e),Larrow(List.map (fun x -> x.lv_type) prms,e.term_type) | PLnot t -> let t = type_bool_term ~silent env t in TUnOp(LNot,t), Ltype (C.find_logic_type Utf8_logic.boolean,[]) | PLand (t1,t2) -> let t1 = type_bool_term ~silent env t1 in let t2 = type_bool_term ~silent env t2 in TBinOp(LAnd,t1,t2), Ltype (C.find_logic_type Utf8_logic.boolean,[]) | PLor (t1,t2) -> let t1 = type_bool_term ~silent env t1 in let t2 = type_bool_term ~silent env t2 in TBinOp(LOr,t1,t2), Ltype (C.find_logic_type Utf8_logic.boolean,[]) | PLtypeof t1 -> let t1 = term env t1 in Ttypeof t1, Ltype (C.find_logic_type "typetag",[]) | PLtype ty -> begin match logic_type loc env ty with | Ctype ty -> Ttype ty, Ltype (C.find_logic_type "typetag",[]) | Linteger | Lreal | Ltype _ | Lvar _ | Larrow _ -> error loc "cannot take type tag of logic type" end | PLlet (ident, def, body) -> let tdef = term env def in (* At least for now, the type is supposed to be fully instantiated. No generalization is needed. *) let var = Cil_const.make_logic_info_local ident in let tdef = normalize_lambda_term env tdef in let args, tdef = match tdef.term_node with Tlambda(args,term) -> args, term | _ -> [],tdef in var.l_type <- Some tdef.term_type; var.l_var_info.lv_type <- tdef.term_type; var.l_profile <- args; var.l_body <- LBterm tdef; let env = Lenv.add_logic_info ident var env in let tbody = term ~silent env body in Tlet(var,tbody), tbody.term_type | PLcomprehension(t,quants,pred) -> let quants, env = add_quantifiers loc quants env in let t = term env t in let pred = Extlib.opt_map (predicate env) pred in Tcomprehension(t,quants,pred), Ltype(C.find_logic_type "set",[t.term_type]) | PLsingleton t -> let t = term env t in if is_set_type t.term_type then error loc "syntax error (set of set is not yet implemented)" ; Tunion [t], (* lifting to a set can be used for non-set type *) Ltype(C.find_logic_type "set",[t.term_type]) | PLunion l -> fresh_type#reset(); let init_type = visitCilLogicType (fresh_type:>cilVisitor) (make_set_type (Lvar "_")) in let convert_ptr,locs, typ = List.fold_left (fun (convert_ptr,locs,typ) t -> let loc = term env t in let convert_ptr, typ = location_set_conversion loc.term_loc convert_ptr loc loc.term_type typ env in convert_ptr,loc::locs, typ) (NoConv, [], init_type) l in let locs = List.rev_map (make_set_conversion convert_ptr) locs in Tunion locs, typ | PLinter l -> fresh_type#reset(); let init_type = visitCilLogicType (fresh_type:>cilVisitor) (make_set_type (Lvar "_")) in let convert_ptr, locs, typ = List.fold_left (fun (convert_ptr,locs,typ) t -> let loc = term env t in let convert_ptr, typ = location_set_conversion loc.term_loc convert_ptr loc loc.term_type typ env in (convert_ptr,loc::locs, typ)) (NoConv, [], init_type) l in let locs = List.rev_map (make_set_conversion convert_ptr) locs in Tinter locs, typ | PLempty -> let typ = fresh_type#reset(); visitCilLogicType(fresh_type:>cilVisitor) (make_set_type (Lvar "_")) in Tempty_set,typ | PLrange (t1,t2) -> (* we allow range of floats/real. *) let t1,ty1 = type_num_term_option env t1 in let t2,ty2 = type_num_term_option env t2 in (Trange(t1,t2), Ltype(C.find_logic_type "set", [arithmetic_conversion ty1 ty2])) | PLvalid _ | PLvalid_read _ | PLfresh _ | PLallocable _ | PLfreeable _ | PLinitialized _ | PLexists _ | PLforall _ | PLimplies _ | PLiff _ | PLxor _ | PLsubtype _ | PLseparated _ -> if silent then raise Backtrack; error loc "syntax error (expression expected but predicate found)" and term_lval f t = let check_lval t = match t.term_node with TLval (h,_ as lv) | TCastE(_,{term_node = TLval (h,_ as lv)}) | TLogic_coerce(_,{term_node = TLval(h,_ as lv) }) | Tat({term_node = TLval(h,_ as lv)},_) -> (match h with TVar { lv_name = v; lv_origin = None } when v <> "\\exit_status" -> error t.term_loc "not an assignable left value: %s" v (* Tresult only exists when typing C functions and Tmem would lead to an error earlier if applied to pure logic expression. *) | TVar _ | TResult _ | TMem _ -> f lv t) | TStartOf lv | TCastE(_,{term_node = TStartOf lv}) | Tat ({term_node = TStartOf lv}, _) -> f lv t | _ -> error t.term_loc "not a left value: %a" Cil_printer.pp_term t in lift_set check_lval t and type_logic_app env loc f labels ttl = (* support for overloading *) let infos = try [Lenv.find_logic_info f env] with Not_found -> C.find_all_logic_functions f in match infos with | [] -> error loc "unbound function %s" f | [info] -> begin let labels = List.map (find_logic_label loc env) labels in let params = List.map (fun x -> fresh x.lv_type) info.l_profile in let env, tl = type_arguments ~overloaded:false env loc params ttl in let label_assoc = labels_assoc loc f env info.l_labels labels in match info.l_type with | Some t -> let t = fresh t in let t = instantiate env t in info, label_assoc, tl, Some t | None -> info, label_assoc, tl, None end | _ -> (* overloading *) let l = List.fold_left (fun acc info -> try let labels = List.map (find_logic_label loc env) labels in let params = List.map (fun x -> fresh x.lv_type) info.l_profile in let env, tl = type_arguments ~overloaded:true env loc params ttl in let tl = List.combine (List.map (instantiate env) params) tl in let label_assoc = labels_assoc loc f env info.l_labels labels in match info.l_type with | Some t -> let t = fresh t in let t = try instantiate env t with _ -> raise Not_applicable in (info, label_assoc, tl, Some t)::acc | None -> (info, label_assoc, tl, None)::acc with Not_applicable -> acc) [] infos in (* remove non-minimal calls *) let l = List.fold_left filter_non_minimal_arguments [] l in match l with | [] -> let tl = List.map (fun t -> t.term_type) ttl in error loc "no such predicate or logic function %s(%a)" f (Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_logic_type) tl | [x,y,z,t] -> (x,y,snd (List.split z),t) | _ -> let tl = List.map (fun t -> t.term_type) ttl in error loc "ambiguous logic call to %s(%a)" f (Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_logic_type) tl and type_int_term env t = let tt = term env t in if not (plain_integral_type tt.term_type) then error t.lexpr_loc "integer expected but %a found" Cil_printer.pp_logic_type tt.term_type; tt and type_bool_term ?(silent=false) env t = let tt = term ~silent env t in if not (plain_boolean_type tt.term_type) then error t.lexpr_loc "boolean expected but %a found" Cil_printer.pp_logic_type tt.term_type; mk_cast tt (Ltype (C.find_logic_type Utf8_logic.boolean,[])) and type_num_term_option env t = match t with None -> None, Linteger (* Warning: should be an hybrid of integer and float. *) | Some t -> let t = type_num_term env t in Some t, t.term_type and type_num_term env t = let tt = term env t in if not (is_arithmetic_type tt.term_type) then error t.lexpr_loc "integer or float expected"; tt (* type_arguments checks if argument list tl is well-typed for the formal parameter list at *) and type_arguments ~overloaded env loc at tl = let rec type_list env = function | [], [] -> env, [] | et :: etl, ({term_loc=tloc} as t) :: tl -> let env, _,t' = instantiate_app ~overloaded tloc t et env in let env, l = type_list env (etl, tl) in env, t' :: l | [], _ -> if overloaded then raise Not_applicable else error loc "too many arguments" | _, [] -> if overloaded then raise Not_applicable else error loc "partial application" in let rec conversion env = function | [], [] -> [] | et::etl, ({term_loc=tloc} as t) :: tl -> let iet = instantiate env et in let _,t = implicit_conversion ~overloaded tloc t t.term_type iet in let l = conversion env (etl,tl) in t::l | _ -> assert false (* captured by first auxiliary function *) in let env, args = type_list env (at, tl) in (* perform conversion triggered by latter args over the former ones *) let res = conversion env (at,args) in env, res and boolean_term_to_predicate t = let loc = t.term_loc in let conversion zero = prel ~loc (Cil_types.Rneq, t, zero) in let arith_conversion () = conversion (Cil.lzero ~loc ()) in let ptr_conversion () = conversion (Logic_const.term ~loc Tnull t.term_type) in match unroll_type t.term_type with | Ctype (TInt _) -> arith_conversion () | Ctype (TFloat _) -> conversion (Logic_const.treal_zero ~loc ~ltyp:t.term_type ()) | Ctype (TPtr _) -> ptr_conversion () | Ctype (TArray _) -> ptr_conversion () (* Could be transformed to \true: an array is never \null *) | Ctype (TFun _) -> ptr_conversion () (* decay as pointer *) | Linteger -> arith_conversion () | Lreal -> conversion (Logic_const.treal_zero ~loc ()) | Ltype ({lt_name = name},[]) when name = Utf8_logic.boolean -> let ctrue = C.find_logic_ctor "\\true" in prel ~loc (Cil_types.Req,t, { term_node = TDataCons(ctrue,[]); term_loc = loc; term_type = Ltype(ctrue.ctor_type,[]); term_name = []; }) | Ltype _ | Lvar _ | Larrow _ | Ctype (TVoid _ | TNamed _ | TComp _ | TEnum _ | TBuiltin_va_list _) -> error loc "expecting a predicate and not a term" and boolean_to_predicate env p0 = boolean_term_to_predicate (term env p0) and abstract_predicate env p0 = let loc = p0.lexpr_loc in match p0.lexpr_node with PLlambda (args,p) -> let (prms,env) = add_quantifiers loc args env in let other_prms, p = abstract_predicate env p in (other_prms @ prms), p | _ -> [], predicate env p0 and predicate env p0 = let loc = p0.lexpr_loc in match p0.lexpr_node with | PLfalse -> unamed ~loc Pfalse | PLtrue -> unamed ~loc Ptrue | PLrel (t1, (Eq | Neq | Lt | Le | Gt | Ge as op), t2) -> let loc1 = t1.lexpr_loc in let loc2 = t2.lexpr_loc in let loc = loc_join t1.lexpr_loc t2.lexpr_loc in let t1 = term env t1 in let ty1 = t1.term_type in let t2 = term env t2 in let ty2 = t2.term_type in let conditional_conversion t1 t2 = let env,t,ty1,ty2 = conditional_conversion loc env t1 t2 in let t1 = { t1 with term_type = instantiate env t1.term_type } in let _,t1 = implicit_conversion ~overloaded:false loc1 t1 t1.term_type ty1 in let t2 = { t2 with term_type = instantiate env t2.term_type } in let _,t2 = implicit_conversion ~overloaded:false loc2 t2 t2.term_type ty2 in prel ~loc (type_rel op, mk_cast t1 t, mk_cast t2 t) in begin match op with | _ when is_arithmetic_type ty1 && is_arithmetic_type ty2 -> conditional_conversion t1 t2 | Eq | Neq when isLogicPointer t1 && isLogicNull t2 -> let t1 = mk_logic_pointer_or_StartOf t1 in prel ~loc (type_rel op, t1, mk_cast t2 t1.term_type) | Eq | Neq when isLogicPointer t2 && isLogicNull t1 -> let t2 = mk_logic_pointer_or_StartOf t2 in prel ~loc (type_rel op, mk_cast t1 t2.term_type, t2) | Eq | Neq when isLogicArrayType ty1 && isLogicArrayType ty2 -> if is_same_logic_array_type ty1 ty2 then prel ~loc (type_rel op, t1, t2) else error loc "comparison of incompatible types %a and %a" Cil_printer.pp_logic_type ty1 Cil_printer.pp_logic_type ty2 | _ when isLogicPointer t1 && isLogicPointer t2 -> let t1 = mk_logic_pointer_or_StartOf t1 in let t2 = mk_logic_pointer_or_StartOf t2 in if is_same_logic_ptr_type ty1 ty2 || ((op = Eq || op = Neq) && (isLogicVoidPointerType t1.term_type || isLogicVoidPointerType t2.term_type)) then prel ~loc (type_rel op, t1, t2) else if (op=Eq || op = Neq) then conditional_conversion t1 t2 else error loc "comparison of incompatible types: %a and %a" Cil_printer.pp_logic_type t1.term_type Cil_printer.pp_logic_type t2.term_type | Eq | Neq -> conditional_conversion t1 t2 | _ -> error loc "comparison of incompatible types: %a and %a" Cil_printer.pp_logic_type t1.term_type Cil_printer.pp_logic_type t2.term_type end | PLand (p1, p2) -> pand ~loc:p0.lexpr_loc (predicate env p1, predicate env p2) | PLor (p1, p2) -> por ~loc:p0.lexpr_loc (predicate env p1, predicate env p2) | PLxor (p1, p2) -> pxor ~loc:p0.lexpr_loc (predicate env p1, predicate env p2) | PLimplies (p1, p2) -> pimplies ~loc:p0.lexpr_loc (predicate env p1, predicate env p2) | PLiff (p1, p2) -> piff ~loc:p0.lexpr_loc (predicate env p1, predicate env p2) | PLnot p -> (match (predicate env p) with | {content = Prel (Cil_types.Rneq, t, z)} when isLogicZero z -> prel ~loc:p0.lexpr_loc (Cil_types.Req, t, Cil.lzero ~loc ()) | p -> pnot ~loc:p0.lexpr_loc p) | PLapp (p, labels, tl) -> let ttl= List.map (term env) tl in let info, label_assoc, tl, t = type_logic_app env loc p labels ttl in begin match t with | Some t -> (* error loc "%s is a function, not a predicate" p *) boolean_term_to_predicate { term_loc = loc; term_node = Tapp(info, label_assoc, tl); term_type = t ; term_name = []} | None -> papp ~loc:p0.lexpr_loc (info, label_assoc, tl) end | PLif (t, p1, p2) -> begin try let t = type_bool_term ~silent:true env t in pif ~loc:p0.lexpr_loc (t, predicate env p1, predicate env p2) with Backtrack -> (* p1 ? p2 : p3 is syntactic sugar for (p1 ==> p2) && (!p1 ==> p3) *) predicate env {lexpr_node = (PLand ({lexpr_node = (PLimplies (t, p1)); lexpr_loc = loc}, {lexpr_node = (PLimplies ({lexpr_node = PLnot t; lexpr_loc = loc}, p2)); lexpr_loc = loc})); lexpr_loc = loc} end | PLforall (q, p) -> let q, env' = add_quantifiers p0.lexpr_loc q env in pforall ~loc:p0.lexpr_loc (q, predicate env' p) | PLexists (q, p) -> let q, env' = add_quantifiers p0.lexpr_loc q env in pexists ~loc:p0.lexpr_loc (q, predicate env' p) | PLfresh (l12,t,n) -> let l1,l2= match l12 with | None -> (find_logic_label loc env "Old"),(find_current_label loc env ) | Some (l1,l2) ->(find_logic_label loc env l1),(find_logic_label loc env l2) in let tloc = t.lexpr_loc in if l1 == l2 then error tloc "\\fresh requires two different labels"; let t = term env t in let n = term env n in if isLogicPointerType t.term_type then let t = mk_logic_pointer_or_StartOf t in pfresh ~loc:p0.lexpr_loc (l1,l2,t,n) else error tloc "subscripted value is not a pointer" | PLfreeable (l, t) -> (* freeable need a current label to have some semantics *) let l = find_current_logic_label loc env l in let t = term env t in if isLogicPointer t then let t = mk_logic_pointer_or_StartOf t in pfreeable ~loc:p0.lexpr_loc (l,t) else error loc "subscripted value is neither array nor pointer" | PLallocable (l, t) -> (* allocable need a current label to have some semantics *) let l = find_current_logic_label loc env l in let t = term env t in if isLogicPointer t then let t = mk_logic_pointer_or_StartOf t in pallocable ~loc:p0.lexpr_loc (l,t) else error loc "subscripted value is neither array nor pointer" | PLvalid_read (l, t) -> (* validity need a current label to have some semantics *) let l = find_current_logic_label loc env l in let loc = t.lexpr_loc in let t = term env t in let t = mk_logic_pointer_or_StartOf t in check_non_void_ptr loc t.term_type; pvalid_read ~loc:p0.lexpr_loc (l,t) | PLvalid (l,t) -> (* validity need a current label to have some semantics *) let l = find_current_logic_label loc env l in let loc = t.lexpr_loc in let t = term env t in let t = mk_logic_pointer_or_StartOf t in check_non_void_ptr loc t.term_type; pvalid ~loc:p0.lexpr_loc (l,t) | PLinitialized (l,t) -> (* initialized need a current label to have some semantics *) let l = find_current_logic_label loc env l in let t = term env t in let t = mk_logic_pointer_or_StartOf t in check_non_void_ptr t.term_loc t.term_type; pinitialized ~loc:p0.lexpr_loc (l,t) | PLold p -> let lab = find_old_label p0.lexpr_loc env in let env = Lenv.set_current_logic_label lab env in (* could be Tat(t,lab) *) pold ~loc:p0.lexpr_loc (predicate env p) | PLat (p, l) -> let lab = find_logic_label p0.lexpr_loc env l in let env = Lenv.set_current_logic_label lab env in pat ~loc:p0.lexpr_loc (predicate env p, lab) | PLvar x -> (try let def = C.find_macro x in predicate env def with Not_found -> let loc = p0.lexpr_loc in let make_app info = match info.l_type with | None -> let labels = match info.l_labels with [] -> [] | [l] -> [l,find_current_label loc env] | _ -> error loc "%s labels must be explicitly instantiated" x in papp ~loc (info,labels,[]) | Some _ -> boolean_to_predicate env p0 in try make_app (Lenv.find_logic_info x env) with Not_found -> (try let info = List.find (fun x -> x.l_profile = []) (C.find_all_logic_functions x) in make_app info with Not_found -> boolean_to_predicate env p0)) | PLlet(x,def,body) -> let typ, args, tdef = try let tdef = term ~silent:true env def in let tdef = normalize_lambda_term env tdef in (match tdef.term_node with Tlambda(args,t) -> Some t.term_type, args, LBterm t | _ -> Some tdef.term_type,[], LBterm tdef) with Backtrack -> let args, tdef = abstract_predicate env def in None, args, LBpred tdef in let var = Cil_const.make_logic_info_local x in var.l_profile <- args; var.l_var_info.lv_type <- (match typ with None -> Ctype (Cil.voidType) | Some t -> t); var.l_type <- typ; var.l_body <- tdef; let env = Lenv.add_logic_info x var env in let tbody = predicate env body in { name = []; loc = p0.lexpr_loc; content = Plet(var,tbody) } | PLcast _ | PLblock_length _ | PLbase_addr _ | PLoffset _ | PLarrget _ | PLarrow _ | PLdot _ | PLbinop _ | PLunop _ | PLconstant _ | PLnull | PLresult | PLcoercion _ | PLcoercionE _ | PLsizeof _ | PLsizeofE _ | PLlambda _ | PLupdate _ | PLinitIndex _ | PLinitField _ | PLtypeof _ | PLtype _ -> boolean_to_predicate env p0 | PLrange _ -> error p0.lexpr_loc "cannot use operator .. within a predicate" | PLnamed (n, p) -> let p = predicate env p in { p with name = n::p.name } | PLsubtype (t,tc) -> let t = term env t in let tc = term env tc in psubtype ~loc:p0.lexpr_loc (t,tc) | PLseparated seps -> let type_loc loc = let res = term env loc in let res = mk_logic_pointer_or_StartOf res in check_non_void_ptr res.term_loc res.term_type; res in let seps = List.map type_loc seps in pseparated ~loc:p0.lexpr_loc seps | PLcomprehension _ | PLsingleton _ | PLunion _ | PLinter _ | PLempty -> error p0.lexpr_loc "expecting a predicate and not tsets" (* checks if the given offset points to a location inside a formal. *) and is_substructure off = let rec aux is_array_field off = match off with TNoOffset -> true | TField (f,o) -> aux (Cil.isArrayType f.ftype) o | TModel(mi,o) -> aux (Logic_utils.isLogicArrayType mi.mi_field_type) o | TIndex(_,o) -> (* if we are in an array field, the element is still part of the structure. Otherwise, this is an index to a memory cell outside of the current region. *) is_array_field && aux is_array_field o (* The formal is never an array by definition: start recursion with false. *) in aux false off and term_lval_assignable ~accept_formal env t = let f t = if isLogicArrayType t.term_type then error t.term_loc "not an assignable left value: %a" Cil_printer.pp_term t else begin match t.term_node with | Tapp _ -> t (* allow to use footprint functions in assigns. *) | _ -> term_lval (fun _ t -> match t.term_node with TStartOf lv | TCastE(_,{ term_node = TStartOf lv}) -> error t.term_loc "not an assignable left value: %a" Cil_printer.pp_term_lval lv | TLval (TVar v, o) when not accept_formal -> (match v.lv_origin with None -> t | Some v -> if v.vformal && is_substructure o then error t.term_loc "can not assign part of a formal parameter: %a" Cil_printer.pp_term t else t) | _ -> t ) t end in lift_set f (term env t) (* silent is an internal argument that should not escape the scope of this module. *) let term env t = term ~silent:false env t let type_variant env = function | (t, None) -> (type_int_term env t, None) | (t, r) -> (term env t, r) let type_from ~accept_formal env (l,d) = (* Yannick: [assigns *\at(\result,Post)] should be allowed *) let tl = term_lval_assignable ~accept_formal env l in let tl = Logic_const.new_identified_term tl in match d with FromAny -> (tl,FromAny) | From f -> let tf = List.map (term_lval_assignable ~accept_formal:true env) f in let tf = List.map (fun td -> if Logic_utils.contains_result td then error td.term_loc "invalid \\result in dependencies"; Logic_const.new_identified_term td) tf in (tl, From tf) let type_assign ~accept_formal env a = match a with WritesAny -> WritesAny | Writes l -> let res = List.map (type_from ~accept_formal env) l in (* we drop assigns \result; and assigns \exit_status; without from clause, as this does not convey any information. *) let res = List.filter (fun (l,f) -> not (Logic_const.is_result l.it_content || Logic_const.is_exit_status l.it_content) || f <> FromAny) res in Writes res let id_predicate env pred = Logic_const.new_predicate (predicate env pred) let id_term env t = Logic_const.new_identified_term (term env t) let loop_pragma env = function | Unroll_specs l -> (Unroll_specs (List.map (term env) l)) | Widen_hints l -> (Widen_hints (List.map (term env) l)) | Widen_variables l -> (Widen_variables (List.map (term env) l)) let type_annot loc ti = let env = append_here_label (Lenv.empty()) in let this_type = logic_type loc env ti.this_type in let v = Cil_const.make_logic_var_formal ti.this_name this_type in let env = Lenv.add_var ti.this_name v env in let body = predicate env ti.inv in let infos = Cil_const.make_logic_info ti.inv_name in infos.l_profile <- [v]; infos.l_labels <- [Logic_const.here_label]; infos.l_body <- LBpred body; C.add_logic_function infos; infos let model_annot loc ti = let env = Lenv.empty() in let model_for_type = c_logic_type loc env ti.model_for_type in if has_field ti.model_name model_for_type then error loc "Cannot add model field %s for type %a: it already exists" ti.model_name Cil_printer.pp_typ model_for_type else begin let model_type = logic_type loc env ti.model_type in let infos = { mi_name = ti.model_name; mi_base_type = model_for_type; mi_field_type = model_type; mi_decl = loc; } in Logic_env.add_model_field infos; infos end let check_behavior_names loc existing_behaviors names = List.iter (fun x -> if not (List.mem x existing_behaviors) then error loc "reference to unknown behavior %s" x) names let check_unique_behavior_names loc old_behaviors behaviors = List.fold_left (fun names b -> if b.b_name = Cil.default_behavior_name then names else begin if (List.mem b.b_name names) then error loc "behavior %s already defined" b.b_name ; b.b_name::names end) old_behaviors behaviors let type_extended ~typing_context ~loc behavior extensions = List.iter (fun (name,_,ps) -> let loc = match ps with | [] -> loc | p::_ -> p.lexpr_loc in Extensions.typer name ~typing_context ~loc behavior ps) extensions let type_spec old_behaviors loc is_stmt_contract result env s = let env = append_here_label env in let env_with_result = add_result env result in let env_with_result_and_exit_status = add_exit_status env_with_result in (* assigns_env is a bit special: - both \result and \exit_status (in a \at(_,Post) term are admissible) - Old and Post labels are admissible - Default label is Old (Assigns are evaluated in Pre-state * allocates is also using assigns_env *) let assigns_env = env_with_result_and_exit_status in let assigns_env = append_old_and_post_labels assigns_env in let old = Lenv.find_logic_label "Old" assigns_env in let assigns_env = Lenv.set_current_logic_label old assigns_env in let assigns_env = Lenv.exit_post_state (Lenv.enter_post_state assigns_env Exits) in let post_state_env k = let env = match k with | Returns -> env_with_result | Normal -> if is_stmt_contract then env else env_with_result | Exits -> add_exit_status env | Breaks | Continues -> env in Lenv.enter_post_state (append_old_and_post_labels env) k in let rec multiple_post_clauses_state_env l = match l with | [] -> env | [x] -> post_state_env x (* Usuual case*) (* The two cases below are used in the ACSL importer plugin *) | (Returns|Normal)::r -> add_result (multiple_post_clauses_state_env r) result | (Exits|Breaks|Continues)::r -> Lenv.enter_post_state (multiple_post_clauses_state_env r) Exits in let spec_behavior = let spec_behavior = s.spec_behavior in if spec_behavior = [] then (* at least allocates \nothing *) [mk_behavior ~allocation:None ()] else spec_behavior in let b = List.map (fun {b_assigns= ba; b_name = bn; b_post_cond=be; b_assumes= bas; b_allocation=bfa; b_requires=br; b_extended=bext} -> let result = { b_assigns= type_assign ~accept_formal:is_stmt_contract assigns_env ba; b_allocation= (match bfa with | FreeAllocAny -> FreeAllocAny | FreeAlloc(f,a) -> FreeAlloc((List.map (id_term env) f), List.map (id_term (post_state_env Normal)) a)); b_name = bn; b_post_cond = List.map (fun (k,p)-> let p' = id_predicate (post_state_env k) p in (k,p')) be; b_assumes= List.map (id_predicate env) bas; b_requires= List.map (id_predicate env) br; b_extended= []} in let typing_context = make_typing_context ~pre_state:env ~post_state:multiple_post_clauses_state_env ~assigns_env:assigns_env ~type_predicate:predicate ~type_term:term ~type_assigns:type_assign in type_extended ~typing_context ~loc result bext; result) spec_behavior in let none_for_stmt_contract clause = function | None -> None | (Some _) as x -> if is_stmt_contract then error loc "%s clause isn't allowed into statement contract" clause; x in let v = Extlib.opt_map (type_variant env) (none_for_stmt_contract "decreases" s.spec_variant) in let t = Extlib.opt_map (id_predicate env) (none_for_stmt_contract "terminates" s.spec_terminates) in let my_names = check_unique_behavior_names loc [] b in let bnames = old_behaviors @ my_names in let expand_my_names = function | [] -> if my_names = [] then error loc "complete or disjoint behaviors clause in a contract with empty \ list of behavior." else my_names | l -> l in let complete = List.map expand_my_names s.spec_complete_behaviors in let disjoint = List.map expand_my_names s.spec_disjoint_behaviors in List.iter (check_behavior_names loc bnames) complete; List.iter (check_behavior_names loc bnames) disjoint; let module S = Set.Make(struct type t = string list let compare s1 s2 = Pervasives.compare (List.sort Pervasives.compare s1) (List.sort Pervasives.compare s2) end) in let cleanup_duplicate l = S.elements (List.fold_left (fun acc e -> S.add e acc) S.empty l) in let complete = cleanup_duplicate complete in let disjoint = cleanup_duplicate disjoint in { spec_behavior = b; spec_variant = v; spec_terminates = t; spec_complete_behaviors = complete; spec_disjoint_behaviors = disjoint; } let funspec old_behaviors vi formals typ s = let env = append_pre_label (Lenv.funspec()) in let log_return_typ = Ctype (Cil.getReturnType typ) in let env = match formals with | None -> (* This is the spec of a function declaration *) let add_formal env v = Lenv.add_var v.vname (Cil.cvar_to_lvar v) env in begin try List.fold_left add_formal env (Cil.getFormalsDecl vi) with Not_found -> env (*declaration with an empty list of argument*) end | Some formals -> let add_formal env v = Lenv.add_var v.vname (Cil.cvar_to_lvar v) env in List.fold_left add_formal env formals in type_spec old_behaviors vi.vdecl false log_return_typ env s let slice_pragma env = function SPexpr t -> SPexpr (term env t) | (SPctrl | SPstmt) as sp -> sp let impact_pragma env = function IPexpr t -> IPexpr (term env t) | IPstmt as ip -> ip let code_annot_env () = let env = append_here_label (append_pre_label (Lenv.empty())) in if C.is_loop () then append_loop_labels env else env let loop_annot_env () = append_loop_labels (append_here_label (append_pre_label (Lenv.empty()))) let code_annot loc current_behaviors current_return_type ca = let annot = match ca with | AAssert (behav,p) -> check_behavior_names loc current_behaviors behav; AAssert (behav,predicate (code_annot_env()) p) | APragma (Impact_pragma sp) -> APragma (Impact_pragma (impact_pragma (code_annot_env()) sp)) | APragma (Slice_pragma sp) -> APragma (Slice_pragma (slice_pragma (code_annot_env()) sp)) | APragma (Loop_pragma lp) -> APragma (Loop_pragma (loop_pragma (code_annot_env()) lp)) | AStmtSpec (behav,s) -> (* function behaviors and statement behaviors are not at the same level. Do not mix them in a complete or disjoint clause here. *) check_behavior_names loc current_behaviors behav; let env = append_pre_label (Lenv.empty()) in let my_spec = type_spec [] loc true current_return_type env s in ignore (check_unique_behavior_names loc current_behaviors my_spec.spec_behavior); AStmtSpec (behav,my_spec) | AVariant v -> AVariant (type_variant (loop_annot_env ()) v) | AInvariant (behav,f,i) -> let env = if f then loop_annot_env () else code_annot_env () in check_behavior_names loc current_behaviors behav; AInvariant (behav,f,predicate env i) | AAllocation (behav,fa) -> check_behavior_names loc current_behaviors behav; AAllocation(behav, (match fa with | FreeAllocAny -> FreeAllocAny | FreeAlloc(f,a) -> FreeAlloc((List.map (id_term (loop_annot_env())) f), List.map (id_term (loop_annot_env())) a))); | AAssigns (behav,a) -> AAssigns (behav,type_assign ~accept_formal:true (loop_annot_env()) a) in Logic_const.new_code_annotation annot let formals loc env p = let add_var (p,env) (t,x) = let lt = logic_type loc env t in let var = Cil_const.make_logic_var_formal x lt in (var::p, Lenv.add_var x var env) in let (p,env) = List.fold_left add_var ([],env) p in List.rev p, env let init_type_variables loc l = List.fold_left (fun env x -> try ignore (Lenv.find_type_var x env); error loc "duplicated type variable in annotation" with Not_found -> Lenv.add_type_var x (Lvar x) env) (Lenv.empty()) l (* checks whether all the type variable contained in the return type t of a logic function are bound in a parameter's type (p being the list of formals). type-checking error otherwise *) let check_polymorphism loc ?return_type p = let obj known_vars = let update_known_vars s = known_vars:= Datatype.String.Set.add s !known_vars in object inherit Cil.nopCilVisitor method vlogic_type = function Lvar s -> update_known_vars s; Cil.DoChildren | _ -> Cil.DoChildren end in let rt_vars = ref Datatype.String.Set.empty in let prm_vars = ref Datatype.String.Set.empty in ignore(Extlib.opt_map (Cil.visitCilLogicType (obj rt_vars)) return_type); List.iter (fun v -> ignore (Cil.visitCilLogicType (obj prm_vars) v.lv_type)) p; if not (Datatype.String.Set.subset !rt_vars !prm_vars) then error loc "some type variable appears only in the return type. \ All type variables need to occur also in the parameters types." let annot_env loc labels poly = let env = init_type_variables loc poly in let labels,env = List.fold_right (fun l (labs,e) -> try let _ = Lenv.find_logic_label l e in error loc "multiply defined label `%s'" l with Not_found -> let lab = LogicLabel (None, l) in (lab::labs,Lenv.add_logic_label l lab e)) labels ([],env) in let env = match labels with | [lab] -> (* if there is exactly one label, it is the default label *) Lenv.set_current_logic_label lab env | _ -> env in labels,env let logic_decl loc f labels poly ?return_type p = let labels,env = annot_env loc labels poly in let t = match return_type with | None -> None; | Some t -> Some (logic_type loc env t) in let p, env = formals loc env p in check_polymorphism loc ?return_type:t p; let info = Cil_const.make_logic_info f in (* Should we add implicitely a default label for the declaration? *) let labels = match !Lenv.default_label with None -> labels | Some lab -> [lab] in (* Quick fix for bug 428, but this is far from perfect - Predicates still have a varinfo with Ctype Void - Polymorphism is not reflected on the lvar level. - However, such lvar should rarely if at all be seen under a Tvar. *) (match p,t with _,None -> () | [], Some t -> info.l_var_info.lv_type <- t | _,Some t -> let typ = Larrow (List.map (fun x -> x.lv_type) p,t) in info.l_var_info.lv_type <- typ); info.l_tparams <- poly; info.l_profile <- p; info.l_type <- t; info.l_labels <- labels; begin C.add_logic_function info; env,info end let type_datacons loc env type_info (name,params) = let tparams = List.map (logic_type loc env) params in let my_info = { ctor_name = name; ctor_type = type_info; ctor_params = tparams } in C.add_logic_ctor name my_info; my_info let typedef loc env my_info = function | TDsum cons -> LTsum (List.map (type_datacons loc env my_info) cons) | TDsyn typ -> LTsyn (logic_type loc env typ) let rec annot a = let loc = a.decl_loc in Cil.CurrentLoc.set loc; match a.decl_node with | LDlogic_reads (f, labels, poly, t, p, l) -> let env,info = logic_decl loc f labels poly ~return_type:t p in info.l_body <- (match l with | Some l -> let l = List.map (fun x -> new_identified_term (update_term_wrt_default_label (term env x))) l in LBreads l | None -> LBnone); update_info_wrt_default_label info (* potential creation of label w.r.t. reads clause *) ; Dfun_or_pred (info,loc) | LDpredicate_reads (f, labels, poly, p, l) -> let env,info = logic_decl loc f labels poly p in info.l_body <- (match l with | Some l -> let l = List.map (fun x -> new_identified_term (update_term_wrt_default_label (term env x))) l in LBreads l | None -> LBnone); update_info_wrt_default_label info (* potential creation of label w.r.t. reads clause *) ; Dfun_or_pred (info,loc) | LDlogic_def(f, labels, poly,t,p,e) -> let env,info = logic_decl loc f labels poly ~return_type:t p in let redefinition = false in let rt = match info.l_type with | None -> assert false | Some t -> t in (try let e = term env e in let _,new_typ,new_term = instantiate_app ~overloaded:false loc e rt env in if is_same_type new_typ rt then begin info.l_body <- LBterm (update_term_wrt_default_label new_term); update_info_wrt_default_label info (* potential creation of label w.r.t. def *) ; Dfun_or_pred (info,loc) end else error loc "return type of logic function %s is %a but %a was expected" f Cil_printer.pp_logic_type new_typ Cil_printer.pp_logic_type rt with e when not redefinition -> C.remove_logic_function f; raise e) | LDpredicate_def (f, labels, poly, p, e) -> let env,info = logic_decl loc f labels poly p in let e = update_predicate_wrt_default_label (predicate env e) in (match !Lenv.default_label with None -> () | Some lab -> info.l_labels <- [lab]); info.l_body <- LBpred e; update_info_wrt_default_label info; (* potential creation of label w.r.t. def *) Dfun_or_pred (info,loc) | LDinductive_def (f, input_labels, poly, p, indcases) -> let _env,info = logic_decl loc f input_labels poly p in (* env is ignored: because params names are indeed useless...*) let need_label = ref false in let l = List.map (fun (id,labels,poly,e) -> let labels,env = annot_env loc labels poly in let p = predicate env e in let labels, np = match !Lenv.default_label, env.Lenv.current_logic_label with | Some lab, None | None, Some lab -> need_label := true ; [ lab ], update_predicate_wrt_label p lab | _, _ -> labels, p in (id, labels, poly, np)) indcases in if !need_label && input_labels = [] then error loc "inductive predicate %s needs a label" f else ( info.l_body <- LBinductive l; Dfun_or_pred (info,loc) ) | LDaxiomatic(id,decls) -> (* Format.eprintf "Typing axiomatic %s@." id; *) let l = List.map annot decls in Daxiomatic(id,l,loc) | LDtype(s,l,def) -> let env = init_type_variables loc l in let my_info = { lt_name = s; lt_params = l; lt_def = None; (* will be updated later *) } in C.add_logic_type s my_info; (try let tdef = Extlib.opt_map (typedef loc env my_info) def in my_info.lt_def <- tdef; Dtype (my_info,loc) with e -> (* clean up the env in case we are in continue mode *) C.remove_logic_type s; Extlib.may (function TDsum cons -> List.iter (fun (name,_) -> C.remove_logic_ctor name) cons | TDsyn _ -> ()) def; raise e) | LDlemma (x,is_axiom, labels, poly, e) -> if Logic_env.Lemmas.mem x then begin let old_def = Logic_env.Lemmas.find x in let old_loc = Cil_datatype.Global_annotation.loc old_def in let is_axiom = match old_def with | Dlemma(_, is_axiom, _, _, _, _) -> is_axiom | _ -> Kernel.fatal "Logic_env.get_lemma must return Dlemma" in error loc "%s is already registered as %s (%a)" x (if is_axiom then "axiom" else "lemma") Cil_datatype.Location.pretty old_loc end; let labels,env = annot_env loc labels poly in let p = predicate env e in let labels = match !Lenv.default_label with | None -> labels | Some lab -> [lab] in let def = Dlemma (x,is_axiom, labels, poly, p, loc) in Logic_env.Lemmas.add x def; def | LDinvariant (s, e) -> let env = append_here_label (Lenv.empty()) in let p = predicate env e in let li = Cil_const.make_logic_info s in li.l_labels <- [Logic_const.here_label]; li.l_body <- LBpred p; C.add_logic_function li; Dinvariant (li,loc) | LDtype_annot l -> Dtype_annot (type_annot loc l,loc) | LDmodel_annot l -> Dmodel_annot (model_annot loc l,loc); | LDvolatile (tsets, (rd_opt, wr_opt)) -> let tsets = List.map (term_lval_assignable ~accept_formal:false (Lenv.empty ())) tsets in let checks_tsets_type fct ctyp = List.iter (fun t -> let check t = match Logic_utils.unroll_type t with | Ctype ctyp' -> Cil_datatype.Typ.equal ctyp ctyp' | _ -> false in if not (Logic_const.plain_or_set check t.term_type) then error t.term_loc "incompatible return type of '%s' with %a" fct Cil_printer.pp_term t) tsets in let checks_reads_fct fct ty = let error () = error loc "incompatible type of '%s' with volatile writes declaration" fct; in let ret,args,is_varg_arg,_attrib = if not (Cil.isFunctionType ty) then error (); Cil.splitFunctionType ty in let volatile_ret_type = typeAddAttributes [Attr ("volatile",[])] ret in let ret_type = ret in match args with | Some [_,arg1,_] when (not (isVoidType ret || is_varg_arg)) && isPointerType arg1 && Cil_datatype.Typ.equal (typeOf_pointed arg1) volatile_ret_type -> (* matching prototype: T fct (volatile T *arg1) *) checks_tsets_type fct volatile_ret_type (* tsets should have type: volatile T *) | Some [_,arg1,_] when (not (isVoidType ret || is_varg_arg)) && isPointerType arg1 && Cil_datatype.Typ.equal (typeOf_pointed arg1) ret_type && Cil.typeHasAttributeDeep "volatile" ret -> (* matching prototype: T fct (T *arg1) when T has some volatile attr*) checks_tsets_type fct ret_type (* tsets should have type: T *) | _ -> error () in let checks_writes_fct fct ty = let error () = error loc "incompatible type of '%s' with volatile writes declaration" fct; in let ret,args,is_varg_arg,_attrib = if not (Cil.isFunctionType ty) then error (); Cil.splitFunctionType ty in let volatile_ret_type = typeAddAttributes [Attr ("volatile",[])] ret in let ret_type = ret in match args with | Some ((_,arg1,_)::[_,arg2,_]) when (not (isVoidType ret || is_varg_arg)) && isPointerType arg1 && Cil_datatype.Typ.equal arg2 ret_type && Cil_datatype.Typ.equal (typeOf_pointed arg1) volatile_ret_type -> (* matching prototype: T fct (volatile T *arg1, T arg2) *) checks_tsets_type fct volatile_ret_type (* tsets should have type: volatile T *) | Some ((_,arg1,_)::[_,arg2,_]) when (not (isVoidType ret || is_varg_arg)) && isPointerType arg1 && Cil_datatype.Typ.equal arg2 ret_type && Cil_datatype.Typ.equal (typeOf_pointed arg1) ret_type && Cil.typeHasAttributeDeep "volatile" ret -> (* matching prototype: T fct (T *arg1, T arg2) when T has some volatile attr *) checks_tsets_type fct ret_type (* tsets should have type: T *) | _ -> error () in let get_volatile_fct checks_type = function | None -> None | Some fct -> try (match (C.find_var fct).lv_origin with | None -> raise Not_found | Some vi as vi_opt-> checks_type fct vi.vtype ; vi_opt) with Not_found -> error loc "cannot find function '%s' for volatile clause" fct in let tsets = List.map (Logic_const.new_identified_term) tsets in let rvi_opt = get_volatile_fct checks_reads_fct rd_opt in let wvi_opt = get_volatile_fct checks_writes_fct wr_opt in Dvolatile (tsets, rvi_opt, wvi_opt, loc) let custom _c = CustomDummy end (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/logic_builtin.mli0000644000175000017500000000347312155630366021774 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) val add: Cil_types.builtin_logic_info -> unit val init: unit -> unit -> unit frama-c-Fluorine-20130601/cil/src/logic/logic_print.ml0000644000175000017500000004670612155630366021317 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) open Format open Cil_types open Pretty_utils open Logic_ptree let print_constant fmt = function | IntConstant s -> pp_print_string fmt s | FloatConstant s -> pp_print_string fmt s | StringConstant s -> fprintf fmt "\"%s\"" s | WStringConstant s -> fprintf fmt "\"%s\"" s let rec print_logic_type name fmt typ = let pname = match name with | Some d -> (fun fmt -> fprintf fmt "@ %t" d) | None -> (fun _ -> ()) in match typ with LTvoid -> fprintf fmt "void%t" pname | LTinteger -> fprintf fmt "%s%t" (if Kernel.Unicode.get () then Utf8_logic.integer else "integer") pname | LTreal -> fprintf fmt "%s%t" (if Kernel.Unicode.get () then Utf8_logic.real else "real") pname | LTint i -> fprintf fmt "%a%t" Cil_printer.pp_ikind i pname | LTfloat f -> fprintf fmt "%a%t" Cil_printer.pp_fkind f pname | LTarray (t,c) -> let pname fmt = fprintf fmt "%t[@[%a@]]" pname (pp_opt print_constant) c in print_logic_type (Some pname) fmt t | LTpointer t -> let needs_paren = match t with LTarray _ -> true | _ -> false in let pname fmt = Format.fprintf fmt "%a*%t%a" (pp_cond needs_paren) "(" pname (pp_cond needs_paren) ")" in print_logic_type (Some pname) fmt t | LTunion s -> fprintf fmt "union@ %s%t" s pname | LTenum s -> fprintf fmt "enum@ %s%t" s pname | LTstruct s -> fprintf fmt "struct@ %s%t" s pname | LTnamed (s,l) -> fprintf fmt "%s%a%t" s (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@]>" (print_logic_type None)) l pname | LTarrow(args,ret) -> let pname fmt = fprintf fmt "%t(@[%a@])" pname (pp_list ~sep:",@ " (print_logic_type None)) args in print_logic_type (Some pname) fmt ret let print_typed_ident fmt (t,s) = print_logic_type (Some (fun fmt -> pp_print_string fmt s)) fmt t let print_quantifiers fmt l = pp_list ~sep:",@ " print_typed_ident fmt l let get_relation_string = function Lt -> "<" | Gt -> ">" | Le -> "<=" | Ge -> ">=" | Eq -> "==" | Neq -> "!=" let get_binop_string = function Badd -> "+" | Bsub -> "-" | Bmul -> "*" | Bdiv -> "/" | Bmod -> "%" | Bbw_and -> "&" | Bbw_or -> "|" | Bbw_xor -> "^" | Blshift -> "<<" | Brshift -> ">>" let get_unop_string = function Uminus -> "-" | Ustar -> "*" | Uamp -> "&" | Ubw_not -> "~" let getParenthLevel e = match e.lexpr_node with | PLnamed _ -> 95 | PLlambda _ | PLlet _ | PLrange _ -> 90 | PLforall _ | PLexists _ -> 87 | PLimplies _ | PLiff _ -> 85 | PLand _ | PLor _ | PLxor _ -> 80 | PLif _ -> 77 | PLbinop (_,(Bbw_and | Bbw_or | Bbw_xor),_) -> 75 | PLrel _ -> 70 | PLbinop (_,(Badd|Bsub|Blshift|Brshift),_) -> 60 | PLbinop (_,(Bmul|Bdiv|Bmod),_) -> 40 | PLunop ((Uamp|Uminus|Ubw_not),_) | PLcast _ | PLnot _ -> 30 | PLcoercion _ | PLcoercionE _ -> 25 | PLunop (Ustar,_) | PLdot _ | PLarrow _ | PLarrget _ | PLsizeof _ | PLsizeofE _ -> 20 | PLapp _ | PLold _ | PLat _ | PLoffset _ | PLbase_addr _ | PLblock_length _ | PLupdate _ | PLinitField _ | PLinitIndex _ | PLvalid _ | PLvalid_read _ | PLinitialized _ | PLallocable _ | PLfreeable _ | PLfresh _ | PLseparated _ | PLsubtype _ | PLunion _ | PLinter _ -> 10 | PLvar _ | PLconstant _ | PLresult | PLnull | PLtypeof _ | PLtype _ | PLfalse | PLtrue | PLcomprehension _ | PLempty | PLsingleton _ -> 0 let rec print_path_elt fmt = function | PLpathField s -> fprintf fmt ".%s" s | PLpathIndex i -> fprintf fmt "[@[%a@]]" print_lexpr i and print_path_val fmt (path, v) = match v with | PLupdateTerm e -> fprintf fmt "@[%a@ =@ %a@]" (pp_list ~sep:"@;" print_path_elt) path print_lexpr e | PLupdateCont path_val_list -> fprintf fmt "{ \\with %a@ }" (pp_list ~sep:",@ " print_path_val) path_val_list and print_init_index fmt (i,v) = print_path_val fmt ([PLpathIndex i], PLupdateTerm v) and print_init_field fmt (s,v) = print_path_val fmt ([PLpathField s], PLupdateTerm v) and print_lexpr fmt e = print_lexpr_level 100 fmt e and print_label_1 fmt l = match l with | None -> () | Some s -> fprintf fmt "{%s}" s and print_label_2 fmt l = match l with | None -> () | Some (s1,s2) -> fprintf fmt "{%s,%s}" s1 s2 and print_lexpr_level n fmt e = let n' = getParenthLevel e in let print_lexpr fmt e = print_lexpr_level n' fmt e in let print_lexpr_plain fmt e = print_lexpr_level 100 fmt e in let aux fmt e = match e.lexpr_node with PLvar s -> pp_print_string fmt s | PLapp(s,tv,args) -> fprintf fmt "%s@;%a@;(@[%a@])" s (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@]>" pp_print_string) tv (pp_list ~sep:",@ " print_lexpr_plain) args | PLlambda (quant,e) -> fprintf fmt "@[<2>\\lambda@ @[%a@];@ %a@]" print_quantifiers quant print_lexpr e | PLlet (n,def,body) -> fprintf fmt "@[@[<2>\\let@ %s@ =@ %a;@]@\n%a@]" n print_lexpr def print_lexpr body | PLconstant c -> print_constant fmt c | PLunop(op,e) -> fprintf fmt "%s%a" (get_unop_string op) print_lexpr e | PLbinop(e1,op,e2) -> fprintf fmt "%a@ %s@ %a" print_lexpr e1 (get_binop_string op) print_lexpr e2 | PLdot(e,f) -> fprintf fmt "%a.%s" print_lexpr e f | PLarrow(e,f) -> fprintf fmt "%a->%s" print_lexpr e f | PLarrget(b,i) -> fprintf fmt "%a[@;@[%a@]@;]" print_lexpr b print_lexpr i | PLold(e) -> fprintf fmt "\\old(@;@[%a@]@;)" print_lexpr_plain e | PLat(e,s) -> fprintf fmt "\\at(@;@[%a,@ %s@]@;)" print_lexpr_plain e s | PLbase_addr (l,e) -> fprintf fmt "\\base_addr%a(@;@[%a@])" print_label_1 l print_lexpr_plain e | PLblock_length (l,e) -> fprintf fmt "\\block_length%a(@;@[%a@])" print_label_1 l print_lexpr_plain e | PLoffset (l,e) -> fprintf fmt "\\offset%a(@;@[%a@])" print_label_1 l print_lexpr_plain e | PLresult -> pp_print_string fmt "\\result" | PLnull -> pp_print_string fmt "\\null" | PLcast (t,e) -> fprintf fmt "(@[%a@])@;%a" (print_logic_type None) t print_lexpr e | PLrange(e1,e2) -> fprintf fmt "%a@;..@;%a" (pp_opt print_lexpr) e1 (pp_opt print_lexpr) e2 | PLsizeof t -> fprintf fmt "sizeof(@;@[%a@]@;)" (print_logic_type None) t | PLsizeofE e -> fprintf fmt "sizeof(@;@[%a@]@;)" print_lexpr_plain e | PLcoercion(e,t) -> fprintf fmt "%a@ :>@ %a" print_lexpr e (print_logic_type None) t | PLcoercionE(e1,e2) -> fprintf fmt "%a@ :>@ %a" print_lexpr e1 print_lexpr e2 | PLupdate(e1,path,e2) -> fprintf fmt "{@ @[%a@ \\with@ %a@]}" print_lexpr_plain e1 print_path_val (path, e2) | PLinitField(init_field_list) -> fprintf fmt "{@ %a@}" (pp_list ~sep:",@ " print_init_field) init_field_list | PLinitIndex(init_index_list) -> fprintf fmt "{@ %a@}" (pp_list ~sep:",@ " print_init_index) init_index_list | PLtypeof e -> fprintf fmt "typeof(@;@[%a@]@;)" print_lexpr_plain e | PLtype t -> fprintf fmt "\\type(@;@[%a@]@;" (print_logic_type None) t | PLfalse -> pp_print_string fmt "\\false" | PLtrue -> pp_print_string fmt "\\true" | PLrel (e1,rel,e2) -> fprintf fmt "%a@ %s@ %a" print_lexpr e1 (get_relation_string rel) print_lexpr e2 | PLand(e1,e2) -> fprintf fmt "%a@ &&@ %a" print_lexpr e1 print_lexpr e2 | PLor(e1,e2) -> fprintf fmt "%a@ ||@ %a" print_lexpr e1 print_lexpr e2 | PLxor(e1,e2) -> fprintf fmt "%a@ ^^@ %a" print_lexpr e1 print_lexpr e2 | PLimplies(e1,e2) -> fprintf fmt "%a@ ==>@ %a" print_lexpr e1 print_lexpr e2 | PLiff(e1,e2) -> fprintf fmt "%a@ <==>@ %a" print_lexpr e1 print_lexpr e2 | PLnot e -> fprintf fmt "!@;%a" print_lexpr e | PLif (e1,e2,e3) -> fprintf fmt "%a@ ?@ %a@ :@ %a" print_lexpr e1 print_lexpr e2 print_lexpr e3 | PLforall(q,e) -> fprintf fmt "@[\\forall@ @[%a@];@ %a@]" print_quantifiers q print_lexpr e | PLexists(q,e) -> fprintf fmt "@[\\exists@ @[%a@];@ %a@]" print_quantifiers q print_lexpr e | PLvalid (l,e) -> fprintf fmt "\\valid%a(@;@[%a@]@;)" print_label_1 l print_lexpr_plain e | PLvalid_read (l,e) -> fprintf fmt "\\valid_read%a(@;@[%a@]@;)" print_label_1 l print_lexpr_plain e | PLinitialized (l,e) -> fprintf fmt "\\initialized%a(@;@[%a@]@;)" print_label_1 l print_lexpr_plain e | PLseparated l -> fprintf fmt "\\separated(@;@[%a@]@;)" (pp_list ~sep:",@ " print_lexpr_plain) l | PLfreeable (l,e) -> fprintf fmt "\\freeable%a(@;@[%a@]@;)" print_label_1 l print_lexpr_plain e | PLallocable (l,e) -> fprintf fmt "\\allocable%a(@;@[%a@]@;)" print_label_1 l print_lexpr_plain e | PLfresh (l2,e1,e2) -> fprintf fmt "\\fresh%a(@;@[%a@],@[%a@]@;)" print_label_2 l2 print_lexpr_plain e1 print_lexpr_plain e2 | PLnamed(s,e) -> fprintf fmt "%s:@ %a" s print_lexpr e | PLsubtype (e1,e2) -> fprintf fmt "%a@ <:@ %a" print_lexpr e1 print_lexpr e2 | PLcomprehension(e,q,p) -> fprintf fmt "{@ @[%a;@ %a%a@]@ }" print_lexpr e print_quantifiers q (pp_opt ~pre:"@ |@ " print_lexpr) p | PLsingleton e -> fprintf fmt "{@ @[%a@]@ }" print_lexpr e | PLempty -> pp_print_string fmt "\\empty" | PLunion l-> fprintf fmt "\\union(%a)" (pp_list ~pre:"@;@[" ~sep:",@ " ~suf:"@]@;" print_lexpr_plain) l | PLinter l-> fprintf fmt "\\inter(%a)" (pp_list ~pre:"@;@[" ~sep:",@ " ~suf:"@]@;" print_lexpr_plain) l in if n <= n' then fprintf fmt "(@[%a@])" aux e else aux fmt e let print_typedef fmt = function | TDsum l -> let print_const fmt (s,args) = fprintf fmt "%s%a" s (pp_list ~pre:"@ (@[" ~sep:",@ " ~suf:"@])" (print_logic_type None)) args in pp_list ~sep:"@ |@ " print_const fmt l | TDsyn t -> print_logic_type None fmt t let print_type_annot fmt ty = fprintf fmt "@[type@ invariant@ %s(@;@[%a@ %s]@;)@ =@ %a;@]" ty.inv_name (print_logic_type None) ty.this_type ty.this_name print_lexpr ty.inv let print_model_annot fmt ty = fprintf fmt "@[model@ %a {@;@[%a@ %s]@;}@ @]" (print_logic_type None) ty.model_for_type (print_logic_type None) ty.model_type ty.model_name let rec print_decl fmt d = match d.decl_node with | LDlogic_def(name,labels,tvar,rt,prms,body) -> fprintf fmt "@[<2>logic@ %a@ %s%a%a%a@ =@ %a;@]" (print_logic_type None) rt name (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar (pp_list ~pre:"(@[" ~sep:",@ " ~suf:"@])" print_typed_ident) prms print_lexpr body | LDlogic_reads(name,labels,tvar,rt,prms,reads) -> fprintf fmt "@[<2>logic@ %a@ %s%a%a%a@ =@ %a;@]" (print_logic_type None) rt name (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar (pp_list ~pre:"(@[" ~sep:",@ " ~suf:"@])" print_typed_ident) prms (pp_opt ~pre:"@[<2>reads@ " (pp_list ~sep:",@ " print_lexpr)) reads | LDtype(name,tvar,def) -> fprintf fmt "@[<2>type@ %s%a%a;@]" name (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar (pp_opt ~pre:"@ =@ " print_typedef) def | LDpredicate_reads(name,labels,tvar,prms,reads) -> fprintf fmt "@[<2>predicate@ %s%a%a%a@ =@ %a;@]" name (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar (pp_list ~pre:"(@[" ~sep:",@ " ~suf:"@])" print_typed_ident) prms (pp_opt ~pre:"@[<2>reads@ " (pp_list ~sep:",@ " print_lexpr)) reads | LDpredicate_def(name,labels,tvar,prms,body) -> fprintf fmt "@[<2>predicate@ %s%a%a%a@ =@ %a;@]" name (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar (pp_list ~pre:"(@[" ~sep:",@ " ~suf:"@])" print_typed_ident) prms print_lexpr body | LDinductive_def(name,labels,tvar,prms,cases) -> let print_case fmt (name,labels,tvar,body) = fprintf fmt "@[<2>case@ %s%a%a:@ %a;@]" name (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar print_lexpr body in fprintf fmt "@[<2>inductive@ %s%a%a@;(%a)@ {@\n%a@]@\n}" name (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar (pp_list ~sep:",@ " print_typed_ident) prms (pp_list ~sep:"@\n" print_case) cases | LDlemma(name,is_axiom,labels,tvar,body) -> fprintf fmt "@[<2>%a@ %s%a%a:@ %a;@]" (pp_cond ~pr_false:"lemma" is_axiom) "axiom" name (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar print_lexpr body | LDaxiomatic (s,d) -> fprintf fmt "@[<2>axiomatic@ %s@ {@\n%a@]@\n}" s (pp_list ~sep:"@\n" print_decl) d | LDinvariant (s,e) -> fprintf fmt "@[<2>invariant@ %s:@ %a;@]" s print_lexpr e | LDtype_annot ty -> print_type_annot fmt ty | LDmodel_annot ty -> print_model_annot fmt ty | LDvolatile(tsets,(read,write)) -> fprintf fmt "@[<2>volatile@ %a%a%a;@]" (pp_list ~pre:"@[" ~sep:",@ " ~suf:"@]" print_lexpr) tsets (pp_opt ~pre:"@ reads@ " pp_print_string) read (pp_opt ~pre:"@ writes@ " pp_print_string) write let print_deps fmt deps = match deps with FromAny -> () | From l -> pp_list ~pre:"@ @[<2>\\from@ " ~sep:",@ " ~suf:"@]" print_lexpr fmt l let print_assigns fmt a = match a with WritesAny -> () | Writes l -> pp_list ~sep:"@\n" (fun fmt (loc,deps) -> fprintf fmt "@\nassigns@ %a%a;" print_lexpr loc print_deps deps) fmt l let print_allocation ~isloop fmt fa = match fa with | FreeAllocAny -> () | FreeAlloc([],[]) -> let prefix = if isloop then "loop " else "" in fprintf fmt "@\n%sallocates@ \\nothing;" prefix | FreeAlloc(f,a) -> let prefix = if isloop then "loop " else "" in let pFreeAlloc kw fmt af = match af with | [] -> () | _ -> fprintf fmt "@\n%s%s@ %a;" prefix kw (pp_list ~sep:",@ " print_lexpr) a in fprintf fmt "%a%a" (pFreeAlloc "frees") f (pFreeAlloc "allocates") a let print_clause name fmt e = fprintf fmt "@\n%s@ %a;" name print_lexpr e let print_post fmt (k,e) = print_clause (Cil_printer.get_termination_kind_name k) fmt e let print_behavior fmt bhv = fprintf fmt "@[<2>behavior@ %s:%a%a%a%a%a@]" bhv.b_name (pp_list ~pre:"" ~suf:"" (print_clause "assumes")) bhv.b_assumes (pp_list ~pre:"" ~suf:"" (print_clause "requires")) bhv.b_requires (pp_list ~pre:"" ~suf:"" print_post) bhv.b_post_cond (print_allocation ~isloop:false) bhv.b_allocation print_assigns bhv.b_assigns (* TODO: prints extensions *) let print_variant fmt (v,cmp) = fprintf fmt "%a%a;" print_lexpr v (pp_opt ~pre:"@ for@ " pp_print_string) cmp let print_spec fmt spec = fprintf fmt "@[%a%a%a%a%a@]" (pp_list ~sep:"@\n" ~suf:"@\n" print_behavior) spec.spec_behavior (pp_opt ~pre:"decreases@ " ~suf:"@\n" print_variant) spec.spec_variant (pp_opt ~pre:"terminates@ " ~suf:"@\n" print_lexpr) spec.spec_terminates (pp_list ~pre:"complete@ behaviors@ " ~sep:"@\n" ~suf:"@\n" (pp_list ~sep:",@ " pp_print_string)) spec.spec_complete_behaviors (pp_list ~pre:"disjoint@ behaviors@ " ~sep:"@\n" ~suf:"@\n" (pp_list ~sep:",@ " pp_print_string)) spec.spec_disjoint_behaviors let print_loop_pragma fmt p = match p with Unroll_specs l -> fprintf fmt "UNROLL@ %a" (pp_list ~sep:",@ " print_lexpr) l | Widen_hints l -> fprintf fmt "WIDEN_HINTS@ %a" (pp_list ~sep:",@ " print_lexpr) l | Widen_variables l -> fprintf fmt "WIDEN_VARIABLES@ %a" (pp_list ~sep:",@ " print_lexpr) l let print_slice_pragma fmt p = match p with | SPexpr e -> fprintf fmt "expr@ %a" print_lexpr e | SPctrl -> pp_print_string fmt "ctrl" | SPstmt -> pp_print_string fmt "stmt" let print_impact_pragma fmt p = match p with | IPexpr e -> fprintf fmt "expr@ %a" print_lexpr e | IPstmt -> pp_print_string fmt "stmt" let print_pragma fmt p = match p with Loop_pragma p -> fprintf fmt "loop@ pragma@ %a;" print_loop_pragma p | Slice_pragma p -> fprintf fmt "slice@ pragma@ %a;" print_slice_pragma p | Impact_pragma p -> fprintf fmt "impact@ pragma@ %a;" print_impact_pragma p let print_code_annot fmt ca = let print_behaviors fmt bhvs = (pp_list ~pre:"for@ " ~sep:",@ " ~suf:":@ " pp_print_string) fmt bhvs in match ca with AAssert(bhvs,e) -> fprintf fmt "%aassert@ %a;" print_behaviors bhvs print_lexpr e | AStmtSpec (bhvs,s) -> fprintf fmt "%a%a" print_behaviors bhvs print_spec s | AInvariant (bhvs,loop,e) -> fprintf fmt "%a%ainvariant@ %a;" print_behaviors bhvs (pp_cond loop) "loop@ " print_lexpr e | AVariant e -> fprintf fmt "loop@ variant@ %a;" print_variant e | AAssigns (bhvs,a) -> fprintf fmt "%aloop@ %a" print_behaviors bhvs print_assigns a | AAllocation (bhvs,fa) -> fprintf fmt "%a%a" print_behaviors bhvs (print_allocation ~isloop:true) fa | APragma p -> print_pragma fmt p (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/logic_parser.mly0000644000175000017500000015063112155630366021641 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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 2.1 */ /* for more details (enclosed in the file licenses/LGPLv2.1). */ /* */ /**************************************************************************/ /* Grammar for C annotations */ %{ open Cil open Cil_types open Logic_ptree open Logic_utils let loc () = (symbol_start_pos (), symbol_end_pos ()) let info x = { lexpr_node = x; lexpr_loc = loc () } let loc_info loc x = { lexpr_node = x; lexpr_loc = loc } let loc_start x = fst x.lexpr_loc let loc_end x = snd x.lexpr_loc let clause_order i name1 name2 = raise (Not_well_formed ((rhs_start_pos i, rhs_end_pos i), "wrong order of clause in contract: " ^ name1 ^ " after " ^ name2 ^ ".")) let missing i token next_token = raise (Not_well_formed ((rhs_start_pos i, rhs_end_pos i), Pretty_utils.sfprintf "expecting '%s' before %s" token next_token)) type sense_of_relation = Unknown | Disequal | Less | Greater let check_empty (loc,msg) l = match l with [] -> () | _ -> raise (Not_well_formed (loc,msg)) let relation_sense rel sense = match rel, sense with Eq, _ -> sense, true | Neq, Unknown -> Disequal, true (* No chain of disequality for now*) | (Gt|Ge), (Unknown|Greater) -> Greater, true | (Lt|Le), (Unknown|Less) -> Less, true | _ -> sense, false let type_variables_stack = Stack.create () let enter_type_variables_scope l = List.iter Logic_env.add_typename l; Stack.push l type_variables_stack let exit_type_variables_scope () = let l = Stack.pop type_variables_stack in List.iter Logic_env.remove_typename l let rt_type = ref false let set_rt_type () = rt_type:= true let reset_rt_type () = rt_type:=false let is_rt_type () = !rt_type let loc_decl d = { decl_node = d; decl_loc = loc () } let wrap_extended = List.map (fun (n,p) -> n,0, p) let concat_froms a1 a2 = let compare_pair (b1,_) (b2,_) = is_same_lexpr b1 b2 in (* NB: the following has an horrible complexity, but the order of clauses in the input is preserved. *) let concat_one acc (_,f2 as p) = try let (_,f1) = List.find (compare_pair p) acc in match (f1, f2) with | _,FromAny -> (* the new fundeps does not give more information than the one which is already present. Just ignore it. *) acc | FromAny, _ -> (* the new fundeps is strictly more precise than the old one. We can remove the old dependencies. *) let acc = Extlib.filter_out (compare_pair p) acc in acc @ [p] | From _, From _ -> (* we keep the two functional dependencies, as they have to be proved separately. *) acc @ [p] with Not_found -> acc @ [p] in List.fold_left concat_one a1 a2 let concat_allocation fa1 fa2 = match fa1,fa2 with | FreeAllocAny,_ -> fa2 | _,FreeAllocAny -> fa1 | FreeAlloc(f1,a1),FreeAlloc(f2,a2) -> FreeAlloc(f2@f1,a2@a1) (* a1 represents the assigns _after_ the current clause a2. *) let concat_assigns a1 a2 = match a1,a2 with WritesAny,a -> Writes (concat_froms [] a) | Writes [], [] -> a1 | Writes [], _ | Writes _, [] -> raise ( Not_well_formed (loc(),"Mixing \\nothing and a real location")) | Writes a1, a2 -> Writes (concat_froms a2 a1) let concat_loop_assigns_allocation annots bhvs2 a2 fa2= (* NB: this is supposed to merge assigns related to named behaviors, in case of annotation like for a,b: assigns x,y; for b,c: assigns z,t; DO NOT CALL this function for loop assigns not attached to specific behaviors. *) assert (bhvs2 <> []); if fa2 == FreeAllocAny && a2 == WritesAny then annots else let split l1 l2 = let treat_one (only1,both,only2) x = if List.mem x l1 then (Extlib.filter_out (fun y -> x=y) only1,x::both,only2) else (only1,both,x::only2) in List.fold_left treat_one (l1,[],[]) l2 in let treat_one ca (bhvs2,acc) = match ca,a2,fa2 with (AAssigns(bhvs1,a1)),(Writes a2),_ -> let (only1,both,only2) = split bhvs1 bhvs2 in (match both with | [] -> bhvs2, ca::acc | _ -> let common_annot = AAssigns(both,concat_assigns a1 a2) in let annots = match only1 with | [] -> common_annot :: acc | _ -> AAssigns(only1,a1) :: common_annot :: acc in only2,annots) | (AAllocation(bhvs1,fa1)),_,(FreeAlloc _) -> let (only1,both,only2) = split bhvs1 bhvs2 in (match both with | [] -> bhvs2, ca::acc | _ -> let common_annot = AAllocation(both,concat_allocation fa1 fa2) in let annots = match only1 with | [] -> common_annot :: acc | _ -> AAllocation(only1,fa1) :: common_annot :: acc in only2,annots) | _,_,_ -> bhvs2,ca::acc in let (bhvs2, annots) = List.fold_right treat_one annots (bhvs2,[]) in match bhvs2 with | [] -> annots (* Already considered all cases. *) | _ -> let annots = if a2 <> WritesAny then AAssigns (bhvs2,a2) :: annots else annots in if fa2 <> FreeAllocAny then AAllocation (bhvs2,fa2) :: annots else annots let obsolete name ~source ~now = Kernel.warning ~source "parsing obsolete ACSL construct '%s'. '%s' should be used instead." name now let check_registered kw = if Logic_utils.is_extension kw then kw else raise Parsing.Parse_error %} /*****************************************************************************/ /* IMPORTANT NOTE: When you add a new token, be sure that it will be */ /* recognized by the any: rule at the end of this file. */ /* Otherwise, the token will not be usable inside a contract. */ /*****************************************************************************/ %token MODULE FUNCTION CONTRACT INCLUDE EXT_AT EXT_LET /* ACSL extension for external spec file */ %token IDENTIFIER TYPENAME %token STRING_LITERAL %token CONSTANT %token CONSTANT10 %token LPAR RPAR IF ELSE COLON COLON2 COLONCOLON DOT DOTDOT DOTDOTDOT %token INT INTEGER REAL BOOLEAN FLOAT LT GT LE GE EQ NE COMMA ARROW EQUAL %token FORALL EXISTS IFF IMPLIES AND OR NOT SEPARATED %token TRUE FALSE OLD AT RESULT %token BLOCK_LENGTH BASE_ADDR OFFSET VALID VALID_READ VALID_INDEX VALID_RANGE %token ALLOCATION STATIC REGISTER AUTOMATIC DYNAMIC UNALLOCATED %token ALLOCABLE FREEABLE FRESH %token DOLLAR QUESTION MINUS PLUS STAR AMP SLASH PERCENT LSQUARE RSQUARE EOF %token GLOBAL INVARIANT VARIANT DECREASES FOR LABEL ASSERT SEMICOLON NULL EMPTY %token REQUIRES ENSURES ALLOCATES FREES ASSIGNS LOOP NOTHING SLICE IMPACT PRAGMA FROM %token EXITS BREAKS CONTINUES RETURNS %token VOLATILE READS WRITES %token LOGIC PREDICATE INDUCTIVE AXIOMATIC AXIOM LEMMA LBRACE RBRACE %token GHOST MODEL CASE %token VOID CHAR SIGNED UNSIGNED SHORT LONG DOUBLE STRUCT ENUM UNION %token BSUNION INTER %token LTCOLON COLONGT TYPE BEHAVIOR BEHAVIORS ASSUMES COMPLETE DISJOINT %token TERMINATES %token BIFF BIMPLIES HAT HATHAT PIPE TILDE GTGT LTLT %token SIZEOF LAMBDA LET %token TYPEOF BSTYPE %token WITH CONST %token INITIALIZED %token CUSTOM %nonassoc lowest %right prec_named %nonassoc IDENTIFIER TYPENAME SEPARATED %nonassoc prec_forall prec_exists prec_lambda LET %right QUESTION prec_question %left IFF %right IMPLIES %left OR %left HATHAT %left AND %left PIPE %left BIFF %right BIMPLIES %left HAT %left AMP %nonassoc prec_no_rel %left prec_rel_list /* for list of relations (LT GT LE GE EQ NE) */ %left LT %left LTLT GTGT %left PLUS MINUS %left STAR SLASH PERCENT CONST VOLATILE %right prec_cast TILDE NOT prec_unary_op %nonassoc LTCOLON COLONGT %left DOT ARROW LSQUARE %right prec_par %nonassoc highest %type lexpr_eof %start lexpr_eof %type annot %start annot %type spec %start spec %type ext_spec %start ext_spec %% enter_kw_c_mode: /* empty */ { enter_kw_c_mode () } exit_kw_c_mode: /* empty */ { exit_kw_c_mode () } enter_rt_type: /* empty */ { if is_rt_type () then enter_rt_type_mode () } exit_rt_type: /* empty */ { if is_rt_type () then exit_rt_type_mode () } begin_rt_type: /* empty */ { set_rt_type () } end_rt_type: /* empty */ { reset_rt_type () } /*** predicates and terms ***/ lexpr_list: | /* epsilon */ { [] } | ne_lexpr_list { $1 } ; ne_lexpr_list: | lexpr { [$1] } | lexpr COMMA ne_lexpr_list { $1 :: $3 } ; lexpr_eof: | lexpr EOF { $1 } ; lexpr_option: | /* epsilon */ { None } | lexpr { Some $1 } ; lexpr: /* predicates */ | lexpr IMPLIES lexpr { info (PLimplies ($1, $3)) } | lexpr IFF lexpr { info (PLiff ($1, $3)) } | lexpr OR lexpr { info (PLor ($1, $3)) } | lexpr AND lexpr { info (PLand ($1, $3)) } | lexpr HATHAT lexpr { info (PLxor ($1, $3)) } /* terms */ | lexpr AMP lexpr { info (PLbinop ($1, Bbw_and, $3)) } | lexpr PIPE lexpr { info (PLbinop ($1, Bbw_or, $3)) } | lexpr HAT lexpr { info (PLbinop ($1, Bbw_xor, $3)) } | lexpr BIMPLIES lexpr { info (PLbinop (info (PLunop (Ubw_not, $1)), Bbw_or, $3)) } | lexpr BIFF lexpr { info (PLbinop (info (PLunop (Ubw_not, $1)), Bbw_xor, $3)) } | lexpr QUESTION lexpr COLON2 lexpr %prec prec_question { info (PLif ($1, $3, $5)) } /* both terms and predicates */ | any_identifier COLON lexpr %prec prec_named { info (PLnamed ($1, $3)) } | string COLON lexpr %prec prec_named { let (iswide,str) = $1 in if iswide then begin let l = loc () in raise (Not_well_formed(l, "Wide strings are not allowed as labels.")) end; info (PLnamed (("\"" ^ str ^ "\""), $3)) } | lexpr_rel %prec prec_rel_list { $1 } ; lexpr_rel: | lexpr_end_rel %prec prec_no_rel { $1 } | lexpr_inner rel_list %prec prec_rel_list { let rel, rhs, _, oth_rel = $2 in let loc = loc_start $1, loc_end rhs in let relation = loc_info loc (PLrel($1,rel,rhs)) in match oth_rel with None -> relation | Some oth_relation -> info (PLand(relation,oth_relation)) } ; lexpr_binder: | LET bounded_var EQUAL lexpr SEMICOLON lexpr %prec LET {info (PLlet($2,$4,$6))} | FORALL binders SEMICOLON lexpr %prec prec_forall { info (PLforall ($2, $4)) } | EXISTS binders SEMICOLON lexpr %prec prec_exists { info (PLexists ($2, $4)) } | LAMBDA binders SEMICOLON lexpr %prec prec_lambda { info (PLlambda ($2,$4)) } ; lexpr_end_rel: lexpr_inner %prec prec_no_rel { $1 } | lexpr_binder { $1 } | NOT lexpr_binder { info (PLnot $2) } ; rel_list: | relation lexpr_end_rel %prec prec_rel_list { $1, $2, fst(relation_sense $1 Unknown), None } | relation lexpr_inner rel_list %prec prec_rel_list { let next_rel, rhs, sense, oth_rel = $3 in let (sense, correct) = relation_sense $1 sense in if correct then let loc = loc_start $2, loc_end rhs in let my_rel = loc_info loc (PLrel($2,next_rel,rhs)) in let oth_rel = match oth_rel with None -> my_rel | Some rel -> let loc = loc_start $2, loc_end rel in loc_info loc (PLand(my_rel,rel)) in $1,$2,sense,Some oth_rel else begin let loc = Parsing.rhs_start_pos 1, Parsing.rhs_end_pos 3 in raise (Not_well_formed(loc,"Inconsistent relation chain.")); end } ; relation: | LT { Lt } | GT { Gt } | LE { Le } | GE { Ge } | EQ { Eq } | NE { Neq } /* C. Marche: added to produce better error messages */ | EQUAL { let l = loc () in raise (Not_well_formed(l, "Assignment operators not allowed in annotations.")) } ; lexpr_inner: | string { let (is_wide,content) = $1 in let cst = if is_wide then WStringConstant content else StringConstant content in info (PLconstant cst) } | NOT lexpr_inner { info (PLnot $2) } | TRUE { info PLtrue } | FALSE { info PLfalse } | VALID opt_label_1 LPAR lexpr RPAR { info (PLvalid ($2,$4)) } | VALID_READ opt_label_1 LPAR lexpr RPAR { info (PLvalid_read ($2,$4)) } | VALID_INDEX opt_label_1 LPAR lexpr COMMA lexpr RPAR { let source = fst (loc ()) in obsolete ~source "\\valid_index(addr,idx)" ~now:"\\valid(addr+idx)"; info (PLvalid ($2,info (PLbinop ($4, Badd, $6)))) } | VALID_RANGE opt_label_1 LPAR lexpr COMMA lexpr COMMA lexpr RPAR { let source = fst (loc ()) in obsolete "\\valid_range(addr,min,max)" ~source ~now:"\\valid(addr+(min..max))"; info (PLvalid ($2,info (PLbinop ($4, Badd, (info (PLrange((Some $6),Some $8))))))) } | INITIALIZED opt_label_1 LPAR lexpr RPAR { info (PLinitialized ($2,$4)) } | FRESH opt_label_2 LPAR lexpr COMMA lexpr RPAR { info (PLfresh ($2,$4, $6)) } | BASE_ADDR opt_label_1 LPAR lexpr RPAR { info (PLbase_addr ($2,$4)) } | BLOCK_LENGTH opt_label_1 LPAR lexpr RPAR { info (PLblock_length ($2,$4)) } | OFFSET opt_label_1 LPAR lexpr RPAR { info (PLoffset ($2,$4)) } | ALLOCABLE opt_label_1 LPAR lexpr RPAR { info (PLallocable ($2,$4)) } | FREEABLE opt_label_1 LPAR lexpr RPAR { info (PLfreeable ($2,$4)) } | ALLOCATION opt_label_1 LPAR lexpr RPAR { Format.eprintf "Warning: \\static not yet implemented." ; (* TODO: *) raise Parse_error } | AUTOMATIC { Format.eprintf "Warning: \\static not yet implemented." ; (* TODO: *) raise Parse_error } | DYNAMIC { Format.eprintf "Warning: \\dynamic not yet implemented." ; (* TODO: *) raise Parse_error } | REGISTER { Format.eprintf "Warning: \\register not yet implemented." ; (* TODO: *) raise Parse_error } | STATIC { Format.eprintf "Warning: \\static not yet implemented." ; (* TODO: *) raise Parse_error } | UNALLOCATED { Format.eprintf "Warning: \\unallocated not yet implemented." ; (* TODO: *) raise Parse_error } | NULL { info PLnull } | constant { info (PLconstant $1) } | lexpr_inner PLUS lexpr_inner { info (PLbinop ($1, Badd, $3)) } | lexpr_inner MINUS lexpr_inner { info (PLbinop ($1, Bsub, $3)) } | lexpr_inner STAR lexpr_inner { info (PLbinop ($1, Bmul, $3)) } | lexpr_inner SLASH lexpr_inner { info (PLbinop ($1, Bdiv, $3)) } | lexpr_inner PERCENT lexpr_inner { info (PLbinop ($1, Bmod, $3)) } | lexpr_inner ARROW identifier_or_typename { info (PLarrow ($1, $3)) } | lexpr_inner DOT identifier_or_typename { info (PLdot ($1, $3)) } | lexpr_inner LSQUARE range RSQUARE { info (PLarrget ($1, $3)) } | lexpr_inner LSQUARE lexpr RSQUARE { info (PLarrget ($1, $3)) } | MINUS lexpr_inner %prec prec_unary_op { info (PLunop (Uminus, $2)) } | PLUS lexpr_inner %prec prec_unary_op { $2 } | TILDE lexpr_inner { info (PLunop (Ubw_not, $2)) } | STAR lexpr_inner %prec prec_unary_op { info (PLunop (Ustar, $2)) } | AMP lexpr_inner %prec prec_unary_op { info (PLunop (Uamp, $2)) } | SIZEOF LPAR lexpr RPAR { info (PLsizeofE $3) } | SIZEOF LPAR logic_type RPAR { info (PLsizeof $3) } | OLD LPAR lexpr RPAR { info (PLold $3) } | AT LPAR lexpr COMMA label_name RPAR { info (PLat ($3, $5)) } | RESULT { info PLresult } | SEPARATED LPAR ne_lexpr_list RPAR { info (PLseparated $3) } | identifier LPAR ne_lexpr_list RPAR { info (PLapp ($1, [], $3)) } | identifier LBRACE ne_label_args RBRACE LPAR ne_lexpr_list RPAR { info (PLapp ($1, $3, $6)) } | identifier LBRACE ne_label_args RBRACE { info (PLapp ($1, $3, [])) } | identifier %prec IDENTIFIER { info (PLvar $1) } | lexpr_inner GTGT lexpr_inner { info (PLbinop ($1, Brshift, $3))} | lexpr_inner LTLT lexpr_inner { info (PLbinop ($1, Blshift, $3))} | LPAR lexpr RPAR %prec prec_par { info $2.lexpr_node } | LPAR range RPAR { info $2.lexpr_node } | LPAR cast_logic_type RPAR lexpr_inner %prec prec_cast { info (PLcast ($2, $4)) } | lexpr_inner LTCOLON lexpr_inner %prec prec_cast { info (PLsubtype ($1, $3)) } | lexpr_inner COLONGT logic_type %prec prec_cast { info (PLcoercion ($1, $3)) } | lexpr_inner COLONGT lexpr_inner %prec prec_cast { info (PLcoercionE ($1, $3)) } | TYPEOF LPAR lexpr RPAR { info (PLtypeof $3) } | BSTYPE LPAR type_spec STAR RPAR { info (PLtype $3) } /* tsets */ | EMPTY { info PLempty } | BSUNION LPAR lexpr_list RPAR { info (PLunion $3) } | INTER LPAR lexpr_list RPAR { info (PLinter $3) } | LBRACE lexpr RBRACE { info (PLsingleton ($2)) } | LBRACE lexpr PIPE binders RBRACE {info (PLcomprehension ($2,$4,None)) } | LBRACE lexpr PIPE binders SEMICOLON lexpr RBRACE { info (PLcomprehension ($2,$4,Some $6)) } /* Aggregated object initialization */ | LBRACE field_init RBRACE { info (PLinitField($2)) } | LBRACE array_init RBRACE { info (PLinitIndex($2)) } | LBRACE lexpr WITH update RBRACE { List.fold_left (fun a (path,upd_val) -> info (PLupdate(a,path,upd_val))) $2 $4 } /* | LET bounded_var EQUAL lexpr SEMICOLON lexpr %prec LET {info (PLlet($2,$4,$6))}*/ ; ne_label_args: | identifier { [ $1 ] } | identifier COMMA ne_label_args { $1 :: $3 } string: | STRING_LITERAL { $1 } | string STRING_LITERAL { let (is_wide,prefix) = $1 in let (is_wide2,suffix) = $2 in (is_wide || is_wide2, prefix ^ suffix) } ; range: | lexpr_option DOTDOT lexpr_option { info (PLrange($1,$3)) } ; /*** Aggregated object initialization ***/ field_path_elt: | DOT identifier_or_typename { $2 } ; field_init_elt: | field_path_elt EQUAL lexpr { ($1, $3) } ; field_init: | field_init_elt { [$1] } | field_init_elt COMMA field_init { $1::$3 } ; array_path_elt: | LSQUARE lexpr RSQUARE { $2 } | LSQUARE range RSQUARE { $2 } ; array_init_elt: | array_path_elt EQUAL lexpr { ($1, $3) } array_init: | array_init_elt { [$1] } | array_init_elt COMMA array_init { $1::$3 } ; /*** Functional update ***/ update: | update_elt { [$1] } | update_elt COMMA update { $1::$3 } ; update_elt: | path EQUAL lexpr { $1, PLupdateTerm $3 } | path EQUAL LBRACE WITH update RBRACE { $1, PLupdateCont $5 } ; path: | path_elt { [$1] } | path_elt path { $1::$2 } ; path_elt: | field_path_elt { PLpathField $1 } | array_path_elt { PLpathIndex $1 } ; /*** binders ***/ binders: | binders_reentrance { let (_lt, vars) = $1 in vars } ; binders_reentrance: | decl_spec { let (lt, var) = $1 in (lt, [var]) } | binders_reentrance COMMA decl_spec { let _, vars = $1 in let (lt, var) = $3 in (lt, vars @ [ var ]) } | binders_reentrance COMMA var_spec { let last_type_spec, vars = $1 in (last_type_spec, vars @ [ let (modif, name) = $3 in (modif last_type_spec, name)]) } ; decl_spec: | type_spec var_spec { ($1, let (modif, name) = $2 in (modif $1, name)) } ; var_spec: | var_spec_bis { let (outer, inner,name) = $1 in ((fun x -> outer (inner x)), name)} | stars var_spec_bis { let (outer, inner, name) = $2 in ((fun x -> outer (inner ($1 x))), name) } ; constant: | CONSTANT { $1 } | CONSTANT10 { IntConstant $1 } ; constant_option: | constant { Some $1 } | /* empty */ { None } ; var_spec_bis: | identifier { ((fun x -> x),(fun x -> x), $1) } | var_spec_bis LSQUARE constant_option RSQUARE { let (outer, inner, name) = $1 in (outer, (fun x -> inner (LTarray (x,$3))), name) } | LPAR var_spec RPAR { let (modif, name) = $2 in (modif, (fun x -> x), name) } | var_spec_bis LPAR abs_param_type_list RPAR { let (outer, inner,name) = $1 in let params = $3 in (outer, (fun x -> inner (LTarrow (params,x))), name) } ; abs_param_type_list: | /* empty */ { [ ] } | abs_param_list { $1 } | abs_param_list COMMA DOTDOTDOT { Format.eprintf "Warning: elipsis type is not yet implemented." ; (* TODO: *) raise Parse_error } ; abs_param_list: | abs_param { [ $1 ] } | abs_param_list COMMA abs_param { $1 @ [ $3 ] } ; /* TODO: abs_param should be less restrictive than parameter since its name can be omitted */ abs_param: | logic_type { $1 } ; /*** restricted type expressions ***/ id_as_typename: | identifier { LTnamed($1, []) } ; ne_parameters: | parameter { [$1] } | parameter COMMA ne_parameters { $1 :: $3 } ; parameter: | type_spec var_spec { let (modif, name) = $2 in (modif $1, name)} | id_as_typename var_spec { let (modif, name) = $2 in (modif $1, name) } ; /*** type expressions ***/ logic_type: | type_spec abs_spec_option { $2 $1 } ; cv: CONST { } | VOLATILE { } ; type_spec_cv: type_spec { $1 } | cv type_spec { $2 } | type_spec cv { $1 } cast_logic_type: | type_spec_cv abs_spec_option { $2 $1 } | type_spec_cv abs_spec cv { $2 $1 } ; logic_rt_type: | id_as_typename { $1 } | begin_rt_type logic_type end_rt_type { $2 } ; abs_spec_option: | /* empty */ %prec TYPENAME { fun t -> t } | abs_spec { $1 } ; abs_spec: | tabs { $1 } | stars %prec TYPENAME { $1 } | stars tabs { fun t -> $2 ($1 t) } | stars abs_spec_bis %prec TYPENAME { fun t -> $2 ($1 t) } | stars abs_spec_bis tabs { fun t -> $2 ($3 ($1 t)) } | abs_spec_bis tabs { fun t -> $1 ($2 t) } | abs_spec_bis %prec TYPENAME { $1 } ; abs_spec_bis: | LPAR abs_spec RPAR { $2 } | abs_spec_bis LPAR abs_param_type_list RPAR { fun t -> $1 (LTarrow($3,t)) }; ; stars: | STAR { fun t -> LTpointer t } | stars STAR { fun t -> $1 (LTpointer t) } ; tabs: | LSQUARE constant_option RSQUARE %prec TYPENAME { fun t -> LTarray (t,$2) } | LSQUARE constant_option RSQUARE tabs { fun t -> (LTarray ($4 t,$2)) } ; type_spec: | INTEGER { LTinteger } | REAL { LTreal } | BOOLEAN { LTnamed (Utf8_logic.boolean,[]) } | VOID { LTvoid } | CHAR { LTint IChar } /** [char] */ | SIGNED CHAR { LTint ISChar } /** [signed char] */ | UNSIGNED CHAR { LTint IUChar } /** [unsigned char] */ | INT { LTint IInt } /** [int] */ | SIGNED INT { LTint IInt } /** [int] */ | UNSIGNED INT { LTint IUInt } /** [unsigned int] */ | UNSIGNED { LTint IUInt } | SHORT { LTint IShort } /** [short] */ | SIGNED SHORT { LTint IShort } /** [short] */ | UNSIGNED SHORT { LTint IUShort } /** [unsigned short] */ | LONG { LTint ILong } /** [long] */ | SIGNED LONG { LTint ILong } /** [long] */ | UNSIGNED LONG { LTint IULong } /** [unsigned long] */ | SIGNED LONG INT{ LTint ILong } /** [long] */ | LONG INT { LTint ILong } /** [long] */ | UNSIGNED LONG INT { LTint IULong } /** [unsigned long] */ | LONG LONG { LTint ILongLong } /** [long long] (or [_int64] on Microsoft Visual C) */ | SIGNED LONG LONG { LTint ILongLong } /** [long long] (or [_int64] on Microsoft Visual C) */ | UNSIGNED LONG LONG { LTint IULongLong } /** [unsigned long long] (or [unsigned _int64] on Microsoft Visual C) */ | LONG LONG INT { LTint ILongLong } /** [long long] (or [_int64] on Microsoft Visual C) */ | SIGNED LONG LONG INT { LTint ILongLong } /** [long long] (or [_int64] on Microsoft Visual C) */ | UNSIGNED LONG LONG INT { LTint IULongLong } /** [unsigned long long] (or [unsigned _int64] on Microsoft Visual C) */ | FLOAT { LTfloat FFloat } | DOUBLE { LTfloat FDouble } | LONG DOUBLE { LTfloat FLongDouble } | STRUCT exit_rt_type identifier { LTstruct $3 } | ENUM exit_rt_type identifier { LTenum $3 } | UNION exit_rt_type identifier { LTunion $3 } | TYPENAME { LTnamed ($1,[]) } | TYPENAME LT enter_rt_type ne_logic_type_list GT exit_rt_type { LTnamed($1,$4) } ; ne_logic_type_list: | logic_type { [$1] } | logic_type COMMA enter_rt_type ne_logic_type_list { $1 :: $4 } ; /*** from annotations ***/ full_lexpr: | enter_kw_c_mode lexpr exit_kw_c_mode { $2 } ; full_identifier: | enter_kw_c_mode identifier exit_kw_c_mode { $2 } ; full_identifier_or_typename: | enter_kw_c_mode identifier_or_typename exit_kw_c_mode { $2 } ; full_parameters: | enter_kw_c_mode ne_parameters exit_kw_c_mode { $2 } ; full_parameter: | enter_kw_c_mode parameter exit_kw_c_mode { $2 } ; full_zones: | enter_kw_c_mode zones exit_kw_c_mode { $2 } ; full_ne_lexpr_list: enter_kw_c_mode ne_lexpr_list exit_kw_c_mode { $2 } ; full_logic_type: | enter_kw_c_mode logic_type exit_kw_c_mode { $2 } ; full_logic_rt_type: | enter_kw_c_mode logic_rt_type exit_kw_c_mode { $2 } full_assigns: | enter_kw_c_mode assigns exit_kw_c_mode { $2 } ; /*** ACSL extension for external spec file ***/ ext_spec: | ext_global_clauses_opt ext_module_specs_opt ext_global_specs_opt EOF { ("",$1,$2)::$3 } ; ext_global_clauses_opt: | /* empty */ { [] } | ext_global_clauses { $1 } ; ext_global_clauses: | ext_global_clause { [$1] } | ext_global_clause ext_global_clauses { $1::$2 } ; ext_global_clause: | decl { Ext_decl (loc_decl $1) } | EXT_LET any_identifier EQUAL full_lexpr SEMICOLON { Ext_macro ($2, $4) } | INCLUDE string SEMICOLON { let b,s = $2 in Ext_include(b,s, loc()) } ; ext_global_specs_opt: | /* empty */ { [] } | ext_global_specs { $1 } ; ext_global_specs: | ext_global_spec { [$1] } | ext_global_spec ext_global_specs { $1::$2 } ; ext_global_spec: | ext_module_markup ext_global_clauses_opt ext_module_specs { ($1,$2,$3) } | ext_module_markup { ($1,[],[]) } ; ext_module_specs_opt: | /* empty */ { [] } | ext_module_specs { $1 } ; ext_module_specs: | ext_module_spec { [$1] } | ext_module_spec ext_module_specs { $1::$2 } ; ext_module_spec: | ext_function_markup ext_function_specs_opt { ($1,$2) } ; ext_function_specs_opt: | /* empty */ { [] } | ext_function_specs { $1 } ; ext_function_specs: | ext_at_loop_markup { []} | ext_at_stmt_markup { []} | ext_function_spec { [$1] } | ext_function_spec ext_function_specs { $1::$2 } ; ext_function_spec: | ext_global_clause { Ext_glob $1 } | ext_at_loop_markup ext_stmt_loop_spec { Ext_loop_spec($1,$2,loc()) } | ext_at_stmt_markup ext_stmt_loop_spec { Ext_stmt_spec($1,$2,loc()) } | ext_contract_markup contract { let s,pos = $2 in Ext_spec (s,pos) } ; ext_stmt_loop_spec: | annotation { $1 } | ext_contract_markup contract { let s, pos = $2 in Acode_annot (pos, AStmtSpec ([],s)) } ; ext_identifier_opt: | /* empty*/ { "" } | ext_identifier { $1 } ; ext_identifier: | any_identifier { $1 } ; ext_module_markup: | MODULE ext_identifier COLON { $2 } ; ext_function_markup: | FUNCTION ext_identifier COLON { $2, loc() } ; ext_contract_markup: | CONTRACT ext_identifier_opt COLON { $2 } ; ext_at_loop_markup: | EXT_AT LOOP CONSTANT10 COLON { $3 } ; ext_at_stmt_markup: | EXT_AT CONSTANT10 COLON { $2 } | EXT_AT any_identifier COLON { $2 } ; /*** function and statement contracts ***/ spec: | contract EOF { $1 } ; contract: | requires terminates decreases simple_clauses behaviors complete_or_disjoint { let requires=$1 in let (allocation,assigns,post_cond,extended) = $4 in let behaviors = $5 in let (completes,disjoints) = $6 in let behaviors = if requires <> [] || post_cond <> [] || allocation <> FreeAllocAny || assigns <> WritesAny || extended <> [] then let allocation = if allocation <> FreeAllocAny then Some allocation else None in (mk_behavior ~requires ~post_cond ~assigns ~allocation ~extended:(wrap_extended extended) ()) :: behaviors else behaviors in { spec_terminates = $2; spec_variant = $3; spec_behavior = behaviors; spec_complete_behaviors = completes; spec_disjoint_behaviors = disjoints; }, loc() } | requires ne_terminates REQUIRES { clause_order 3 "requires" "terminates" } | requires terminates ne_decreases REQUIRES { clause_order 4 "requires" "decreases" } | requires terminates ne_decreases TERMINATES { clause_order 4 "terminates" "decreases" } | requires terminates decreases ne_simple_clauses REQUIRES { clause_order 5 "requires" "post-condition or assigns" } | requires terminates decreases ne_simple_clauses TERMINATES { clause_order 5 "terminates" "post-condition or assigns" } | requires terminates decreases ne_simple_clauses DECREASES { clause_order 5 "decreases" "post-condition or assigns" } | requires terminates decreases simple_clauses ne_behaviors TERMINATES { clause_order 6 "terminates" "behavior" } | requires terminates decreases simple_clauses ne_behaviors DECREASES { clause_order 6 "decreases" "behavior" } | requires terminates decreases simple_clauses behaviors ne_complete_or_disjoint REQUIRES { clause_order 7 "requires" "complete or disjoint" } | requires terminates decreases simple_clauses behaviors ne_complete_or_disjoint TERMINATES { clause_order 7 "terminates" "complete or disjoint" } | requires terminates decreases simple_clauses behaviors ne_complete_or_disjoint DECREASES { clause_order 7 "decreases" "complete or disjoint" } | requires terminates decreases simple_clauses behaviors ne_complete_or_disjoint BEHAVIOR { clause_order 7 "behavior" "complete or disjoint" } | requires terminates decreases simple_clauses behaviors ne_complete_or_disjoint ASSIGNS { clause_order 7 "assigns" "complete or disjoint" } | requires terminates decreases simple_clauses behaviors ne_complete_or_disjoint ALLOCATES { clause_order 7 "allocates" "complete or disjoint" } | requires terminates decreases simple_clauses behaviors ne_complete_or_disjoint FREES { clause_order 7 "frees" "complete or disjoint" } | requires terminates decreases simple_clauses behaviors ne_complete_or_disjoint post_cond_kind { clause_order 7 "post-condition" "complete or disjoint" } ; // use that to detect potentially missing ';' at end of clause clause_kw: | REQUIRES { "requires" } | ASSUMES {"assumes"} | ASSIGNS { "assigns" } | post_cond { snd $1 } | DECREASES { "decreases"} | BEHAVIOR { "behavior"} | ALLOCATES {"allocates"} | FREES {"frees"} | COMPLETE {"complete"} | DISJOINT {"disjoint"} /* often, we'll be in c_kw_mode, where these keywords are recognized as identifiers... */ | IDENTIFIER { $1 } | EOF { "end of annotation" } requires: | /* epsilon */ { [] } | ne_requires { $1 } ; ne_requires: | REQUIRES full_lexpr SEMICOLON requires { $2::$4 } | REQUIRES full_lexpr clause_kw { missing 2 ";" $3} ; terminates: | /* epsilon */ { None } | ne_terminates { Some $1 } ; ne_terminates: | TERMINATES full_lexpr SEMICOLON { $2 } | TERMINATES full_lexpr clause_kw { missing 2 ";" $3 } ; decreases: | /* epsilon */ { None } | ne_decreases { Some $1 } ; ne_decreases: | DECREASES variant SEMICOLON { $2 } | DECREASES variant clause_kw { missing 2 ";" $3 } ; variant: | full_lexpr FOR any_identifier { ($1, Some $3) } | full_lexpr { ($1, None) } ; simple_clauses: | /* epsilon */ { FreeAllocAny,WritesAny,[],[] } | ne_simple_clauses { $1 } ; allocation: | ALLOCATES full_zones { FreeAlloc([],$2) } | FREES full_zones { FreeAlloc($2,[]) } ne_simple_clauses: | post_cond_kind full_lexpr SEMICOLON simple_clauses { let allocation,assigns,post_cond,extended = $4 in allocation,assigns,(($1,$2)::post_cond),extended } | allocation SEMICOLON simple_clauses { let allocation,assigns,post_cond,extended = $3 in let a = concat_allocation allocation $1 in a,assigns,post_cond,extended } | ASSIGNS full_assigns SEMICOLON simple_clauses { let allocation,assigns,post_cond,extended = $4 in let a = concat_assigns assigns $2 in allocation,a,post_cond,extended } | grammar_extension SEMICOLON simple_clauses { let allocation,assigns,post_cond,extended = $3 in allocation,assigns,post_cond,$1::extended } | post_cond_kind full_lexpr clause_kw { missing 2 ";" $3 } | allocation clause_kw { missing 1 ";" $2 } | ASSIGNS full_assigns clause_kw { missing 2 ";" $3 } | grammar_extension clause_kw { missing 1 ";" $2 } ; grammar_extension: /* Grammar Extensibility for plugins */ | grammar_extension_name full_zones { $1,$2 } ; post_cond_kind: | post_cond { fst $1 } ; behaviors: | /* epsilon */ { [] } | ne_behaviors { $1 } ne_behaviors: | BEHAVIOR behavior_name COLON behavior_body behaviors { let (assumes,requires,(allocation,assigns,post_cond,extended)) = $4 in let behaviors = $5 in let allocation = Some allocation in let b = Cil.mk_behavior ~name:$2 ~assumes ~requires ~post_cond ~assigns ~allocation ~extended:(wrap_extended extended) () in b::behaviors } behavior_body: | assumes requires simple_clauses { $1,$2,$3 } | assumes ne_requires ASSUMES { clause_order 3 "assumes" "requires" } | assumes requires ne_simple_clauses ASSUMES { clause_order 4 "assumes" "assigns or post-condition" } | assumes requires ne_simple_clauses REQUIRES { clause_order 4 "requires" "assigns or post-condition" } ; assumes: | /* epsilon */ { [] } | ASSUMES full_lexpr SEMICOLON assumes { $2::$4 } | ASSUMES full_lexpr clause_kw { missing 2 ";" $3 } ; complete_or_disjoint: | /* epsilon */ { [],[] } | ne_complete_or_disjoint { $1 } ne_complete_or_disjoint: | COMPLETE BEHAVIORS behavior_name_list SEMICOLON complete_or_disjoint { let complete,disjoint = $5 in $3::complete, disjoint } | DISJOINT BEHAVIORS behavior_name_list SEMICOLON complete_or_disjoint { let complete,disjoint = $5 in complete,$3::disjoint } /* complete behaviors decreases; is valid (provided there's a behavior named decreases) */ | COMPLETE BEHAVIORS ne_behavior_name_list clause_kw { missing 3 ";" $4 } | DISJOINT BEHAVIORS ne_behavior_name_list clause_kw { missing 3 ";" $4 } ; /*** assigns and tsets ***/ assigns: | zones { List.map (fun x -> (x,FromAny)) $1 } | ne_zones FROM zones {List.map (fun x -> (x, From $3)) $1} /* | ne_zones FROM zones EQUAL lexpr { Format.eprintf "Warning: functional expression of \\from clause is ignored (not yet implemented)." ; List.map (fun x -> (x, $3)) $1 }*/ ; zones : | ne_zones { $1 } | NOTHING { [] } ; ne_zones : | ne_lexpr_list { $1 } ; /*** annotations ***/ annot: | annotation EOF { $1 } | is_spec any EOF { Aspec } | decl_list EOF { Adecl ($1) } | CUSTOM any_identifier COLON custom_tree EOF { Acustom(loc (),$2, $4) } ; custom_tree: | TYPE type_spec { CustomType $2 } | LOGIC lexpr %prec prec_named { CustomLexpr $2 } | any_identifier_non_logic %prec lowest { CustomOther($1,[]) } | any_identifier_non_logic LPAR custom_tree_list RPAR %prec lowest { CustomOther($1,$3) } ; custom_tree_list: | custom_tree { [$1] } | custom_tree COMMA custom_tree_list { $1::$3 } annotation: | loop_annotations { let (b,v,p) = $1 in (* TODO: do better, do not lose the structure ! *) let l = b@v@p in Aloop_annot (loc (), l) } | FOR ne_behavior_name_list COLON contract { let s, pos = $4 in Acode_annot (pos, AStmtSpec ($2,s)) } | code_annotation { Acode_annot (loc(),$1) } | code_annotation beg_code_annotation { raise (Not_well_formed (loc(), "Only one code annotation is allowed per comment")) } | full_identifier_or_typename { Aattribute_annot (loc (), $1) } ; /*** loop annotations ***/ loop_annotations: | loop_annot_stack { let (i,fa,a,b,v,p) = $1 in let invs = List.map (fun i -> AInvariant([],true,i)) i in let oth = match a with | WritesAny -> b | Writes _ -> (* by definition all existing AAssigns are tied to at least one behavior. No need to merge against them. *) AAssigns ([],a)::b in let oth = match fa with | FreeAllocAny -> oth | _ -> AAllocation ([],fa)::oth in (invs@oth,v,p) } ; /* TODO: gather loop assigns that are related to the same behavior */ loop_annot_stack: | loop_invariant loop_annot_opt { let (i,fa,a,b,v,p) = $2 in ($1::i,fa,a,b,v,p) } | loop_effects loop_annot_opt { let (i,fa,a,b,v,p) = $2 in (i,fa,concat_assigns a $1,b,v,p) } | loop_allocation loop_annot_opt { let (i,fa,a,b,v,p) = $2 in (i,concat_allocation fa $1,a,b,v,p) } | FOR ne_behavior_name_list COLON loop_annot_stack { let (i,fa,a,b,v,p) = $4 in let behav = $2 in let invs = List.map (fun i -> AInvariant(behav,true,i)) i in let oth = concat_loop_assigns_allocation b behav a fa in ([],FreeAllocAny,WritesAny,invs@oth,v,p) } | loop_variant loop_annot_opt { let pos,loop_variant = $1 in let (i,fa,a,b,v,p) = $2 in check_empty (pos,"loop invariant is not allowed after loop variant.") i ; (match fa with | FreeAlloc(f,a) -> check_empty (pos,"loop frees is not allowed after loop variant.") f ; check_empty (pos,"loop allocates is not allowed after loop variant.") a | FreeAllocAny -> ()); (match a with WritesAny -> () | Writes _ -> raise (Not_well_formed (pos,"loop assigns is not allowed after loop variant."))); check_empty (pos,"loop behavior is not allowed after loop variant.") b ; check_empty (pos,"loop annotations can have at most one variant.") v ; (i,fa,a,b,AVariant loop_variant::v,p) } | loop_pragma loop_annot_opt { let (i,fa,a,b,v,p) = $2 in (i,fa,a,b,v,APragma (Loop_pragma $1)::p) } | loop_grammar_extension loop_annot_opt { raise (Not_well_formed (loc(),"Grammar extension for loop annotations is not yet implemented")) } ; loop_annot_opt: | /* epsilon */ { ([], FreeAllocAny, WritesAny, [], [], []) } | loop_annot_stack { $1 } ; loop_effects: | LOOP ASSIGNS full_assigns SEMICOLON { $3 } ; loop_allocation: | LOOP allocation SEMICOLON { $2 } ; loop_invariant: | LOOP INVARIANT full_lexpr SEMICOLON { $3 } ; loop_variant: | LOOP VARIANT variant SEMICOLON { loc(),$3 } ; /* Grammar Extensibility for plugins */ loop_grammar_extension: | LOOP grammar_extension SEMICOLON { raise (Not_well_formed (loc(),"Grammar extension for loop annotations is not yet implemented")) } ; loop_pragma: | LOOP PRAGMA any_identifier full_ne_lexpr_list SEMICOLON { if $3 = "UNROLL_LOOP" || $3 = "UNROLL" then (if $3 <> "UNROLL" then Format.eprintf "Warning: use of deprecated keyword '%s'.\nShould use 'UNROLL' instead.@." $3; Unroll_specs $4) else if $3 = "WIDEN_VARIABLES" then Widen_variables $4 else if $3 = "WIDEN_HINTS" then Widen_hints $4 else raise (Not_well_formed (loc(),"Unknown loop pragma")) } ; /*** code annotations ***/ beg_code_annotation: | IMPACT {} | SLICE {} | FOR {} | ASSERT {} | INVARIANT {} ; code_annotation: | slice_pragma { APragma (Slice_pragma $1) } | impact_pragma { APragma (Impact_pragma $1) } | FOR ne_behavior_name_list COLON ASSERT full_lexpr SEMICOLON { AAssert ($2,$5) } | FOR ne_behavior_name_list COLON INVARIANT full_lexpr SEMICOLON { AInvariant ($2,false,$5) } | ASSERT full_lexpr SEMICOLON { AAssert ([],$2) } | INVARIANT full_lexpr SEMICOLON { AInvariant ([],false,$2) } ; slice_pragma: | SLICE PRAGMA any_identifier full_lexpr SEMICOLON { if $3 = "expr" then SPexpr $4 else raise (Not_well_formed (loc(), "Unknown slice pragma")) } | SLICE PRAGMA any_identifier SEMICOLON { if $3 = "ctrl" then SPctrl else if $3 = "stmt" then SPstmt else raise (Not_well_formed (loc(), "Unknown slice pragma")) } ; impact_pragma: | IMPACT PRAGMA any_identifier full_lexpr SEMICOLON { if $3 = "expr" then IPexpr $4 else raise (Not_well_formed (loc(), "Unknown impact pragma")) } | IMPACT PRAGMA any_identifier SEMICOLON { if $3 = "stmt" then IPstmt else raise (Not_well_formed (loc(), "Unknown impact pragma")) } ; /*** declarations and logical definitions ***/ decl_list: | decl { [loc_decl $1] } | decl decl_list { (loc_decl $1) :: $2 } decl: | GLOBAL INVARIANT any_identifier COLON full_lexpr SEMICOLON { LDinvariant ($3, $5) } | VOLATILE ne_zones volatile_opt SEMICOLON { LDvolatile ($2, $3) } | type_annot {LDtype_annot $1} | model_annot {LDmodel_annot $1} | logic_def { $1 } | deprecated_logic_decl { $1 } ; volatile_opt: | /* empty */ { None, None } | READS any_identifier volatile_opt { let read,write=$3 in if read = None then (Some $2),write else (Format.eprintf "Warning: read %s ignored@." $2; $3) } | WRITES any_identifier volatile_opt { let read,write=$3 in if write = None then read,(Some $2) else (Format.eprintf "Warning: write %s ignored@." $2; $3) } ; type_annot: | TYPE INVARIANT any_identifier LPAR full_parameter RPAR EQUAL full_lexpr SEMICOLON { let typ,name = $5 in{ inv_name = $3; this_name = name; this_type = typ; inv = $8; } } ; opt_semicolon: | /* epsilon */ { } | SEMICOLON { } model_annot: | MODEL type_spec LBRACE full_parameter opt_semicolon RBRACE SEMICOLON { let typ,name = $4 in { model_for_type = $2; model_name = name; model_type = typ; } } ; poly_id_type: | full_identifier { enter_type_variables_scope []; ($1,[]) } | full_identifier LT ne_tvar_list GT { enter_type_variables_scope $3; ($1,$3) } ; /* we need to recognize the typename as soon as it has been declared, so that it can be used in data constructors in the type definition itself */ poly_id_type_add_typename: | poly_id_type { let (id,_) = $1 in Logic_env.add_typename id; $1 } ; poly_id: | poly_id_type { let (id,tvar) = $1 in (id,[],tvar) } | full_identifier LBRACE ne_label_list RBRACE { enter_type_variables_scope []; ($1,$3,[]) } | full_identifier LBRACE ne_label_list RBRACE LT ne_tvar_list GT { enter_type_variables_scope $6; $1,$3,$6 } ; opt_parameters: | /*epsilon*/ { [] } | parameters { $1 } ; parameters: | LPAR full_parameters RPAR { $2 } ; logic_def: /* logic function definition */ | LOGIC full_logic_rt_type poly_id opt_parameters EQUAL full_lexpr SEMICOLON { let (id, labels, tvars) = $3 in exit_type_variables_scope (); LDlogic_def (id, labels, tvars, $2, $4, $6) } /* predicate definition */ | PREDICATE poly_id opt_parameters EQUAL full_lexpr SEMICOLON { let (id,labels,tvars) = $2 in exit_type_variables_scope (); LDpredicate_def (id, labels, tvars, $3, $5) } /* inductive predicate definition */ | INDUCTIVE poly_id parameters LBRACE indcases RBRACE { let (id,labels,tvars) = $2 in exit_type_variables_scope (); LDinductive_def(id, labels, tvars, $3, $5) } | LEMMA poly_id COLON full_lexpr SEMICOLON { let (id,labels,tvars) = $2 in exit_type_variables_scope (); LDlemma (id, false, labels, tvars, $4) } | AXIOMATIC any_identifier LBRACE logic_decls RBRACE { LDaxiomatic($2,$4) } | TYPE poly_id_type_add_typename EQUAL typedef SEMICOLON { let (id,tvars) = $2 in exit_type_variables_scope (); LDtype(id,tvars,Some $4) } ; deprecated_logic_decl: /* OBSOLETE: logic function declaration */ | LOGIC full_logic_rt_type poly_id opt_parameters SEMICOLON { let (id, labels, tvars) = $3 in let source = fst (loc ()) in exit_type_variables_scope (); obsolete "logic declaration" ~source ~now:"an axiomatic block"; LDlogic_reads (id, labels, tvars, $2, $4, None) } /* OBSOLETE: predicate declaration */ | PREDICATE poly_id opt_parameters SEMICOLON { let (id,labels,tvars) = $2 in exit_type_variables_scope (); let source = fst (loc ()) in obsolete "logic declaration" ~source ~now:"an axiomatic block"; LDpredicate_reads (id, labels, tvars, $3, None) } /* OBSOLETE: type declaration */ | TYPE poly_id_type SEMICOLON { let (id,tvars) = $2 in Logic_env.add_typename id; exit_type_variables_scope (); let source = fst (loc ()) in obsolete "logic type declaration" ~source ~now:"an axiomatic block"; LDtype(id,tvars,None) } /* OBSOLETE: axiom */ | AXIOM poly_id COLON full_lexpr SEMICOLON { let (id,_,_) = $2 in raise (Not_well_formed (loc(),"Axiom " ^ id ^ " is declared outside of an axiomatic.")) } ; logic_decls: | /* epsilon */ { [] } | logic_decl_loc logic_decls { $1::$2 } ; logic_decl: | logic_def { $1 } /* logic function declaration */ | LOGIC full_logic_rt_type poly_id opt_parameters reads_clause SEMICOLON { let (id, labels, tvars) = $3 in exit_type_variables_scope (); LDlogic_reads (id, labels, tvars, $2, $4, $5) } /* predicate declaration */ | PREDICATE poly_id opt_parameters reads_clause SEMICOLON { let (id,labels,tvars) = $2 in exit_type_variables_scope (); LDpredicate_reads (id, labels, tvars, $3, $4) } /* type declaration */ | TYPE poly_id_type SEMICOLON { let (id,tvars) = $2 in Logic_env.add_typename id; exit_type_variables_scope (); LDtype(id,tvars,None) } /* axiom */ | AXIOM poly_id COLON full_lexpr SEMICOLON { let (id,labels,tvars) = $2 in exit_type_variables_scope (); LDlemma (id, true, labels, tvars, $4) } ; logic_decl_loc: | logic_decl { loc_decl $1 } ; reads_clause: | /* epsilon */ { None } | READS zones { Some $2 } ; typedef: | ne_datacons_list { TDsum $1 } | full_logic_type { TDsyn $1 } ; datacons_list: | /* epsilon */ { [] } | PIPE datacons datacons_list { $2 :: $3 } ; ne_datacons_list: | datacons datacons_list { $1 :: $2 } | PIPE datacons datacons_list { $2 :: $3 } ; datacons: | full_identifier { ($1,[]) } | full_identifier LPAR ne_type_list RPAR { ($1,$3) } ; ne_type_list: | full_logic_type { [$1] } | full_logic_type COMMA ne_type_list { $1::$3 } indcases: | /* epsilon */ { [] } | CASE poly_id COLON full_lexpr SEMICOLON indcases { let (id,labels,tvars) = $2 in exit_type_variables_scope (); (id,labels,tvars,$4)::$6 } ; ne_tvar_list: | full_identifier { [$1] } | full_identifier COMMA ne_tvar_list { $1 :: $3 } ; ne_label_list: | label_name { [$1] } | label_name COMMA ne_label_list { $1 :: $3 } ; opt_label_1: | opt_label_list { match $1 with | [] -> None | l::[] -> Some l | _ -> raise (Not_well_formed (loc(),"Only one label is allowed")) } ; opt_label_2: | opt_label_list { match $1 with | [] -> None | l1::l2::[] -> Some (l1,l2) | _::[] -> raise (Not_well_formed (loc(),"One label is missing")) | _ -> raise (Not_well_formed (loc(),"Only two labels are allowed")) } ; opt_label_list: | /* epsilon */ { [] } | LBRACE ne_label_list RBRACE { $2 } ; /* names */ label_name: | any_identifier { $1 } ; behavior_name_list: | /* epsilon */ { [] } | ne_behavior_name_list { $1 } ; ne_behavior_name_list: | behavior_name { [$1] } | behavior_name COMMA ne_behavior_name_list {$1 :: $3} ; behavior_name: | any_identifier { $1 } ; any_identifier: | identifier_or_typename { $1 } | keyword { $1 } ; any_identifier_non_logic: | identifier_or_typename { $1 } | non_logic_keyword { $1 } identifier_or_typename: | IDENTIFIER { $1 } | TYPENAME { $1 } ; identifier: | IDENTIFIER { $1 } ; bounded_var: | identifier { $1 } | TYPENAME /* Since TYPENAME cannot be accepted by lexpr rule */ { raise (Not_well_formed(loc (), "Type names are not allowed as binding variable")) } ; c_keyword: | CASE { "case" } | CHAR { "char" } | BOOLEAN { "boolean" } | CONST { "const" } | DOUBLE { "double" } | ELSE { "else" } | ENUM { "enum" } | FLOAT { "float" } | IF { "if" } | INT { "int" } | LONG { "long" } | SHORT { "short" } | SIGNED { "signed" } | SIZEOF { "sizeof" } | STATIC { "static" } | STRUCT { "struct" } | UNION { "union" } | UNSIGNED { "unsigned" } | VOID { "void" } ; acsl_c_keyword: | FOR { "for" } | VOLATILE { "volatile" } ; post_cond: | ENSURES { Normal, "normal" } | EXITS { Exits, "exits" } | BREAKS { Breaks, "breaks" } | CONTINUES { Continues, "continues" } | RETURNS { Returns, "returns" } ; is_acsl_spec: | post_cond { snd $1 } | ASSIGNS { "assigns" } | ALLOCATES { "allocates" } | FREES { "frees" } | BEHAVIOR { "behavior" } | REQUIRES { "requires" } | TERMINATES { "terminates" } | COMPLETE { "complete" } | DECREASES { "decreases" } | DISJOINT { "disjoint" } ; is_acsl_decl_or_code_annot: | ASSERT { "assert" } | ASSUMES { "assumes" } | GLOBAL { "global" } | IMPACT { "impact" } | INDUCTIVE { "inductive" } | INVARIANT { "invariant" } | LEMMA { "lemma" } | LOOP { "loop" } | PRAGMA { "pragma" } | PREDICATE { "predicate" } | SLICE { "slice" } | TYPE { "type" } | MODEL { "model" } | AXIOM { "axiom" } | VARIANT { "variant" } | AXIOMATIC { "axiomatic" } ; is_acsl_other: | BEHAVIORS { "behaviors" } | INTEGER { "integer" } | LABEL { "label" } | READS { "reads" } | REAL { "real" } | WRITES { "writes" } | CUSTOM { "custom" } ; is_ext_spec: | CONTRACT { "contract" } | FUNCTION { "function" } | MODULE { "module" } | INCLUDE { "include" } | EXT_AT { "at" } | EXT_LET { "let" } ; keyword: | LOGIC { "logic" } | non_logic_keyword { $1 } non_logic_keyword: | c_keyword { $1 } | acsl_c_keyword { $1 } | is_ext_spec { $1 } | is_acsl_spec { $1 } | is_acsl_decl_or_code_annot { $1 } | is_acsl_other { $1 } ; /* ACSL extension language */ grammar_extension_name: | full_identifier_or_typename { check_registered $1 } | is_acsl_other { check_registered $1 } | c_keyword { check_registered $1 } ; /* Spec are parsed after the function prototype itself. This rule distinguishes between spec and other annotations by the first keyword of the annotation. in order to return the appropriate token in clexer.mll */ is_spec: | is_acsl_spec { () } | grammar_extension_name { () } /* ACSL extension language */ ; bs_keyword: | ALLOCABLE { () } | ALLOCATION { () } | AUTOMATIC { () } | AT { () } | BASE_ADDR { () } | BLOCK_LENGTH { () } | DYNAMIC { () } | EMPTY { () } | FALSE { () } | FORALL { () } | FREEABLE { () } | FRESH { () } | FROM { () } | INTER { () } | LAMBDA { () } | LET { () } | NOTHING { () } | NULL { () } | OLD { () } | OFFSET { () } | REGISTER { () } | RESULT { () } | SEPARATED { () } | TRUE { () } | BSTYPE { () } | TYPEOF { () } | BSUNION { () } | UNALLOCATED { () } | VALID { () } | VALID_INDEX { () } | VALID_RANGE { () } | VALID_READ { () } | INITIALIZED { () } | WITH { () } ; wildcard: | any_identifier { () } | bs_keyword { () } | AMP { () } | AND { () } | ARROW { () } | BIFF { () } | BIMPLIES { () } | COLON { () } | COLON2 { () } | COLONCOLON { () } | COLONGT { () } | COMMA { () } | CONSTANT { () } | CONSTANT10 { () } | DOLLAR { () } | DOT { () } | DOTDOT { () } | DOTDOTDOT { () } | EQ { () } | EQUAL { () } | EXISTS { () } | GE { () } | GHOST { () } | GT { () } | GTGT { () } | HAT { () } | HATHAT { () } | IFF { () } | IMPLIES { () } | LBRACE { () } | LE { () } | LPAR { () } | LSQUARE { () } | LT { () } | LTCOLON { () } | LTLT { () } | MINUS { () } | NE { () } | NOT { () } | OR { () } | PERCENT { () } | PIPE { () } | PLUS { () } | QUESTION { () } | RBRACE { () } | RPAR { () } | RSQUARE { () } | SEMICOLON { () } | SLASH { () } | STAR { () } | STRING_LITERAL { () } | TILDE { () } ; any: | wildcard { () } | wildcard any { () } ; %% (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/logic_print.mli0000644000175000017500000000523612155630366021461 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Pretty-printing of a parsed logic tree. *) open Logic_ptree val print_constant: Format.formatter -> constant -> unit (** First arguments prints the name of identifier declared with the corresponding type (None for pure type. C syntax makes impossible to separate printing the type and the identifier in a declaration... *) val print_logic_type: (Format.formatter -> unit) option -> Format.formatter -> logic_type -> unit val print_quantifiers: Format.formatter -> quantifiers -> unit val print_lexpr: Format.formatter -> lexpr -> unit val print_type_annot: Format.formatter -> type_annot -> unit val print_typedef: Format.formatter -> typedef -> unit val print_decl: Format.formatter -> decl -> unit val print_spec: Format.formatter -> spec -> unit val print_code_annot: Format.formatter -> code_annot -> unit val print_assigns: Format.formatter -> assigns -> unit val print_variant: Format.formatter -> variant -> unit frama-c-Fluorine-20130601/cil/src/logic/logic_const.ml0000644000175000017500000003170512155630366021302 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) open Cil_types (** Smart constructors for the logic. @plugin development guide *) (** {1 Identification Numbers} *) module AnnotId = State_builder.SharedCounter(struct let name = "annot_counter" end) module PredicateId = State_builder.SharedCounter(struct let name = "predicate_counter" end) module TermId = State_builder.SharedCounter(struct let name = "term_counter" end) let new_code_annotation annot = { annot_content = annot ; annot_id = AnnotId.next () } let fresh_code_annotation = AnnotId.next let new_predicate p = { ip_id = PredicateId.next (); ip_content = p.content; ip_loc = p.loc; ip_name = p.name } let fresh_predicate_id = PredicateId.next let pred_of_id_pred p = { name = p.ip_name; loc = p.ip_loc; content = p.ip_content } let refresh_predicate p = { p with ip_id = PredicateId.next () } let new_identified_term t = { it_id = TermId.next (); it_content = t } let fresh_term_id = TermId.next let refresh_identified_term d = new_identified_term d.it_content let refresh_identified_term_list = List.map refresh_identified_term let refresh_deps = function | FromAny -> FromAny | From l -> From(refresh_identified_term_list l) let refresh_from (a,d) = (new_identified_term a.it_content, refresh_deps d) let refresh_allocation = function | FreeAllocAny -> FreeAllocAny | FreeAlloc(f,a) -> FreeAlloc((refresh_identified_term_list f),refresh_identified_term_list a) let refresh_assigns = function | WritesAny -> WritesAny | Writes l -> Writes(List.map refresh_from l) let refresh_behavior b = { b with b_requires = List.map refresh_predicate b.b_requires; b_assumes = List.map refresh_predicate b.b_assumes; b_post_cond = List.map (fun (k,p) -> (k, refresh_predicate p)) b.b_post_cond; b_assigns = refresh_assigns b.b_assigns; b_allocation = refresh_allocation b.b_allocation; b_extended = List.map (fun (s,n,p) -> (s,n,List.map refresh_predicate p)) b.b_extended } let refresh_spec s = { spec_behavior = List.map refresh_behavior s.spec_behavior; spec_variant = s.spec_variant; spec_terminates = Extlib.opt_map refresh_predicate s.spec_terminates; spec_complete_behaviors = s.spec_complete_behaviors; spec_disjoint_behaviors = s.spec_disjoint_behaviors; } let refresh_code_annotation annot = let content = match annot.annot_content with | AAssert _ | AInvariant _ | AAllocation _ | AVariant _ | APragma _ as c -> c | AStmtSpec(l,spec) -> AStmtSpec(l, refresh_spec spec) | AAssigns(l,a) -> AAssigns(l, refresh_assigns a) in new_code_annotation content (** {1 Smart constructors} *) (** {2 pre-defined logic labels} *) (* empty line for ocamldoc *) let pre_label = LogicLabel (None, "Pre") let post_label = LogicLabel (None, "Post") let here_label = LogicLabel (None, "Here") let old_label = LogicLabel (None, "Old") let loop_current_label = LogicLabel (None, "LoopCurrent") let loop_entry_label = LogicLabel (None, "LoopEntry") (** {2 Types} *) (** [set_conversion ty1 ty2] returns a set type as soon as [ty1] and/or [ty2] is a set. Elements have type [ty1], or the type of the elements of [ty1] if it is itself a set-type ({i.e.} we do not build set of sets that way).*) let set_conversion ty1 ty2 = match ty1,ty2 with | Ltype ({lt_name = "set"},[_]),_ -> ty1 | ty1, Ltype({lt_name = "set"} as lt,[_]) -> Ltype(lt,[ty1]) | _ -> ty1 (** converts a type into the corresponding set type if needed. *) let make_set_type ty = set_conversion ty (Ltype(Logic_env.find_logic_type "set",[Lvar "_"])) (** returns the type of elements of a set type. @raise Failure if the input type is not a set type. *) let type_of_element ty = match ty with | Ltype ({lt_name = "set"},[t]) -> t | _ -> failwith "not a set type" (** [plain_or_set f t] applies [f] to [t] or to the type of elements of [t] if it is a set type *) let plain_or_set f = function | Ltype ({lt_name = "set"},[t]) -> f t | t -> f t let transform_element f t = set_conversion (plain_or_set f t) t let is_plain_type = function | Ltype ({lt_name = "set"},[_]) -> false | _ -> true let is_boolean_type = function | Ltype ({ lt_name = s }, []) when s = Utf8_logic.boolean -> true | _ -> false (** {2 Offsets} *) let rec lastTermOffset (off: term_offset) : term_offset = match off with | TNoOffset | TField(_,TNoOffset) | TIndex(_,TNoOffset) | TModel(_,TNoOffset)-> off | TField(_,off) | TIndex(_,off) | TModel(_,off) -> lastTermOffset off let rec addTermOffset (toadd: term_offset) (off: term_offset) : term_offset = match off with | TNoOffset -> toadd | TField(fid', offset) -> TField(fid', addTermOffset toadd offset) | TIndex(t, offset) -> TIndex(t, addTermOffset toadd offset) | TModel(m,offset) -> TModel(m,addTermOffset toadd offset) let addTermOffsetLval toadd (b, off) : term_lval = b, addTermOffset toadd off (** {2 Terms} *) (* empty line for ocamldoc *) (** @plugin development guide *) let term ?(loc=Lexing.dummy_pos, Lexing.dummy_pos) term typ = { term_node = term; term_type = typ; term_name = []; term_loc = loc } let taddrof ?(loc=Lexing.dummy_pos, Lexing.dummy_pos) lv typ = match lv with | TMem h, TNoOffset -> h | _ -> term ~loc (TAddrOf lv) typ (** range of integers *) let trange ?(loc=Lexing.dummy_pos, Lexing.dummy_pos) (low,high) = term ~loc (Trange(low,high)) (Ltype(Logic_env.find_logic_type "set",[Linteger])) (** An integer constant (of type integer). *) let tinteger ?(loc=Cil_datatype.Location.unknown) i = term ~loc (TConst (Integer (Integer.of_int i,None))) Linteger (** An integer constant (of type integer) from an int64 . *) let tinteger_s64 ?(loc=Cil_datatype.Location.unknown) i64 = term ~loc (TConst (Integer (Integer.of_int64 i64,None))) Linteger let tint ?(loc=Cil_datatype.Location.unknown) i = term ~loc (TConst (Integer (i,None))) Linteger (** A real constant (of type real) from a Caml float . *) let treal ?(loc=Cil_datatype.Location.unknown) f = let s = Pretty_utils.to_string Floating_point.pretty f in let r = { r_literal = s ; r_upper = f ; r_lower = f ; r_nearest = f ; } in term ~loc (TConst (LReal r)) Lreal let treal_zero ?(loc=Cil_datatype.Location.unknown) ?(ltyp=Lreal) () = let zero = { r_nearest = 0.0 ; r_upper = 0.0 ; r_lower = 0.0 ; r_literal = "0." } in term ~loc (TConst (LReal zero)) ltyp let tat ?(loc=Cil_datatype.Location.unknown) (t,label) = term ~loc (Tat(t,label)) t.term_type let told ?(loc=Cil_datatype.Location.unknown) t = tat ~loc (t,old_label) let tvar ?(loc=Cil_datatype.Location.unknown) lv = term ~loc (TLval(TVar lv,TNoOffset)) lv.lv_type let tresult ?(loc=Cil_datatype.Location.unknown) typ = term ~loc (TLval(TResult typ,TNoOffset)) (Ctype typ) (* needed by Cil, upon which Logic_utils depends. TODO: some refactoring of these two files *) (** true if the given term is a lvalue denoting result or part of it *) let rec is_result t = match t.term_node with | TLval (TResult _,_) -> true | Tat(t,_) -> is_result t | _ -> false let rec is_exit_status t = match t.term_node with | TLval (TVar n,_) when n.lv_name = "\\exit_status" -> true | Tat(t,_) -> is_exit_status t | _ -> false (** {2 Predicate constructors} *) (* empty line for ocamldoc *) let unamed ?(loc=Cil_datatype.Location.unknown) p = {content = p ; loc = loc; name = [] } let ptrue = unamed Ptrue let pfalse = unamed Pfalse let pold ?(loc=Cil_datatype.Location.unknown) p = match p.content with | Ptrue | Pfalse -> p | _ -> {p with content = Pat(p, old_label); loc = loc} let papp ?(loc=Cil_datatype.Location.unknown) (p,lab,a) = unamed ~loc (Papp(p,lab,a)) let pand ?(loc=Cil_datatype.Location.unknown) (p1, p2) = match p1.content, p2.content with | Ptrue, _ -> p2 | _, Ptrue -> p1 | Pfalse, _ -> p1 | _, Pfalse -> p2 | _, _ -> unamed ~loc (Pand (p1, p2)) let por ?(loc=Cil_datatype.Location.unknown) (p1, p2) = match p1.content, p2.content with | Ptrue, _ -> p1 | _, Ptrue -> p2 | Pfalse, _ -> p2 | _, Pfalse -> p1 | _, _ -> unamed ~loc (Por (p1, p2)) let pxor ?(loc=Cil_datatype.Location.unknown) (p1, p2) = match p1.content, p2.content with | Ptrue, Ptrue -> unamed ~loc Pfalse | Ptrue, _ -> p1 | _, Ptrue -> p2 | Pfalse, _ -> p2 | _, Pfalse -> p1 | _,_ -> unamed ~loc (Pxor (p1,p2)) let pnot ?(loc=Cil_datatype.Location.unknown) p2 = match p2.content with | Ptrue -> {p2 with content = Pfalse; loc = loc } | Pfalse -> {p2 with content = Ptrue; loc = loc } | Pnot p -> p | _ -> unamed ~loc (Pnot p2) let pands l = List.fold_right (fun p1 p2 -> pand (p1, p2)) l ptrue let pors l = List.fold_right (fun p1 p2 -> por (p1, p2)) l pfalse let plet ?(loc=Cil_datatype.Location.unknown) p = match p.content with | (_, ({content = Ptrue} as p)) -> p | (v, p) -> unamed ~loc (Plet (v, p)) let pimplies ?(loc=Cil_datatype.Location.unknown) (p1,p2) = match p1.content, p2.content with | Ptrue, _ | _, Ptrue -> p2 | Pfalse, _ -> { name = p1.name; loc = loc; content = Ptrue } | _, _ -> unamed ~loc (Pimplies (p1, p2)) let pif ?(loc=Cil_datatype.Location.unknown) (t,p2,p3) = match (p2.content, p3.content) with | Ptrue, Ptrue -> ptrue | Pfalse, Pfalse -> pfalse | _,_ -> unamed ~loc (Pif (t,p2,p3)) let piff ?(loc=Cil_datatype.Location.unknown) (p2,p3) = match p2.content, p3.content with | Pfalse, Pfalse -> ptrue | Ptrue, _ -> p3 | _, Ptrue -> p2 | _,_ -> unamed ~loc (Piff (p2,p3)) (** @plugin development guide *) let prel ?(loc=Cil_datatype.Location.unknown) (a,b,c) = unamed ~loc (Prel(a,b,c)) let pforall ?(loc=Cil_datatype.Location.unknown) (l,p) = match l with | [] -> p | _ :: _ -> match p.content with | Ptrue -> p | _ -> unamed ~loc (Pforall (l,p)) let pexists ?(loc=Cil_datatype.Location.unknown) (l,p) = match l with | [] -> p | _ :: _ -> match p.content with | Pfalse -> p | _ -> unamed ~loc (Pexists (l,p)) let pfresh ?(loc=Cil_datatype.Location.unknown) (l1,l2,p,n) = unamed ~loc (Pfresh (l1,l2,p,n)) let pallocable ?(loc=Cil_datatype.Location.unknown) (l,p) = unamed ~loc (Pallocable (l,p)) let pfreeable ?(loc=Cil_datatype.Location.unknown) (l,p) = unamed ~loc (Pfreeable (l,p)) let pvalid_read ?(loc=Cil_datatype.Location.unknown) (l,p) = unamed ~loc (Pvalid_read (l,p)) let pvalid ?(loc=Cil_datatype.Location.unknown) (l,p) = unamed ~loc (Pvalid (l,p)) (* the index should be an integer or a range of integers *) let pvalid_index ?(loc=Cil_datatype.Location.unknown) (l,t1,t2) = let ty1 = t1.term_type in let ty2 = t2.term_type in let t, ty =(match t1.term_node with | TStartOf lv -> TAddrOf (addTermOffsetLval (TIndex(t2,TNoOffset)) lv) | _ -> TBinOp (PlusPI, t1, t2)), set_conversion ty1 ty2 in let t = term ~loc t ty in pvalid ~loc (l,t) (* the range should be a range of integers *) let pvalid_range ?(loc=Cil_datatype.Location.unknown) (l,t1,b1,b2) = let t2 = trange ((Some b1), (Some b2)) in pvalid_index ~loc (l,t1,t2) let pat ?(loc=Cil_datatype.Location.unknown) (p,q) = unamed ~loc (Pat (p,q)) let pinitialized ?(loc=Cil_datatype.Location.unknown) (l,p) = unamed ~loc (Pinitialized (l,p)) let psubtype ?(loc=Cil_datatype.Location.unknown) (p,q) = unamed ~loc (Psubtype (p,q)) let pseparated ?(loc=Cil_datatype.Location.unknown) seps = unamed ~loc (Pseparated seps) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/logic_utils.mli0000644000175000017500000003213012155630366021456 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Utilities for ACSL constructs. @plugin development guide *) open Cil_types (** exception raised when a parsed logic expression is syntactically not well-formed. *) exception Not_well_formed of Cil_types.location * string (** basic utilities for logic terms and predicates. See also {! Logic_const} to build terms and predicates. @plugin development guide *) (** add a logic function in the environment. See {!Logic_env.add_logic_function_gen}*) val add_logic_function : logic_info -> unit (** creates a new term @deprecated since Carbon-20101201 Use {!Logic_const.term} instead. *) val mk_dummy_term: term_node -> typ -> term (** {2 Types} *) (** instantiate type variables in a logic type. *) val instantiate : (string * logic_type) list -> logic_type -> logic_type (** expands logic type definitions. If the [unroll_typedef] flag is set to [true] (this is the default), C typedef will be expanded as well. *) val unroll_type : ?unroll_typedef:bool -> logic_type -> logic_type (** [isLogicType test typ] is [false] for pure logic types and the result of test for C types. *) val isLogicType : (typ -> bool) -> logic_type -> bool (** {3 Predefined tests over types} *) val isLogicArrayType : logic_type -> bool val isLogicCharType : logic_type -> bool val isLogicVoidType : logic_type -> bool val isLogicPointerType : logic_type -> bool val isLogicVoidPointerType : logic_type -> bool (** {3 Type conversions} *) (** @return the equivalent C type. @raise Failure if the type is purely logical *) val logicCType : logic_type -> typ (** transforms an array into pointer. *) val array_to_ptr : logic_type -> logic_type (** C type to logic type, with implicit conversion for arithmetic types. *) val typ_to_logic_type : typ -> logic_type (** {2 Predicates} *) val named_of_identified_predicate: identified_predicate -> predicate named (** transforms \old and \at(,Old) into \at(,L) for L a label pointing to the given statement, creating one if needed. *) val translate_old_label: stmt -> predicate named -> predicate named (** {2 Terms} *) (** [true] if the term denotes a C array. *) val is_C_array : term -> bool (** creates a TStartOf from an TLval. *) val mk_logic_StartOf : term -> term (** [true] if the term is a pointer. *) val isLogicPointer : term -> bool (** creates either a TStartOf or the corresponding TLval. *) val mk_logic_pointer_or_StartOf : term -> term (** creates a logic cast if required, with some automatic simplifications being performed automatically *) val mk_cast: ?loc:location -> typ -> term -> term (** [array_with_range arr size] returns the logic term [array'+{0..(size-1)}], [array'] being [array] cast to a pointer to char *) val array_with_range: exp -> term -> term (** Removes TLogic_coerce at head of term. *) val remove_logic_coerce: term -> term (** {2 Predicates} *) (** \valid_index *) (* val mk_pvalid_index: ?loc:location -> term * term -> predicate named *) (** \valid_range *) (* val mk_pvalid_range: ?loc:location -> term * term * term -> predicate named *) val pointer_comparable: ?loc:location -> term -> term -> predicate named (** \pointer_comparable @since Fluorine-20130401 *) (** {3 Conversion from exp to term}*) (** translates a C expression into an "equivalent" logical term. If cast is [true]: expressions with integral type are cast to corresponding C type. If cast is [false]: no cast performed to C type, except for constants since there are no logic integer constants for the time being => they keep their C type. @plugin development guide *) val expr_to_term : cast:bool -> exp -> term val lval_to_term_lval : cast:bool -> lval -> term_lval val host_to_term_host : cast:bool -> lhost -> term_lhost val offset_to_term_offset : cast:bool -> offset -> term_offset val constant_to_lconstant: constant -> logic_constant val lconstant_to_constant: logic_constant-> constant (** Parse the given string as a float logic constant, taking into account the fact that the constant may not be exactly representable. This function should only be called on strings that have been recognized by the parser as valid floats *) val string_to_float_lconstant: string -> logic_constant (** [remove_term_offset o] returns [o] without its last offset and this last offset. *) val remove_term_offset : term_offset -> term_offset * term_offset (** true if \result is included in the lval. *) val lval_contains_result : term_lhost -> bool (** true if \result is included in the offset. *) val loffset_contains_result : term_offset -> bool (** true if \result is included in the term *) val contains_result : term -> bool (** returns the body of the given predicate. @raise Not_found if the logic_info is not the definition of a predicate. *) val get_pred_body : logic_info -> predicate named (** true if the term is \result or an offset of \result. @deprecated since Carbon-20101201 use Logic_const.is_result instead *) val is_result : term -> bool val lhost_c_type : term_lhost -> typ (** {2 Predicates} *) (** [true] if the predicate is Ptrue. @since Nitrogen-20111001 *) val is_trivially_true: predicate named -> bool (** [true] if the predicate is Pfalse @since Nitrogen-20111001 *) val is_trivially_false: predicate named -> bool (** {2 Structural equality between annotations} *) val is_same_list: ('a -> 'a -> bool) -> 'a list -> 'a list -> bool val is_same_logic_label : logic_label -> logic_label -> bool (** @since Nitrogen-20111001 *) val is_same_pconstant: Logic_ptree.constant -> Logic_ptree.constant -> bool val is_same_type : logic_type -> logic_type -> bool val is_same_var : logic_var -> logic_var -> bool val is_same_logic_signature : logic_info -> logic_info -> bool val is_same_logic_profile : logic_info -> logic_info -> bool val is_same_builtin_profile : builtin_logic_info -> builtin_logic_info -> bool val is_same_logic_ctor_info : logic_ctor_info -> logic_ctor_info -> bool (** @deprecated Nitrogen-20111001 use {!Cil.compareConstant} instead. *) val is_same_constant : constant -> constant -> bool val is_same_term : term -> term -> bool val is_same_logic_info : logic_info -> logic_info -> bool val is_same_logic_body : logic_body -> logic_body -> bool val is_same_indcase : string * logic_label list * string list * predicate named -> string * logic_label list * string list * predicate named -> bool val is_same_tlval : term_lval -> term_lval -> bool val is_same_lhost : term_lhost -> term_lhost -> bool val is_same_offset : term_offset -> term_offset -> bool val is_same_predicate : predicate -> predicate -> bool val is_same_named_predicate : predicate named -> predicate named -> bool val is_same_identified_predicate : identified_predicate -> identified_predicate -> bool val is_same_identified_term : identified_term -> identified_term -> bool val is_same_deps : identified_term deps -> identified_term deps -> bool val is_same_allocation : identified_term allocation -> identified_term allocation -> bool val is_same_assigns : identified_term assigns -> identified_term assigns -> bool val is_same_variant : term variant -> term variant -> bool val is_same_post_cond : termination_kind * identified_predicate -> termination_kind * identified_predicate -> bool val is_same_behavior : funbehavior -> funbehavior -> bool val is_same_spec : funspec -> funspec -> bool val is_same_logic_type_def : logic_type_def -> logic_type_def -> bool val is_same_logic_type_info : logic_type_info -> logic_type_info -> bool val is_same_loop_pragma : term loop_pragma -> term loop_pragma -> bool val is_same_slice_pragma : term slice_pragma -> term slice_pragma -> bool val is_same_impact_pragma : term impact_pragma -> term impact_pragma -> bool val is_same_pragma : term pragma -> term pragma -> bool val is_same_code_annotation : code_annotation -> code_annotation -> bool val is_same_global_annotation : global_annotation -> global_annotation -> bool val is_same_axiomatic : global_annotation list -> global_annotation list -> bool (** @since Oxygen-20120901 *) val is_same_model_info: model_info -> model_info -> bool val is_same_lexpr: Logic_ptree.lexpr -> Logic_ptree.lexpr -> bool (** hash function compatible with is_same_term *) val hash_term: term -> int (** {2 Merging contracts} *) val get_behavior_names : ('a, 'b, 'c) spec -> string list (** Concatenates two assigns if both are defined, returns WritesAny if one (or both) of them is WritesAny. @since Nitrogen-20111001 *) val concat_assigns: identified_term assigns -> identified_term assigns -> identified_term assigns (** merge assigns: take the one that is defined and select an arbitrary one if both are, emitting a warning unless both are syntactically the same. *) val merge_assigns : identified_term assigns -> identified_term assigns -> identified_term assigns (** Concatenates two allocation clauses if both are defined, returns FreeAllocAny if one (or both) of them is FreeAllocAny. @since Nitrogen-20111001 *) val concat_allocation: identified_term allocation -> identified_term allocation -> identified_term allocation (** merge allocation: take the one that is defined and select an arbitrary one if both are, emitting a warning unless both are syntactically the same. @since Oxygen-20120901 *) val merge_allocation : identified_term allocation -> identified_term allocation -> identified_term allocation val merge_behaviors : silent:bool -> funbehavior list -> funbehavior list -> funbehavior list (** [merge_funspec oldspec newspec] merges [newspec] into [oldspec]. If the funspec belongs to a kernel function, do not forget to call {!Kernel_function.set_spec} after merging. *) val merge_funspec : ?silent_about_merging_behav:bool -> funspec -> funspec -> unit (** Reset the given funspec to empty. @since Nitrogen-20111001 *) val clear_funspec: funspec -> unit (** {2 Discriminating code_annotations} *) (** Functions below allows to test a special kind of code_annotation. Use them in conjunction with {!Annotations.get_filter} to retrieve a particular kind of annotations associated to a statement. *) val is_assert : code_annotation -> bool val is_contract : code_annotation -> bool val is_stmt_invariant : code_annotation -> bool val is_loop_invariant : code_annotation -> bool val is_invariant : code_annotation -> bool val is_variant : code_annotation -> bool val is_assigns : code_annotation -> bool val is_pragma : code_annotation -> bool val is_loop_pragma : code_annotation -> bool val is_slice_pragma : code_annotation -> bool val is_impact_pragma : code_annotation -> bool val is_loop_annot : code_annotation -> bool val is_property_pragma : term pragma -> bool (** Should this pragma be proved by plugins *) val extract_loop_pragma : code_annotation list -> term loop_pragma list val extract_contract : code_annotation list -> (string list * funspec) list (** {2 Parsing hackery} *) (** Values that control the various modes of the parser and lexer for logic. Use with care. *) (** register a given name as a clause name for extended contract. *) val register_extension: string -> unit val is_extension: string -> bool val kw_c_mode : bool ref val enter_kw_c_mode : unit -> unit val exit_kw_c_mode : unit -> unit val is_kw_c_mode : unit -> bool val rt_type_mode : bool ref val enter_rt_type_mode : unit -> unit val exit_rt_type_mode : unit -> unit val is_rt_type_mode : unit -> bool (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/utf8_logic.mli0000644000175000017500000000421112155630366021203 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** UTF-8 string for logic symbols. *) val forall : string val exists : string val eq : string val neq : string val le : string val ge : string val implies : string val iff : string val conj : string val disj : string val neg : string val x_or : string val inset : string val minus: string val boolean: string val integer: string val real: string (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/logic_env.ml0000644000175000017500000002475612155630366020754 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) open Cil_types module CurrentLoc = Cil_const.CurrentLoc let error (b,_e) fstring = Kernel.abort ~source:b ("In annotation: " ^^ fstring) module Logic_builtin = State_builder.Hashtbl (Datatype.String.Hashtbl) (Cil_datatype.Builtin_logic_info) (struct let name = "built-in logic functions table" let dependencies = [] let size = 17 end) module Logic_info = State_builder.Hashtbl (Datatype.String.Hashtbl) (Cil_datatype.Logic_info) (struct let name = "logic functions table" let dependencies = [ Logic_builtin.self ] let size = 17 end) module Logic_builtin_used = struct include State_builder.Ref (Cil_datatype.Logic_info.Set) (struct let name = "used built-in logic functions" let dependencies = [ Logic_builtin.self; Logic_info.self ] let default () = Cil_datatype.Logic_info.Set.empty end) let add li = set (Cil_datatype.Logic_info.Set.add li (get())) let mem li = Cil_datatype.Logic_info.Set.mem li (get()) let iter f = Cil_datatype.Logic_info.Set.iter f (get()) end module Logic_type_builtin = State_builder.Hashtbl (Datatype.String.Hashtbl) (Cil_datatype.Logic_type_info) (struct let name = "built-in logic types table" let dependencies = [] let size = 17 end) let is_builtin_logic_type = Logic_type_builtin.mem module Logic_type_info = State_builder.Hashtbl (Datatype.String.Hashtbl) (Cil_datatype.Logic_type_info) (struct let name = "logic types table" let dependencies = [ Logic_type_builtin.self ] let size = 17 end) module Logic_ctor_builtin = State_builder.Hashtbl (Datatype.String.Hashtbl) (Cil_datatype.Logic_ctor_info) (struct let name = "built-in logic contructors table" let dependencies = [] let size = 17 end) module Logic_ctor_info = State_builder.Hashtbl (Datatype.String.Hashtbl) (Cil_datatype.Logic_ctor_info) (struct let name = "logic contructors table" let dependencies = [ Logic_ctor_builtin.self ] let size = 17 end) module Lemmas = State_builder.Hashtbl (Datatype.String.Hashtbl) (Cil_datatype.Global_annotation) (struct let name = "lemmas" let dependencies = [] let size = 17 end) module Model_info = State_builder.Hashtbl (Datatype.String.Hashtbl) (Cil_datatype.Model_info) (struct let name = "model fields table" let dependencies = [] let size = 17 end) (* We depend from ast, but it is initialized after Logic_typing... *) let init_dependencies from = State_dependency_graph.add_dependencies ~from [ Logic_info.self; Logic_type_info.self; Logic_ctor_info.self; Lemmas.self; Model_info.self; ] let builtin_to_logic b = let params = List.map (fun (x, t) -> Cil_const.make_logic_var_formal x t) b.bl_profile in let li = Cil_const.make_logic_info b.bl_name in li.l_type <- b.bl_type; li.l_tparams <- b.bl_params; li.l_profile <- params; li.l_labels <- b.bl_labels; Logic_builtin_used.add li; Logic_info.add b.bl_name li; li let is_builtin_logic_function = Logic_builtin.mem let is_logic_function s = is_builtin_logic_function s || Logic_info.mem s let find_all_logic_functions s = match Logic_info.find_all s with | [] -> let builtins = Logic_builtin.find_all s in let res = List.map builtin_to_logic builtins in (* Format.printf "builtin func:@."; List.iter (fun x -> Format.printf "%s#%d@." x.l_var_info.lv_name x.l_var_info.lv_id) res; *) res | l -> (* Format.printf "func in env:@."; List.iter (fun x -> Format.printf "%s#%d@." x.l_var_info.lv_name x.l_var_info.lv_id) l; *) l let find_logic_cons vi = List.find (fun x -> Cil_datatype.Logic_var.equal x.l_var_info vi) (Logic_info.find_all vi.lv_name) (* add_logic_function takes as argument a function eq_logic_info which decides whether two logic_info are identical. It is intended to be Logic_utils.is_same_logic_profile, but this one can not be called from here since it will cause a circular dependency Logic_env <- Logic_utils <- Cil <- Logic_env *) let add_logic_function_gen is_same_profile l = if is_builtin_logic_function l.l_var_info.lv_name then error (CurrentLoc.get()) "logic function or predicate %s is built-in. You can not redefine it" l.l_var_info.lv_name ; List.iter (fun li -> if is_same_profile li l then error (CurrentLoc.get ()) "already declared logic function or predicate %s with same profile" l.l_var_info.lv_name) (Logic_info.find_all l.l_var_info.lv_name); Logic_info.add l.l_var_info.lv_name l let remove_logic_function = Logic_info.remove let is_logic_type = Logic_type_info.mem let find_logic_type = Logic_type_info.find let add_logic_type t infos = if is_logic_type t (* type variables hide type definitions on their scope *) then error (CurrentLoc.get ()) "logic type %s already declared" t else Logic_type_info.add t infos let remove_logic_type = Logic_type_info.remove let is_logic_ctor = Logic_ctor_info.mem let find_logic_ctor = Logic_ctor_info.find let add_logic_ctor c infos = if is_logic_ctor c then error (CurrentLoc.get ()) "logic constructor %s already declared" c else Logic_ctor_info.add c infos let remove_logic_ctor = Logic_ctor_info.remove let is_model_field = Model_info.mem let find_all_model_fields s = Model_info.find_all s let find_model_field s typ = let l = Model_info.find_all s in let rec find_cons typ = try List.find (fun x -> Cil_datatype.Typ.equal x.mi_base_type typ) l with Not_found as e -> (* Don't use Cil.unrollType here: unrollType will unroll until it finds something other than TNamed. We want to go step by step. *) (match typ with | TNamed(ti,_) -> find_cons ti.ttype | _ -> raise e) in find_cons typ let add_model_field m = try ignore (find_model_field m.mi_name m.mi_base_type); error (CurrentLoc.get()) "Cannot add model field %s to type %a: it already exists." m.mi_name Cil_datatype.Typ.pretty m.mi_base_type with Not_found -> Model_info.add m.mi_name m let remove_model_field = Model_info.remove let is_builtin_logic_ctor = Logic_ctor_builtin.mem let builtin_states = [ Logic_builtin.self; Logic_type_builtin.self; Logic_ctor_builtin.self ] module Builtins= struct include Hook.Make(struct end) (* ensures we do not apply the hooks twice *) module Applied = State_builder.False_ref (struct let name = "Application of logic built-ins hook" let dependencies = builtin_states (* if the built-in states are not kept, hooks must be replayed. *) end) let apply () = Kernel.feedback ~level:5 "Applying logic built-ins hooks for project %s" (Project.get_name (Project.current())); if Applied.get () then Kernel.feedback ~level:5 "Already applied" else begin Applied.set true; apply () end end let prepare_tables () = Logic_ctor_info.clear (); Logic_type_info.clear (); Logic_info.clear (); Lemmas.clear (); Model_info.clear (); Logic_type_builtin.iter Logic_type_info.add; Logic_ctor_builtin.iter Logic_ctor_info.add; Logic_builtin_used.iter (fun x -> Logic_info.add x.l_var_info.lv_name x) (** C typedefs *) (** - true => identifier is a type name - false => identifier is a plain identifier *) let typenames: (string, bool) Hashtbl.t = Hashtbl.create 13 let add_typename t = Hashtbl.add typenames t true let hide_typename t = Hashtbl.add typenames t false let remove_typename t = Hashtbl.remove typenames t let reset_typenames () = Hashtbl.clear typenames let typename_status t = try Hashtbl.find typenames t with Not_found -> false let builtin_types_as_typenames () = Logic_type_builtin.iter (fun x _ -> add_typename x) let add_builtin_logic_function_gen is_same_profile l = List.iter (fun li -> if is_same_profile li l then error (CurrentLoc.get ()) "already declared builtin logic function or predicate \ %s with same profile" l.bl_name) (Logic_builtin.find_all l.bl_name); Logic_builtin.add l.bl_name l let add_builtin_logic_type name infos = if not (Logic_type_builtin.mem name) then begin Logic_type_builtin.add name infos; add_typename name; add_logic_type name infos end let add_builtin_logic_ctor name infos = if not (Logic_ctor_builtin.mem name) then begin Logic_ctor_builtin.add name infos; add_logic_ctor name infos end let iter_builtin_logic_function f = Logic_builtin.iter (fun _ info -> f info) let iter_builtin_logic_type f = Logic_type_builtin.iter (fun _ info -> f info) let iter_builtin_logic_ctor f = Logic_ctor_builtin.iter (fun _ info -> f info) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/logic_env.mli0000644000175000017500000001510512155630366021111 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** {1 Global Logic Environment} *) open Cil_types (** {2 Global Tables} *) module Logic_info: State_builder.Hashtbl with type key = string and type data = Cil_types.logic_info module Logic_type_info: State_builder.Hashtbl with type key = string and type data = Cil_types.logic_type_info module Logic_ctor_info: State_builder.Hashtbl with type key = string and type data = Cil_types.logic_ctor_info (** @since Oxygen-20120901 *) module Model_info: State_builder.Hashtbl with type key = string and type data = Cil_types.model_info (** @since Oxygen-20120901 *) module Lemmas: State_builder.Hashtbl with type key = string and type data = Cil_types.global_annotation val builtin_states: State.t list (** {2 Shortcuts to the functions of the modules above} *) (** Prepare all internal tables before their uses: clear all tables except builtins. *) val prepare_tables : unit -> unit (** {3 Add an user-defined object} *) (** add_logic_function_gen takes as argument a function eq_logic_info which decides whether two logic_info are identical. It is intended to be Logic_utils.is_same_logic_profile, but this one can not be called from here since it will cause a circular dependency Logic_env <- Logic_utils <- Cil <- Logic_env. {b Do not use this function directly} unless you're really sure about what you're doing. Use {!Logic_utils.add_logic_function} instead. *) val add_logic_function_gen: (logic_info -> logic_info -> bool) -> logic_info -> unit val add_logic_type: string -> logic_type_info -> unit val add_logic_ctor: string -> logic_ctor_info -> unit (** @since Oxygen-20120901 *) val add_model_field: model_info -> unit (** {3 Add a builtin object} *) module Builtins: sig val apply: unit -> unit (** adds all requested objects in the environment. *) val extend: (unit -> unit) -> unit (** request an addition in the environment. Use one of the functions below in the body of the argument. *) end (** logic function/predicates that are effectively used in current project. *) module Logic_builtin_used: sig val add: logic_info -> unit val mem: logic_info -> bool val iter: (logic_info -> unit) -> unit val self: State.t end (** see add_logic_function_gen above *) val add_builtin_logic_function_gen: (builtin_logic_info -> builtin_logic_info -> bool) -> builtin_logic_info -> unit val add_builtin_logic_type: string -> logic_type_info -> unit val add_builtin_logic_ctor: string -> logic_ctor_info -> unit val is_builtin_logic_function: string -> bool val is_builtin_logic_type: string -> bool val is_builtin_logic_ctor: string -> bool val iter_builtin_logic_function: (builtin_logic_info -> unit) -> unit val iter_builtin_logic_type: (logic_type_info -> unit) -> unit val iter_builtin_logic_ctor: (logic_ctor_info -> unit) -> unit (** {3 searching the environment} *) val find_all_logic_functions : string -> logic_info list (** returns all model fields of the same name. @since Oxygen-20120901 *) val find_all_model_fields: string -> model_info list (** [find_model_info field typ] returns the model field associated to [field] in type [typ]. @raise Not_found if no such type exists. @since Oxygen-20120901 *) val find_model_field: string -> typ -> model_info (** cons is a logic function with no argument. It is used as a variable, but may occasionally need to find associated logic_info. @raise Not_found if the given varinfo is not associated to a global logic constant. *) val find_logic_cons: logic_var -> logic_info val find_logic_type: string -> logic_type_info val find_logic_ctor: string -> logic_ctor_info (** {3 tests of existence} *) val is_logic_function: string -> bool val is_logic_type: string -> bool val is_logic_ctor: string -> bool (** @since Oxygen-20120901 *) val is_model_field: string -> bool (** {3 removing} *) val remove_logic_function: string -> unit val remove_logic_type: string -> unit val remove_logic_ctor: string -> unit (** @since Oxygen-20120901 *) val remove_model_field: string -> unit (** {2 Typename table} *) (** marks an identifier as being a typename in the logic *) val add_typename: string -> unit (** marks temporarily a typename as being a normal identifier in the logic *) val hide_typename: string -> unit (** removes latest typename status associated to a given identifier *) val remove_typename: string -> unit (** erases all the typename status *) val reset_typenames: unit -> unit (** returns the typename status of the given identifier. *) val typename_status: string -> bool (** marks builtin logical types as logical typenames for the logic lexer. *) val builtin_types_as_typenames: unit -> unit (** {2 Internal use} *) val init_dependencies: State.t -> unit (** Used to postpone dependency of Lenv global tables wrt Cil_state, which is initialized afterwards. *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/logic_const.mli0000644000175000017500000002334312155630366021452 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Smart contructors for logic annotations. @plugin development guide *) open Cil_types open Cil_datatype (* ************************************************************************** *) (** {2 Nodes with a unique ID} *) (* ************************************************************************** *) (** creates a code annotation with a fresh id. *) val new_code_annotation : (term, predicate named, identified_predicate, identified_term) code_annot -> code_annotation (** @return a fresh id for a code annotation. *) val fresh_code_annotation: unit -> int (** set a fresh id to an existing code annotation*) val refresh_code_annotation: code_annotation -> code_annotation (** creates a new identified predicate with a fresh id. *) val new_predicate: predicate named -> identified_predicate (** Gives a new id to an existing predicate. @since Oxygen-20120901 *) val refresh_predicate: identified_predicate -> identified_predicate (** @return a fresh id for predicates *) val fresh_predicate_id: unit -> int (** extract a named predicate for an identified predicate. *) val pred_of_id_pred: identified_predicate -> predicate named (** creates a new identified term with a fresh id*) val new_identified_term: term -> identified_term (** Gives a new id to an existing predicate @since Oxygen-20120901 *) val refresh_identified_term: identified_term -> identified_term (** @return a fresh id from an identified term*) val fresh_term_id: unit -> int (* ************************************************************************** *) (** {2 Logic labels} *) (* ************************************************************************** *) val pre_label: logic_label val post_label: logic_label val here_label: logic_label val old_label: logic_label val loop_current_label: logic_label val loop_entry_label: logic_label (* ************************************************************************** *) (** {2 Predicates} *) (* ************************************************************************** *) (** makes a predicate with no name. Default location is unknown.*) val unamed: ?loc:location -> 'a -> 'a named (** \true *) val ptrue: predicate named (** \false *) val pfalse: predicate named (** \old *) val pold: ?loc:location -> predicate named -> predicate named (** application of predicate*) val papp: ?loc:location -> logic_info * (logic_label * logic_label) list * term list -> predicate named (** && *) val pand: ?loc:location -> predicate named * predicate named -> predicate named (** || *) val por: ?loc:location -> predicate named * predicate named -> predicate named (** ^^ *) val pxor: ?loc:location -> predicate named * predicate named -> predicate named (** ! *) val pnot: ?loc:location -> predicate named -> predicate named (** Folds && over a list of predicates. *) val pands: predicate named list -> predicate named (** Folds || over a list of predicates. *) val pors: predicate named list -> predicate named (** local binding *) val plet: ?loc:location -> (logic_info * predicate named) named -> predicate named (** ==> *) val pimplies : ?loc:location -> predicate named * predicate named -> predicate named (** ? : *) val pif: ?loc:location -> term * predicate named * predicate named -> predicate named (** <==> *) val piff: ?loc:location -> predicate named * predicate named -> predicate named (** Binary relation. @plugin development guide *) val prel: ?loc:location -> relation * term * term -> predicate named (** \forall *) val pforall: ?loc:location -> quantifiers * predicate named -> predicate named (** \exists *) val pexists: ?loc:location -> quantifiers * predicate named -> predicate named (** \fresh(pt,size) *) val pfresh: ?loc:location -> logic_label * logic_label * term * term -> predicate named (** \allocable *) val pallocable: ?loc:location -> logic_label * term -> predicate named (** \freeable *) val pfreeable: ?loc:location -> logic_label * term -> predicate named (** \valid_read *) val pvalid_read: ?loc:location -> logic_label * term -> predicate named (** \valid *) val pvalid: ?loc:location -> logic_label * term -> predicate named (** \initialized *) val pinitialized: ?loc:location -> logic_label * term -> predicate named (** \at *) val pat: ?loc:location -> predicate named * logic_label -> predicate named (** \valid_index: requires index having integer type or set of integers *) val pvalid_index: ?loc:location -> logic_label * term * term -> predicate named (** \valid_range: requires bounds having integer type *) val pvalid_range: ?loc:location -> logic_label * term * term * term -> predicate named (** subtype relation *) val psubtype: ?loc:location -> term * term -> predicate named (** \separated *) val pseparated: ?loc:location -> term list -> predicate named (* ************************************************************************** *) (** {2 Logic types} *) (* ************************************************************************** *) (** [set_conversion ty1 ty2] returns a set type as soon as [ty1] and/or [ty2] is a set. Elements have type [ty1], or the type of the elements of [ty1] if it is itself a set-type ({i.e.} we do not build set of sets that way). *) val set_conversion: logic_type -> logic_type -> logic_type (** converts a type into the corresponding set type if needed. Does nothing if the argument is already a set type. *) val make_set_type: logic_type -> logic_type (** returns the type of elements of a set type. @raise Failure if the input type is not a set type. *) val type_of_element: logic_type -> logic_type (** [plain_or_set f t] applies [f] to [t] or to the type of elements of [t] if it is a set type *) val plain_or_set: (logic_type -> 'a) -> logic_type -> 'a (** [transform_element f t] is the same as [set_conversion (plain_or_set f t) t] @since Nitrogen-20111001 *) val transform_element: (logic_type -> logic_type) -> logic_type -> logic_type (** [true] if the argument is not a set type *) val is_plain_type: logic_type -> bool val is_boolean_type: logic_type -> bool (** @return true if the argument is the boolean type *) (* ************************************************************************** *) (** {1 Logic Terms} *) (* ************************************************************************** *) (** returns a anonymous term of the given type. *) val term : ?loc:Location.t -> term_node -> logic_type -> term (** & *) val taddrof: ?loc:Location.t -> term_lval -> logic_type -> term (** [..] of integers *) val trange: ?loc:Location.t -> term option * term option -> term (** integer constant *) val tinteger: ?loc:Location.t -> int -> term (** integer constant *) val tinteger_s64: ?loc:Location.t -> int64 -> term (** integer constant @since Oxygen-20120901 *) val tint: ?loc:Location.t -> Integer.t -> term (** real constant *) val treal: ?loc:Location.t -> float -> term (** real zero *) val treal_zero: ?loc:Location.t -> ?ltyp:logic_type -> unit -> term (** \at *) val tat: ?loc:Location.t -> term * logic_label -> term (** \old @since Nitrogen-20111001 *) val told: ?loc:Location.t -> term -> term (** variable *) val tvar: ?loc:Location.t -> logic_var -> term (** \result *) val tresult: ?loc:Location.t -> typ -> term (** [true] if the term is \result (potentially enclosed in \at)*) val is_result: term -> bool (** [true] if the term is \exit_status (potentially enclosed in \at) @since Nitrogen-20111001 *) val is_exit_status: term -> bool (* ************************************************************************** *) (** {1 Logic Offsets} *) (* ************************************************************************** *) (** Equivalent to [lastOffset] for terms. @since Oxygen-20120901 *) val lastTermOffset: term_offset -> term_offset (** Equivalent to [addOffset] for terms. @since Oxygen-20120901 *) val addTermOffset: term_offset -> term_offset -> term_offset (** Equivalent to [addOffsetLval] for terms. @since Oxygen-20120901 *) val addTermOffsetLval: term_offset -> term_lval -> term_lval (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/utf8_logic.ml0000644000175000017500000000613612155630366021042 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) let from_unichar n = let rec log64 n = if n = 0 then 0 else 1 + log64 (n lsr 5) in let utf8_storage_len n = if n < 0x80 then 1 else log64 (n lsr 1) in (* this function is not exported, so it's OK to do a few 'unsafe' things *) let write_unichar s ~pos c = let len = utf8_storage_len c in if len = 1 then String.unsafe_set s pos (Char.unsafe_chr c) else begin String.unsafe_set s pos (Char.unsafe_chr (((1 lsl len - 1) lsl (8-len)) lor (c lsr ((len-1)*6)))); for i = 1 to len-1 do String.unsafe_set s (pos+i) (Char.unsafe_chr (((c lsr ((len-1-i)*6)) land 0x3f) lor 0x80)) done ; end ; len in let s = String.create 6 in let len = write_unichar s ~pos:0 n in String.sub s 0 len let forall = from_unichar 0x2200 let exists = from_unichar 0x2203 let eq = from_unichar (*0x2263*) (*0x2250*) 0x2261 let neq = from_unichar 0x2262 let le = from_unichar 0x2264 let ge = from_unichar 0x2265 let minus = from_unichar 0x2212 let implies = from_unichar 0x21D2 let iff = from_unichar 0x21D4 let conj = from_unichar 0x2227 let disj = from_unichar 0x2228 let neg = from_unichar 0x00AC let x_or = from_unichar 0x22BB let inset = from_unichar 0x2208 let boolean = from_unichar 0x1D539 let integer = from_unichar 0x2124 let real = from_unichar 0x211D (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/check_logic_parser.ml0000644000175000017500000001055412155630366022604 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) let file = open_in "logic_parser.mly" module Strings = Set.Make(String) let tokens = ref Strings.empty let wildcards = ref Strings.empty type state = Throw | Wildcard let is_token_line s = String.length s >= 6 && String.sub s 0 6 = "%token" let add_tokens s = let rec add_token s1 = Scanf.sscanf s1 " %[A-Za-z0-9_] %s@$" (fun kw tl -> if kw <> "" then begin tokens:=Strings.add kw !tokens; add_token tl end) in let s = String.sub s 7 (String.length s - 7) in let s = if String.contains s '>' then begin let idx = String.index s '>' in String.sub s (idx+1) (String.length s - idx - 1) end else s in add_token s let wildcard_rules = [ "bs_keyword"; "wildcard"; "keyword"; "c_keyword"; "acsl_c_keyword"; "is_ext_spec"; "is_acsl_spec"; "is_acsl_decl_or_code_annot"; "is_acsl_other"; "post_cond"; "identifier_or_typename" ] let find_rule_name s = let l = String.index s ':' in String.sub s 0 l let is_wildcard_rule s = if String.contains s ':' then begin let rule = find_rule_name s in let res = List.mem rule wildcard_rules in res end else false let is_other_rule s = if String.contains s ':' then begin let rule = find_rule_name s in not (List.mem rule wildcard_rules) end else false let add_wildcards s = let s = if String.contains s ':' then begin let l = String.index s ':' in String.sub s (l+1) (String.length s - l - 1) end else s in let rec add_wildcard s = Scanf.sscanf s " | %s { %_s@} %s" (fun kw tl -> wildcards := Strings.add kw !wildcards; if tl <> "" then add_wildcard tl) in if s <> "" then try add_wildcard s with Scanf.Scan_failure _ -> () let () = try let state = ref Throw in while true do let s = input_line file in if is_token_line s then add_tokens s else if !state = Throw then begin if is_wildcard_rule s then begin state:=Wildcard; add_wildcards s end end else (* state is Wildcard *) if is_other_rule s then state:=Throw else add_wildcards s done with End_of_file -> () let whitelist = List.fold_right Strings.add [ "EOF" ] Strings.empty let () = let diff = Strings.diff (Strings.diff !tokens whitelist) !wildcards in if not (Strings.is_empty diff) then begin prerr_endline "Some tokens are not captured by wildcard rules. This will cause issue \ if those tokens appear in a contract. Please add the following tokens \ in the appropriate rule:"; Strings.iter prerr_endline diff; exit 2 end frama-c-Fluorine-20130601/cil/src/logic/logic_preprocess.mli0000644000175000017500000000451712155630366022513 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** adds another pre-processing step in order to expand macros in annotations. *) (** [file suffix cpp file] takes the file to preprocess, and the pre-processing directive, and returns the name of the file containing the completely pre-processed source. suffix will be appended to the name of intermediate files generated for pre-processing annotations (gcc pre-processing differs between .c and .cxx files) @raises Sys_error if the file cannot be opened. @modifies Oxygen-20120901: added suffix argument *) val file: string -> (string -> string -> string) -> string -> string frama-c-Fluorine-20130601/cil/src/logic/logic_utils.ml0000644000175000017500000016043112155630366021313 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) open Cil open Logic_const open Cil_types open Logic_ptree exception Not_well_formed of Cil_types.location * string let mk_dummy_term e ctyp = Logic_const.term e (Ctype ctyp) let rec instantiate subst = function | Ltype(ty,prms) -> Ltype(ty, List.map (instantiate subst) prms) | Larrow(args,rt) -> Larrow(List.map (instantiate subst) args, instantiate subst rt) | Lvar v as ty -> (* This is an application of type parameters: no need to recursively substitute in the resulting type. *) (try List.assoc v subst with Not_found -> ty) | Ctype _ | Linteger | Lreal as ty -> ty let rec unroll_type ?(unroll_typedef=true) = function | Ltype (tdef,prms) as ty -> (match tdef.lt_def with | None | Some (LTsum _) -> ty | Some (LTsyn ty) -> let subst = try List.combine tdef.lt_params prms with Invalid_argument _ -> Kernel.fatal "Logic type used with wrong number of parameters" in unroll_type ~unroll_typedef (instantiate subst ty) ) | Ctype ty when unroll_typedef -> Ctype (Cil.unrollType ty) | Linteger | Lreal | Lvar _ | Larrow _ | Ctype _ as ty -> ty (* ************************************************************************* *) (** {1 From C to logic}*) (* ************************************************************************* *) let isLogicType f t = plain_or_set (function Ctype t -> f t | _ -> false) (unroll_type t) (** true if the type is a C array (or a set of)*) let isLogicArrayType = isLogicType Cil.isArrayType let isLogicCharType = isLogicType Cil.isCharType let isLogicVoidType = isLogicType Cil.isVoidType let isLogicPointerType = isLogicType Cil.isPointerType let isLogicVoidPointerType = isLogicType Cil.isVoidPtrType let logicCType = plain_or_set (function Ctype t -> t | Lvar _ -> Cil.intType | _ -> failwith "not a C type") let plain_array_to_ptr ty = match unroll_type ty with | Ctype(TArray(ty,lo,_,attr) as tarr) -> let length_attr = match lo with | None -> [] | Some _ -> try let len = Cil.bitsSizeOf tarr in let len = try len / (Cil.bitsSizeOf ty) with Cil.SizeOfError _ -> Kernel.fatal "Inconsistent information: I know the length of \ array type %a, but not of its elements." Cil_printer.pp_typ tarr in (* Normally, overflow is checked in bitsSizeOf itself *) let la = AInt (Integer.of_int len) in [ Attr("arraylen",[la])] with Cil.SizeOfError _ -> Kernel.warning ~current:true "Cannot represent length of array as an attribute"; [] in Ctype(TPtr(ty, Cil.addAttributes length_attr attr)) | ty -> ty let array_to_ptr = plain_or_set plain_array_to_ptr let typ_to_logic_type e_typ = let ty = Cil.unrollType e_typ in if Cil.isIntegralType ty then Linteger else if Cil.isFloatingType ty then Lreal else Ctype e_typ let named_of_identified_predicate ip = { name = ip.ip_name; loc = ip.ip_loc; content = ip.ip_content } let translate_old_label s p = let get_label () = match s.labels with | [] -> s.labels <- [Label (Printf.sprintf "__sid_%d_label" s.sid, Cil_datatype.Stmt.loc s,false)] | _ -> () in let make_new_at_predicate p = get_label(); let res = pat (p, (StmtLabel (ref s))) in res.content in let make_new_at_term t = get_label (); let res = tat (t, (StmtLabel (ref s))) in res.term_node in let vis = object inherit Cil.nopCilVisitor method vpredicate = function | Pat(p,lab) when lab = Logic_const.old_label -> ChangeDoChildrenPost(make_new_at_predicate p, fun x -> x) | _ -> DoChildren method vterm_node = function | Tat(t,lab) when lab = Logic_const.old_label -> ChangeDoChildrenPost(make_new_at_term t, fun x->x) | _ -> DoChildren end in Cil.visitCilPredicateNamed vis p let rec is_C_array t = let is_C_array_lhost = function TVar { lv_origin = Some _ } -> true (* \result always refer to a C value *) | TResult _ -> true (* dereference implies an access to a C value. *) | TMem _ -> true | TVar _ -> false in isLogicArrayType t.term_type && (match t.term_node with | TStartOf (lh,_) -> is_C_array_lhost lh | TLval(lh,_) -> is_C_array_lhost lh | Tif(_,t1,t2) -> is_C_array t1 && is_C_array t2 | Tlet (_,t) -> is_C_array t | _ -> false) (* TUpdate gives back a logic array, TStartOf has pointer type anyway, other constructors are never arrays. *) (** do not use it on something which is not a C array *) let rec mk_logic_StartOf t = let my_type = array_to_ptr t.term_type in match t.term_node with TLval s -> { t with term_node = TStartOf s; term_type = my_type } | Tif(c,t1,t2) -> { t with term_node = Tif(c,mk_logic_StartOf t1, mk_logic_StartOf t2); term_type = my_type } | Tlet (body,t) -> { t with term_node = Tlet(body, mk_logic_StartOf t); term_type = my_type } | _ -> Kernel.fatal "mk_logic_StartOf given a non-C-array term" let isLogicPointer t = isLogicPointerType t.term_type || (is_C_array t) let mk_logic_pointer_or_StartOf t = if isLogicPointer t then if is_C_array t then mk_logic_StartOf t else t else Kernel.fatal ~source:(fst t.term_loc) "%a is neither a pointer nor a C array" Cil_printer.pp_term t let need_logic_cast oldt newt = not (Cil_datatype.Logic_type.equal (Ctype oldt) (Ctype newt)) (* Does the same kind of optimization than [Cil.mkCastT] for [Ctype]. *) let mk_cast ?(loc=Cil_datatype.Location.unknown) newt t = let mk_cast t = (* to new type [newt] *) let typ = Cil.type_remove_attributes_for_logic_type newt in term ~loc (TCastE (typ, t)) (Ctype typ) in match t.term_type with | Ctype oldt -> if not (need_logic_cast oldt newt) then t else begin match Cil.unrollType newt, t.term_node with | TPtr _, TCastE (_, t') -> (match t'.term_type with | Ctype typ' -> (match unrollType typ' with | (TPtr _ as typ'') -> (* Old cast can be removed...*) if need_logic_cast newt typ'' then mk_cast t' else (* In fact, both casts can be removed. *) t' | _ -> mk_cast t ) | _ -> mk_cast t) | _ -> (* Do not remove old cast because they are conversions !!! *) mk_cast t end | _ -> mk_cast t let real_of_float s f = { r_literal = s ; r_nearest = f ; r_upper = f ; r_lower = f } let constant_to_lconstant c = match c with | CInt64(i,_,s) -> Integer (i,s) | CStr s -> LStr s | CWStr s -> LWStr s | CChr s -> LChr s | CReal (f,_,Some s) -> LReal (real_of_float s f) | CEnum e -> LEnum e | CReal (f,fkind,None) -> let s = match fkind with | FFloat -> Format.sprintf "%.8ef" f | FDouble | FLongDouble -> Format.sprintf "%.16ed" f in LReal (real_of_float s f) let lconstant_to_constant c = match c with | Integer (i,s) -> CInt64(i,Cil.intKindForValue i false,s) | LStr s -> CStr s | LWStr s -> CWStr s | LChr s -> CChr s | LReal r -> CReal (r.r_nearest,FDouble,Some r.r_literal) | LEnum e -> CEnum e let string_to_float_lconstant str = let l = String.length str in let hasSuffix s = let ls = String.length s in l >= ls && s = String.uppercase (String.sub str (l - ls) ls) in (* Maybe it ends in U or UL. Strip those *) let baseint, kind = if hasSuffix "L" or hasSuffix "l" then String.sub str 0 (l - 1), Some FLongDouble else if hasSuffix "F" or hasSuffix "f" then String.sub str 0 (l - 1), Some FFloat else if hasSuffix "D" or hasSuffix "d" then String.sub str 0 (l - 1), Some FDouble else str, None in match kind with | Some FDouble | Some FLongDouble -> (* Hope that the architecture is such that [long double = double] *) let f = Floating_point.double_precision_of_string baseint in LReal(real_of_float str f.Floating_point.f_nearest) | Some FFloat -> let f = Floating_point.single_precision_of_string baseint in LReal(real_of_float str f.Floating_point.f_nearest) | None -> (* parse as double precision interval, because we do not have better *) let f = Floating_point.double_precision_of_string baseint in let open Floating_point in LReal { r_nearest = f.f_nearest ; r_upper = f.f_upper ; r_lower = f.f_lower ; r_literal = str } let rec expr_to_term ~cast e = let e_typ = unrollType (Cil.typeOf e) in let loc = e.eloc in let result = match e.enode with | Const c -> TConst (constant_to_lconstant c) | SizeOf t -> TSizeOf t | SizeOfE e -> TSizeOfE (expr_to_term ~cast e) | SizeOfStr s -> TSizeOfStr s | StartOf lv -> TStartOf (lval_to_term_lval ~cast lv) | AddrOf lv -> TAddrOf (lval_to_term_lval ~cast lv) | CastE (ty,e) -> (mk_cast (unrollType ty) (expr_to_term ~cast e)).term_node | BinOp (op, l, r, _) -> let is_arith_cmp_op op = match op with | Cil_types.Lt | Cil_types.Gt | Cil_types.Le | Cil_types.Ge | Cil_types.Eq | Cil_types.Ne -> true | _ -> false in let nnode = TBinOp (op,expr_to_term ~cast l,expr_to_term ~cast r) in if (cast && (Cil.isIntegralType e_typ || Cil.isFloatingType e_typ)) || is_arith_cmp_op op (* BTS 1175 *) then (mk_cast e_typ (Logic_const.term nnode (typ_to_logic_type e_typ))).term_node else nnode | UnOp (op, e, _) -> let nnode = TUnOp (op,expr_to_term ~cast e) in if cast && (Cil.isIntegralType e_typ || Cil.isFloatingType e_typ) then (mk_cast e_typ (Logic_const.term nnode (typ_to_logic_type e_typ))).term_node else nnode | AlignOfE e -> TAlignOfE (expr_to_term ~cast e) | AlignOf typ -> TAlignOf typ | Lval lv -> TLval (lval_to_term_lval ~cast lv) | Info (e,_) -> (expr_to_term ~cast e).term_node in if cast then Logic_const.term ~loc result (Ctype e_typ) else match e.enode with | Const(CStr _ | CWStr _ | CChr _ | CEnum _) | Lval(Var _, NoOffset) -> Logic_const.term ~loc result (Ctype e_typ) | _ -> Logic_const.term ~loc result (typ_to_logic_type e_typ) and lval_to_term_lval ~cast (host,offset) = host_to_term_host ~cast host, offset_to_term_offset ~cast offset and host_to_term_host ~cast = function | Var s -> TVar (Cil.cvar_to_lvar s) | Mem e -> TMem (expr_to_term ~cast e) and offset_to_term_offset ~cast:cast = function | NoOffset -> TNoOffset | Index (e,off) -> TIndex (expr_to_term ~cast e,offset_to_term_offset ~cast off) | Field (fi,off) -> TField(fi,offset_to_term_offset ~cast off) let array_with_range arr size = let loc = arr.eloc in let arr = Cil.stripCasts arr in let typ_arr = typeOf arr in let no_cast = isCharPtrType typ_arr || isCharArrayType typ_arr in let char_ptr = typ_to_logic_type Cil.charPtrType in let arr = expr_to_term ~cast:true arr in let arr = if no_cast then arr else mk_cast ~loc Cil.charPtrType arr and range_end = Logic_const.term ~loc:size.term_loc (TBinOp (MinusA, size, Cil.lconstant Integer.one)) size.term_type in let range = Logic_const.trange (Some (Cil.lconstant Integer.zero), Some (range_end)) in Logic_const.term ~loc(TBinOp (PlusPI, arr, range)) char_ptr let remove_logic_coerce t = match t.term_node with | TLogic_coerce(_,t) -> t | _ -> t (* ************************************************************************* *) (** {1 Various utilities} *) (* ************************************************************************* *) let rec remove_term_offset o = match o with TNoOffset -> TNoOffset, TNoOffset | TIndex(_,TNoOffset) | TField(_,TNoOffset) | TModel(_,TNoOffset) -> TNoOffset, o | TIndex(e,o) -> let (oth,last) = remove_term_offset o in TIndex(e,oth), last | TField(f,o) -> let (oth,last) = remove_term_offset o in TField(f,oth), last | TModel(f,o) -> let oth,last = remove_term_offset o in TModel(f,oth), last let rec lval_contains_result v = match v with TResult _ -> true | TMem t -> contains_result t | TVar _ -> false and loffset_contains_result o = match o with TNoOffset -> false | TField(_,o) | TModel(_,o) -> loffset_contains_result o | TIndex(t,o) -> contains_result t || loffset_contains_result o (** @return [true] if the underlying lval contains an occurence of \result; [false] otherwise or if the term is not an lval. *) and contains_result t = match t.term_node with TLval(v,offs) -> lval_contains_result v || loffset_contains_result offs | Tat(t,_) -> contains_result t | _ -> false (** @return the definition of a predicate. @raise Not_found if the predicate is only declared *) let get_pred_body pi = match pi.l_body with LBpred p -> p | _ -> raise Not_found let is_result = Logic_const.is_result let is_trivially_false p = match p.content with Pfalse -> true | _ -> false let is_trivially_true p = match p.content with Ptrue -> true | _ -> false let is_same_list f l1 l2 = try List.for_all2 f l1 l2 with Invalid_argument _ -> false (* [VP 2011-04-19] StmtLabel case is a bit restricted, but it's not really possible to do any better, and this function should not be called in contexts where it matters. *) let is_same_logic_label l1 l2 = match l1, l2 with StmtLabel s1, StmtLabel s2 -> !s1 == !s2 | StmtLabel _, LogicLabel _ | LogicLabel _, StmtLabel _ -> false (* What is important here is the name of the logic label, not the hypothetical statement it is referring to. *) | LogicLabel (_, l1), LogicLabel (_, l2) -> l1 = l2 let is_same_opt f x1 x2 = match x1,x2 with None, None -> true | Some x1, Some x2 -> f x1 x2 | None, _ | _, None -> false let is_same_c_type t1 t2 = Cil_datatype.Logic_type_ByName.equal (Ctype t1) (Ctype t2) let is_same_type t1 t2 = Cil_datatype.Logic_type_ByName.equal t1 t2 let is_same_var v1 v2 = v1.lv_name = v2.lv_name && is_same_type v1.lv_type v2.lv_type let is_same_string (s1: string) s2 = s1 = s2 let is_same_logic_signature l1 l2 = l1.l_var_info.lv_name = l2.l_var_info.lv_name && is_same_opt is_same_type l1.l_type l2.l_type && is_same_list is_same_string l1.l_tparams l2.l_tparams && is_same_list is_same_var l1.l_profile l2.l_profile && is_same_list is_same_logic_label l1.l_labels l2.l_labels let is_same_logic_profile l1 l2 = l1.l_var_info.lv_name = l2.l_var_info.lv_name && is_same_list (fun v1 v2 -> is_same_type v1.lv_type v2.lv_type) l1.l_profile l2.l_profile let is_same_builtin_profile l1 l2 = l1.bl_name = l2.bl_name && is_same_list (fun (_,t1) (_,t2) -> is_same_type t1 t2) l1.bl_profile l2.bl_profile let add_logic_function = Logic_env.add_logic_function_gen is_same_logic_profile let is_same_logic_ctor_info ci1 ci2 = ci1.ctor_name = ci2.ctor_name && ci1.ctor_type.lt_name = ci2.ctor_type.lt_name && is_same_list is_same_type ci1.ctor_params ci2.ctor_params let is_same_constant = Cil.compareConstant let is_same_pconstant c1 c2 = match c1, c2 with | IntConstant c1, IntConstant c2 -> c1 = c2 | IntConstant _, _ | _, IntConstant _ -> false | FloatConstant c1, FloatConstant c2 -> c1 = c2 | FloatConstant _,_ | _,FloatConstant _ -> false | StringConstant c1, StringConstant c2 -> c1 = c2 | StringConstant _,_ | _,StringConstant _ -> false | WStringConstant c1, WStringConstant c2 -> c1 = c2 let is_same_binop o1 o2 = match o1,o2 with | PlusA, PlusA | (PlusPI | IndexPI), (PlusPI | IndexPI) (* Semantically equivalent *) | MinusA, MinusA | MinusPI, MinusPI | MinusPP, MinusPP | Mult, Mult | Div, Div | Mod, Mod | Shiftlt, Shiftlt | Shiftrt, Shiftrt | Cil_types.Lt, Cil_types.Lt | Cil_types.Gt, Cil_types.Gt | Cil_types.Le, Cil_types.Le | Cil_types.Ge, Cil_types.Ge | Cil_types.Eq, Cil_types.Eq | Cil_types.Ne, Cil_types.Ne | BAnd, BAnd | BXor, BXor | BOr, BOr | LAnd, LAnd | LOr, LOr -> true | (PlusA | PlusPI | IndexPI | MinusA | MinusPI | MinusPP | Mult | Div | Mod | Shiftlt | Shiftrt | Cil_types.Lt | Cil_types.Gt | Cil_types.Le | Cil_types.Ge | Cil_types.Eq | Cil_types.Ne | BAnd | BXor | BOr | LAnd | LOr), _ -> false let _compare_c c1 c2 = match c1, c2 with | CEnum e1, CEnum e2 -> e1.einame = e2.einame && e1.eihost.ename = e2.eihost.ename && (match isInteger (constFold true e1.eival), isInteger (constFold true e2.eival) with | Some i1, Some i2 -> Integer.equal i1 i2 | _ -> false) | CInt64 (i1,k1,_), CInt64(i2,k2,_) -> k1 = k2 && Integer.equal i1 i2 | CStr s1, CStr s2 -> s1 = s2 | CWStr l1, CWStr l2 -> (try List.for_all2 (fun x y -> Int64.compare x y = 0) l1 l2 with Invalid_argument _ -> false) | CChr c1, CChr c2 -> c1 = c2 | CReal(f1,k1,_), CReal(f2,k2,_) -> k1 = k2 && f1 = f2 | (CEnum _ | CInt64 _ | CStr _ | CWStr _ | CChr _ | CReal _), _ -> false let rec is_same_term t1 t2 = match t1.term_node, t2.term_node with TConst c1, TConst c2 -> Cil_datatype.Logic_constant.equal c1 c2 | TLval l1, TLval l2 -> is_same_tlval l1 l2 | TSizeOf t1, TSizeOf t2 -> Cil_datatype.TypByName.equal t1 t2 | TSizeOfE t1, TSizeOfE t2 -> is_same_term t1 t2 | TSizeOfStr s1, TSizeOfStr s2 -> s1 = s2 | TAlignOf t1, TAlignOf t2 -> Cil_datatype.TypByName.equal t1 t2 | TAlignOfE t1, TAlignOfE t2 -> is_same_term t1 t2 | TUnOp (o1,t1), TUnOp(o2,t2) -> o1 = o2 && is_same_term t1 t2 | TBinOp(o1,l1,r1), TBinOp(o2,l2,r2) -> is_same_binop o1 o2 && is_same_term l1 l2 && is_same_term r1 r2 | TCastE(typ1,t1), TCastE(typ2,t2) -> Cil_datatype.TypByName.equal typ1 typ2 && is_same_term t1 t2 | TAddrOf l1, TAddrOf l2 -> is_same_tlval l1 l2 | TStartOf l1, TStartOf l2 -> is_same_tlval l1 l2 | Tapp(f1,labels1, args1), Tapp(f2, labels2, args2) -> is_same_logic_signature f1 f2 && List.for_all2 (fun (x,y) (t,z) -> is_same_logic_label x t && is_same_logic_label y z) labels1 labels2 && List.for_all2 is_same_term args1 args2 | Tif(c1,t1,e1), Tif(c2,t2,e2) -> is_same_term c1 c2 && is_same_term t1 t2 && is_same_term e1 e2 | Tbase_addr (l1,t1), Tbase_addr (l2,t2) | Tblock_length (l1,t1), Tblock_length (l2,t2) | Toffset (l1,t1), Toffset (l2,t2) | Tat(t1,l1), Tat(t2,l2) -> is_same_logic_label l1 l2 && is_same_term t1 t2 | Tnull, Tnull -> true | TCoerce(t1,typ1), TCoerce(t2,typ2) -> is_same_term t1 t2 && Cil_datatype.TypByName.equal typ1 typ2 | TCoerceE(t1,tt1), TCoerceE(t2,tt2) -> is_same_term t1 t2 && is_same_term tt1 tt2 | Tlambda (v1,t1), Tlambda(v2,t2) -> is_same_list is_same_var v1 v2 && is_same_term t1 t2 | TUpdate(t1,i1,nt1), TUpdate(t2,i2,nt2) -> is_same_term t1 t2 && is_same_offset i1 i2 && is_same_term nt1 nt2 | Ttypeof t1, Ttypeof t2 -> is_same_term t1 t2 | Ttype ty1, Ttype ty2 -> Cil_datatype.TypByName.equal ty1 ty2 | TDataCons(ci1,prms1), TDataCons(ci2,prms2) -> is_same_logic_ctor_info ci1 ci2 && is_same_list is_same_term prms1 prms2 | Tempty_set, Tempty_set -> true | (Tunion l1, Tunion l2) | (Tinter l1, Tinter l2) -> (try List.for_all2 is_same_term l1 l2 with Invalid_argument _ -> false) | Tcomprehension(e1,q1,p1), Tcomprehension(e2,q2,p2) -> is_same_term e1 e2 && is_same_list is_same_var q1 q2 && is_same_opt is_same_named_predicate p1 p2 | Trange(l1,h1), Trange(l2,h2) -> is_same_opt is_same_term l1 l2 && is_same_opt is_same_term h1 h2 | Tlet(d1,b1), Tlet(d2,b2) -> is_same_logic_info d1 d2 && is_same_term b1 b2 | TLogic_coerce(ty1,t1), TLogic_coerce(ty2,t2) -> is_same_type ty1 ty2 && is_same_term t1 t2 | (TConst _ | TLval _ | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ | TUnOp _ | TBinOp _ | TCastE _ | TAddrOf _ | TStartOf _ | Tapp _ | Tlambda _ | TDataCons _ | Tif _ | Tat _ | Tbase_addr _ | Tblock_length _ | Toffset _ | Tnull | TCoerce _ | TCoerceE _ | TUpdate _ | Ttypeof _ | Ttype _ | Tcomprehension _ | Tempty_set | Tunion _ | Tinter _ | Trange _ | Tlet _ | TLogic_coerce _ ),_ -> false and is_same_logic_info l1 l2 = is_same_logic_signature l1 l2 && is_same_logic_body l1.l_body l2.l_body and is_same_logic_body b1 b2 = match b1,b2 with | LBnone, LBnone -> true | LBreads l1, LBreads l2 -> is_same_list is_same_identified_term l1 l2 | LBterm t1, LBterm t2 -> is_same_term t1 t2 | LBpred p1, LBpred p2 -> is_same_named_predicate p1 p2 | LBinductive l1, LBinductive l2 -> is_same_list is_same_indcase l1 l2 | (LBnone | LBinductive _ | LBpred _ | LBterm _ | LBreads _), _ -> false and is_same_indcase (id1,labs1,typs1,p1) (id2,labs2,typs2,p2) = id1 = id2 && is_same_list is_same_logic_label labs1 labs2 && is_same_list (=) typs1 typs2 && is_same_named_predicate p1 p2 and is_same_tlval (h1,o1) (h2,o2) = is_same_lhost h1 h2 && is_same_offset o1 o2 and is_same_lhost h1 h2 = match h1, h2 with TVar v1, TVar v2 -> is_same_var v1 v2 | TMem t1, TMem t2 -> is_same_term t1 t2 | TResult t1, TResult t2 -> Cil_datatype.TypByName.equal t1 t2 | (TVar _ | TMem _ | TResult _ ),_ -> false and is_same_offset o1 o2 = match o1, o2 with TNoOffset, TNoOffset -> true | TField (f1,o1), TField(f2,o2) -> f1.fname = f2.fname && is_same_offset o1 o2 | TModel(f1,o1), TModel(f2,o2) -> f1.mi_name == f2.mi_name && is_same_offset o1 o2 | TIndex(t1,o1), TIndex(t2,o2) -> is_same_term t1 t2 && is_same_offset o1 o2 | (TNoOffset| TField _| TIndex _ | TModel _),_ -> false and is_same_predicate p1 p2 = match p1, p2 with | Pfalse, Pfalse -> true | Ptrue, Ptrue -> true | Papp(i1,labels1,args1), Papp(i2,labels2,args2) -> is_same_logic_signature i1 i2 && List.for_all2 (fun (x,y) (z,t) -> is_same_logic_label x z && is_same_logic_label y t) labels1 labels2 && List.for_all2 is_same_term args1 args2 | Prel(r1,lt1,rt1), Prel(r2,lt2,rt2) -> r1 = r2 && is_same_term lt1 lt2 && is_same_term rt1 rt2 | Pand(lp1,rp1), Pand(lp2,rp2) | Por(lp1,rp1), Por(lp2,rp2) | Pxor (lp1,rp1), Pxor(lp2,rp2) | Pimplies(lp1,rp1), Pimplies(lp2,rp2) | Piff(lp1,rp1), Piff(lp2,rp2) -> is_same_named_predicate lp1 lp2 && is_same_named_predicate rp1 rp2 | Pnot p1, Pnot p2 -> is_same_named_predicate p1 p2 | Pif (c1,t1,e1), Pif(c2,t2,e2) -> is_same_term c1 c2 && is_same_named_predicate t1 t2 && is_same_named_predicate e1 e2 | Plet (d1,p1), Plet(d2,p2) -> is_same_logic_info d1 d2 && is_same_named_predicate p1 p2 | Pforall(q1,p1), Pforall(q2,p2) -> is_same_list is_same_var q1 q2 && is_same_named_predicate p1 p2 | Pexists(q1,p1), Pexists(q2,p2) -> is_same_list is_same_var q1 q2 && is_same_named_predicate p1 p2 | Pat(p1,l1), Pat(p2,l2) -> is_same_logic_label l1 l2 && is_same_named_predicate p1 p2 | Pallocable (l1,t1), Pallocable (l2,t2) | Pfreeable (l1,t1), Pfreeable (l2,t2) | Pvalid (l1,t1), Pvalid (l2,t2) | Pvalid_read (l1,t1), Pvalid_read (l2,t2) | Pinitialized (l1,t1), Pinitialized (l2,t2) -> is_same_logic_label l1 l2 && is_same_term t1 t2 | Pfresh (l1,m1,t1,n1), Pfresh (l2,m2,t2,n2) -> is_same_logic_label l1 l2 && is_same_logic_label m1 m2 && is_same_term t1 t2 && is_same_term n1 n2 | Psubtype(lt1,rt1), Psubtype(lt2,rt2) -> is_same_term lt1 lt2 && is_same_term rt1 rt2 | Pseparated(seps1), Pseparated(seps2) -> (try List.for_all2 is_same_term seps1 seps2 with Invalid_argument _ -> false) | (Pfalse | Ptrue | Papp _ | Prel _ | Pand _ | Por _ | Pimplies _ | Piff _ | Pnot _ | Pif _ | Plet _ | Pforall _ | Pexists _ | Pat _ | Pvalid _ | Pvalid_read _ | Pinitialized _ | Pfresh _ | Pallocable _ | Pfreeable _ | Psubtype _ | Pxor _ | Pseparated _ ), _ -> false and is_same_named_predicate pred1 pred2 = pred1.name = pred2.name && is_same_predicate pred1.content pred2.content and is_same_identified_predicate p1 p2 = is_same_list (=) p1.ip_name p2.ip_name && is_same_predicate p1.ip_content p2.ip_content and is_same_identified_term l1 l2 = is_same_term l1.it_content l2.it_content let is_same_deps z1 z2 = match (z1,z2) with (FromAny, FromAny) -> true | From loc1, From loc2 -> is_same_list is_same_identified_term loc1 loc2 | (FromAny | From _), _ -> false let is_same_from (b1,f1) (b2,f2) = is_same_identified_term b1 b2 && is_same_deps f1 f2 let is_same_assigns a1 a2 = match (a1,a2) with (WritesAny, WritesAny) -> true | Writes loc1, Writes loc2 -> is_same_list is_same_from loc1 loc2 | (WritesAny | Writes _), _ -> false let is_same_allocation a1 a2 = match (a1,a2) with (FreeAllocAny, FreeAllocAny) -> true | FreeAlloc(f1,a1), FreeAlloc(f2,a2) -> is_same_list is_same_identified_term f1 f2 && is_same_list is_same_identified_term a1 a2 | (FreeAllocAny | FreeAlloc _), _ -> false let is_same_variant (v1,o1 : _ Cil_types.variant) (v2,o2: _ Cil_types.variant) = is_same_term v1 v2 && (match o1, o2 with None, None -> true | None, _ | _, None -> false | Some o1, Some o2 -> o1 = o2) let is_same_post_cond ((k1: Cil_types.termination_kind),p1) (k2,p2) = k1 = k2 && is_same_identified_predicate p1 p2 let is_same_behavior b1 b2 = b1.b_name = b2.b_name && is_same_list is_same_identified_predicate b1.b_assumes b2.b_assumes && is_same_list is_same_identified_predicate b1.b_requires b2.b_requires && is_same_list is_same_post_cond b1.b_post_cond b2.b_post_cond && is_same_assigns b1.b_assigns b2.b_assigns let is_same_spec spec1 spec2 = is_same_list is_same_behavior spec1.spec_behavior spec2.spec_behavior && is_same_opt is_same_variant spec1.spec_variant spec2.spec_variant && is_same_opt is_same_identified_predicate spec1.spec_terminates spec2.spec_terminates && spec1.spec_complete_behaviors = spec2.spec_complete_behaviors && spec1.spec_disjoint_behaviors = spec2.spec_disjoint_behaviors let is_same_logic_type_def d1 d2 = match d1,d2 with LTsum l1, LTsum l2 -> is_same_list is_same_logic_ctor_info l1 l2 | LTsyn ty1, LTsyn ty2 -> is_same_type ty1 ty2 | (LTsyn _ | LTsum _), _ -> false let is_same_logic_type_info t1 t2 = t1.lt_name = t2.lt_name && is_same_list (=) t1.lt_params t2.lt_params && is_same_opt is_same_logic_type_def t1.lt_def t2.lt_def let is_same_loop_pragma p1 p2 = match p1,p2 with Unroll_specs l1, Unroll_specs l2 -> is_same_list is_same_term l1 l2 | Widen_hints l1, Widen_hints l2 -> is_same_list is_same_term l1 l2 | Widen_variables l1, Widen_variables l2 -> is_same_list is_same_term l1 l2 | (Unroll_specs _ | Widen_hints _ | Widen_variables _), _ -> false let is_same_slice_pragma p1 p2 = match p1,p2 with SPexpr t1, SPexpr t2 -> is_same_term t1 t2 | SPctrl, SPctrl | SPstmt, SPstmt -> true | (SPexpr _ | SPctrl | SPstmt), _ -> false let is_same_impact_pragma p1 p2 = match p1,p2 with | IPexpr t1, IPexpr t2 -> is_same_term t1 t2 | IPstmt, IPstmt -> true | (IPexpr _ | IPstmt), _ -> false let is_same_pragma p1 p2 = match p1,p2 with | Loop_pragma p1, Loop_pragma p2 -> is_same_loop_pragma p1 p2 | Slice_pragma p1, Slice_pragma p2 -> is_same_slice_pragma p1 p2 | Impact_pragma p1, Impact_pragma p2 -> is_same_impact_pragma p1 p2 | (Loop_pragma _ | Slice_pragma _ | Impact_pragma _), _ -> false let is_same_code_annotation ca1 ca2 = match ca1.annot_content, ca2.annot_content with | AAssert(l1,p1), AAssert(l2,p2) -> is_same_list (=) l1 l2 && is_same_named_predicate p1 p2 | AStmtSpec (l1,s1), AStmtSpec (l2,s2) -> is_same_list (=) l1 l2 && is_same_spec s1 s2 | AInvariant(l1,b1,p1), AInvariant(l2,b2,p2) -> is_same_list (=) l1 l2 && b1 = b2 && is_same_named_predicate p1 p2 | AVariant v1, AVariant v2 -> is_same_variant v1 v2 | AAssigns(l1,a1), AAssigns(l2,a2) -> is_same_list (=) l1 l2 && is_same_assigns a1 a2 | AAllocation(l1,fa1), AAllocation(l2,fa2) -> is_same_list (=) l1 l2 && is_same_allocation fa1 fa2 | APragma p1, APragma p2 -> is_same_pragma p1 p2 | (AAssert _ | AStmtSpec _ | AInvariant _ | AVariant _ | AAssigns _ | AAllocation _ | APragma _ ), _ -> false let is_same_model_info mi1 mi2 = mi1.mi_name = mi2.mi_name && is_same_c_type mi1.mi_base_type mi2.mi_base_type && is_same_type mi1.mi_field_type mi2.mi_field_type let rec is_same_global_annotation ga1 ga2 = match (ga1,ga2) with | Dfun_or_pred (li1,_), Dfun_or_pred (li2,_) -> is_same_logic_info li1 li2 | Daxiomatic (id1,ga1,_), Daxiomatic (id2,ga2,_) -> id1 = id2 && is_same_list is_same_global_annotation ga1 ga2 | Dtype (t1,_), Dtype (t2,_) -> is_same_logic_type_info t1 t2 | Dlemma(n1,ax1,labs1,typs1,st1,_), Dlemma(n2,ax2,labs2,typs2,st2,_) -> n1 = n2 && ax1 = ax2 && is_same_list is_same_logic_label labs1 labs2 && is_same_list (=) typs1 typs2 && is_same_named_predicate st1 st2 | Dinvariant (li1,_), Dinvariant (li2,_) -> is_same_logic_info li1 li2 | Dtype_annot (li1,_), Dtype_annot (li2,_) -> is_same_logic_info li1 li2 | Dmodel_annot (li1,_), Dmodel_annot (li2,_) -> is_same_model_info li1 li2 | Dcustom_annot (c1, n1, _), Dcustom_annot (c2, n2,_) -> n1 = n2 && c1 = c2 | Dvolatile(t1,r1,w1,_), Dvolatile(t2,r2,w2,_) -> is_same_list is_same_identified_term t1 t2 && is_same_opt (fun x y -> x.vname = y.vname) r1 r2 && is_same_opt (fun x y -> x.vname = y.vname) w1 w2 | (Dfun_or_pred _ | Daxiomatic _ | Dtype _ | Dlemma _ | Dinvariant _ | Dtype_annot _ | Dcustom_annot _ | Dmodel_annot _ | Dvolatile _), (Dfun_or_pred _ | Daxiomatic _ | Dtype _ | Dlemma _ | Dinvariant _ | Dtype_annot _ | Dcustom_annot _ | Dmodel_annot _ | Dvolatile _) -> false let is_same_axiomatic ax1 ax2 = is_same_list is_same_global_annotation ax1 ax2 let is_same_pl_constant c1 c2 = match c1,c2 with | IntConstant s1, IntConstant s2 | FloatConstant s1, FloatConstant s2 | StringConstant s1, StringConstant s2 | WStringConstant s1, WStringConstant s2 -> s1 = s2 | (IntConstant _| FloatConstant _ | StringConstant _ | WStringConstant _), _ -> false let rec is_same_pl_type t1 t2 = match t1, t2 with | LTvoid, LTvoid | LTinteger, LTinteger | LTreal, LTreal -> true | LTint k1, LTint k2 -> (match k1, k2 with | IBool, IBool | IChar, IChar | ISChar, ISChar | IUChar, IUChar | IInt, IInt | IUInt, IUInt | IShort, IShort | IUShort, IUShort | ILong, ILong | IULong, IULong | ILongLong, ILongLong | IULongLong, IULongLong -> true | (IBool | IChar | ISChar | IUChar | IInt | IUInt | IShort | IUShort | ILong | IULong | ILongLong | IULongLong), _ -> false ) | LTfloat k1, LTfloat k2 -> (match k1,k2 with | FFloat, FFloat | FDouble, FDouble | FLongDouble, FLongDouble -> true | (FFloat | FDouble | FLongDouble),_ -> false) | LTarray (t1,c1), LTarray(t2,c2) -> is_same_pl_type t1 t2 && is_same_opt is_same_pl_constant c1 c2 | LTpointer t1, LTpointer t2 -> is_same_pl_type t1 t2 | LTenum s1, LTenum s2 | LTstruct s1, LTstruct s2 | LTunion s1, LTunion s2 -> s1 = s2 | LTnamed (s1,prms1), LTnamed(s2,prms2) -> s1 = s2 && is_same_list is_same_pl_type prms1 prms2 | LTarrow(prms1,t1), LTarrow(prms2,t2) -> is_same_list is_same_pl_type prms1 prms2 && is_same_pl_type t1 t2 | (LTvoid | LTinteger | LTreal | LTint _ | LTfloat _ | LTarrow _ | LTarray _ | LTpointer _ | LTenum _ | LTunion _ | LTnamed _ | LTstruct _),_ -> false let is_same_quantifiers = is_same_list (fun (t1,x1) (t2,x2) -> x1 = x2 && is_same_pl_type t1 t2) let is_same_unop op1 op2 = match op1,op2 with | Uminus, Uminus | Ubw_not, Ubw_not | Ustar, Ustar | Uamp, Uamp -> true | (Uminus | Ustar | Uamp | Ubw_not), _ -> false let is_same_binop op1 op2 = match op1, op2 with | Badd, Badd | Bsub, Bsub | Bmul, Bmul | Bdiv, Bdiv | Bmod, Bmod | Bbw_and, Bbw_and | Bbw_or, Bbw_or | Bbw_xor, Bbw_xor | Blshift, Blshift | Brshift, Brshift -> true | (Badd | Bsub | Bmul | Bdiv | Bmod | Bbw_and | Bbw_or | Bbw_xor | Blshift | Brshift),_ -> false let is_same_relation r1 r2 = match r1, r2 with | Lt, Lt | Gt, Gt | Le, Le | Ge, Ge | Eq, Eq | Neq, Neq -> true | (Lt | Gt | Le | Ge | Eq | Neq), _ -> false let rec is_same_path_elt p1 p2 = match p1, p2 with PLpathField s1, PLpathField s2 -> s1 = s2 | PLpathIndex e1, PLpathIndex e2 -> is_same_lexpr e1 e2 | (PLpathField _ | PLpathIndex _), _ -> false and is_same_update_term t1 t2 = match t1, t2 with | PLupdateTerm e1, PLupdateTerm e2 -> is_same_lexpr e1 e2 | PLupdateCont l1, PLupdateCont l2 -> let is_same_elt (p1,e1) (p2,e2) = is_same_list is_same_path_elt p1 p2 && is_same_update_term e1 e2 in is_same_list is_same_elt l1 l2 | (PLupdateTerm _ | PLupdateCont _), _ -> false and is_same_lexpr l1 l2 = match l1.lexpr_node,l2.lexpr_node with | PLvar s1, PLvar s2 -> s1 = s2 | PLapp (s1,l1,arg1), PLapp (s2,l2,arg2) -> s1 = s2 && is_same_list (=) l1 l2 && is_same_list is_same_lexpr arg1 arg2 | PLlambda(q1,e1), PLlambda(q2,e2) | PLforall (q1,e1), PLforall(q2,e2) | PLexists(q1,e1), PLexists(q2,e2) -> is_same_quantifiers q1 q2 && is_same_lexpr e1 e2 | PLlet(x1,d1,e1), PLlet(x2,d2,e2) -> x1 = x2 && is_same_lexpr d1 d2 && is_same_lexpr e1 e2 | PLconstant c1, PLconstant c2 -> is_same_pl_constant c1 c2 | PLunop(op1,e1), PLunop(op2,e2) -> is_same_unop op1 op2 && is_same_lexpr e1 e2 | PLbinop(le1,op1,re1), PLbinop(le2,op2,re2) -> is_same_binop op1 op2 && is_same_lexpr le1 le2 && is_same_lexpr re1 re2 | PLdot(e1,f1), PLdot(e2,f2) | PLarrow(e1,f1), PLarrow(e2,f2) -> f1 = f2 && is_same_lexpr e1 e2 | PLarrget(b1,o1), PLarrget(b2,o2) -> is_same_lexpr b1 b2 && is_same_lexpr o1 o2 | PLold e1, PLold e2 -> is_same_lexpr e1 e2 | PLat (e1,s1), PLat(e2,s2) -> s1 = s2 && is_same_lexpr e1 e2 | PLresult, PLresult | PLnull, PLnull | PLfalse, PLfalse | PLtrue, PLtrue | PLempty, PLempty -> true | PLcast(t1,e1), PLcast(t2,e2) | PLcoercion(e1,t1), PLcoercion (e2,t2)-> is_same_pl_type t1 t2 && is_same_lexpr e1 e2 | PLrange(l1,h1), PLrange(l2,h2) -> is_same_opt is_same_lexpr l1 l2 && is_same_opt is_same_lexpr h1 h2 | PLsizeof t1, PLsizeof t2 -> is_same_pl_type t1 t2 | PLsizeofE e1,PLsizeofE e2 | PLtypeof e1,PLtypeof e2-> is_same_lexpr e1 e2 | PLcoercionE (b1,t1), PLcoercionE(b2,t2) | PLsubtype(b1,t1), PLsubtype(b2,t2) -> is_same_lexpr b1 b2 && is_same_lexpr t1 t2 | PLupdate(b1,p1,r1), PLupdate(b2,p2,r2) -> is_same_lexpr b1 b2 && is_same_list is_same_path_elt p1 p2 && is_same_update_term r1 r2 | PLinitIndex l1, PLinitIndex l2 -> let is_same_elt (i1,v1) (i2,v2) = is_same_lexpr i1 i2 && is_same_lexpr v1 v2 in is_same_list is_same_elt l1 l2 | PLinitField l1, PLinitField l2 -> let is_same_elt (s1,v1) (s2,v2) = s1 = s2 && is_same_lexpr v1 v2 in is_same_list is_same_elt l1 l2 | PLtype t1, PLtype t2 -> is_same_pl_type t1 t2 | PLrel(le1,r1,re1), PLrel(le2,r2,re2) -> is_same_relation r1 r2 && is_same_lexpr le1 le2 && is_same_lexpr re1 re2 | PLand(l1,r1), PLand(l2,r2) | PLor(l1,r1), PLor(l2,r2) | PLimplies(l1,r1), PLimplies(l2,r2) | PLxor(l1,r1), PLxor(l2,r2) | PLiff(l1,r1), PLiff(l2,r2) -> is_same_lexpr l1 l2 && is_same_lexpr r1 r2 | PLnot e1, PLnot e2 -> is_same_lexpr e1 e2 | PLfresh (l1,e11,e12), PLfresh (l2,e21,e22) -> l1=l2 && is_same_lexpr e11 e21 && is_same_lexpr e12 e22 | PLallocable (l1,e1), PLallocable (l2,e2) | PLfreeable (l1,e1), PLfreeable (l2,e2) | PLvalid (l1,e1), PLvalid (l2,e2) | PLvalid_read (l1,e1), PLvalid_read (l2,e2) | PLbase_addr (l1,e1), PLbase_addr (l2,e2) | PLoffset (l1,e1), PLoffset (l2,e2) | PLblock_length (l1,e1), PLblock_length (l2,e2) | PLinitialized (l1,e1), PLinitialized (l2,e2) -> l1=l2 && is_same_lexpr e1 e2 | PLseparated l1, PLseparated l2 -> is_same_list is_same_lexpr l1 l2 | PLif(c1,t1,e1), PLif(c2,t2,e2) -> is_same_lexpr c1 c2 && is_same_lexpr t1 t2 && is_same_lexpr e1 e2 | PLnamed(s1,e1), PLnamed(s2,e2) -> s1 = s2 && is_same_lexpr e1 e2 | PLcomprehension(e1,q1,p1), PLcomprehension(e2,q2,p2) -> is_same_lexpr e1 e2 && is_same_quantifiers q1 q2 && is_same_opt is_same_lexpr p1 p2 | PLsingleton e1, PLsingleton e2 -> is_same_lexpr e1 e2 | PLunion l1, PLunion l2 | PLinter l1, PLinter l2 -> is_same_list is_same_lexpr l1 l2 | (PLvar _ | PLapp _ | PLlambda _ | PLlet _ | PLconstant _ | PLunop _ | PLbinop _ | PLdot _ | PLarrow _ | PLarrget _ | PLold _ | PLat _ | PLbase_addr _ | PLblock_length _ | PLoffset _ | PLresult | PLnull | PLcast _ | PLrange _ | PLsizeof _ | PLsizeofE _ | PLtypeof _ | PLcoercion _ | PLcoercionE _ | PLupdate _ | PLinitIndex _ | PLtype _ | PLfalse | PLtrue | PLinitField _ | PLrel _ | PLand _ | PLor _ | PLxor _ | PLimplies _ | PLiff _ | PLnot _ | PLif _ | PLforall _ | PLexists _ | PLvalid _ | PLvalid_read _ | PLfreeable _ | PLallocable _ | PLinitialized _ | PLseparated _ | PLfresh _ | PLnamed _ | PLsubtype _ | PLcomprehension _ | PLunion _ | PLinter _ | PLsingleton _ | PLempty ),_ -> false let hash_label l = match l with StmtLabel _ -> 0 (* We can't rely on sid at this point. *) | LogicLabel (_,l) -> 19 + Hashtbl.hash l exception StopRecursion of int let rec hash_term (acc,depth,tot) t = if tot <= 0 || depth <= 0 then raise (StopRecursion acc) else begin match t.term_node with | TConst c -> (acc + Cil_datatype.Logic_constant.hash c, tot - 1) | TLval lv -> hash_term_lval (acc+19,depth - 1,tot -1) lv | TSizeOf t -> (acc + 38 + Cil_datatype.TypByName.hash t, tot - 1) | TSizeOfE t -> hash_term (acc+57,depth -1, tot-1) t | TSizeOfStr s -> (acc + 76 + Hashtbl.hash s, tot - 1) | TAlignOf t -> (acc + 95 + Cil_datatype.TypByName.hash t, tot - 1) | TAlignOfE t -> hash_term (acc+114,depth-1,tot-1) t | TUnOp(op,t) -> hash_term (acc+133+Hashtbl.hash op,depth-1,tot-2) t | TBinOp(bop,t1,t2) -> let hash1,tot1 = hash_term (acc+152+Hashtbl.hash bop,depth-1,tot-2) t1 in hash_term (hash1,depth-1,tot1) t2 | TCastE(ty,t) -> let hash1 = Cil_datatype.TypByName.hash ty in hash_term (acc+171+hash1,depth-1,tot-2) t | TAddrOf lv -> hash_term_lval (acc+190,depth-1,tot-1) lv | TStartOf lv -> hash_term_lval (acc+209,depth-1,tot-1) lv | Tapp (li,labs,apps) -> let hash1 = acc + 228 + Hashtbl.hash li.l_var_info.lv_name in let hash_lb (acc,tot) (_,lb) = if tot = 0 then raise (StopRecursion acc) else (acc + hash_label lb,tot - 1) in let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in let res = List.fold_left hash_lb (hash1,tot-1) labs in List.fold_left hash_one_term res apps | Tlambda(quants,t) -> let hash_var (acc,tot) lv = if tot = 0 then raise (StopRecursion acc) else (acc + Hashtbl.hash lv.lv_name,tot-1) in let (acc,tot) = List.fold_left hash_var (acc+247,tot-1) quants in hash_term (acc,depth-1,tot-1) t | TDataCons(ctor,args) -> let hash = acc + 266 + Hashtbl.hash ctor.ctor_name in let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in List.fold_left hash_one_term (hash,tot-1) args | Tif(t1,t2,t3) -> let hash1,tot1 = hash_term (acc+285,depth-1,tot) t1 in let hash2,tot2 = hash_term (hash1,depth-1,tot1) t2 in hash_term (hash2,depth-1,tot2) t3 | Tat(t,l) -> let hash = acc + 304 + hash_label l in hash_term (hash,depth-1,tot-2) t | Tbase_addr (l,t) -> let hash = acc + 323 + hash_label l in hash_term (hash,depth-1,tot-2) t | Tblock_length (l,t) -> let hash = acc + 342 + hash_label l in hash_term (hash,depth-1,tot-2) t | Toffset (l,t) -> let hash = acc + 351 + hash_label l in hash_term (hash,depth-1,tot-2) t | Tnull -> acc+361, tot - 1 | TCoerce(t,ty) -> let hash = Cil_datatype.TypByName.hash ty in hash_term (acc+380+hash,depth-1,tot-2) t | TCoerceE(t1,t2) -> let hash1,tot1 = hash_term (acc+399,depth-1,tot-1) t1 in hash_term (hash1,depth-1,tot1) t2 | TUpdate(t1,off,t2) -> let hash1,tot1 = hash_term (acc+418,depth-1,tot-1) t1 in let hash2,tot2 = hash_term_offset (hash1,depth-1,tot1) off in hash_term (hash2,depth-1,tot2) t2 | Ttypeof t -> hash_term (acc+437,depth-1,tot-1) t | Ttype t -> acc + 456 + Cil_datatype.TypByName.hash t, tot - 1 | Tempty_set -> acc + 475, tot - 1 | Tunion tl -> let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in List.fold_left hash_one_term (acc+494,tot-1) tl | Tinter tl -> let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in List.fold_left hash_one_term (acc+513,tot-1) tl | Tcomprehension (t,quants,_) -> (* TODO: hash predicates *) let hash_var (acc,tot) lv = if tot = 0 then raise (StopRecursion acc) else (acc + Hashtbl.hash lv.lv_name,tot-1) in let (acc,tot) = List.fold_left hash_var (acc+532,tot-1) quants in hash_term (acc,depth-1,tot-1) t | Trange(t1,t2) -> let acc = acc + 551 in let acc,tot = match t1 with None -> acc,tot - 1 | Some t -> hash_term (acc,depth-1,tot-2) t in if tot <= 0 then raise (StopRecursion acc) else (match t2 with None -> acc, tot - 1 | Some t -> hash_term (acc,depth-1,tot-1) t) | Tlet(li,t) -> hash_term (acc + 570 + Hashtbl.hash li.l_var_info.lv_name, depth-1, tot-1) t | TLogic_coerce(_,t) -> hash_term (acc + 587, depth - 1, tot - 1) t end and hash_term_lval (acc,depth,tot) (h,o) = if depth <= 0 || tot <= 0 then raise (StopRecursion acc) else begin let hash, tot = hash_term_lhost (acc, depth-1, tot - 1) h in hash_term_offset (hash, depth-1, tot) o end and hash_term_lhost (acc,depth,tot) h = if depth<=0 || tot <= 0 then raise (StopRecursion acc) else begin match h with | TVar lv -> acc + Hashtbl.hash lv.lv_name, tot - 1 | TResult t -> acc + 19 + Cil_datatype.TypByName.hash t, tot - 2 | TMem t -> hash_term (acc+38,depth-1,tot-1) t end and hash_term_offset (acc,depth,tot) o = if depth<=0 || tot <= 0 then raise (StopRecursion acc) else begin match o with | TNoOffset -> acc, tot - 1 | TField(fi,o) -> hash_term_offset (acc+19+Hashtbl.hash fi.fname,depth-1,tot-1) o | TModel(mi,o) -> hash_term_offset (acc+31+Cil_datatype.Model_info.hash mi,depth-1,tot-1) o | TIndex (t,o) -> let hash, tot = hash_term (acc+37,depth-1,tot-1) t in hash_term_offset (hash,depth-1,tot) o end let hash_term t = try fst (hash_term (0,10,100) t) with StopRecursion h -> h let get_behavior_names spec = List.fold_left (fun acc b -> b.b_name::acc) [] spec.spec_behavior let merge_allocation fa1 fa2 = if is_same_allocation fa1 fa2 then fa1 else match (fa1,fa2) with | FreeAllocAny, _ -> fa2 | _, FreeAllocAny -> fa1 | FreeAlloc([],a),FreeAlloc(f,[]) | FreeAlloc(f,[]),FreeAlloc([],a) -> FreeAlloc(f,a); | _ -> Kernel.warning ~once:true ~current:true "incompatible allocations clauses. Keeping only the first one."; fa1 let concat_allocation fa1 fa2 = if is_same_allocation fa1 fa2 then fa1 else match (fa1,fa2) with | FreeAllocAny, _ -> fa2 | _, FreeAllocAny -> fa1 | FreeAlloc(f1,a1),FreeAlloc(f2,a2) -> FreeAlloc(f1@f2,a1@a2) (* Merge two from clauses (arguments of constructor Writes). For each assigned location, find the From clauses and verify that they are equal. This avoids duplicates. Beware: this is quadratic in case of mismatch between the two assigns lists. However, in most cases the lists are the same *) let merge_assigns_list l1 l2 = (* Find [asgn] in the list of from clauses given as second argument *) let rec matches asgn = function | [] -> None, [] | (asgn', _ as hd) :: q -> if is_same_identified_term asgn asgn' then Some hd, q (* Return matching from clause *) else let r, l = matches asgn q in (* Search further on *) r, hd :: l in let rec aux l1 l2 = match l1, l2 with | [], [] -> [] (* Merge finished *) | [], _ :: _ -> aux l2 l1 (* to get the warnings on the elements of l2 *) | (asgn1, from1 as cl1) :: q1, l2 -> match matches asgn1 l2 with | None, l2 -> (* asgn1 is only in l1 *) (* Warn only if asgn1 is not \result, as \result is only useful to specify a \from clause (and is removed without one)*) if not (Logic_const.is_result asgn1.it_content) then begin let loc = asgn1.it_content.term_loc in Kernel.warning ~once:true ~source:(fst loc) "location %a is not present in all assigns clauses" Cil_printer.pp_identified_term asgn1; end; (asgn1, from1) :: aux q1 l2 | Some (asgn2, from2 as cl2), q2 -> (* asgn1 is in l1 and l2. Check the from clauses *) if is_same_deps from1 from2 || from2 = FromAny then cl1 :: aux q1 q2 else if from1 = FromAny then cl2 :: aux q1 q2 else begin let loc1 = asgn1.it_content.term_loc in let loc2 = asgn2.it_content.term_loc in Kernel.warning ~once:true ~source:(fst loc1) "@[incompatible@ from@ clauses (%a:'%a'@ and@ %a:'%a').@ \ Keeping@ only@ the first@ one.@]" Cil_printer.pp_location loc1 Cil_printer.pp_from cl1 Cil_printer.pp_location loc2 Cil_printer.pp_from cl2; cl1 :: aux q1 q2 end in aux l1 l2 let merge_assigns a1 a2 = if is_same_assigns a1 a2 then a1 else match (a1,a2) with | WritesAny, _ -> a2 | _, WritesAny -> a1 | Writes l1, Writes l2 -> Writes (merge_assigns_list l1 l2) let concat_assigns a1 a2 = match a1,a2 with | WritesAny, _ | _, WritesAny -> WritesAny | Writes l1, Writes l2 -> Writes (l1 @ l2) let merge_behaviors ~silent old_behaviors fresh_behaviors = old_behaviors @ (List.filter (fun b -> try let old_b = List.find (fun x -> x.b_name = b.b_name) old_behaviors in if not (is_same_behavior b old_b) then begin if not silent then Kernel.warning ~current:true "found two %s. Merging them%t" (if Cil.is_default_behavior b then "contracts" else "behaviors named " ^ b.b_name) (fun fmt -> if Kernel.debug_atleast 1 then Format.fprintf fmt ":@ @[%a@] vs. @[%a@]" Cil_printer.pp_behavior b Cil_printer.pp_behavior old_b) ; old_b.b_assumes <- old_b.b_assumes @ b.b_assumes; old_b.b_requires <- old_b.b_requires @ b.b_requires; old_b.b_post_cond <- old_b.b_post_cond @ b.b_post_cond; old_b.b_assigns <- merge_assigns old_b.b_assigns b.b_assigns; old_b.b_allocation <- merge_allocation old_b.b_allocation b.b_allocation; end ; false with Not_found -> true) fresh_behaviors) let merge_funspec ?(silent_about_merging_behav=false) old_spec fresh_spec = if not (is_same_spec old_spec fresh_spec || Cil.is_empty_funspec fresh_spec) then if Cil.is_empty_funspec old_spec then begin old_spec.spec_terminates <- fresh_spec.spec_terminates; old_spec.spec_behavior <- fresh_spec.spec_behavior; old_spec.spec_complete_behaviors <- fresh_spec.spec_complete_behaviors; old_spec.spec_disjoint_behaviors <- fresh_spec.spec_disjoint_behaviors; old_spec.spec_variant <- fresh_spec.spec_variant; end else begin old_spec.spec_behavior <- merge_behaviors ~silent:silent_about_merging_behav old_spec.spec_behavior fresh_spec.spec_behavior ; (match old_spec.spec_variant,fresh_spec.spec_variant with | None,None -> () | Some _, None -> () | None, Some _ -> old_spec.spec_variant <- fresh_spec.spec_variant | Some _old, Some _fresh -> Kernel.warning ~current:true "found two variants for function specification. Keeping only the first one."); (match old_spec.spec_terminates, fresh_spec.spec_terminates with | None, None -> () | Some p1, Some p2 when is_same_identified_predicate p1 p2 -> () | _ -> Kernel.warning ~current:true "found two different terminates clause for function specification. \ keeping only the fist one"); old_spec.spec_complete_behaviors <- List.fold_left (fun acc b -> if List.mem b old_spec.spec_complete_behaviors then acc else b::acc) old_spec.spec_complete_behaviors fresh_spec.spec_complete_behaviors ; old_spec.spec_disjoint_behaviors <- List.fold_left (fun acc b -> if List.mem b old_spec.spec_disjoint_behaviors then acc else b::acc) old_spec.spec_disjoint_behaviors fresh_spec.spec_disjoint_behaviors end let clear_funspec spec = let tmp = Cil.empty_funspec () in spec.spec_terminates <- tmp.spec_terminates; spec.spec_behavior <- tmp.spec_behavior; spec.spec_complete_behaviors <- tmp.spec_complete_behaviors; spec.spec_disjoint_behaviors <- tmp.spec_disjoint_behaviors; spec.spec_variant <- tmp.spec_variant let lhost_c_type = function | TVar v -> (match v.lv_type with | Ctype ty -> ty | _ -> assert false) | TMem t -> (match t.term_type with | Ctype (TPtr(ty,_)) -> ty | _ -> assert false) | TResult ty -> ty let is_assert ca = match ca.annot_content with AAssert _ -> true | _ -> false let is_contract ca = match ca.annot_content with AStmtSpec _ -> true | _ -> false let is_stmt_invariant ca = match ca.annot_content with AInvariant(_,f,_) -> not f | _ -> false let is_loop_invariant ca = match ca.annot_content with AInvariant(_,f,_) -> f | _ -> false let is_invariant ca = match ca.annot_content with AInvariant _ -> true | _ -> false let is_variant ca = match ca.annot_content with AVariant _ -> true | _ -> false let is_allocation ca = match ca.annot_content with AAllocation _ -> true | _ -> false let is_assigns ca = match ca.annot_content with AAssigns _ -> true | _ -> false let is_pragma ca = match ca.annot_content with APragma _ -> true | _ -> false let is_loop_pragma ca = match ca.annot_content with APragma (Loop_pragma _) -> true | _ -> false let is_slice_pragma ca = match ca.annot_content with APragma (Slice_pragma _) -> true | _ -> false let is_impact_pragma ca = match ca.annot_content with APragma (Impact_pragma _) -> true | _ -> false let is_loop_annot s = is_loop_invariant s || is_assigns s || is_allocation s || is_variant s || is_loop_pragma s let is_property_pragma = function | Loop_pragma (Unroll_specs _ | Widen_hints _ | Widen_variables _) | Slice_pragma (SPexpr _ | SPctrl | SPstmt) | Impact_pragma (IPexpr _ | IPstmt) -> false (* If at some time a pragma becomes something which should be proven, update the pragma-related code in gui/property_navigator.ml *) let extract_loop_pragma l = List.fold_right (fun ca l -> match ca.annot_content with APragma (Loop_pragma lp) -> lp::l | _ -> l) l [] let extract_contract l = List.fold_right (fun ca l -> match ca.annot_content with AStmtSpec (l1,spec) -> (l1,spec) :: l | _ -> l) l [] (* ************************************************************************* *) (** {2 Parsing utilities} *) (* ************************************************************************* *) (** Hack to allow typedefs whose names are ACSL keywords: the state of the lexer depends on the parser rule. See logic_lexer.mll and logic_parser.mly for more details. *) let extensions = ref Datatype.String.Set.empty let register_extension s = extensions := Datatype.String.Set.add s !extensions let is_extension s = Datatype.String.Set.mem s !extensions (** - false => keywords are all ACSL keywords - true => only C keywords are recognized as such. (other remains plain identifiers/typenames) *) let kw_c_mode = ref false let enter_kw_c_mode () = kw_c_mode := true let exit_kw_c_mode () = kw_c_mode := false let is_kw_c_mode () = !kw_c_mode let rt_type_mode = ref false (** enter a mode where any identifier is considered a type name. Needed for for return type of a logic function, as the list of admissible variables will be known afterwards. *) let enter_rt_type_mode () = rt_type_mode:=true let exit_rt_type_mode () = rt_type_mode:=false let is_rt_type_mode () = !rt_type_mode let pointer_comparable ?loc t1 t2 = let preds = Logic_env.find_all_logic_functions "\\pointer_comparable" in let cfct_ptr = TPtr (TFun(Cil.voidType,None,false,[]),[]) in let fct_ptr = Ctype cfct_ptr in let obj_ptr = Ctype Cil.voidPtrType in let discriminate t = let loc = t.term_loc in match t.term_type with | Ctype ty -> (match Cil.unrollType ty with | TPtr(TFun _,_) -> Logic_const.term ~loc (TCastE(cfct_ptr,t)) fct_ptr, fct_ptr | TPtr _ -> t, obj_ptr | TInt _ when Cil.isLogicZero t -> t, obj_ptr | TVoid _ | TInt _ | TFloat _ | TFun _ | TNamed _ | TComp _ | TEnum _ | TBuiltin_va_list _ | TArray _ -> Logic_const.term ~loc (TCastE(voidPtrType,t)) obj_ptr, obj_ptr ) | _ -> Logic_const.term ~loc (TCastE(voidPtrType,t)) obj_ptr, obj_ptr in let t1, ty1 = discriminate t1 in let t2, ty2 = discriminate t2 in let pi = try List.find (function | { l_profile = [v1; v2] } -> is_same_type v1.lv_type ty1 && is_same_type v2.lv_type ty2 | _ -> false) preds with Not_found -> Kernel.fatal "built-in predicate \\pointer_comparable not found" in Logic_const.unamed ?loc (Papp (pi, [], [t1;t2])) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/logic_lexer.mll0000644000175000017500000004167412155630366021455 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) { open Logic_parser open Lexing open Logic_ptree type state = Normal | Test let state_stack = Stack.create () let () = Stack.push Normal state_stack let get_state () = try Stack.top state_stack with Stack.Empty -> Normal let pop_state () = try ignore (Stack.pop state_stack) with Stack.Empty -> () exception Error of (int * int) * string let loc lexbuf = (lexeme_start lexbuf, lexeme_end lexbuf) let lex_error lexbuf s = raise (Error (loc lexbuf, "lexical error, " ^ s)) let find_utf8 = let h = Hashtbl.create 97 in List.iter (fun (i,t) -> Hashtbl.add h i t) [ Utf8_logic.forall, FORALL; Utf8_logic.exists, EXISTS; Utf8_logic.eq, EQ; Utf8_logic.neq, NE; Utf8_logic.le, LE; Utf8_logic.ge, GE; Utf8_logic.implies,IMPLIES; Utf8_logic.iff, IFF; Utf8_logic.conj, AND; Utf8_logic.disj, OR; Utf8_logic.neg, NOT; Utf8_logic.x_or, HATHAT; Utf8_logic.minus, MINUS; Utf8_logic.boolean, BOOLEAN; Utf8_logic.integer, INTEGER; Utf8_logic.real, REAL ]; fun s -> try Hashtbl.find h s with Not_found -> IDENTIFIER s let identifier, is_acsl_keyword = let all_kw = Hashtbl.create 37 in let c_kw = Hashtbl.create 37 in let type_kw = Hashtbl.create 3 in List.iter (fun (i,t,flag) -> Hashtbl.add all_kw i t; if flag then Hashtbl.add c_kw i t ) [ "allocates", ALLOCATES, false; "assert", ASSERT, false; "assigns", ASSIGNS, false; "assumes", ASSUMES, false; "at", EXT_AT, false;(* ACSL extension for external spec file *) "axiom", AXIOM, false; "axiomatic", AXIOMATIC, false; "behavior", BEHAVIOR, false; "behaviors", BEHAVIORS, false; "breaks", BREAKS, false; "case", CASE, true; "char", CHAR, true; "complete", COMPLETE, false; "const", CONST, true; "continues", CONTINUES, false; "contract", CONTRACT, false;(* ACSL extension for external spec file *) "custom", CUSTOM, false; (* ACSL extension for custom annotations *) "decreases", DECREASES, false; "disjoint", DISJOINT, false; "double", DOUBLE, true; "else", ELSE, true; "ensures", ENSURES, false ; "enum", ENUM, true; "exits", EXITS, false; "frees", FREES, false; "function", FUNCTION, false;(* ACSL extension for external spec file *) "float", FLOAT, true; "for", FOR, true; "global", GLOBAL, false; "if", IF, true; "impact", IMPACT, false; "inductive", INDUCTIVE, false; "include", INCLUDE, false;(* ACSL extension for external spec file *) "int", INT, true; "invariant", INVARIANT, false; "label", LABEL, false; "lemma", LEMMA, false; "let", EXT_LET, false;(* ACSL extension for external spec file *) "logic", LOGIC, false; "long", LONG, true; "loop", LOOP, false; "model", MODEL, false;(* ACSL extension for model fields *) "module", MODULE, false;(* ACSL extension for external spec file *) "pragma", PRAGMA, false; "predicate", PREDICATE, false; "reads", READS, false; "requires", REQUIRES, false; "returns", RETURNS, false; "short", SHORT, true; "signed", SIGNED, true; "sizeof", SIZEOF, true; "slice", SLICE, false; "struct", STRUCT, true; "terminates", TERMINATES, false; "type", TYPE, false; "union", UNION, true; "unsigned", UNSIGNED, true; "variant", VARIANT, false; "void", VOID, true; "volatile", VOLATILE, true; "writes", WRITES, false; ]; List.iter (fun (x, y) -> Hashtbl.add type_kw x y) ["integer", INTEGER; "real", REAL; "boolean", BOOLEAN; ]; (fun s -> try Hashtbl.find (if Logic_utils.is_kw_c_mode () then c_kw else all_kw) s with Not_found -> if Logic_env.typename_status s then TYPENAME s else (try Hashtbl.find type_kw s with Not_found -> if Logic_utils.is_rt_type_mode () then TYPENAME s else IDENTIFIER s)), (fun s -> Hashtbl.mem all_kw s || Hashtbl.mem type_kw s) let bs_identifier = let h = Hashtbl.create 97 in List.iter (fun (i,t) -> Hashtbl.add h i t) [ "\\allocation", ALLOCATION; "\\allocable", ALLOCABLE; "\\automatic", AUTOMATIC; "\\at", AT; "\\base_addr", BASE_ADDR; "\\block_length", BLOCK_LENGTH; "\\dynamic", DYNAMIC; "\\empty", EMPTY; "\\exists", EXISTS; "\\false", FALSE; "\\forall", FORALL; "\\freeable", FREEABLE; "\\fresh", FRESH; "\\from", FROM; "\\initialized", INITIALIZED; "\\inter", INTER; "\\lambda", LAMBDA; "\\let", LET; "\\nothing", NOTHING; "\\null", NULL; "\\offset", OFFSET; "\\old", OLD; "\\register", REGISTER; "\\result", RESULT; "\\separated", SEPARATED; "\\static", STATIC; "\\true", TRUE; "\\type", BSTYPE; "\\typeof", TYPEOF; "\\unallocated", UNALLOCATED; "\\union", BSUNION; "\\valid", VALID; "\\valid_read", VALID_READ; "\\valid_index", VALID_INDEX; "\\valid_range", VALID_RANGE; "\\with", WITH; ]; fun lexbuf -> let s = lexeme lexbuf in try Hashtbl.find h s with Not_found -> IDENTIFIER s let int_of_digit chr = match chr with '0'..'9' -> (Char.code chr) - (Char.code '0') | 'a'..'f' -> (Char.code chr) - (Char.code 'a') + 10 | 'A'..'F' -> (Char.code chr) - (Char.code 'A') + 10 | _ -> assert false (* Update lexer buffer. *) let update_newline_loc lexbuf = let pos = lexbuf.Lexing.lex_curr_p in lexbuf.Lexing.lex_curr_p <- { pos with Lexing.pos_lnum = pos.Lexing.pos_lnum + 1; Lexing.pos_bol = pos.Lexing.pos_cnum; } (* Update lexer buffer. *) let update_line_loc lexbuf line absolute chars = let pos = lexbuf.Lexing.lex_curr_p in lexbuf.Lexing.lex_curr_p <- { pos with Lexing.pos_lnum = if absolute then line else pos.Lexing.pos_lnum + line; Lexing.pos_bol = pos.Lexing.pos_cnum - chars; } (* Update lexer buffer. *) let update_file_loc lexbuf file = let pos = lexbuf.Lexing.lex_curr_p in lexbuf.Lexing.lex_curr_p <- { pos with Lexing.pos_fname = file } (* Update lexer buffer. *) let update_bol_loc lexbuf bol = let pos = lexbuf.Lexing.lex_curr_p in lexbuf.Lexing.lex_curr_p <- { pos with Lexing.pos_bol = bol} } let space = [' ' '\t' '\012' '\r' '@' ] let rD = ['0'-'9'] let rO = ['0'-'7'] let rL = ['a'-'z' 'A'-'Z' '_'] let rH = ['a'-'f' 'A'-'F' '0'-'9'] let rE = ['E''e']['+''-']? rD+ let rP = ['P''p']['+''-']? rD+ let rFS = ('f'|'F'|'l'|'L'|'d'|'D') let rIS = ('u'|'U'|'l'|'L')* let comment_line = "//" [^'\n']* let escape = '\\' ('\'' | '"' | '?' | '\\' | 'a' | 'b' | 'f' | 'n' | 'r' | 't' | 'v') let hex_escape = '\\' ['x' 'X'] rH+ let oct_escape = '\\' rO rO? rO? let utf8_char = ['\128'-'\254']+ rule token = parse | space+ { token lexbuf } | '\n' { update_newline_loc lexbuf; token lexbuf } | comment_line '\n' { update_newline_loc lexbuf; token lexbuf } | comment_line eof { token lexbuf } | '\\' rL (rL | rD)* { bs_identifier lexbuf } | rL (rL | rD)* { let s = lexeme lexbuf in identifier s } | '0'['x''X'] rH+ rIS? { CONSTANT (IntConstant (lexeme lexbuf)) } | '0' rD+ rIS? { CONSTANT (IntConstant (lexeme lexbuf)) } | rD+ { CONSTANT10 (lexeme lexbuf) } | rD+ rIS { CONSTANT (IntConstant (lexeme lexbuf)) } | ('L'? "'" as prelude) (([^ '\\' '\'' '\n']|("\\"[^ '\n']))+ as content) "'" { let b = Buffer.create 5 in Buffer.add_string b prelude; let lbf = Lexing.from_string content in CONSTANT (IntConstant (chr b lbf ^ "'")) } (* floating-point literals, both decimal and hexadecimal *) | rD+ rE rFS? | rD* "." rD+ (rE)? rFS? | rD+ "." rD* (rE)? rFS? | '0'['x''X'] rH+ '.' rH* rP rFS? | '0'['x''X'] rH* '.' rH+ rP rFS? | '0'['x''X'] rH+ rP rFS? { CONSTANT (FloatConstant (lexeme lexbuf)) } (* hack to lex 0..3 as 0 .. 3 and not as 0. .3 *) | (rD+ as n) ".." { lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - 2; CONSTANT (IntConstant n) } | 'L'? '"' as prelude (([^ '\\' '"' '\n']|("\\"[^ '\n']))* as content) '"' { STRING_LITERAL (prelude.[0] = 'L',content) } | '#' { hash lexbuf } | "==>" { IMPLIES } | "<==>" { IFF } | "-->" { BIMPLIES } | "<-->" { BIFF } | "&&" { AND } | "||" { OR } | "!" { NOT } | "$" { DOLLAR } | "," { COMMA } | "->" { ARROW } | "?" { Stack.push Test state_stack; QUESTION } | ";" { SEMICOLON } | ":" { match get_state() with Normal -> COLON | Test -> pop_state(); COLON2 } | "::" { COLONCOLON } | "." { DOT } | ".." { DOTDOT } | "..." { DOTDOTDOT } | "-" { MINUS } | "+" { PLUS } | "*" { STAR } | "&" { AMP } | "^^" { HATHAT } | "^" { HAT } | "|" { PIPE } | "~" { TILDE } | "/" { SLASH } | "%" { PERCENT } | "<" { LT } | ">" { GT } | "<=" { LE } | ">=" { GE } | "==" { EQ } | "=" { EQUAL } | "!=" { NE } | "(" { Stack.push Normal state_stack; LPAR } | ")" { pop_state(); RPAR } | "{" { Stack.push Normal state_stack; LBRACE } | "}" { pop_state(); RBRACE } | "[" { Stack.push Normal state_stack; LSQUARE } | "]" { pop_state(); RSQUARE } | "<:" { LTCOLON } | ":>" { COLONGT } | "<<" { LTLT } | ">>" { GTGT } | utf8_char as c { find_utf8 c } | eof { EOF } | _ { lex_error lexbuf ("illegal character " ^ lexeme lexbuf) } and chr buffer = parse | hex_escape { let s = lexeme lexbuf in let real_s = String.sub s 2 (String.length s - 2) in let rec add_one_char s = let l = String.length s in if l = 0 then () else let h = int_of_digit s.[0] in let c,s = if l = 1 then (h,"") else (16*h + int_of_digit s.[1], String.sub s 2 (String.length s - 2)) in Buffer.add_char buffer (Char.chr c); add_one_char s in add_one_char real_s; chr buffer lexbuf } | oct_escape { let s = lexeme lexbuf in let real_s = String.sub s 1 (String.length s - 1) in let rec value i s = if s = "" then i else value (8*i+int_of_digit s.[0]) (String.sub s 1 (String.length s -1)) in let c = value 0 real_s in Buffer.add_char buffer (Char.chr c); chr buffer lexbuf } | escape { Buffer.add_char buffer (match (lexeme lexbuf).[1] with 'a' -> '\007' | 'b' -> '\b' | 'f' -> '\012' | 'n' -> '\n' | 'r' -> '\r' | 't' -> '\t' | '\'' -> '\'' | '"' -> '"' | '?' -> '?' | '\\' -> '\\' | _ -> assert false ); chr buffer lexbuf} | eof { Buffer.contents buffer } | _ { Buffer.add_string buffer (lexeme lexbuf); chr buffer lexbuf } and hash = parse '\n' { update_newline_loc lexbuf; token lexbuf} | [' ''\t'] { hash lexbuf} | rD+ { (* We are seeing a line number. This is the number for the * next line *) let s = Lexing.lexeme lexbuf in let lineno = try int_of_string s with Failure ("int_of_string") -> (* the int is too big. *) Kernel.warning ~source:lexbuf.lex_start_p "Bad line number in preprocessed file: %s" s; (-1) in update_line_loc lexbuf (lineno - 1) true 0; (* A file name may follow *) file lexbuf } | "line" { hash lexbuf } (* MSVC line number info *) | _ { endline lexbuf} and file = parse '\n' { update_newline_loc lexbuf; token lexbuf} | [' ''\t''\r'] { file lexbuf} | '"' [^ '\012' '\t' '"']* '"' { let n = Lexing.lexeme lexbuf in let n1 = String.sub n 1 ((String.length n) - 2) in update_file_loc lexbuf n1; endline lexbuf } | _ { endline lexbuf} and endline = parse '\n' { update_newline_loc lexbuf; token lexbuf} | eof { EOF } | _ { endline lexbuf} { let copy_lexbuf dest_lexbuf src_loc = update_file_loc dest_lexbuf src_loc.pos_fname; update_line_loc dest_lexbuf src_loc.pos_lnum true 0; let bol = src_loc.Lexing.pos_cnum - src_loc.Lexing.pos_bol in update_bol_loc dest_lexbuf (-bol) let start_pos lexbuf = let pos = lexeme_start_p lexbuf in pos.Lexing.pos_cnum - pos.Lexing.pos_bol let end_pos lexbuf = let pos = lexeme_end_p lexbuf in pos.Lexing.pos_cnum - pos.Lexing.pos_bol let parse_from_location f (loc, s : Lexing.position * string) = let output = if Kernel.ContinueOnAnnotError.get() then Kernel.warning ~once:true else Kernel.error ~once:false in let lb = from_string s in copy_lexbuf lb loc; try let res = f token lb in lb.Lexing.lex_curr_p, res with | Parsing.Parse_error as _e -> output ~source:lb.lex_curr_p "unexpected token '%s'" (Lexing.lexeme lb); Logic_utils.exit_kw_c_mode (); raise Parsing.Parse_error | Error (_, m) -> output ~source:lb.lex_curr_p "%s" m; Logic_utils.exit_kw_c_mode (); raise Parsing.Parse_error | Logic_utils.Not_well_formed (loc, m) -> output ~source:(fst loc) "%s" m; Logic_utils.exit_kw_c_mode (); raise Parsing.Parse_error | exn -> output ~source:lb.lex_curr_p "Unknown error (%s)" (Printexc.to_string exn); Logic_utils.exit_kw_c_mode (); raise exn let lexpr = parse_from_location Logic_parser.lexpr_eof let annot = parse_from_location Logic_parser.annot let spec = parse_from_location Logic_parser.spec (* ACSL extension for external spec file *) let ext_spec = parse_from_location Logic_parser.ext_spec } (* Local Variables: compile-command: "make -C ../../.. byte" End: *) frama-c-Fluorine-20130601/cil/src/logic/logic_typing.mli0000644000175000017500000002136312155630366021636 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) (** Logic typing and logic environment. @plugin development guide *) open Cil_types (** Relation operators conversion @since Nitrogen-20111001 *) val type_rel: Logic_ptree.relation -> Cil_types.relation (** Arithmetic binop conversion. Addition and Substraction are always considered as being used on integers. It is the responsibility of the user to introduce PlusPI/IndexPI, MinusPI and MinusPP where needed. @since Nitrogen-20111001 *) val type_binop: Logic_ptree.binop -> Cil_types.binop val unescape: string -> string val wcharlist_of_string: string -> int64 list val is_arithmetic_type: Cil_types.logic_type -> bool val is_integral_type: Cil_types.logic_type -> bool val is_set_type: Cil_types.logic_type -> bool val is_array_type: Cil_types.logic_type -> bool val is_pointer_type: Cil_types.logic_type -> bool val type_of_pointed: logic_type -> logic_type val type_of_array_elem: logic_type -> logic_type val type_of_set_elem: logic_type -> logic_type val ctype_of_pointed: logic_type -> typ val ctype_of_array_elem: logic_type -> typ val add_offset_lval: term_offset -> term_lval -> term_lval val arithmetic_conversion: Cil_types.logic_type -> Cil_types.logic_type -> Cil_types.logic_type (** Local logic environment *) module Lenv : sig type t val empty : unit -> t end (** Functions that can be called when type-checking an extension of ACSL. *) type typing_context = { is_loop: unit -> bool; anonCompFieldName : string; conditionalConversion : typ -> typ -> typ; find_macro : string -> Logic_ptree.lexpr; find_var : string -> logic_var; find_enum_tag : string -> exp * typ; find_comp_type : kind:string -> string -> typ; find_comp_field: compinfo -> string -> offset; find_type : string -> typ; find_label : string -> stmt ref; remove_logic_function : string -> unit; remove_logic_type: string -> unit; remove_logic_ctor: string -> unit; add_logic_function: logic_info -> unit; add_logic_type: string -> logic_type_info -> unit; add_logic_ctor: string -> logic_ctor_info -> unit; find_all_logic_functions: string -> logic_info list; find_logic_type: string -> logic_type_info; find_logic_ctor: string -> logic_ctor_info; pre_state:Lenv.t; post_state:termination_kind list -> Lenv.t; assigns_env: Lenv.t; type_predicate:Lenv.t -> Logic_ptree.lexpr -> predicate named; type_term:Lenv.t -> Logic_ptree.lexpr -> term; type_assigns: accept_formal:bool -> Lenv.t -> Logic_ptree.lexpr assigns -> identified_term assigns; error: 'a. location -> ('a,Format.formatter,unit) format -> 'a; } (** [register_behavior_bextension name f] registers a typing function [f] to be used to type clause with name [name]. This function may change the funbehavior in place. Here is a basic example: let foo_typer ~typing_context ~loc bhv ps = match ps with p::[] -> bhv.b_extended <- ("FOO",42, [Logic_const.new_predicate (typing_context.type_predicate (typing_context.post_state Normal) p)]) ::bhv.b_extended | _ -> typing_context.error loc "expecting a predicate after keyword FOO" let () = register_behavior_extension "FOO" foo_typer @since Carbon-20101201 *) val register_behavior_extension: string -> (typing_context:typing_context -> loc:location -> funbehavior -> Logic_ptree.lexpr list -> unit) -> unit module Make (C : sig val is_loop: unit -> bool (** whether the annotation we want to type is contained in a loop. *) val anonCompFieldName : string val conditionalConversion : typ -> typ -> typ val find_macro : string -> Logic_ptree.lexpr val find_var : string -> logic_var val find_enum_tag : string -> exp * typ val find_comp_type : kind:string -> string -> typ val find_comp_field: compinfo -> string -> offset val find_type : string -> typ val find_label : string -> stmt ref val remove_logic_function : string -> unit val remove_logic_type: string -> unit val remove_logic_ctor: string -> unit val add_logic_function: logic_info -> unit val add_logic_type: string -> logic_type_info -> unit val add_logic_ctor: string -> logic_ctor_info -> unit val find_all_logic_functions : string -> Cil_types.logic_info list val find_logic_type: string -> logic_type_info val find_logic_ctor: string -> logic_ctor_info (** What to do when we have a term of type Integer in a context expecting a C integral type. @raise Failure to reject such conversion @since Nitrogen-20111001 *) val integral_cast: Cil_types.typ -> Cil_types.term -> Cil_types.term end) : sig (** @since Nitrogen-20111001 *) val type_of_field: location -> string -> logic_type -> (term_offset * logic_type) (** @since Nitrogen-20111001 *) val mk_cast: Cil_types.term -> Cil_types.logic_type -> Cil_types.term (** type-checks a term. *) val term : Lenv.t -> Logic_ptree.lexpr -> term val predicate : Lenv.t -> Logic_ptree.lexpr -> predicate named (** [code_annot loc behaviors rt annot] type-checks an in-code annotation. @param loc current location @param behaviors list of existing behaviors @param rt return type of current function @param annot the annotation *) val code_annot : Cil_types.location -> string list -> Cil_types.logic_type -> Logic_ptree.code_annot -> code_annotation val type_annot : location -> Logic_ptree.type_annot -> logic_info val model_annot : location -> Logic_ptree.model_annot -> model_info val annot : Logic_ptree.decl -> global_annotation val custom : Logic_ptree.custom_tree -> Cil_types.custom_tree (** [funspec behaviors f prms typ spec] type-checks a function contract. @param behaviors list of existing behaviors (outside of the current spec, e.g. in the spec of the corresponding declaration when type-checking the spec of a definition) @param f the function @param prms its parameters @param its type @param spec the spec to typecheck *) val funspec : string list -> varinfo -> (varinfo list) option -> typ -> Logic_ptree.spec -> funspec end (** append the Old and Post labels in the environment *) val append_old_and_post_labels: Lenv.t -> Lenv.t (** appends the Here label in the environment *) val append_here_label: Lenv.t -> Lenv.t (** appends the "Pre" label in the environment *) val append_pre_label: Lenv.t -> Lenv.t (** adds a given variable in local environment. *) val add_var: string -> logic_var -> Lenv.t -> Lenv.t (** add [\result] in the environment. *) val add_result: Lenv.t -> logic_type -> Lenv.t (** enter a given post-state. *) val enter_post_state: Lenv.t -> termination_kind -> Lenv.t (** enter a given post-state and put [\result] in the env. NB: if the kind of the post-state is neither [Normal] nor [Returns], this is not a normal ACSL environment. Use with caution. *) val post_state_env: termination_kind -> logic_type -> Lenv.t (* Local Variables: compile-command: "LC_ALL=C make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/logic_builtin.ml0000644000175000017500000002525512155630366021625 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) open Cil_types let add = Logic_env.add_builtin_logic_function_gen Logic_utils.is_same_builtin_profile let float_type = Ctype Cil.floatType let double_type = Ctype Cil.doubleType let long_double_type = Ctype Cil.longDoubleType let object_ptr = Ctype Cil.voidPtrType let fun_ptr = Ctype (TPtr(TFun(Cil.voidType,None,false,[]),[])) let init = let called = ref false in (* Since hooks are not projectified this function must be added exactly once per session, otherwise we might end up with several built-ins with the same name. *) fun () -> if !called then (fun () -> ()) else begin called:=true; fun () -> (* types *) (* let tvar v = new_identified_term (tvar v) in *) let boolean = { lt_name = Utf8_logic.boolean; lt_params = []; lt_def = None; } in let set = { lt_name = "set"; lt_params = ["elem"]; lt_def = None; } in let typetag = {lt_name = "typetag"; lt_params = []; lt_def = None; } in let sign = {lt_name = "sign"; lt_params = []; lt_def = None; } in let float_format = {lt_name = "float_format"; lt_params = []; lt_def = None; } in let rounding_mode = {lt_name = "rounding_mode"; lt_params = []; lt_def = None; } in List.iter (fun x -> Logic_env.add_builtin_logic_type x.lt_name x) [ boolean; set; typetag; sign; float_format; rounding_mode ]; (* constructors *) List.iter (fun (typename, constrs) -> let l = List.map (fun cname -> let c = { ctor_name = cname; ctor_type = typename; ctor_params = [] } in Logic_env.add_builtin_logic_ctor cname c; c) constrs in typename.lt_def <- Some (LTsum l)) [ boolean, ["\\true"; "\\false"]; sign , [ "\\Positive"; "\\Negative"] ; float_format, [ "\\Single"; "\\Double"; "\\Quad" ] ; rounding_mode, [ "\\Up"; "\\Down"; "\\ToZero"; "\\NearestAway"; "\\NearestEven" ]; ]; let float_format = Ltype(float_format,[]) in let rounding_mode = Ltype(rounding_mode,[]) in (* predicates *) List.iter (fun (f,tparams,params) -> add { bl_name = f; bl_params = tparams; bl_profile = params; bl_type = None; bl_labels = []}) [ "\\is_finite", [], ["x", float_type] ; "\\is_finite", [], ["x", double_type] ; "\\is_finite", [], ["x", long_double_type] ; "\\is_infinite", [], ["x", float_type] ; "\\is_infinite", [], ["x", double_type] ; "\\is_infinite", [], ["x", long_double_type] ; "\\is_NaN", [], ["x", float_type] ; "\\is_NaN", [], ["x", double_type] ; "\\is_NaN", [], ["x", long_double_type] ; "\\is_minus_infinity", [], ["x", float_type] ; "\\is_minus_infinity", [], ["x", double_type] ; "\\is_minus_infinity", [], ["x", long_double_type] ; "\\is_plus_infinity", [], ["x", float_type] ; "\\is_plus_infinity", [], ["x", double_type] ; "\\is_plus_infinity", [], ["x", long_double_type] ; "\\le_float", [], ["x", float_type; "y", float_type]; "\\lt_float", [], ["x", float_type; "y", float_type]; "\\ge_float", [], ["x", float_type; "y", float_type]; "\\gt_float", [], ["x", float_type; "y", float_type]; "\\eq_float", [], ["x", float_type; "y", float_type]; "\\ne_float", [], ["x", float_type; "y", float_type]; "\\le_float", [], ["x", double_type; "y", double_type]; "\\lt_float", [], ["x", double_type; "y", double_type]; "\\ge_float", [], ["x", double_type; "y", double_type]; "\\gt_float", [], ["x", double_type; "y", double_type]; "\\eq_float", [], ["x", double_type; "y", double_type]; "\\ne_float", [], ["x", double_type; "y", double_type]; "\\no_overflow_single", [], ["m", rounding_mode; "x", Lreal] ; "\\no_overflow_double", [], ["m", rounding_mode; "x", Lreal] ; "\\subset", ["a"], ["s1", Ltype (set, [Lvar "a"]); "s2", Ltype (set, [Lvar "a"])]; "\\pointer_comparable", [], [("p1", object_ptr); ("p2", object_ptr)]; "\\pointer_comparable", [], [("p1", fun_ptr); ("p2", fun_ptr)]; "\\pointer_comparable", [], [("p1", fun_ptr); ("p2", object_ptr)]; "\\pointer_comparable", [], [("p1", object_ptr); ("p2", fun_ptr)]; ]; (* functions *) List.iter (fun (f,params,ret_type) -> add { bl_name = f; bl_params = []; bl_profile = params; bl_type = Some ret_type; bl_labels = []}) [ "\\min", ["x",Linteger;"y",Linteger], Linteger ; "\\max", ["x",Linteger;"y",Linteger], Linteger ; "\\min", ["x",Lreal;"y",Lreal], Lreal ; "\\max", ["x",Lreal;"y",Lreal], Lreal ; "\\abs", ["x",Linteger], Linteger ; "\\labs", ["x",Linteger], Linteger ; "\\abs", ["x",Lreal], Lreal ; "\\fabs", ["x",Lreal], Lreal ; "\\sqrt", ["x",Lreal], Lreal ; "\\pow", ["x",Lreal;"y",Lreal], Lreal ; "\\ceil", ["x",Lreal], Linteger ; "\\floor", ["x",Lreal], Linteger ; (* transcendantal functions *) "\\exp", ["x",Lreal], Lreal ; "\\log", ["x",Lreal], Lreal ; "\\log10", ["x",Lreal], Lreal ; "\\cos", ["x",Lreal], Lreal ; "\\sin", ["x",Lreal], Lreal ; "\\tan", ["x",Lreal], Lreal ; "\\pi", [], Lreal ; "\\cosh", ["x",Lreal], Lreal ; "\\sinh", ["x",Lreal], Lreal ; "\\tanh", ["x",Lreal], Lreal ; "\\acos", ["x",Lreal], Lreal ; "\\asin", ["x",Lreal], Lreal ; "\\atan", ["x",Lreal], Lreal ; "\\atan2", ["x",Lreal;"y",Lreal], Lreal ; "\\hypot", ["x",Lreal;"y",Lreal], Lreal ; (* TODO ? * div() fmod() frexp() ldexp() * ldiv() modf() modf() *) "\\sum", ["min",Linteger; "max", Linteger; "f",(Larrow ([Linteger],Linteger))], Linteger ; "\\sum", ["min",Linteger; "max", Linteger; "f",(Larrow ([Linteger],Lreal))], Lreal ; "\\product", ["min",Linteger; "max", Linteger; "f",(Larrow ([Linteger],Linteger))], Linteger ; "\\product", ["min",Linteger; "max", Linteger; "f",(Larrow ([Linteger],Lreal))], Lreal ; "\\min", ["min",Linteger; "max", Linteger; "f",(Larrow ([Linteger],Linteger))], Linteger ; "\\min", ["min",Linteger; "max", Linteger; "f",(Larrow ([Linteger],Lreal))], Lreal ; "\\max", ["min",Linteger; "max", Linteger; "f",(Larrow ([Linteger],Linteger))], Linteger ; "\\max", ["min",Linteger; "max", Linteger; "f",(Larrow ([Linteger],Lreal))], Lreal ; "\\numof", ["min",Linteger; "max", Linteger; "f",(Larrow ([Linteger],Ltype(boolean,[])))], Linteger ; (* for floats special values *) "\\round_float", ["f", float_format; "m", rounding_mode; "x", Lreal], Lreal ; "\\sign", ["x",float_type], Ltype(sign,[]) ; "\\sign", ["x",double_type], Ltype(sign,[]) ; "\\sign", ["x",long_double_type], Ltype(sign,[]) ; "\\model", ["x",float_type], Lreal; "\\model", ["x",double_type], Lreal; (*"\\model", ["x",long_double_type], Lreal;*) "\\exact", ["x",float_type], Lreal; "\\exact", ["x",double_type], Lreal; (*"\\exact", ["x",long_double_type], Lreal;*) "\\total_error", ["x",float_type], Lreal; "\\total_error", ["x",double_type], Lreal; (*"\\total_error", ["x",long_double_type], Lreal;*) "\\round_error", ["x",float_type], Lreal; "\\round_error", ["x",double_type], Lreal; (*"\\round_error", ["x",long_double_type], Lreal;*) "\\relative_error", ["x",float_type], Lreal; "\\relative_error", ["x",double_type], Lreal; (*"\\relative_error", ["x",long_double_type], Lreal;*) "\\round_float", ["m", rounding_mode; "x", Lreal], float_type; "\\round_double", ["m", rounding_mode ; "x", Lreal], double_type; (*"\\round_quad", ["m", rounding_mode; "x", Lreal], long_double_type;*) ] end (* Local Variables: compile-command: "make -j -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/logic/logic_preprocess.mll0000644000175000017500000003704112155630366022514 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 2.1 *) (* for more details (enclosed in the file licenses/LGPLv2.1). *) (* *) (**************************************************************************) { open Lexing type state = NORMAL | SLASH | INCOMMENT type end_of_buffer = NEWLINE | SPACE | CHAR let buf = Buffer.create 1024 let macros = Buffer.create 1024 let beg_of_line = Buffer.create 8 let blacklisted_macros = [ "__STDC__"; "__STDC_HOSTED__"; "assert"] let is_newline = ref CHAR let curr_file = ref "" let curr_line = ref 1 let is_ghost = ref false let begin_annot_line = ref 1 let reset () = Buffer.clear buf; Buffer.clear macros; Buffer.clear beg_of_line; is_newline := CHAR; curr_file := ""; curr_line := 1; is_ghost := false; begin_annot_line := 1 let backslash = "__BACKSLASH__" let abort_preprocess reason outfile = let source = {Lexing.dummy_pos with Lexing.pos_fname = !curr_file; pos_lnum = !curr_line;} in Kernel.error ~source "Can't preprocess annotation: %s\nAnnotation will be kept as is" reason; Buffer.output_buffer outfile buf let preprocess_annot suffix cpp outfile = (*Printf.printf "Preprocessing annotation:\n%!"; Buffer.output_buffer stdout buf; print_newline(); *) let debug = Kernel.debug_atleast 3 || Kernel.Debug_category.exists (fun x -> x = "parser") in let ppname = try Extlib.temp_file_cleanup_at_exit ~debug "ppannot" suffix with Extlib.Temp_file_error s -> Kernel.abort "Could not open temporary file for logic pre-processing: %s" s in let ppfile = open_out ppname in Buffer.output_buffer ppfile macros; (* NB: the three extra spaces replace the beginning of the annotation in order to keep the columns count accurate (at least until there's a macro expansion). *) Printf.fprintf ppfile "# %d %s \n " !begin_annot_line !curr_file; Buffer.output_buffer ppfile beg_of_line; Buffer.output_buffer ppfile buf; (* cpp complains if the temp file does not end with a newline *) Buffer.clear beg_of_line; if not (!is_newline = NEWLINE) then output_char ppfile '\n'; close_out ppfile; let cppname = Extlib.temp_file_cleanup_at_exit ~debug "cppannot" suffix in let res = Sys.command (cpp ppname cppname) in if not debug then Extlib.safe_remove ppname; output_string outfile "/*@"; if !is_ghost then output_string outfile " ghost\n"; if res <> 0 then begin abort_preprocess "Preprocessor call exited with an error" outfile; if not debug then Extlib.safe_remove cppname end else begin try let tmp = open_in_bin cppname in let tmp_buf = Buffer.create 1024 in Buffer.clear tmp_buf; let x = ref (input_char tmp) in let state = ref NORMAL in (try while true do (* we have to remove the spurious \n at the end of buffer*) let c = input_char tmp in (match !x with '/' -> (match !state with NORMAL -> state:=SLASH | SLASH ->state:=INCOMMENT | INCOMMENT -> () ) | '\n' -> state:=NORMAL | _ -> (match !state with SLASH->state:=NORMAL | NORMAL | INCOMMENT -> ()) ); Buffer.add_char tmp_buf !x; x:=c; done; assert false with End_of_file -> if !is_newline <> CHAR then Buffer.add_char tmp_buf !x; (* one-line annotations get a new line anyway. *) if !state = INCOMMENT then Buffer.add_char tmp_buf '\n'; let res = Buffer.contents tmp_buf in let res = Str.global_replace (Str.regexp_string backslash) "\\\\" res in (* Printf.printf "after preprocessing:\n%s%!" res; *) output_string outfile res; close_in tmp; if not debug then Sys.remove cppname) with | End_of_file -> if not debug then (try Sys.remove cppname with Sys_error _ -> ()); abort_preprocess "Empty result in annotation pre-processing" outfile | Sys_error e -> if not debug then (try Sys.remove cppname with Sys_error _ -> ()); abort_preprocess ("System error: " ^ e) outfile end; Printf.fprintf outfile "*/\n# %d %s\n%!" !curr_line !curr_file; Buffer.clear buf let make_newline () = incr curr_line; Buffer.clear beg_of_line } rule main suffix cpp outfile = parse | ("#define"|"#undef") [' ''\t']* ((['a'-'z''A'-'Z''0'-'9''_'])* as m) [^'\n']* '\n' { if not (List.mem m blacklisted_macros) then Buffer.add_string macros (lexeme lexbuf); output_char outfile '\n'; make_newline (); main suffix cpp outfile lexbuf } | "#" [' ''\t']* "line"? [' ''\t']* (['0'-'9']+ as line) [' ''\t']* (('"' [^'"']+ '"') as file) [^'\n']* "\n" { (try curr_line := (int_of_string line) -1 with Failure "int_of_string" -> curr_line:= -1); if file <> "" then curr_file := file; output_string outfile (lexeme lexbuf); make_newline(); main suffix cpp outfile lexbuf } | "/*" (_ as c) { if c = !Clexer.annot_char then begin is_newline:=CHAR; begin_annot_line := ! curr_line; Buffer.clear buf; maybe_ghost suffix cpp outfile lexbuf end else begin output_string outfile (lexeme lexbuf); if c = '\n' then make_newline(); Buffer.add_string beg_of_line " "; comment suffix cpp outfile c lexbuf; end} | "//" (_ as c) { if c = !Clexer.annot_char then begin Buffer.clear buf; begin_annot_line := !curr_line; is_newline:=CHAR; maybe_oneline_ghost suffix cpp outfile lexbuf end else if c = '\n' then begin make_newline (); output_string outfile (lexeme lexbuf); main suffix cpp outfile lexbuf end else begin output_string outfile (lexeme lexbuf); oneline_comment suffix cpp outfile lexbuf; end} | eof { flush outfile } | '\n' { make_newline (); output_char outfile '\n'; main suffix cpp outfile lexbuf } | '"' { Buffer.add_char beg_of_line ' '; output_char outfile '"'; c_string suffix cpp outfile lexbuf } | "'" { Buffer.add_char beg_of_line ' '; output_char outfile '\''; c_char suffix cpp outfile lexbuf } | _ as c { Buffer.add_char beg_of_line ' '; output_char outfile c; main suffix cpp outfile lexbuf } and c_string suffix cpp outfile = parse | "\\\"" { Buffer.add_string beg_of_line " "; output_string outfile (lexeme lexbuf); c_string suffix cpp outfile lexbuf } | "\"" { Buffer.add_char beg_of_line ' '; output_char outfile '"'; main suffix cpp outfile lexbuf } | '\n' { make_newline (); output_char outfile '\n'; c_string suffix cpp outfile lexbuf } | "\\\\" { Buffer.add_string beg_of_line " "; output_string outfile (lexeme lexbuf); c_string suffix cpp outfile lexbuf } | _ as c { Buffer.add_char beg_of_line ' '; output_char outfile c; c_string suffix cpp outfile lexbuf } (* C syntax allows for multiple char character constants *) and c_char suffix cpp outfile = parse | "\\\'" { Buffer.add_string beg_of_line " "; output_string outfile (lexeme lexbuf); c_char suffix cpp outfile lexbuf } | "'" { Buffer.add_char beg_of_line ' '; output_char outfile '\''; main suffix cpp outfile lexbuf } | '\n' { make_newline (); output_char outfile '\n'; c_char suffix cpp outfile lexbuf } | "\\\\" { Buffer.add_string beg_of_line " "; output_string outfile (lexeme lexbuf); c_char suffix cpp outfile lexbuf } | _ as c { Buffer.add_char beg_of_line ' '; output_char outfile c; c_char suffix cpp outfile lexbuf } and maybe_ghost suffix cpp outfile = parse [' ''\t']+ as space{ Buffer.add_string buf space; maybe_ghost suffix cpp outfile lexbuf } | '\n' { is_newline := NEWLINE; incr curr_line; Buffer.add_char buf '\n'; maybe_ghost suffix cpp outfile lexbuf } | "ghost" { is_ghost := true; Buffer.add_string buf " "; annot suffix cpp outfile lexbuf } (* silently skipping an empty annotation *) | "*/" { main suffix cpp outfile lexbuf } | _ as c { Buffer.add_char buf c; is_ghost:=false; annot suffix cpp outfile lexbuf} and maybe_oneline_ghost suffix cpp outfile = parse [' ''\t']+ as space{ Buffer.add_string buf space; maybe_oneline_ghost suffix cpp outfile lexbuf } | '\n' { incr curr_line; main suffix cpp outfile lexbuf } | "ghost" { is_ghost := true; Buffer.add_string buf " "; oneline_annot suffix cpp outfile lexbuf } | _ as c { Buffer.add_char buf c; is_ghost:=false; oneline_annot suffix cpp outfile lexbuf } and annot suffix cpp outfile = parse "*/" { preprocess_annot suffix cpp outfile; main suffix cpp outfile lexbuf } | '\n' { is_newline := NEWLINE; incr curr_line; Buffer.add_char buf '\n'; annot suffix cpp outfile lexbuf } | "//" { Buffer.add_string buf "//"; annot_comment suffix cpp outfile lexbuf } | '@' { if !is_newline = NEWLINE then is_newline:=SPACE; Buffer.add_char buf ' '; annot suffix cpp outfile lexbuf } | ' ' { if !is_newline = NEWLINE then is_newline:=SPACE; Buffer.add_char buf ' '; annot suffix cpp outfile lexbuf } (* We're not respecting char count here. Maybe using '$' would do it, as cpp is likely to count it as part of an identifier, but this would imply that we can not speak about $ ident in annotations. *) | '\\' { Buffer.add_string buf backslash; annot suffix cpp outfile lexbuf } | '\'' { Buffer.add_char buf '\''; char suffix annot cpp outfile lexbuf } | '"' { Buffer.add_char buf '"'; string suffix annot cpp outfile lexbuf } | _ as c { is_newline := CHAR; Buffer.add_char buf c; annot suffix cpp outfile lexbuf } and annot_comment suffix cpp outfile = parse | '\n' { incr curr_line; is_newline:=NEWLINE; Buffer.add_char buf '\n'; annot suffix cpp outfile lexbuf } | "*/" { preprocess_annot suffix cpp outfile; main suffix cpp outfile lexbuf } | eof { abort_preprocess "eof in the middle of a comment" outfile } | _ as c { Buffer.add_char buf c; annot_comment suffix cpp outfile lexbuf } and char suffix annot cpp outfile = parse | '\n' { incr curr_line; is_newline:=NEWLINE; Buffer.add_char buf '\n'; char suffix annot cpp outfile lexbuf } | '\'' { is_newline:=CHAR; Buffer.add_char buf '\''; annot suffix cpp outfile lexbuf } | "\\'" { is_newline:=CHAR; Buffer.add_string buf "\\'"; char suffix annot cpp outfile lexbuf } | "\\\\" { is_newline:=CHAR; Buffer.add_string buf "\\\\"; char suffix annot cpp outfile lexbuf } | eof { abort_preprocess "eof while parsing a char literal" outfile } | _ as c { is_newline:=CHAR; Buffer.add_char buf c; char suffix annot cpp outfile lexbuf } and string suffix annot cpp outfile = parse | '\n' { incr curr_line; is_newline:=NEWLINE; Buffer.add_char buf '\n'; string suffix annot cpp outfile lexbuf } | '"' { is_newline:=CHAR; Buffer.add_char buf '"'; annot suffix cpp outfile lexbuf } | "\\\"" { is_newline:=CHAR; Buffer.add_string buf "\\\""; string suffix annot cpp outfile lexbuf } | eof { abort_preprocess "eof while parsing a string literal" outfile } | _ as c { is_newline:=CHAR; Buffer.add_char buf c; string suffix annot cpp outfile lexbuf } and comment suffix cpp outfile c = parse "/" { Buffer.add_char beg_of_line ' '; output_string outfile (lexeme lexbuf); if c = '*' then main suffix cpp outfile lexbuf else comment suffix cpp outfile '/' lexbuf } | '\n' { make_newline (); output_char outfile '\n'; comment suffix cpp outfile '\n' lexbuf } | eof { abort_preprocess "eof while parsing C comment" outfile} | _ as c { Buffer.add_char beg_of_line ' '; output_char outfile c; comment suffix cpp outfile c lexbuf} and oneline_annot suffix cpp outfile = parse "\n"|eof { incr curr_line; preprocess_annot suffix cpp outfile; main suffix cpp outfile lexbuf } | '@' { Buffer.add_char buf ' '; oneline_annot suffix cpp outfile lexbuf } | '\\' { Buffer.add_string buf backslash; oneline_annot suffix cpp outfile lexbuf } | '\'' { Buffer.add_char buf '\''; char suffix oneline_annot cpp outfile lexbuf } | '"' { Buffer.add_char buf '"'; string suffix oneline_annot cpp outfile lexbuf } | _ as c { Buffer.add_char buf c; oneline_annot suffix cpp outfile lexbuf } and oneline_comment suffix cpp outfile = parse "\n"|eof { make_newline(); output_string outfile (lexeme lexbuf); main suffix cpp outfile lexbuf} | _ as c { output_char outfile c; oneline_comment suffix cpp outfile lexbuf} { let file suffix cpp filename = reset (); let debug = Kernel.Debug_category.exists (fun x -> x = "parser") in let inchan = open_in_bin filename in let lex = Lexing.from_channel inchan in let ppname = Extlib.temp_file_cleanup_at_exit ~debug (Filename.basename filename) ".pp" in let ppfile = open_out ppname in main suffix cpp ppfile lex; close_in inchan; close_out ppfile; ppname } (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/check.ml0000644000175000017500000011056712155630367016764 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* A consistency checker for CIL *) open Cil_types open Cil module M = Cilmsg module H = Hashtbl (* open Pretty *) (* A few parameters to customize the checking *) type checkFlags = NoCheckGlobalIds (* Do not check that the global ids have the proper * hash value *) let checkGlobalIds = ref true (* Attributes must be sorted *) type ctxAttr = CALocal (* Attribute of a local variable *) | CAGlobal (* Attribute of a global variable *) | CAType (* Attribute of a type *) let valid = ref true let warn fmt = valid := false; Cil.warn fmt let warnContext fmt = valid := false; Cil.warnContext fmt let checkAttributes (attrs: attribute list) : unit = let rec loop lastname = function [] -> () | Attr(an, _) :: resta -> if an < lastname then ignore (warn "Attributes not sorted"); loop an resta in loop "" attrs (* Keep track of defined types *) let typeDefs : (string, typ) H.t = H.create 117 (* Keep track of all variables names, enum tags and type names *) let varNamesEnv : (string, unit) H.t = H.create 117 (* We also keep a map of variables indexed by id, to ensure that only one * varinfo has a given id *) let varIdsEnv: (int, varinfo) H.t = H.create 117 (* And keep track of all varinfo's to check the uniqueness of the * identifiers *) let allBases: (int, varinfo) H.t = H.create 117 (* Also keep a list of environments. We place an empty string in the list to * mark the start of a local environment (i.e. a function) *) let varNamesList : (string * int) list ref = ref [] let defineName s = if s = "" then M.fatal "Empty name" ; if H.mem varNamesEnv s then ignore (M.warning "Multiple definitions for %s" s); H.add varNamesEnv s () let defineVariable vi = defineName vi.vname; varNamesList := (vi.vname, vi.vid) :: !varNamesList; (* Check the id *) if H.mem allBases vi.vid then ignore (M.warning "Id %d is already defined (%s)\n" vi.vid (!Cil.output_ident vi.vname)); H.add allBases vi.vid vi; (* And register it in the current scope also *) H.add varIdsEnv vi.vid vi (* Check that a varinfo has already been registered *) let checkVariable vi = try (* Check in the current scope only *) if vi != H.find varIdsEnv vi.vid then ignore (warnContext "varinfos for %s not shared\n" (!Cil.output_ident vi.vname)); with Not_found -> ignore (warn "Unknown id (%d) for %s\n" vi.vid (!Cil.output_ident vi.vname)) let startEnv () = varNamesList := ("", -1) :: !varNamesList let endEnv () = let rec loop = function [] -> M.fatal "Cannot find start of env" | ("", _) :: rest -> varNamesList := rest | (s, id) :: rest -> begin H.remove varNamesEnv s; H.remove varIdsEnv id; loop rest end in loop !varNamesList (* The current function being checked *) let currentReturnType : typ ref = ref voidType (* A map of labels in the current function *) let labels: (string, unit) H.t = H.create 17 (* A list of statements seen in the current function *) let statements: stmt list ref = ref [] (* A list of the targets of Gotos *) let gotoTargets: (string * stmt) list ref = ref [] (*** TYPES ***) (* Cetain types can only occur in some contexts, so keep a list of context *) type ctxType = CTStruct (* In a composite type *) | CTUnion | CTFArg (* In a function argument type *) | CTFRes (* In a function result type *) | CTArray (* In an array type *) | CTPtr (* In a pointer type *) | CTExp (* In an expression, as the type of * the result of binary operators, or * in a cast *) | CTSizeof (* In a sizeof *) | CTDecl (* In a typedef, or a declaration *) let d_context () = function CTStruct -> text "CTStruct" | CTUnion -> text "CTUnion" | CTFArg -> text "CTFArg" | CTFRes -> text "CTFRes" | CTArray -> text "CTArray" | CTPtr -> text "CTPtr" | CTExp -> text "CTExp" | CTSizeof -> text "CTSizeof" | CTDecl -> text "CTDecl" (* Keep track of all tags that we use. For each tag remember also the info * structure and a flag whether it was actually defined or just used. A * forward declaration acts as a definition. *) type defuse = Defined (* We actually have seen a definition of this tag *) | Forward (* We have seen a forward declaration for it. This is done using * a GType with an empty type name *) | Used (* Only uses *) let compUsed : (int, compinfo * defuse ref) H.t = H.create 117 let enumUsed : (string, enuminfo * defuse ref) H.t = H.create 117 let typUsed : (string, typeinfo * defuse ref) H.t = H.create 117 (* For composite types we also check that the names are unique *) let compNames : (string, unit) H.t = H.create 17 (* Check a type *) let rec checkType (t: typ) (ctx: ctxType) = (* Check that it appears in the right context *) let rec checkContext = function TVoid _ -> ctx = CTPtr || ctx = CTFRes || ctx = CTDecl | TNamed (ti, a) -> checkContext ti.ttype | TArray _ -> (ctx = CTStruct || ctx = CTUnion || ctx = CTSizeof || ctx = CTDecl || ctx = CTArray || ctx = CTPtr) | TComp _ -> ctx <> CTExp | _ -> true in if not (checkContext t) then ignore (warn "Type (%a) used in wrong context. Expected context: %a" d_plaintype t d_context ctx); match t with (TVoid a | TBuiltin_va_list a) -> checkAttributes a | TInt (ik, a) -> checkAttributes a | TFloat (_, a) -> checkAttributes a | TPtr (t, a) -> checkAttributes a; checkType t CTPtr | TNamed (ti, a) -> checkAttributes a; if ti.tname = "" then ignore (warnContext "Using a typeinfo for an empty-named type\n"); checkTypeInfo Used ti | TComp (comp, a) -> checkAttributes a; (* Mark it as a forward. We'll check it later. If we try to check it * now we might encounter undefined types *) checkCompInfo Used comp | TEnum (enum, a) -> begin checkAttributes a; checkEnumInfo Used enum end | TArray(bt, len, a) -> checkAttributes a; checkType bt CTArray; (match len with None -> () | Some l -> begin let t = checkExp true l in match t with TInt((IInt|IUInt), _) -> () | _ -> M.fatal "Type of array length is not integer" end) | TFun (rt, targs, isva, a) -> checkAttributes a; checkType rt CTFRes; List.iter (fun (an, at, aa) -> checkType at CTFArg; checkAttributes aa) (argsToList targs) (* Check that a type is a promoted integral type *) and checkIntegralType (t: typ) = checkType t CTExp; match unrollType t with TInt _ -> () | _ -> ignore (warn "Non-integral type") (* Check that a type is a promoted arithmetic type *) and checkArithmeticType (t: typ) = checkType t CTExp; match unrollType t with TInt _ | TFloat _ -> () | _ -> ignore (warn "Non-arithmetic type") (* Check that a type is a promoted boolean type *) and checkBooleanType (t: typ) = checkType t CTExp; match unrollType t with TInt _ | TFloat _ | TPtr _ -> () | _ -> ignore (warn "Non-boolean type") (* Check that a type is a pointer type *) and checkPointerType (t: typ) = checkType t CTExp; match unrollType t with TPtr _ -> () | _ -> ignore (warn "Non-pointer type") and typeMatch (t1: typ) (t2: typ) = if not (Cil_datatype.Typ.equal t1 t2) then match unrollType t1, unrollType t2 with (* Allow free interchange of TInt and TEnum *) TInt (IInt, _), TEnum _ -> () | TEnum _, TInt (IInt, _) -> () | _, _ -> ignore (warn "Type mismatch:@\n %a@!and %a@\n" d_type t1 d_type t2) and checkCompInfo (isadef: defuse) comp = let fullname = compFullName comp in try let oldci, olddef = H.find compUsed comp.ckey in (* Check that it is the same *) if oldci != comp then ignore (warnContext "compinfo for %s not shared\n" fullname); (match !olddef, isadef with | Defined, Defined -> ignore (warnContext "Multiple definition of %s\n" fullname) | _, Defined -> olddef := Defined | Defined, _ -> () | _, Forward -> olddef := Forward | _, _ -> ()) with Not_found -> begin (* This is the first time we see it *) (* Check that the name is not empty *) if comp.cname = "" then E.s (bug "Compinfo with empty name"); (* Check that the name is unique *) if H.mem compNames fullname then ignore (warn "Duplicate name %s" fullname); (* Add it to the map before we go on *) H.add compUsed comp.ckey (comp, ref isadef); H.add compNames fullname (); (* Do not check the compinfo unless this is a definition. Otherwise you * might run into undefined types. *) if isadef = Defined then begin checkAttributes comp.cattr; let fctx = if comp.cstruct then CTStruct else CTUnion in let rec checkField f = if not (f.fcomp == comp && (* Each field must share the self cell of * the host *) f.fname <> "") then ignore (warn "Self pointer not set in field %s of %s" f.fname fullname); checkType f.ftype fctx; (* Check the bitfields *) (match unrollType f.ftype, f.fbitfield with | TInt (ik, a), Some w -> checkAttributes a; if w < 0 || w >= bitsSizeOf (TInt(ik, a)) then ignore (warn "Wrong width (%d) in bitfield" w) | _, Some w -> ignore (E.error "Bitfield on a non integer type\n") | _ -> ()); checkAttributes f.fattr in List.iter checkField comp.cfields end end and checkEnumInfo (isadef: defuse) enum = if enum.ename = "" then E.s (bug "Enuminfo with empty name"); try let oldei, olddef = H.find enumUsed enum.ename in (* Check that it is the same *) if oldei != enum then ignore (warnContext "enuminfo for %s not shared\n" enum.ename); (match !olddef, isadef with Defined, Defined -> ignore (warnContext "Multiple definition of enum %s\n" enum.ename) | _, Defined -> olddef := Defined | Defined, _ -> () | _, Forward -> olddef := Forward | _, _ -> ()) with Not_found -> begin (* This is the first time we see it *) (* Add it to the map before we go on *) H.add enumUsed enum.ename (enum, ref isadef); checkAttributes enum.eattr; List.iter (fun (tn, _, _) -> defineName tn) enum.eitems; end and checkTypeInfo (isadef: defuse) ti = try let oldti, olddef = H.find typUsed ti.tname in (* Check that it is the same *) if oldti != ti then ignore (warnContext "typeinfo for %s not shared\n" ti.tname); (match !olddef, isadef with Defined, Defined -> ignore (warnContext "Multiple definition of type %s\n" ti.tname) | Defined, Used -> () | Used, Defined -> ignore (warnContext "Use of type %s before its definition\n" ti.tname) | _, _ -> ignore (warnContext "Bug in checkTypeInfo for %s\n" ti.tname)) with Not_found -> begin (* This is the first time we see it *) if ti.tname = "" then ignore (warnContext "typeinfo with empty name"); checkType ti.ttype CTDecl; (* Add it to the map before we go on *) H.add typUsed ti.tname (ti, ref isadef); end (* Check an lvalue. If isconst then the lvalue appears in a context where * only a compile-time constant can appear. Return the type of the lvalue. * See the typing rule from cil.mli *) and checkLval (isconst: bool) (lv: lval) : typ = match lv with Var vi, off -> checkVariable vi; checkOffset vi.vtype off | Mem addr, off -> begin if isconst then ignore (warn "Memory operation in constant"); let ta = checkExp false addr in match unrollType ta with TPtr (t, _) -> checkOffset t off | _ -> E.s (bug "Mem on a non-pointer") end (* Check an offset. The basetype is the type of the object referenced by the * base. Return the type of the lvalue constructed from a base value of right * type and the offset. See the typing rules from cil.mli *) and checkOffset basetyp : offset -> typ = function NoOffset -> basetyp | Index (ei, o) -> checkExpType false ei intType; begin match unrollType basetyp with TArray (t, _, _) -> checkOffset t o | t -> E.s (bug "typeOffset: Index on a non-array: %a" d_plaintype t) end | Field (fi, o) -> (* Now check that the host is shared propertly *) checkCompInfo Used fi.fcomp; (* Check that this exact field is part of the host *) if not (List.exists (fun f -> f == fi) fi.fcomp.cfields) then ignore (warn "Field %s not part of %s" fi.fname (compFullName fi.fcomp)); checkOffset fi.ftype o and checkExpType (isconst: bool) (e: exp) (t: typ) = let t' = checkExp isconst e in (* compute the type *) if isconst then begin (* For initializers allow a string to initialize an * array of characters *) if not (Cil_datatype.Typ.equal t' t) then match e, t with | _ -> typeMatch t' t end else typeMatch t' t (* Check an expression. isconst specifies if the expression occurs in a * context where only a compile-time constant can occur. Return the computed * type of the expression *) and checkExp (isconst: bool) (e: exp) : typ = E.withContext (fun _ -> dprintf "check%s: %a" (if isconst then "Const" else "Exp") d_exp e) (fun _ -> match e with | Const(CInt64 (_, ik, _)) -> TInt(ik, []) | Const(CChr _) -> charType | Const(CStr s) -> charPtrType | Const(CWStr s) -> TPtr(!wcharType,[]) | Const(CReal (_, fk, _)) -> TFloat(fk, []) | Const(CEnum (_, _, ei)) -> TEnum(ei, []) | Lval(lv) -> if isconst then ignore (warn "Lval in constant"); checkLval isconst lv | SizeOf(t) -> begin (* Sizeof cannot be applied to certain types *) checkType t CTSizeof; (match unrollType t with (TFun _ | TVoid _) -> ignore (warn "Invalid operand for sizeof") | _ ->()); uintType end | SizeOfE(e) -> (* The expression in a sizeof can be anything *) let te = checkExp false e in checkExp isconst (SizeOf(te)) | SizeOfStr s -> uintType | AlignOf(t) -> begin (* Sizeof cannot be applied to certain types *) checkType t CTSizeof; (match unrollType t with (TFun _ | TVoid _) -> ignore (warn "Invalid operand for sizeof") | _ ->()); uintType end | AlignOfE(e) -> (* The expression in an AlignOfE can be anything *) let te = checkExp false e in checkExp isconst (AlignOf(te)) | UnOp (Neg, e, tres) -> checkArithmeticType tres; checkExpType isconst e tres; tres | UnOp (BNot, e, tres) -> checkIntegralType tres; checkExpType isconst e tres; tres | UnOp (LNot, e, tres) -> let te = checkExp isconst e in checkBooleanType te; checkIntegralType tres; (* Must check that t is well-formed *) typeMatch tres intType; tres | BinOp (bop, e1, e2, tres) -> begin let t1 = checkExp isconst e1 in let t2 = checkExp isconst e2 in match bop with (Mult | Div) -> typeMatch t1 t2; checkArithmeticType tres; typeMatch t1 tres; tres | (Eq|Ne|Lt|Le|Ge|Gt) -> typeMatch t1 t2; checkArithmeticType t1; typeMatch tres intType; tres | Mod|BAnd|BOr|BXor -> typeMatch t1 t2; checkIntegralType tres; typeMatch t1 tres; tres | LAnd | LOr -> typeMatch t1 t2; checkBooleanType tres; typeMatch t1 tres; tres | Shiftlt | Shiftrt -> typeMatch t1 tres; checkIntegralType t1; checkIntegralType t2; tres | (PlusA | MinusA) -> typeMatch t1 t2; typeMatch t1 tres; checkArithmeticType tres; tres | (PlusPI | MinusPI | IndexPI) -> checkPointerType tres; typeMatch t1 tres; checkIntegralType t2; tres | MinusPP -> checkPointerType t1; checkPointerType t2; typeMatch t1 t2; typeMatch tres intType; tres end | AddrOf (lv) -> begin let tlv = checkLval isconst lv in (* Only certain types can be in AddrOf *) match unrollType tlv with | TVoid _ -> E.s (bug "AddrOf on improper type"); | (TInt _ | TFloat _ | TPtr _ | TComp _ | TFun _ | TArray _ ) -> TPtr(tlv, []) | TEnum _ -> intPtrType | _ -> E.s (bug "AddrOf on unknown type") end | StartOf lv -> begin let tlv = checkLval isconst lv in match unrollType tlv with TArray (t,_, _) -> TPtr(t, []) | _ -> E.s (bug "StartOf on a non-array") end | CastE (tres, e) -> begin let et = checkExp isconst e in checkType tres CTExp; (* Not all types can be cast *) match unrollType et with TArray _ -> E.s (bug "Cast of an array type") | TFun _ -> E.s (bug "Cast of a function type") | TComp _ -> E.s (bug "Cast of a composite type") | TVoid _ -> E.s (bug "Cast of a void type") | _ -> tres end) () (* The argument of withContext *) and checkInit (i: init) : typ = E.withContext (fun _ -> dprintf "checkInit: %a" d_init i) (fun _ -> match i with SingleInit e -> checkExp true e (* | ArrayInit (bt, len, initl) -> begin checkType bt CTSizeof; if List.length initl > len then ignore (warn "Too many initializers in array"); List.iter (fun i -> checkInitType i bt) initl; TArray(bt, Some (integer len), []) end *) | CompoundInit (ct, initl) -> begin checkType ct CTSizeof; (match unrollType ct with TArray(bt, Some (Const(CInt64(len, _, _))), _) -> let rec loopIndex i = function [] -> if i <> len then ignore (warn "Wrong number of initializers in array") | (Index(Const(CInt64(i', _, _)), NoOffset), ei) :: rest -> if i' <> i then ignore (warn "Initializer for index %s when %s was expected\n" (Int64.format "%d" i') (Int64.format "%d" i)); checkInitType ei bt; loopIndex (Int64.succ i) rest | _ :: rest -> ignore (warn "Malformed initializer for array element") in loopIndex Int64.zero initl | TArray(_, _, _) -> ignore (warn "Malformed initializer for array") | TComp (comp, _) -> if comp.cstruct then let rec loopFields (nextflds: fieldinfo list) (initl: (offset * init) list) : unit = match nextflds, initl with [], [] -> () (* We are done *) | f :: restf, (Field(f', NoOffset), i) :: resti -> if f.fname <> f'.fname then ignore (warn "Expected initializer for field %s and found one for %s\n" f.fname f'.fname); checkInitType i f.ftype; loopFields restf resti | [], _ :: _ -> ignore (warn "Too many initializers for struct") | _ :: _, [] -> ignore (warn "Too few initializers for struct") | _, _ -> ignore (warn "Malformed initializer for struct") in loopFields (List.filter (fun f -> f.fname <> missingFieldName) comp.cfields) initl else (* UNION *) if comp.cfields == [] then begin if initl != [] then ignore (warn "Initializer for empty union not empty"); end else begin match initl with [(Field(f, NoOffset), ei)] -> if f.fcomp != comp then ignore (bug "Wrong designator for union initializer"); if !msvcMode && f != List.hd comp.cfields then ignore (warn "On MSVC you can only initialize the first field of a union"); checkInitType ei f.ftype | _ -> ignore (warn "Malformed initializer for union") end | _ -> E.s (warn "Type of Compound is not array or struct or union")); ct end) () (* The arguments of withContext *) and checkInitType (i: init) (t: typ) : unit = let it = checkInit i in typeMatch it t and checkStmt (s: stmt) = E.withContext (fun _ -> (* Print context only for certain small statements *) match s.skind with Loop _ | If _ | Switch _ -> nil | _ -> dprintf "checkStmt: %a" d_stmt s) (fun _ -> (* Check the labels *) let checkLabel = function Label (ln, l, _) -> if H.mem labels ln then ignore (warn "Multiply defined label %s" ln); H.add labels ln () | Case (e, _) -> let t = checkExp true e in if not (isIntegralType t) then E.s (bug "Type of case expression is not integer"); | _ -> () (* Not yet implemented *) in List.iter checkLabel s.labels; (* See if we have seen this statement before *) if List.memq s !statements then ignore (warn "Statement is shared"); (* Remember that we have seen this one *) statements := s :: !statements; match s.skind with Break _ | Continue _ -> () | Goto (gref, l) -> currentLoc := l; (* Find a label *) let lab = match List.filter (function Label _ -> true | _ -> false) !gref.labels with Label (lab, _, _) :: _ -> lab | _ -> ignore (warn "Goto to block without a label\n"); "" in (* Remember it as a target *) gotoTargets := (lab, !gref) :: !gotoTargets | Return (re,l) -> begin currentLoc := l; match re, !currentReturnType with None, TVoid _ -> () | _, TVoid _ -> ignore (warn "Invalid return value") | None, _ -> ignore (warn "Invalid return value") | Some re', rt' -> checkExpType false re' rt' end | Loop (_, b, l, _, _) -> checkBlock b | Block b -> checkBlock b | If (e, bt, bf, l) -> currentLoc := l; let te = checkExp false e in checkBooleanType te; checkBlock bt; checkBlock bf | Switch (e, b, cases, l) -> currentLoc := l; let t = checkExp false e in if not (isIntegralType t) then E.s (bug "Type of switch expression is not integer"); checkExpType false e intType; (* Remember the statements so far *) let prevStatements = !statements in checkBlock b; (* Now make sure that all the cases do occur in that block *) List.iter (fun c -> if not (List.exists (function Case _ -> true | _ -> false) c.labels) then ignore (warn "Case in switch statment without a \"case\"\n"); (* Make sure it is in there *) let rec findCase = function | l when l == prevStatements -> (* Not found *) ignore (warnContext "Cannot find target of switch statement") | [] -> E.s (E.bug "Check: findCase") | c' :: rest when c == c' -> () (* Found *) | _ :: rest -> findCase rest in findCase !statements) cases; | TryFinally (b, h, l) -> currentLoc := l; checkBlock b; checkBlock h | TryExcept (b, (il, e), h, l) -> currentLoc := l; checkBlock b; List.iter checkInstr il; checkExpType false e intType; checkBlock h | Instr i -> checkInstr i) () (* argument of withContext *) and checkBlock (b: block) : unit = List.iter checkStmt b.bstmts and checkInstr (i: instr) = match i with | Set (dest, e, l) -> currentLoc := l; let t = checkLval false dest in (* Not all types can be assigned to *) (match unrollType t with TFun _ -> ignore (warn "Assignment to a function type") | TArray _ -> ignore (warn "Assignment to an array type") | TVoid _ -> ignore (warn "Assignment to a void type") | _ -> ()); checkExpType false e t | Call(dest, what, args, l) -> currentLoc := l; let (rt, formals, isva) = match checkExp false what with TFun(rt, formals, isva, _) -> rt, formals, isva | _ -> E.s (bug "Call to a non-function") in (* Now check the return value*) (match dest, unrollType rt with None, TVoid _ -> () | Some _, TVoid _ -> ignore (warn "void value is assigned") | None, _ -> () (* "Call of function is not assigned" *) | Some destlv, rt' -> let desttyp = checkLval false destlv in if not (Cil_datatype.Typ.equal desttyp rt) then begin (* Not all types can be assigned to *) (match unrollType desttyp with TFun _ -> ignore (warn "Assignment to a function type") | TArray _ -> ignore (warn "Assignment to an array type") | TVoid _ -> ignore (warn "Assignment to a void type") | _ -> ()); (* Not all types can be cast *) (match rt' with TArray _ -> ignore (warn "Cast of an array type") | TFun _ -> ignore (warn "Cast of a function type") | TComp _ -> ignore (warn "Cast of a composite type") | TVoid _ -> ignore (warn "Cast of a void type") | _ -> ()) end); (* Now check the arguments *) let rec loopArgs formals args = match formals, args with [], _ when (isva || args = []) -> () | (fn,ft,_) :: formals, a :: args -> checkExpType false a ft; loopArgs formals args | _, _ -> ignore (warn "Not enough arguments") in if formals = None then ignore (warn "Call to function without prototype\n") else loopArgs (argsToList formals) args | Asm _ -> () (* Not yet implemented *) | Skip _ -> () | Code_annot _ -> () let rec checkGlobal = function GAsm _ -> () | GPragma _ -> () | GText _ -> () | GAnnot _ -> () | GType (ti, l) -> currentLoc := l; E.withContext (fun _ -> dprintf "GType(%s)" ti.tname) (fun _ -> checkTypeInfo Defined ti; if ti.tname <> "" then defineName ti.tname) () | GCompTag (comp, l) -> currentLoc := l; checkCompInfo Defined comp; | GCompTagDecl (comp, l) -> currentLoc := l; checkCompInfo Forward comp; | GEnumTag (enum, l) -> currentLoc := l; checkEnumInfo Defined enum | GEnumTagDecl (enum, l) -> currentLoc := l; checkEnumInfo Forward enum | GVarDecl (vi, l) -> currentLoc := l; (* We might have seen it already *) E.withContext (fun _ -> dprintf "GVarDecl(%s)" (!Cil.output_ident vi.vname)) (fun _ -> (* If we have seen this vid already then it must be for the exact * same varinfo *) if H.mem varIdsEnv vi.vid then checkVariable vi else begin defineVariable vi; checkAttributes vi.vattr; checkType vi.vtype CTDecl; if not (vi.vglob && vi.vstorage <> Register) then E.s (bug "Invalid declaration of %s" (!Cil.output_ident vi.vname)) end) () | GVar (vi, init, l) -> currentLoc := l; (* Maybe this is the first occurrence *) E.withContext (fun _ -> dprintf "GVar(%s)" (!Cil.output_ident vi.vname)) (fun _ -> checkGlobal (GVarDecl (vi, l)); (* Check the initializer *) begin match init.init with None -> () | Some i -> ignore (checkInitType i vi.vtype) end; (* Cannot be a function *) if isFunctionType vi.vtype then E.s (bug "GVar for a function (%s)\n" (!Cil.output_ident vi.vname)); ) () | GFun (fd, l) -> begin currentLoc := l; (* Check if this is the first occurrence *) let vi = fd.svar in let fname = vi.vname in E.withContext (fun _ -> dprintf "GFun(%s)" (!Cil.output_ident fname)) (fun _ -> checkGlobal (GVarDecl (vi, l)); (* Check that the argument types in the type are identical to the * formals *) let rec loopArgs targs formals = match targs, formals with [], [] -> () | (fn, ft, fa) :: targs, fo :: formals -> if fn <> fo.vname || ft != fo.vtype || fa != fo.vattr then ignore (warnContext "Formal %s not shared (type + locals) in %s" (!Cil.output_ident fo.vname) (!Cil.output_ident fname)); loopArgs targs formals | _ -> E.s (bug "Type has different number of formals for %s" (!Cil.output_ident fname)) in begin match vi.vtype with TFun (rt, args, isva, a) -> begin currentReturnType := rt; loopArgs (argsToList args) fd.sformals end | _ -> E.s (bug "Function %s does not have a function type" (!Cil.output_ident fname)) end; ignore (fd.smaxid >= 0 || E.s (bug "smaxid < 0 for %s" (!Cil.output_ident fname))); (* Now start a new environment, in a finally clause *) begin try startEnv (); (* Do the locals *) let doLocal tctx v = if v.vglob then ignore (warnContext "Local %s has the vglob flag set" (!Cil.output_ident v.vname)); if v.vstorage <> NoStorage && v.vstorage <> Register then ignore (warnContext "Local %s has storage %a\n" (!Cil.output_ident v.vname) d_storage v.vstorage); checkType v.vtype tctx; checkAttributes v.vattr; defineVariable v in List.iter (doLocal CTFArg) fd.sformals; List.iter (doLocal CTDecl) fd.slocals; statements := []; gotoTargets := []; checkBlock fd.sbody; H.clear labels; (* Now verify that we have scanned all targets *) List.iter (fun (lab, t) -> if not (List.memq t !statements) then ignore (warnContext "Target of \"goto %s\" statement does not appear in function body" lab)) !gotoTargets; statements := []; gotoTargets := []; (* Done *) endEnv () with e -> endEnv (); raise e end; ()) () (* final argument of withContext *) end let checkFile flags fl = if !E.verboseFlag then ignore (E.log "Checking file %s\n" fl.fileName); valid := true; List.iter (function NoCheckGlobalIds -> checkGlobalIds := false) flags; iterGlobals fl (fun g -> try checkGlobal g with _ -> ()); (* Check that for all struct/union tags there is a definition *) H.iter (fun k (comp, isadef) -> if !isadef = Used then begin valid := false; ignore (E.warn "Compinfo %s is referenced but not defined" (compFullName comp)) end) compUsed; (* Check that for all enum tags there is a definition *) H.iter (fun k (enum, isadef) -> if !isadef = Used then begin valid := false; ignore (E.warn "Enuminfo %s is referenced but not defined" enum.ename) end) enumUsed; (* Clean the hashes to let the GC do its job *) H.clear typeDefs; H.clear varNamesEnv; H.clear varIdsEnv; H.clear allBases; H.clear compNames; H.clear compUsed; H.clear enumUsed; H.clear typUsed; varNamesList := []; if !E.verboseFlag then ignore (E.log "Finished checking file %s\n" fl.fileName); !valid frama-c-Fluorine-20130601/cil/src/check.mli0000644000175000017500000001227312155630367017130 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* * * Copyright (c) 2001-2002, * George C. Necula * Scott McPeak * Wes Weimer * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * 3. The names of the contributors may not be used to endorse or promote * products derived from this software without specific prior written * permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * *) (* Checks the well-formedness of the file. Prints warnings and * returns false if errors are found *) type checkFlags = NoCheckGlobalIds (* Do not check that the global ids have the proper * hash value *) val checkFile: checkFlags list -> Cil_types.file -> bool frama-c-Fluorine-20130601/cil/src/machdep_x86_64.mli0000644000175000017500000000645212155630367020474 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) val gcc : Cil_types.mach val msvc : Cil_types.mach frama-c-Fluorine-20130601/cil/src/cil_const.mli0000644000175000017500000001302512155630367020024 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Smart constructors for some CIL data types *) open Cil_types val voidType: typ (** forward reference to current location (see {!Cil.CurrentLoc})*) module CurrentLoc: State_builder.Ref with type data = location module Vid: sig val next: unit -> int end (** set the vid to a fresh number. *) val set_vid: varinfo -> unit (** returns a copy of the varinfo with a fresh vid. If the varinfo has an associated logic var, a copy of the logic var is made as well. @modify Oxygen-20120901 take logic var into account *) val copy_with_new_vid: varinfo -> varinfo (** [change_varinfo_name vi name] changes the name of [vi] to [name]. Takes care of renaming the associated logic_var if any. @since Oxygen-20120901 *) val change_varinfo_name: varinfo -> string -> unit val new_raw_id: unit -> int (** Generate a new ID. This will be different than any variable ID that is generated by {!Cil.makeLocalVar} and friends. Must not be used for setting vid: use {!set_vid} instead. *) (** Create a fresh logical variable giving its name, type and origin. @since Fluorine-20130401 *) val make_logic_var_kind : string -> logic_var_kind -> logic_type -> logic_var (** Create a fresh logical variable giving its name and type. @deprecated Fluorine-20130401 You should use a specific make_logic_var_[kind] function below, or {! Cil.cvar_to_lvar} *) val make_logic_var : string -> logic_type -> logic_var (** Create a new global logic variable @since Fluorine-20130401 *) val make_logic_var_global: string -> logic_type -> logic_var (** Create a new formal logic variable @since Fluorine-20130401 *) val make_logic_var_formal: string -> logic_type -> logic_var (** Create a new quantified logic variable @since Fluorine-20130401 *) val make_logic_var_quant: string -> logic_type -> logic_var (** Create a new local logic variable @since Fluorine-20130401 *) val make_logic_var_local: string -> logic_type -> logic_var (** Create a fresh logical (global) variable giving its name and type. *) val make_logic_info : string -> (* logic_type -> *) logic_info (** Create a new local logic variable given its name. @since Fluorine-20130401 *) val make_logic_info_local : string -> (* logic_type -> *) logic_info (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/cil/src/machdep_x86_32.ml0000644000175000017500000001201412155630367020305 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) open Cil_types let gcc = { (* Generated by code in cil/src/machdep.c *) version_major = 4; version_minor = 0; version = "gcc 4.0.3 - X86-32bits mode"; sizeof_short = 2; sizeof_int = 4; sizeof_long = 4; sizeof_longlong = 8; sizeof_ptr = 4; sizeof_float = 4; sizeof_double = 8; sizeof_longdouble = 12; sizeof_void = 1; sizeof_fun = 1; size_t = "unsigned int"; wchar_t = "int"; ptrdiff_t = "int"; alignof_short = 2; alignof_int = 4; alignof_long = 4; alignof_longlong = 4; alignof_ptr = 4; alignof_float = 4; alignof_double = 4; alignof_longdouble = 4; alignof_str = 1; alignof_fun = 1; alignof_aligned= 16; char_is_unsigned = false; const_string_literals = true; little_endian = true; underscore_name = false ; has__builtin_va_list = true; __thread_is_keyword = true; } let msvc = { (* Generated by code in cil/src/machdep.c *) version_major = 4; version_minor = 0; version = "4.0.3 (Ubuntu 4.0.3-1ubuntu5)"; sizeof_short = 2; sizeof_int = 4; sizeof_long = 4; sizeof_longlong = 8; sizeof_ptr = 4; sizeof_float = 4; sizeof_double = 8; sizeof_longdouble = 12; sizeof_void = 1; sizeof_fun = 1; size_t = "unsigned int"; wchar_t = "int"; ptrdiff_t = "int"; alignof_short = 2; alignof_int = 4; alignof_long = 4; alignof_longlong = 4; alignof_ptr = 4; alignof_float = 4; alignof_double = 4; alignof_longdouble = 4; alignof_str = 1; alignof_fun = 1; char_is_unsigned = false; alignof_aligned= 16; const_string_literals = true; little_endian = true; underscore_name = true ; has__builtin_va_list = false; __thread_is_keyword = false; } frama-c-Fluorine-20130601/cil/src/mergecil.mli0000644000175000017500000001215112155630367017635 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* * * Copyright (c) 2001-2002, * George C. Necula * Scott McPeak * Wes Weimer * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * 3. The names of the contributors may not be used to endorse or promote * products derived from this software without specific prior written * permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * *) (** Merge a number of CIL files *) val merge: Cil_types.file list -> string -> Cil_types.file (* val translate_vinfo : Cil_types.varinfo -> Cil_types.varinfo val translate_typinfo :Cil_types.typeinfo -> Cil_types.typeinfo *) frama-c-Fluorine-20130601/cil/src/cil_state_builder.mli0000644000175000017500000001031012155630367021516 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Functors for building computations which use kernel datatypes. @plugin development guide *) module Stmt_set_ref(Info: State_builder.Info) : State_builder.Set_ref with type elt = Cil_types.stmt module Kinstr_hashtbl(Data:Datatype.S)(Info: State_builder.Info_with_size) : State_builder.Hashtbl with type key = Cil_types.kinstr and type data = Data.t (** @plugin development guide *) module Stmt_hashtbl(Data:Datatype.S)(Info: State_builder.Info_with_size) : State_builder.Hashtbl with type key = Cil_types.stmt and type data = Data.t module Varinfo_hashtbl(Data:Datatype.S)(Info: State_builder.Info_with_size) : State_builder.Hashtbl with type key = Cil_types.varinfo and type data = Data.t (* module Code_annotation_hashtbl (Data:Project.Datatype.S)(Info:State_builder.Info_with_size) : State_builder.Hashtbl with type key = Cil_types.code_annotation and type data = Data.t *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/cil/src/machdep_x86_64.ml0000644000175000017500000001200412155630367020311 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) open Cil_types let gcc = { (* Generated by code in cil/src/machdep.c *) version_major = 4; version_minor = 0; version = "gcc 4.0.3 AMD64"; sizeof_short = 2; sizeof_int = 4; sizeof_long = 8; sizeof_longlong = 8; sizeof_ptr = 8; sizeof_float = 4; sizeof_double = 8; sizeof_longdouble = 16; sizeof_void = 1; sizeof_fun = 1; size_t = "unsigned long"; wchar_t = "int"; ptrdiff_t = "long"; alignof_short = 2; alignof_int = 4; alignof_long = 8; alignof_longlong = 8; alignof_ptr = 8; alignof_float = 4; alignof_double = 8; alignof_longdouble = 16; alignof_str = 1; alignof_fun = 1; alignof_aligned= 16; char_is_unsigned = false; const_string_literals = true; little_endian = true; underscore_name = false ; has__builtin_va_list = true; __thread_is_keyword = true; } let msvc = { (* Generated by code in cil/src/machdep.c *) version_major = 4; version_minor = 0; version = "4.0.3 (Ubuntu 4.0.3-1ubuntu5)"; sizeof_short = 2; sizeof_int = 4; sizeof_long = 8; sizeof_longlong = 8; sizeof_ptr = 8; sizeof_float = 4; sizeof_double = 8; sizeof_longdouble = 16; sizeof_void = 1; sizeof_fun = 1; size_t = "unsigned long"; wchar_t = "int"; ptrdiff_t = "int"; alignof_short = 2; alignof_int = 4; alignof_long = 8; alignof_longlong = 8; alignof_ptr = 8; alignof_float = 4; alignof_double = 8; alignof_longdouble = 16; alignof_str = 1; alignof_fun = 1; alignof_aligned= 16; char_is_unsigned = false; const_string_literals = true; little_endian = true; underscore_name = true ; has__builtin_va_list = false; __thread_is_keyword = false; } frama-c-Fluorine-20130601/cil/src/mergecil.ml0000644000175000017500000033042412155630367017472 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* mergecil.ml *) (* This module is responsible for merging multiple CIL source trees into * a single, coherent CIL tree which contains the union of all the * definitions in the source files. It effectively acts like a linker, * but at the source code level instead of the object code level. *) open Extlib open Cil_types open Cil module H = Hashtbl module A = Alpha open Logic_utils let debugMerge = true let debugInlines = false (* Try to merge structure with the same name. However, do not complain if * they are not the same *) let mergeSynonyms = true (** Whether to use path compression *) let usePathCompression = true (* Try to merge definitions of inline functions. They can appear in multiple * files and we would like them all to be the same. This can slow down the * merger an order of magnitude !!! *) let mergeInlines = true let mergeInlinesRepeat = mergeInlines && true (* This may become an option of Frama-C. The default value has been changed to false after Boron to fix bts#524. *) let mergeInlinesWithAlphaConvert = mergeInlines && false (* when true, merge duplicate definitions of externally-visible functions; * this uses a mechanism which is faster than the one for inline functions, * but only probabilistically accurate *) let mergeGlobals = true (* Return true if 's' starts with the prefix 'p' *) let prefix p s = let lp = String.length p in let ls = String.length s in lp <= ls && String.sub s 0 lp = p let d_nloc fmt (lo: (location * int) option) = match lo with None -> Format.fprintf fmt "None" | Some (l, idx) -> Format.fprintf fmt "Some(%d at %a)" idx Cil_printer.pp_location l type ('a, 'b) node = { nname: 'a; (* The actual name *) nfidx: int; (* The file index *) ndata: 'b; (* Data associated with the node *) mutable nloc: (location * int) option; (* location where defined and index within the file of the definition. * If None then it means that this node actually DOES NOT appear in the * given file. In rare occasions we need to talk in a given file about * types that are not defined in that file. This happens with undefined * structures but also due to cross-contamination of types in a few of * the cases of combineType (see the definition of combineTypes). We * try never to choose as representatives nodes without a definition. * We also choose as representative the one that appears earliest *) mutable nrep: ('a, 'b) node; (* A pointer to another node in its class (one * closer to the representative). The nrep node * is always in an earlier file, except for the * case where a name is undefined in one file * and defined in a later file. If this pointer * points to the node itself then this is the * representative. *) mutable nmergedSyns: bool (* Whether we have merged the synonyms for * the node of this name *) } module Merging (H: sig include Hashtbl.HashedType val merge_synonym: t -> bool (* whether this name should be considered for merging or not. *) val output: Format.formatter -> t -> unit end ): sig type 'a eq_table type 'a syn_table val create_eq_table: int -> 'a eq_table val find_eq_table: 'a eq_table -> (int * H.t) -> (H.t, 'a) node val add_eq_table: 'a eq_table -> (int * H.t) -> (H.t,'a) node -> unit val iter_eq_table: ((int * H.t) -> (H.t,'a) node -> unit) -> 'a eq_table -> unit val clear_eq: 'a eq_table -> unit val create_syn_table: int -> 'a syn_table val clear_syn: 'a syn_table -> unit val mkSelfNode: 'a eq_table -> 'a syn_table -> int -> H.t -> 'a -> (location * int) option -> (H.t, 'a) node val find: bool -> (H.t, 'a) node -> (H.t, 'a) node val union: (H.t, 'a) node -> (H.t,'a) node -> (H.t, 'a) node * (unit -> unit) val findReplacement: bool -> 'a eq_table -> int -> H.t -> ('a * int) option val getNode: 'a eq_table -> 'a syn_table -> int -> H.t -> 'a -> (location * int) option -> (H.t, 'a) node (* [doMergeSynonyms eq compare] tries to merge synonyms. Do not give an error if they fail to merge compare is a comparison function that throws Failure if no match *) val doMergeSynonyms: 'a syn_table -> (int -> 'a -> int -> 'a -> unit) -> unit val dumpGraph: string -> 'a eq_table -> unit end = struct (* Find the representative for a node and compress the paths in the process *) module Heq = Hashtbl.Make (struct type t = int * H.t let hash (d,x) = 19 * d + H.hash x let equal (d1,x1) (d2,x2) = d1 = d2 && H.equal x1 x2 end) module Hsyn = Hashtbl.Make(H) type 'a eq_table = (H.t,'a) node Heq.t type 'a syn_table = (H.t,'a) node Hsyn.t let create_eq_table x = Heq.create x let create_syn_table x = Hsyn.create x let clear_eq = Heq.clear let clear_syn = Hsyn.clear let find_eq_table = Heq.find let add_eq_table = Heq.add let iter_eq_table = Heq.iter (* Make a node with a self loop. This is quite tricky. *) let mkSelfNode eq syn fidx name data l = let rec res = { nname = name; nfidx = fidx; ndata = data; nloc = l; nrep = res; nmergedSyns = false; } in Heq.add eq (fidx, name) res; (* Add it to the proper table *) (* mergeSynonyms is not active for anonymous types, probably because it is licit to have two distinct anonymous types in two different files (which should not be merged). However, for anonymous enums, they can, and are, in fact merged by CIL. Hence, we permit the merging of anonymous enums with the same base name *) if mergeSynonyms && H.merge_synonym name then Hsyn.add syn name res; res (* Find the representative with or without path compression *) let rec find pathcomp nd = let dkey = Kernel.register_category "merge:find" in Kernel.debug ~dkey "find %a(%d)" H.output nd.nname nd.nfidx ; if nd.nrep == nd then begin Kernel.debug ~dkey "= %a(%d)" H.output nd.nname nd.nfidx ; nd end else begin let res = find pathcomp nd.nrep in if usePathCompression && pathcomp && nd.nrep != res then nd.nrep <- res; (* Compress the paths *) res end (* Union two nodes and return the new representative. We prefer as the * representative a node defined earlier. We try not to use as * representatives nodes that are not defined in their files. We return a * function for undoing the union. Make sure that between the union and the * undo you do not do path compression *) let union nd1 nd2 = (* Move to the representatives *) let nd1 = find true nd1 in let nd2 = find true nd2 in if nd1 == nd2 then begin (* It can happen that we are trying to union two nodes that are already * equivalent. This is because between the time we check that two nodes * are not already equivalent and the time we invoke the union operation * we check type isomorphism which might change the equivalence classes *) (* ignore (warn "unioning already equivalent nodes for %s(%d)" nd1.nname nd1.nfidx); *) nd1, fun x -> x end else begin let rep, norep = (* Choose the representative *) if (nd1.nloc != None) = (nd2.nloc != None) then (* They have the same defined status. Choose the earliest *) if nd1.nfidx < nd2.nfidx then nd1, nd2 else if nd1.nfidx > nd2.nfidx then nd2, nd1 else (* In the same file. Choose the one with the earliest index *) begin match nd1.nloc, nd2.nloc with Some (_, didx1), Some (_, didx2) -> if didx1 < didx2 then nd1, nd2 else if didx1 > didx2 then nd2, nd1 else begin Kernel.warning "Merging two elements (%a and %a) \ in the same file (%d) \ with the same idx (%d) within the file" H.output nd1.nname H.output nd2.nname nd1.nfidx didx1 ; nd1, nd2 end | _, _ -> (* both none. Does not matter which one we choose. Should not happen though. *) (* sm: it does happen quite a bit when, e.g. merging STLport with some client source; I'm disabling the warning since it supposedly is harmless anyway, so is useless noise *) (* sm: re-enabling on claim it now will probably not happen *) Kernel.warning ~current:true "Merging two undefined elements in the same file: %a and %a" H.output nd1.nname H.output nd2.nname ; nd1, nd2 end else (* One is defined, the other is not. Choose the defined one *) if nd1.nloc != None then nd1, nd2 else nd2, nd1 in let oldrep = norep.nrep in norep.nrep <- rep; rep, (fun () -> norep.nrep <- oldrep) end let findReplacement pathcomp eq fidx name = let dkey = Kernel.register_category "merge:find" in Kernel.debug ~dkey "findReplacement for %a(%d)" H.output name fidx; try let nd = Heq.find eq (fidx, name) in if nd.nrep == nd then begin Kernel.debug ~dkey "is a representative"; None (* No replacement if this is the representative of its class *) end else let rep = find pathcomp nd in if rep != rep.nrep then Kernel.abort "find does not return the representative" ; Kernel.debug ~dkey "RES = %a(%d)" H.output rep.nname rep.nfidx; Some (rep.ndata, rep.nfidx) with Not_found -> begin Kernel.debug ~dkey "not found in the map"; None end (* Make a node if one does not already exist. Otherwise return the * representative *) let getNode eq syn fidx name data l = let debugGetNode = false in if debugGetNode then Kernel.debug ~level:5 "getNode(%a(%d), %a)" H.output name fidx d_nloc l; try let res = Heq.find eq (fidx, name) in (match res.nloc, l with (* Maybe we have a better location now *) None, Some _ -> res.nloc <- l | Some (old_l, old_idx), Some (l, idx) -> if old_idx != idx then Kernel.warning ~current:true "Duplicate definition of node %a(%d) at indices %d(%a) and %d(%a)" H.output name fidx old_idx Cil_printer.pp_location old_l idx Cil_printer.pp_location l | _, _ -> ()); if debugGetNode then Kernel.debug " node already found"; find false res (* No path compression *) with Not_found -> begin let res = mkSelfNode eq syn fidx name data l in if debugGetNode then Kernel.debug " made a new one"; res end let doMergeSynonyms syn compare = Hsyn.iter (fun n node -> if not node.nmergedSyns then begin (* find all the nodes for the same name *) let all = Hsyn.find_all syn n in (* classes are a list of representative for the nd name. We'll select an appropriate one according to the comparison function. *) let tryone classes nd = nd.nmergedSyns <- true; (* Compare in turn with all the classes we have so far *) let rec compareWithClasses = function | [] -> [nd] (* No more classes. Add this as a new class *) | c :: restc -> try compare c.nfidx c.ndata nd.nfidx nd.ndata; (* Success. Stop here the comparison *) c :: restc with Failure _ -> (* Failed. Try next class *) c :: (compareWithClasses restc) in compareWithClasses classes in (* Start with an empty set of classes for this name *) let _ = List.fold_left tryone [] all in () end) syn (* Dump a graph *) let dumpGraph what eq : unit = Kernel.debug "Equivalence graph for %s is:" what; Heq.iter (fun (fidx, name) nd -> Kernel.debug " %a(%d) %s-> " H.output name fidx (if nd.nloc = None then "(undef)" else ""); if nd.nrep == nd then Kernel.debug "*" else Kernel.debug " %a(%d)" H.output nd.nrep.nname nd.nrep.nfidx ) eq end (** A number of alpha conversion tables. We ought to keep one table for each * name space. Unfortunately, because of the way the C lexer works, type * names must be different from variable names!! We one alpha table both for * variables and types. *) let vtAlpha : (string, location A.alphaTableData ref) H.t = H.create 57 (* Variables and * types *) let sAlpha : (string, location A.alphaTableData ref) H.t = H.create 57 (* Structures and * unions have * the same name * space *) let eAlpha : (string, location A.alphaTableData ref) H.t = H.create 57 (* Enumerations *) let aeAlpha = H.create 57 (* Anonymous enums. *) (* The original mergecil uses plain old Hashtbl for everything. *) module PlainMerging = Merging (struct type t = string let hash = Hashtbl.hash let equal = (=) let merge_synonym name = not (prefix "__anon" name) let output = Format.pp_print_string end) module VolatileMerging = Merging (struct type t = identified_term list let hash = function | [] -> 0 | h::_ -> Logic_utils.hash_term h.it_content let equal = Logic_utils.is_same_list Logic_utils.is_same_identified_term let merge_synonym _ = true let output fmt x = Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_identified_term fmt x end) let hash_type t = let rec aux acc depth = function | TVoid _ -> acc | TInt (ikind,_) -> 3 * acc + Hashtbl.hash ikind | TFloat (fkind,_) -> 5 * acc + Hashtbl.hash fkind | TPtr(t,_) when depth < 5 -> aux (7*acc) (depth+1) t | TPtr _ -> 7 * acc | TArray (t,_,_,_) when depth < 5 -> aux (9*acc) (depth+1) t | TArray _ -> 9 * acc | TFun (r,_,_,_) when depth < 5 -> aux (11*acc) (depth+1) r | TFun _ -> 11 * acc | TNamed (t,_) -> 13 * acc + Hashtbl.hash t.tname | TComp(c,_,_) -> let mul = if c.cstruct then 17 else 19 in mul * acc + Hashtbl.hash c.cname | TEnum (e,_) -> 23 * acc + Hashtbl.hash e.ename | TBuiltin_va_list _ -> 29 * acc in aux 117 0 t module ModelMerging = Merging (struct type t = string * typ let hash (s,t) = Datatype.String.hash s + 3 * hash_type t let equal (s1,t1 : t) (s2,t2) = s1 = s2 && Cil_datatype.TypByName.equal t1 t2 let merge_synonym _ = true let output fmt (s,t) = Format.fprintf fmt "model@ %a@ { %s }" Cil_printer.pp_typ t s end) let same_int64 e1 e2 = match (constFold true e1).enode, (constFold true e2).enode with | Const(CInt64(i, _, _)), Const(CInt64(i', _, _)) -> Integer.equal i i' | _ -> false let have_same_enum_items oldei ei = if List.length oldei.eitems <> List.length ei.eitems then raise (Failure "different number of enumeration elements"); (* We check that they are defined in the same way. This is a fairly * conservative check. *) List.iter2 (fun old_item item -> if old_item.einame <> item.einame then raise (Failure "different names for enumeration items"); if not (same_int64 old_item.eival item.eival) then raise (Failure "different values for enumeration items")) oldei.eitems ei.eitems let same_enum_items oldei ei = try have_same_enum_items oldei ei; true with Failure _ -> false let is_anonymous_enum e = prefix "__anonenum" e.ename module EnumMerging = Merging (struct type t = enuminfo let hash s = Datatype.String.hash s.ename let equal e1 e2 = (is_anonymous_enum e1 && is_anonymous_enum e2 && (same_enum_items e1 e2 || (e1.ename = e2.ename && (e2.ename <- fst (A.newAlphaName aeAlpha None e2.ename Cil_datatype.Location.unknown); false)) )) || e1.ename = e2.ename let merge_synonym _ = true let output fmt e = Cil_printer.pp_global fmt (GEnumTag (e, Cil_datatype.Location.unknown)) end) open PlainMerging (* For each name space we define a set of equivalence classes *) let vEq = PlainMerging.create_eq_table 111 (* Vars *) let sEq = PlainMerging.create_eq_table 111 (* Struct + union *) let eEq = EnumMerging.create_eq_table 111 (* Enums *) let tEq = PlainMerging.create_eq_table 111 (* Type names*) let iEq = PlainMerging.create_eq_table 111 (* Inlines *) let lfEq = PlainMerging.create_eq_table 111 (* Logic functions *) let ltEq = PlainMerging.create_eq_table 111 (* Logic types *) let lcEq = PlainMerging.create_eq_table 111 (* Logic constructors *) let laEq = PlainMerging.create_eq_table 111 (* Axiomatics *) let llEq = PlainMerging.create_eq_table 111 (* Lemmas *) let lcusEq = PlainMerging.create_eq_table 111 (* Custom *) let lvEq = VolatileMerging.create_eq_table 111 let mfEq = ModelMerging.create_eq_table 111 (* Sometimes we want to merge synonyms. We keep some tables indexed by names. * Each name is mapped to multiple exntries *) let vSyn = PlainMerging.create_syn_table 111 let iSyn = PlainMerging.create_syn_table 111 let sSyn = PlainMerging.create_syn_table 111 let eSyn = EnumMerging.create_syn_table 111 let tSyn = PlainMerging.create_syn_table 111 let lfSyn = PlainMerging.create_syn_table 111 let ltSyn = PlainMerging.create_syn_table 111 let lcSyn = PlainMerging.create_syn_table 111 let laSyn = PlainMerging.create_syn_table 111 let llSyn = PlainMerging.create_syn_table 111 let lcusSyn = PlainMerging.create_syn_table 111 let lvSyn = VolatileMerging.create_syn_table 111 let mfSyn = ModelMerging.create_syn_table 111 (** A global environment for variables. Put in here only the non-static * variables, indexed by their name. *) let vEnv : (string, (string, varinfo) node) H.t = H.create 111 (* A set of inline functions indexed by their printout ! *) let inlineBodies : (string, (string, varinfo) node) H.t = H.create 111 (** Keep track, for all global function definitions, of the names of the formal * arguments. They might change during merging of function types if the * prototype occurs after the function definition and uses different names. * We'll restore the names at the end *) let formalNames: (int * string, string list) H.t = H.create 111 (* Accumulate here the globals in the merged file *) let theFileTypes = ref [] let theFile = ref [] (* we keep only one declaration for each function. The other ones are simply discarded, but we need to merge their spec. This is done at the end of the 2nd pass, to avoid going through theFile too many times. *) let spec_to_merge = Cil_datatype.Varinfo.Hashtbl.create 59;; (* renaming to be performed in spec found in declarations when there is a definition for the given function. Similar to spec_to_merge table. *) let formals_renaming = Cil_datatype.Varinfo.Hashtbl.create 59;; (* add 'g' to the merged file *) let mergePushGlobal (g: global) : unit = pushGlobal g ~types:theFileTypes ~variables:theFile let mergePushGlobals gl = List.iter mergePushGlobal gl let add_to_merge_spec vi spec = let l = try Cil_datatype.Varinfo.Hashtbl.find spec_to_merge vi with Not_found -> [] in Cil_datatype.Varinfo.Hashtbl.replace spec_to_merge vi (spec::l) let add_alpha_renaming old_vi old_args new_args = try Cil_datatype.Varinfo.Hashtbl.add formals_renaming old_vi (Cil.create_alpha_renaming old_args new_args) with Invalid_argument _ -> (* [old_args] and [new_args] haven't the same length. May occur at least when trying to merge incompatible declarations. *) () let mergeSpec vi_ref vi_disc spec = if not (Cil.is_empty_funspec spec) then begin let spec = try let my_vars = Cil.getFormalsDecl vi_disc in let to_rename = Cil.getFormalsDecl vi_ref in if debugMerge then Kernel.debug "Renaming arguments: %a -> %a" (Pretty_utils.pp_list ~sep:",@ " Cil_datatype.Varinfo.pretty) my_vars (Pretty_utils.pp_list ~sep:",@ " Cil_datatype.Varinfo.pretty) to_rename; let alpha = Cil.create_alpha_renaming my_vars to_rename in if debugMerge then ( Kernel.debug "Renaming spec of function %a" Cil_datatype.Varinfo.pretty vi_disc; Kernel.debug "original spec is %a" Cil_printer.pp_funspec spec; ); try let res = Cil.visitCilFunspec alpha spec in if debugMerge then Kernel.debug "renamed spec is %a" Cil_printer.pp_funspec spec; res with Not_found -> assert false with Not_found -> spec in let spec = try let alpha = Cil_datatype.Varinfo.Hashtbl.find formals_renaming vi_ref in let res = Cil.visitCilFunspec alpha spec in if debugMerge then Kernel.debug "renamed spec with definition's formals is %a" Cil_printer.pp_funspec res; res with Not_found -> spec in add_to_merge_spec vi_ref spec end (* else no need to keep empty specs *) (* The index of the current file being scanned *) let currentFidx = ref 0 let currentDeclIdx = ref 0 (* The index of the definition in a file. This is * maintained both in pass 1 and in pass 2. Make * sure you count the same things in both passes. *) (* Keep here the file names *) let fileNames : (int, string) H.t = H.create 113 (* Remember the composite types that we have already declared *) let emittedCompDecls: (string, bool) H.t = H.create 113 (* Remember the variables also *) let emittedVarDecls: (string, bool) H.t = H.create 113 (* also keep track of externally-visible function definitions; * name maps to declaration, location, and semantic checksum *) let emittedFunDefn: (string, fundec * location * int) H.t = H.create 113 (* and same for variable definitions; name maps to GVar fields *) let emittedVarDefn: (string, varinfo * init option * location) H.t = H.create 113 (** A mapping from the new names to the original names. Used in PASS2 when we * rename variables. *) let originalVarNames: (string, string) H.t = H.create 113 (* Initialize the module *) let init ?(all=true) () = H.clear sAlpha; H.clear eAlpha; H.clear vtAlpha; H.clear vEnv; if all then PlainMerging.clear_eq vEq; PlainMerging.clear_eq sEq; EnumMerging.clear_eq eEq; PlainMerging.clear_eq tEq; PlainMerging.clear_eq iEq; PlainMerging.clear_eq lfEq; PlainMerging.clear_eq ltEq; PlainMerging.clear_eq lcEq; PlainMerging.clear_eq laEq; PlainMerging.clear_eq llEq; VolatileMerging.clear_eq lvEq; ModelMerging.clear_eq mfEq; PlainMerging.clear_syn vSyn; PlainMerging.clear_syn sSyn; EnumMerging.clear_syn eSyn; PlainMerging.clear_syn tSyn; PlainMerging.clear_syn iSyn; PlainMerging.clear_syn lfSyn; PlainMerging.clear_syn ltSyn; PlainMerging.clear_syn lcSyn; PlainMerging.clear_syn laSyn; PlainMerging.clear_syn llSyn; VolatileMerging.clear_syn lvSyn; ModelMerging.clear_syn mfSyn; theFile := []; theFileTypes := []; H.clear formalNames; H.clear inlineBodies; currentFidx := 0; currentDeclIdx := 0; H.clear fileNames; H.clear emittedVarDecls; H.clear emittedCompDecls; H.clear emittedFunDefn; H.clear emittedVarDefn; H.clear originalVarNames; if all then Logic_env.prepare_tables () let rec global_annot_pass1 g = match g with | Dvolatile(id,rvi,wvi,loc) -> CurrentLoc.set loc; ignore (VolatileMerging.getNode lvEq lvSyn !currentFidx id (id,(rvi,wvi,loc)) (Some (loc,!currentDeclIdx))) | Daxiomatic(id,decls,l) -> CurrentLoc.set l; ignore (PlainMerging.getNode laEq laSyn !currentFidx id (id,decls) (Some (l,!currentDeclIdx))); List.iter global_annot_pass1 decls | Dfun_or_pred (li,l) -> CurrentLoc.set l; let mynode = PlainMerging.getNode lfEq lfSyn !currentFidx li.l_var_info.lv_name li None in (* NB: in case of mix decl/def it is the decl location that is taken. *) if mynode.nloc = None then ignore (PlainMerging.getNode lfEq lfSyn !currentFidx li.l_var_info.lv_name li (Some (l, !currentDeclIdx))) | Dtype_annot (pi,l) -> CurrentLoc.set l; ignore (PlainMerging.getNode lfEq lfSyn !currentFidx pi.l_var_info.lv_name pi (Some (l, !currentDeclIdx))) | Dmodel_annot (mfi,l) -> CurrentLoc.set l; ignore (ModelMerging.getNode mfEq mfSyn !currentFidx (mfi.mi_name,mfi.mi_base_type) mfi (Some (l, !currentDeclIdx))) | Dcustom_annot (c, n, l) -> Format.eprintf "Mergecil : custom@."; CurrentLoc.set l; ignore (PlainMerging.getNode lcusEq lcusSyn !currentFidx n (n,(c,l)) (Some (l, !currentDeclIdx))) | Dinvariant (pi,l) -> CurrentLoc.set l; ignore (PlainMerging.getNode lfEq lfSyn !currentFidx pi.l_var_info.lv_name pi (Some (l, !currentDeclIdx))) | Dtype (info,l) -> CurrentLoc.set l; ignore (PlainMerging.getNode ltEq ltSyn !currentFidx info.lt_name info (Some (l, !currentDeclIdx))) | Dlemma (n,is_ax,labs,typs,st,l) -> CurrentLoc.set l; ignore (PlainMerging.getNode llEq llSyn !currentFidx n (n,(is_ax,labs,typs,st,l)) (Some (l, !currentDeclIdx))) (* Some enumerations have to be turned into an integer. We implement this by * introducing a special enumeration type which we'll recognize later to be * an integer *) let intEnumInfo = let name = "!!!intEnumInfo!!!" (* invalid C name. Can't clash with anything. *) in { eorig_name = name; ename = name; eitems = []; eattr = []; ereferenced = false; ekind = IInt; } (* And add it to the equivalence graph *) let intEnumInfoNode = EnumMerging.getNode eEq eSyn 0 intEnumInfo intEnumInfo (Some (Cil_datatype.Location.unknown, 0)) (* Combine the types. Raises the Failure exception with an error message. * isdef says whether the new type is for a definition *) type combineWhat = CombineFundef (* The new definition is for a function definition. The old * is for a prototype *) | CombineFunarg (* Comparing a function argument type with an old prototype * arg *) | CombineFunret (* Comparing the return of a function with that from an old * prototype *) | CombineOther let rec combineTypes (what: combineWhat) (oldfidx: int) (oldt: typ) (fidx: int) (t: typ) : typ = match oldt, t with | TVoid olda, TVoid a -> TVoid (addAttributes olda a) | TInt (oldik, olda), TInt (ik, a) -> let combineIK oldk k = if oldk == k then oldk else if bytesSizeOfInt oldk=bytesSizeOfInt k && isSigned oldk=isSigned k then (* the types contain the same sort of values but are not equal. For example on x86_16 machep unsigned short and unsigned int. *) if rank oldk let combineFK oldk k = if oldk == k then oldk else (* GCC allows a function definition to have a more precise integer * type than a prototype that says "double" *) if not theMachine.msvcMode && oldk = FDouble && k = FFloat && (what = CombineFunarg || what = CombineFunret) then k else raise (Failure "different floating point types") in TFloat (combineFK oldfk fk, addAttributes olda a) | TEnum (oldei, olda), TEnum (ei, a) -> (* Matching enumerations always succeeds. But sometimes it maps both * enumerations to integers *) matchEnumInfo oldfidx oldei fidx ei; TEnum (oldei, addAttributes olda a) (* Strange one. But seems to be handled by GCC *) | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei, addAttributes olda a) (* Strange one. But seems to be handled by GCC. Warning. Here we are * leaking types from new to old *) | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, addAttributes olda a) | TComp (oldci, _, olda) , TComp (ci, _, a) -> matchCompInfo oldfidx oldci fidx ci; (* If we get here we were successful *) TComp (oldci, empty_size_cache (), addAttributes olda a) | TArray (oldbt, oldsz, _, olda), TArray (bt, sz, _, a) -> let combbt = combineTypes CombineOther oldfidx oldbt fidx bt in let combinesz = match oldsz, sz with None, Some _ -> sz | Some _, None -> oldsz | None, None -> oldsz | Some oldsz', Some sz' -> if same_int64 oldsz' sz' then oldsz else raise (Failure "different array sizes") in TArray (combbt, combinesz, empty_size_cache (), addAttributes olda a) | TPtr (oldbt, olda), TPtr (bt, a) -> TPtr (combineTypes CombineOther oldfidx oldbt fidx bt, addAttributes olda a) | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) -> let newrt = combineTypes (if what = CombineFundef then CombineFunret else CombineOther) oldfidx oldrt fidx rt in if oldva != va then raise (Failure "different vararg specifiers"); (* If one does not have arguments, believe the one with the * arguments *) let newargs = if oldargs = None then args else if args = None then oldargs else let oldargslist = argsToList oldargs in let argslist = argsToList args in if List.length oldargslist <> List.length argslist then raise (Failure "different number of arguments") else begin (* Go over the arguments and update the old ones with the * adjusted types *) Some (List.map2 (fun (on, ot, oa) (an, at, aa) -> let n = if an <> "" then an else on in let t = combineTypes (if what = CombineFundef then CombineFunarg else CombineOther) oldfidx ot fidx at in let a = addAttributes oa aa in (n, t, a)) oldargslist argslist) end in let olda = if Cil.hasAttribute "missingproto" a then olda else Cil.dropAttribute "missingproto" olda in let a = if Cil.hasAttribute "missingproto" olda then a else Cil.dropAttribute "missingproto" a in TFun (newrt, newargs, oldva, addAttributes olda a) | TBuiltin_va_list olda, TBuiltin_va_list a -> TBuiltin_va_list (addAttributes olda a) | TNamed (oldt, olda), TNamed (t, a) -> matchTypeInfo oldfidx oldt fidx t; (* If we get here we were able to match *) TNamed(oldt, addAttributes olda a) (* Unroll first the new type *) | _, TNamed (t, a) -> let res = combineTypes what oldfidx oldt fidx t.ttype in typeAddAttributes a res (* And unroll the old type as well if necessary *) | TNamed (oldt, a), _ -> let res = combineTypes what oldfidx oldt.ttype fidx t in typeAddAttributes a res | _ -> ( (* raise (Failure "different type constructors") *) let msg:string = Pretty_utils.sfprintf "different type constructors: %a vs. %a" Cil_printer.pp_typ oldt Cil_printer.pp_typ t in raise (Failure msg)) (* Match two compinfos and throw a Failure if they do not match *) and matchCompInfo (oldfidx: int) (oldci: compinfo) (fidx: int) (ci: compinfo) : unit = let cstruct = oldci.cstruct in if cstruct <> ci.cstruct then raise (Failure "different struct/union types"); (* See if we have a mapping already *) (* Make the nodes if not already made. Actually return the * representatives *) let oldcinode = PlainMerging.getNode sEq sSyn oldfidx oldci.cname oldci None in let cinode = PlainMerging.getNode sEq sSyn fidx ci.cname ci None in if oldcinode == cinode then (* We already know they are the same *) () else begin (* Replace with the representative data *) let oldci = oldcinode.ndata in let oldfidx = oldcinode.nfidx in let ci = cinode.ndata in let fidx = cinode.nfidx in let old_len = List.length oldci.cfields in let len = List.length ci.cfields in (* It is easy to catch here the case when the new structure is undefined * and the old one was defined. We just reuse the old *) (* More complicated is the case when the old one is not defined but the * new one is. We still reuse the old one and we'll take care of defining * it later with the new fields. * GN: 7/10/04, I could not find when is "later", so I added it below *) if len <> 0 && old_len <> 0 && old_len <> len then begin let curLoc = CurrentLoc.get () in (* d_global blows this away.. *) CurrentLoc.set curLoc; let aggregate_name = if cstruct then "struct" else "union" in let msg = Printf.sprintf "different number of fields in %s %s and %s %s: %d != %d." aggregate_name oldci.cname aggregate_name ci.cname old_len len in raise (Failure msg) end; (* We check that they are defined in the same way. While doing this there * might be recursion and we have to watch for going into an infinite * loop. So we add the assumption that they are equal *) let newrep, undo = union oldcinode cinode in (* We check the fields but watch for Failure. We only do the check when * the lengths are the same. Due to the code above this the other * possibility is that one of the length is 0, in which case we reuse the * old compinfo. *) (* But what if the old one is the empty one ? *) if old_len = len then begin try List.iter2 (fun oldf f -> if oldf.fbitfield <> f.fbitfield then raise (Failure "different bitfield info"); if oldf.fattr <> f.fattr then raise (Failure "different field attributes"); (* Make sure the types are compatible *) let newtype = combineTypes CombineOther oldfidx oldf.ftype fidx f.ftype in (* Change the type in the representative *) oldf.ftype <- newtype) oldci.cfields ci.cfields with Failure reason -> (* Our assumption was wrong. Forget the isomorphism *) undo (); let fields_old = Pretty_utils.sfprintf "%a" Cil_printer.pp_global (GCompTag(oldci, Cil_datatype.Location.unknown)) in let fields = Pretty_utils.sfprintf "%a" Cil_printer.pp_global (GCompTag(ci, Cil_datatype.Location.unknown)) in let fullname_old = compFullName oldci in let fullname = compFullName ci in let msg = match fullname_old = fullname, fields_old = fields (* Could also use a special comparison *) with true, true -> Pretty_utils.sfprintf "Definitions of %s are not isomorphic. Reason follows:@\n@?%s" fullname_old reason | false, true -> Pretty_utils.sfprintf "%s and %s are not isomorphic. Reason follows:@\n@?%s" fullname_old fullname reason | true, false -> Pretty_utils.sfprintf "Definitions of %s are not isomorphic. \ Reason follows:@\n@?%s@\n@?%s@?%s" fullname_old reason fields_old fields | false, false -> Pretty_utils.sfprintf "%s and %s are not isomorphic. Reason follows:@\n@?%s@\n@?%s@?%s" fullname_old fullname reason fields_old fields in raise (Failure msg) end else begin (* We will reuse the old one. One of them is empty. If the old one is * empty, copy over the fields from the new one. Won't this result in * all sorts of undefined types??? *) if old_len = 0 then oldci.cfields <- ci.cfields; end; (* We get here when we succeeded checking that they are equal, or one of * them was empty *) newrep.ndata.cattr <- addAttributes oldci.cattr ci.cattr; () end (* Match two enuminfos and throw a Failure if they do not match *) and matchEnumInfo (oldfidx: int) (oldei: enuminfo) (fidx: int) (ei: enuminfo) : unit = (* Find the node for this enum, no path compression. *) let oldeinode = EnumMerging.getNode eEq eSyn oldfidx oldei oldei None in let einode = EnumMerging.getNode eEq eSyn fidx ei ei None in if oldeinode == einode then (* We already know they are the same *) () else begin (* Replace with the representative data *) let oldei = oldeinode.ndata in let ei = einode.ndata in (* Try to match them. But if you cannot just make them both integers *) try have_same_enum_items oldei ei; (* Set the representative *) let newrep, _ = EnumMerging.union oldeinode einode in (* We get here if the enumerations match *) newrep.ndata.eattr <- addAttributes oldei.eattr ei.eattr; () with Failure msg -> begin let pp_items = Pretty_utils.pp_list ~pre:"{" ~suf:"}" ~sep:",@ " (fun fmt item -> Format.fprintf fmt "%s=%a" item.eiorig_name Cil_printer.pp_exp item.eival) in if oldeinode != intEnumInfoNode && einode != intEnumInfoNode then Kernel.warning "@[merging definitions of enum %s using int type@ (%s);@ items %a and@ %a@]" oldei.ename msg pp_items oldei.eitems pp_items ei.eitems; (* Get here if you cannot merge two enumeration nodes *) if oldeinode != intEnumInfoNode then begin let _ = EnumMerging.union oldeinode intEnumInfoNode in () end; if einode != intEnumInfoNode then begin let _ = EnumMerging.union einode intEnumInfoNode in () end; end end (* Match two typeinfos and throw a Failure if they do not match *) and matchTypeInfo (oldfidx: int) (oldti: typeinfo) (fidx: int) (ti: typeinfo) : unit = if oldti.tname = "" || ti.tname = "" then Kernel.fatal "matchTypeInfo for anonymous type"; (* Find the node for this enum, no path compression. *) let oldtnode = PlainMerging.getNode tEq tSyn oldfidx oldti.tname oldti None in let tnode = PlainMerging.getNode tEq tSyn fidx ti.tname ti None in if oldtnode == tnode then (* We already know they are the same *) () else begin (* Replace with the representative data *) let oldti = oldtnode.ndata in let oldfidx = oldtnode.nfidx in let ti = tnode.ndata in let fidx = tnode.nfidx in (* Check that they are the same *) (try ignore (combineTypes CombineOther oldfidx oldti.ttype fidx ti.ttype); with Failure reason -> begin let msg = let oldname = oldti.tname in let name = ti.tname in if oldname = name then Format.sprintf "Definitions of type %s are not isomorphic. \ Reason follows:@\n@?%s" oldname reason else Format.sprintf "Types %s and %s are not isomorphic. Reason follows:@\n@?%s" oldname name reason in raise (Failure msg) end); let _ = union oldtnode tnode in () end let static_var_visitor = object inherit Cil.nopCilVisitor method vvrbl vi = if vi.vstorage = Static then raise Exit; DoChildren end (* let has_static_ref_predicate pred_info = try ignore (visitCilPredicateInfo static_var_visitor pred_info); false with Exit -> true *) let has_static_ref_logic_function lf_info = try ignore (visitCilLogicInfo static_var_visitor lf_info); false with Exit -> true let matchLogicInfo oldfidx oldpi fidx pi = let oldtnode = PlainMerging.getNode lfEq lfSyn oldfidx oldpi.l_var_info.lv_name oldpi None in let tnode = PlainMerging.getNode lfEq lfSyn fidx pi.l_var_info.lv_name pi None in if oldtnode == tnode then (* We already know they are the same *) () else begin let oldpi = oldtnode.ndata in let oldfidx = oldtnode.nfidx in let pi = tnode.ndata in let fidx = tnode.nfidx in if Logic_utils.is_same_logic_info oldpi pi then begin if has_static_ref_logic_function oldpi then Kernel.abort "multiple inclusion of logic function %s referring to a static variable" oldpi.l_var_info.lv_name else if oldfidx < fidx then tnode.nrep <- oldtnode.nrep else oldtnode.nrep <- tnode.nrep end else Kernel.abort "invalid multiple logic function declarations %s" pi.l_var_info.lv_name end let matchLogicType oldfidx oldnode fidx node = let oldtnode = PlainMerging.getNode ltEq ltSyn oldfidx oldnode.lt_name oldnode None in let tnode = PlainMerging.getNode ltEq ltSyn fidx oldnode.lt_name node None in if oldtnode == tnode then (* We already know they are the same *) () else begin let oldinfo = oldtnode.ndata in let oldfidx = oldtnode.nfidx in let info = tnode.ndata in let fidx = tnode.nfidx in if Logic_utils.is_same_logic_type_info oldinfo info then begin if oldfidx < fidx then tnode.nrep <- oldtnode.nrep else oldtnode.nrep <- tnode.nrep end else Kernel.error ~current:true "invalid multiple logic type declarations %s" node.lt_name end let matchLogicCtor oldfidx oldpi fidx pi = let oldtnode = PlainMerging.getNode lcEq lcSyn oldfidx oldpi.ctor_name oldpi None in let tnode = PlainMerging.getNode lcEq lcSyn fidx pi.ctor_name pi None in if oldtnode != tnode then Kernel.error ~current:true "invalid multiple logic constructors declarations %s" pi.ctor_name let matchLogicAxiomatic oldfidx (oldid,_ as oldnode) fidx (id,_ as node) = let oldanode = PlainMerging.getNode laEq laSyn oldfidx oldid oldnode None in let anode = PlainMerging.getNode laEq laSyn fidx id node None in if oldanode != anode then begin let _, oldax = oldanode.ndata in let oldaidx = oldanode.nfidx in let _, ax = anode.ndata in let aidx = anode.nfidx in if Logic_utils.is_same_axiomatic oldax ax then begin if oldaidx < aidx then anode.nrep <- oldanode.nrep else oldanode.nrep <- anode.nrep end else Kernel.error ~current:true "invalid multiple axiomatic declarations %s" id end let matchLogicLemma oldfidx (oldid, _ as oldnode) fidx (id, _ as node) = let oldlnode = PlainMerging.getNode llEq llSyn oldfidx oldid oldnode None in let lnode = PlainMerging.getNode llEq llSyn fidx id node None in if oldlnode != lnode then begin let (oldid,(oldax,oldlabs,oldtyps,oldst,oldloc)) = oldlnode.ndata in let oldfidx = oldlnode.nfidx in let (id,(ax,labs,typs,st,loc)) = lnode.ndata in let fidx = lnode.nfidx in if Logic_utils.is_same_global_annotation (Dlemma (oldid,oldax,oldlabs,oldtyps,oldst,oldloc)) (Dlemma (id,ax,labs,typs,st,loc)) then begin if oldfidx < fidx then lnode.nrep <- oldlnode.nrep else oldlnode.nrep <- lnode.nrep end else Kernel.error ~current:true "invalid multiple lemmas or axioms declarations for %s" id end let matchVolatileClause oldfidx (oldid,_ as oldnode) fidx (id,_ as node) = let oldlnode = VolatileMerging.getNode lvEq lvSyn oldfidx oldid oldnode None in let lnode = VolatileMerging.getNode lvEq lvSyn fidx id node None in if oldlnode != lnode then begin let (oldid,(oldr,oldw,oldloc)) = oldlnode.ndata in let oldfidx = oldlnode.nfidx in let (id,(r,w,loc)) = lnode.ndata in let fidx = lnode.nfidx in if Logic_utils.is_same_global_annotation (Dvolatile (oldid,oldr,oldw,oldloc)) (Dvolatile (id,r,w,loc)) then begin if oldfidx < fidx then lnode.nrep <- oldlnode.nrep else oldlnode.nrep <- lnode.nrep end else Kernel.error ~current:true "invalid multiple volatile clauses for locations %a" (Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_identified_term) id end let matchModelField oldfidx ({ mi_name = oldname; mi_base_type = oldtyp } as oldnode) fidx ({mi_name = name; mi_base_type = typ } as node) = let oldlnode = ModelMerging.getNode mfEq mfSyn oldfidx (oldname,oldtyp) oldnode None in let lnode = ModelMerging.getNode mfEq mfSyn fidx (name,typ) node None in if oldlnode != lnode then begin let oldmf = oldlnode.ndata in let oldfidx = oldlnode.nfidx in let mf = lnode.ndata in let fidx = oldlnode.nfidx in if Logic_utils.is_same_type oldmf.mi_field_type mf.mi_field_type then begin if oldfidx < fidx then lnode.nrep <- oldlnode.nrep else oldlnode.nrep <- lnode.nrep end else Kernel.error ~current:true "Model field %s of type %a is declared with different logic type: \ %a and %a" mf.mi_name Cil_printer.pp_typ mf.mi_base_type Cil_printer.pp_logic_type mf.mi_field_type Cil_printer.pp_logic_type oldmf.mi_field_type end (* Scan all files and do two things *) (* 1. Initialize the alpha renaming tables with the names of the globals so * that when we come in the second pass to generate new names, we do not run * into conflicts. *) (* 2. For all declarations of globals unify their types. In the process * construct a set of equivalence classes on type names, structure and * enumeration tags *) (* 3. We clean the referenced flags *) let oneFilePass1 (f:file) : unit = H.add fileNames !currentFidx f.fileName; Kernel.feedback ~level:2 "Pre-merging (%d) %s" !currentFidx f.fileName ; currentDeclIdx := 0; if f.globinitcalled || f.globinit <> None then Kernel.warning ~current:true "Merging file %s has global initializer" f.fileName; (* We scan each file and we look at all global varinfo. We see if globals * with the same name have been encountered before and we merge those types * *) let matchVarinfo (vi: varinfo) (loc, _ as l) = ignore (Alpha.registerAlphaName vtAlpha None vi.vname (CurrentLoc.get ())); (* Make a node for it and put it in vEq *) let vinode = PlainMerging.mkSelfNode vEq vSyn !currentFidx vi.vname vi (Some l) in try let oldvinode = PlainMerging.find true (H.find vEnv vi.vname) in let oldloc, _ = match oldvinode.nloc with None -> (Kernel.fatal "old variable is undefined") | Some l -> l in let oldvi = oldvinode.ndata in (* There is an old definition. We must combine the types. Do this first * because it might fail *) let newtype = try combineTypes CombineOther oldvinode.nfidx oldvi.vtype !currentFidx vi.vtype; with (Failure reason) -> begin Kernel.abort "@[Incompatible declaration for %s:@ %s@\n\ First declaration was at %a@\n\ Current declaration is at %a" vi.vname reason Cil_printer.pp_location oldloc Cil_printer.pp_location loc end in let newrep, _ = union oldvinode vinode in (* We do not want to turn non-"const" globals into "const" one. That * can happen if one file declares the variable a non-const while * others declare it as "const". *) if hasAttribute "const" (typeAttrs vi.vtype) != hasAttribute "const" (typeAttrs oldvi.vtype) then begin newrep.ndata.vtype <- typeRemoveAttributes ["const"] newtype; end else newrep.ndata.vtype <- newtype; (* clean up the storage. *) let newstorage = if vi.vstorage = oldvi.vstorage || vi.vstorage = Extern then oldvi.vstorage else if oldvi.vstorage = Extern then vi.vstorage (* Sometimes we turn the NoStorage specifier into Static for inline * functions *) else if oldvi.vstorage = Static && vi.vstorage = NoStorage then Static else begin Kernel.warning ~current:true "Inconsistent storage specification for %s. \ Now is %a and previous was %a at %a" vi.vname Cil_printer.pp_storage vi.vstorage Cil_printer.pp_storage oldvi.vstorage Cil_printer.pp_location oldloc ; vi.vstorage end in newrep.ndata.vstorage <- newstorage; newrep.ndata.vattr <- addAttributes oldvi.vattr vi.vattr with Not_found -> (* Not present in the previous files. Remember it for later *) H.add vEnv vi.vname vinode in List.iter (function | GVarDecl (_,vi, l) | GVar (vi, _, l) -> CurrentLoc.set l; incr currentDeclIdx; vi.vreferenced <- false; if vi.vstorage <> Static then begin matchVarinfo vi (l, !currentDeclIdx); end | GFun (fdec, l) -> CurrentLoc.set l; incr currentDeclIdx; (* Save the names of the formal arguments *) let _, args, _, _ = splitFunctionTypeVI fdec.svar in H.add formalNames (!currentFidx, fdec.svar.vname) (List.map (fun (n,_,_) -> n) (argsToList args)); fdec.svar.vreferenced <- false; (* Force inline functions to be static. *) (* GN: This turns out to be wrong. inline functions are external, * unless specified to be static. *) (* if fdec.svar.vinline && fdec.svar.vstorage = NoStorage then fdec.svar.vstorage <- Static; *) if fdec.svar.vstorage <> Static then begin matchVarinfo fdec.svar (l, !currentDeclIdx) end else begin if fdec.svar.vinline && mergeInlines then (* Just create the nodes for inline functions *) ignore (PlainMerging.getNode iEq iSyn !currentFidx fdec.svar.vname fdec.svar (Some (l, !currentDeclIdx))) end (* Make nodes for the defined type and structure tags *) | GType (t, l) -> incr currentDeclIdx; t.treferenced <- false; if t.tname <> "" then (* The empty names are just for introducing * undefined comp tags *) ignore (PlainMerging.getNode tEq tSyn !currentFidx t.tname t (Some (l, !currentDeclIdx))) else begin (* Go inside and clean the referenced flag for the * declared tags *) match t.ttype with TComp (ci, _, _ ) -> ci.creferenced <- false; (* Create a node for it *) ignore (PlainMerging.getNode sEq sSyn !currentFidx ci.cname ci None) | TEnum (ei, _) -> ei.ereferenced <- false; ignore (EnumMerging.getNode eEq eSyn !currentFidx ei ei None) | _ -> (Kernel.fatal "Anonymous Gtype is not TComp") end | GCompTag (ci, l) -> incr currentDeclIdx; ci.creferenced <- false; ignore (PlainMerging.getNode sEq sSyn !currentFidx ci.cname ci (Some (l, !currentDeclIdx))) | GCompTagDecl (ci,_) -> ci.creferenced <- false | GEnumTagDecl (ei,_) -> ei.ereferenced <- false | GEnumTag (ei, l) -> incr currentDeclIdx; ignore (A.newAlphaName aeAlpha None ei.ename l); ei.ereferenced <- false; ignore (EnumMerging.getNode eEq eSyn !currentFidx ei ei (Some (l, !currentDeclIdx))) | GAnnot (gannot,l) -> CurrentLoc.set l; incr currentDeclIdx; global_annot_pass1 gannot | GText _ | GPragma _ | GAsm _ -> ()) f.globals let matchInlines (oldfidx: int) (oldi: varinfo) (fidx: int) (i: varinfo) = let oldinode = PlainMerging.getNode iEq iSyn oldfidx oldi.vname oldi None in let inode = PlainMerging.getNode iEq iSyn fidx i.vname i None in if oldinode != inode then begin (* Replace with the representative data *) let oldi = oldinode.ndata in let oldfidx = oldinode.nfidx in let i = inode.ndata in let fidx = inode.nfidx in (* There is an old definition. We must combine the types. Do this first * because it might fail *) oldi.vtype <- combineTypes CombineOther oldfidx oldi.vtype fidx i.vtype; (* We get here if we have success *) (* Combine the attributes as well *) oldi.vattr <- addAttributes oldi.vattr i.vattr (* Do not union them yet because we do not know that they are the same. * We have checked only the types so far *) end (************************************************************ * * PASS 2 * * ************************************************************) (** Keep track of the functions we have used already in the file. We need * this to avoid removing an inline function that has been used already. * This can only occur if the inline function is defined after it is used * already; a bad style anyway *) let varUsedAlready: (string, unit) H.t = H.create 111 let pp_profiles fmt li = Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_logic_type fmt (List.map (fun v -> v.lv_type) li.l_profile) (** A visitor that renames uses of variables and types *) class renameVisitorClass = let rename_associated_logic_var lv = match lv.lv_origin with None -> (match PlainMerging.findReplacement true lfEq !currentFidx lv.lv_name with | None -> DoChildren | Some (li,_) -> let lv' = li.l_var_info in if lv == lv' then DoChildren (* Replacement already done... *) else ChangeTo lv') | Some vi -> if not vi.vglob then DoChildren else begin match PlainMerging.findReplacement true vEq !currentFidx vi.vname with | None -> DoChildren | Some (vi',_) -> vi'.vreferenced <- true; if vi == vi' then DoChildren (* replacement was done already*) else begin (match vi'.vlogic_var_assoc with None -> vi'.vlogic_var_assoc <- Some lv; DoChildren | Some lv' -> ChangeTo lv') end end in let find_enumitem_replacement ei = match EnumMerging.findReplacement true eEq !currentFidx ei.eihost with None -> None | Some (enum,_) -> if enum == intEnumInfo then begin (* Two different enums have been merged into an int type. Switch to an integer constant. *) match (constFold true ei.eival).enode with | Const c -> Some c | _ -> Kernel.fatal ~current:true "non constant value for an enum item" end else begin (* Merged with an isomorphic type. Find the appropriate enumitem *) let n = Extlib.find_index (fun e -> e.einame = ei.einame) ei.eihost.eitems in let ei' = List.nth enum.eitems n in assert (same_int64 ei.eival ei'.eival); Some (CEnum ei') end in object (self) inherit nopCilVisitor (* This is either a global variable which we took care of, or a local * variable. Must do its type and attributes. *) method vvdec (_vi: varinfo) = DoChildren (* This is a variable use. See if we must change it *) method vvrbl (vi: varinfo) : varinfo visitAction = if not vi.vglob then DoChildren else if vi.vreferenced then begin H.add varUsedAlready vi.vname (); DoChildren end else begin match PlainMerging.findReplacement true vEq !currentFidx vi.vname with None -> DoChildren | Some (vi', oldfidx) -> if debugMerge then (Kernel.debug "Renaming use of var %s(%d) to %s(%d)" vi.vname !currentFidx vi'.vname oldfidx); vi'.vreferenced <- true; H.add varUsedAlready vi'.vname (); ChangeTo vi' end method vlogic_var_decl lv = rename_associated_logic_var lv method vlogic_var_use lv = rename_associated_logic_var lv method vlogic_info_use li = match PlainMerging.findReplacement true lfEq !currentFidx li.l_var_info.lv_name with None -> if debugMerge then (Kernel.debug "Using logic function %s(%a)(%d)" li.l_var_info.lv_name (Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_logic_type) (List.map (fun v -> v.lv_type) li.l_profile) !currentFidx); DoChildren | Some(li',oldfidx) -> if debugMerge then Kernel.debug "Renaming use of logic function %s(%a)(%d) to %s(%a)(%d)" li.l_var_info.lv_name pp_profiles li !currentFidx li'.l_var_info.lv_name pp_profiles li' oldfidx; ChangeTo li' method vlogic_info_decl li = match PlainMerging.findReplacement true lfEq !currentFidx li.l_var_info.lv_name with None -> if debugMerge then (Kernel.debug "Using logic function %s(%a)(%d)" li.l_var_info.lv_name pp_profiles li !currentFidx); DoChildren | Some(li',oldfidx) -> if debugMerge then (Kernel.debug "Renaming use of logic function %s(%a)(%d) to %s(%a)(%d)" li.l_var_info.lv_name pp_profiles li !currentFidx li'.l_var_info.lv_name pp_profiles li' oldfidx); ChangeTo li' method vlogic_type_info_use lt = match PlainMerging.findReplacement true ltEq !currentFidx lt.lt_name with None -> if debugMerge then (Kernel.debug "Using logic type %s(%d)" lt.lt_name !currentFidx); DoChildren | Some(lt',oldfidx) -> if debugMerge then (Kernel.debug "Renaming use of logic type %s(%d) to %s(%d)" lt.lt_name !currentFidx lt'.lt_name oldfidx); ChangeTo lt' method vlogic_type_info_decl lt = match PlainMerging.findReplacement true ltEq !currentFidx lt.lt_name with None -> if debugMerge then (Kernel.debug "Using logic type %s(%d)" lt.lt_name !currentFidx); DoChildren | Some(lt',oldfidx) -> if debugMerge then (Kernel.debug "Renaming use of logic function %s(%d) to %s(%d)" lt.lt_name !currentFidx lt'.lt_name oldfidx); ChangeTo lt' method vlogic_ctor_info_use lc = match PlainMerging.findReplacement true lcEq !currentFidx lc.ctor_name with None -> if debugMerge then (Kernel.debug "Using logic constructor %s(%d)" lc.ctor_name !currentFidx); DoChildren | Some(lc',oldfidx) -> if debugMerge then (Kernel.debug "Renaming use of logic type %s(%d) to %s(%d)" lc.ctor_name !currentFidx lc'.ctor_name oldfidx); ChangeTo lc' method vlogic_ctor_info_decl lc = match PlainMerging.findReplacement true lcEq !currentFidx lc.ctor_name with None -> if debugMerge then (Kernel.debug "Using logic constructor %s(%d)" lc.ctor_name !currentFidx); DoChildren | Some(lc',oldfidx) -> if debugMerge then (Kernel.debug "Renaming use of logic function %s(%d) to %s(%d)" lc.ctor_name !currentFidx lc'.ctor_name oldfidx); ChangeTo lc' (* The use of a type. Change only those types whose underlying info * is not a root. *) method vtype (t: typ) = match t with TComp (ci, _, a) when not ci.creferenced -> begin match PlainMerging.findReplacement true sEq !currentFidx ci.cname with None -> if debugMerge then (Kernel.debug "No renaming needed %s(%d)" ci.cname !currentFidx); DoChildren | Some (ci', oldfidx) -> if debugMerge then (Kernel.debug "Renaming use of %s(%d) to %s(%d)" ci.cname !currentFidx ci'.cname oldfidx); ChangeTo (TComp (ci', empty_size_cache (), visitCilAttributes (self :> cilVisitor) a)) end | TComp(ci,_,_) -> if debugMerge then (Kernel.debug "%s(%d) referenced. No change" ci.cname !currentFidx); DoChildren | TEnum (ei, a) when not ei.ereferenced -> begin match EnumMerging.findReplacement true eEq !currentFidx ei with None -> DoChildren | Some (ei', _) -> if ei' == intEnumInfo then (* This is actually our friend intEnumInfo *) ChangeTo (TInt(IInt, visitCilAttributes (self :> cilVisitor) a)) else ChangeTo (TEnum (ei', visitCilAttributes (self :> cilVisitor) a)) end | TNamed (ti, a) when not ti.treferenced -> begin match PlainMerging.findReplacement true tEq !currentFidx ti.tname with None -> DoChildren | Some (ti', _) -> ChangeTo (TNamed (ti', visitCilAttributes (self :> cilVisitor) a)) end | _ -> DoChildren method vexpr e = match e.enode with | Const (CEnum ei) -> (match find_enumitem_replacement ei with None -> DoChildren | Some c -> ChangeTo { e with enode = Const c }) | CastE _ -> (* Maybe the cast is no longer necessary if an enum has been replaced by an integer type. *) let post_action e = match e.enode with | CastE(typ,exp) when Cil_datatype.TypByName.equal (typeOf exp) typ -> exp | _ -> e in ChangeDoChildrenPost (e,post_action) | _ -> DoChildren method vterm e = match e.term_node with | TConst(LEnum ei) -> (match find_enumitem_replacement ei with None -> DoChildren | Some c -> let t = visitCilLogicType (self:>cilVisitor) e.term_type in ChangeTo { e with term_node = TConst (Logic_utils.constant_to_lconstant c); term_type = t }) | _ -> DoChildren (* The Field offset might need to be changed to use new compinfo *) method voffs = function Field (f, o) -> begin (* See if the compinfo was changed *) if f.fcomp.creferenced then DoChildren else begin match PlainMerging.findReplacement true sEq !currentFidx f.fcomp.cname with None -> DoChildren (* We did not replace it *) | Some (ci', _oldfidx) -> begin (* First, find out the index of the original field *) let rec indexOf (i: int) = function [] -> Kernel.fatal "Cannot find field %s in %s" f.fname (compFullName f.fcomp) | f' :: _ when f' == f -> i | _ :: rest -> indexOf (i + 1) rest in let index = indexOf 0 f.fcomp.cfields in if List.length ci'.cfields <= index then Kernel.fatal "Too few fields in replacement %s for %s" (compFullName ci') (compFullName f.fcomp); let f' = List.nth ci'.cfields index in ChangeDoChildrenPost (Field (f', o), fun x -> x) end end end | _ -> DoChildren method vterm_offset = function TField (f, o) -> begin (* See if the compinfo was changed *) if f.fcomp.creferenced then DoChildren else begin match PlainMerging.findReplacement true sEq !currentFidx f.fcomp.cname with None -> DoChildren (* We did not replace it *) | Some (ci', _oldfidx) -> begin (* First, find out the index of the original field *) let rec indexOf (i: int) = function [] -> Kernel.fatal "Cannot find field %s in %s" f.fname (compFullName f.fcomp) | f' :: _ when f' == f -> i | _ :: rest -> indexOf (i + 1) rest in let index = indexOf 0 f.fcomp.cfields in if List.length ci'.cfields <= index then Kernel.fatal "Too few fields in replacement %s for %s" (compFullName ci') (compFullName f.fcomp); let f' = List.nth ci'.cfields index in ChangeDoChildrenPost (TField (f', o), fun x -> x) end end end | TModel(f,o) -> (match ModelMerging.findReplacement true mfEq !currentFidx (f.mi_name, f.mi_base_type) with | None -> (* We might have changed the field before choosing it as representative. Check that. *) let f' = (ModelMerging.find_eq_table mfEq (!currentFidx,(f.mi_name, f.mi_base_type))).ndata in if f == f' then DoChildren (* already the representative. *) else ChangeDoChildrenPost (TModel(f',o),fun x -> x) | Some (f',_) -> ChangeDoChildrenPost (TModel(f',o), fun x -> x)) | _ -> DoChildren method vinitoffs o = (self#voffs o) (* treat initializer offsets same as lvalue offsets *) end let renameVisitor = new renameVisitorClass (** A visitor that renames uses of inline functions that were discovered in * pass 2 to be used before they are defined. This is like the renameVisitor * except it only looks at the variables (thus it is a bit more efficient) * and it also renames forward declarations of the inlines to be removed. *) class renameInlineVisitorClass = object inherit nopCilVisitor (* This is a variable use. See if we must change it *) method vvrbl (vi: varinfo) : varinfo visitAction = if not vi.vglob then DoChildren else if vi.vreferenced then begin (* Already renamed *) DoChildren end else begin match PlainMerging.findReplacement true vEq !currentFidx vi.vname with None -> DoChildren | Some (vi', oldfidx) -> if debugMerge then Kernel.debug "Renaming var %s(%d) to %s(%d)" vi.vname !currentFidx vi'.vname oldfidx; vi'.vreferenced <- true; ChangeTo vi' end (* And rename some declarations of inlines to remove. We cannot drop this * declaration (see small1/combineinline6) *) method vglob = function GVarDecl(spec,vi, l) when vi.vinline -> begin (* Get the original name *) let origname = try H.find originalVarNames vi.vname with Not_found -> vi.vname in (* Now see if this must be replaced *) match PlainMerging.findReplacement true vEq !currentFidx origname with None -> DoChildren | Some (vi', _) -> (*TODO: visit the spec to change references to formals *) ChangeTo [GVarDecl (spec,vi', l)] end | _ -> DoChildren end let renameInlinesVisitor = new renameInlineVisitorClass let rec logic_annot_pass2 ~in_axiomatic g a = match a with | Dfun_or_pred (li,l) -> begin CurrentLoc.set l; match PlainMerging.findReplacement true lfEq !currentFidx li.l_var_info.lv_name with | None -> if not in_axiomatic then mergePushGlobals (visitCilGlobal renameVisitor g); Logic_utils.add_logic_function li; | Some _ -> () (* FIXME: should we perform same actions as the case Dlogic_reads above ? *) end | Dtype (t,l) -> begin CurrentLoc.set l; match PlainMerging.findReplacement true ltEq !currentFidx t.lt_name with | None -> if not in_axiomatic then mergePushGlobals (visitCilGlobal renameVisitor g); Logic_env.add_logic_type t.lt_name (PlainMerging.find_eq_table ltEq (!currentFidx,t.lt_name)).ndata | Some _ -> () end | Dinvariant ({l_var_info = {lv_name = n}},l) -> begin CurrentLoc.set l; match PlainMerging.findReplacement true lfEq !currentFidx n with | None -> assert (not in_axiomatic); mergePushGlobals (visitCilGlobal renameVisitor g); Logic_utils.add_logic_function (PlainMerging.find_eq_table lfEq (!currentFidx,n)).ndata | Some _ -> () end | Dtype_annot (n,l) -> begin CurrentLoc.set l; match PlainMerging.findReplacement true lfEq !currentFidx n.l_var_info.lv_name with | None -> let g = visitCilGlobal renameVisitor g in if not in_axiomatic then mergePushGlobals g; Logic_utils.add_logic_function (PlainMerging.find_eq_table lfEq (!currentFidx,n.l_var_info.lv_name)).ndata | Some _ -> () end | Dmodel_annot (mf,l) -> begin CurrentLoc.set l; match ModelMerging.findReplacement true mfEq !currentFidx (mf.mi_name,mf.mi_base_type) with | None -> let mf' = visitCilModelInfo renameVisitor mf in if mf' != mf then begin let my_node = ModelMerging.find_eq_table mfEq (!currentFidx,(mf'.mi_name,mf'.mi_base_type)) in (* Adds a new representative. Do not replace directly my_node, as there might be some pointers to it from other files. *) let my_node' = { my_node with ndata = mf' } in my_node.nrep <- my_node'; (* my_node' represents my_node *) my_node'.nrep <- my_node'; (* my_node' is the canonical representative. *) ModelMerging.add_eq_table mfEq (!currentFidx,(mf'.mi_name,mf'.mi_base_type)) my_node'; end; if not in_axiomatic then mergePushGlobals [GAnnot (Dmodel_annot(mf',l),l)]; Logic_env.add_model_field (ModelMerging.find_eq_table mfEq (!currentFidx,(mf'.mi_name,mf'.mi_base_type))).ndata; | Some _ -> () end | Dcustom_annot (_c, n, l) -> begin CurrentLoc.set l; match PlainMerging.findReplacement true lcusEq !currentFidx n with | None -> let g = visitCilGlobal renameVisitor g in if not in_axiomatic then mergePushGlobals g | Some _ -> () end | Dlemma (n,_,_,_,_,l) -> begin CurrentLoc.set l; match PlainMerging.findReplacement true llEq !currentFidx n with None -> if not in_axiomatic then mergePushGlobals (visitCilGlobal renameVisitor g) | Some _ -> () end | Dvolatile(vi,_,_,loc) -> (CurrentLoc.set loc; match VolatileMerging.findReplacement true lvEq !currentFidx vi with None -> mergePushGlobals (visitCilGlobal renameVisitor g) | Some _ -> ()) | Daxiomatic(n,l,loc) -> begin CurrentLoc.set loc; match PlainMerging.findReplacement true laEq !currentFidx n with None -> assert (not in_axiomatic); mergePushGlobals (visitCilGlobal renameVisitor g); List.iter (logic_annot_pass2 ~in_axiomatic:true g) l | Some _ -> () end let global_annot_pass2 g a = logic_annot_pass2 ~in_axiomatic:false g a (* sm: First attempt at a semantic checksum for function bodies. * Ideally, two function's checksums would be equal only when their * bodies were provably equivalent; but I'm using a much simpler and * less accurate heuristic here. It should be good enough for the * purpose I have in mind, which is doing duplicate removal of * multiply-instantiated template functions. *) let functionChecksum (dec: fundec) : int = begin (* checksum the structure of the statements (only) *) let rec stmtListSum (lst : stmt list) : int = (List.fold_left (fun acc s -> acc + (stmtSum s)) 0 lst) and stmtSum (s: stmt) : int = (* strategy is to just throw a lot of prime numbers into the * computation in hopes of avoiding accidental collision.. *) match s.skind with | UnspecifiedSequence seq -> 131*(stmtListSum (List.map (fun (x,_,_,_,_) -> x) seq)) + 127 | Instr _ -> 13 + 67 | Return(_) -> 17 | Goto(_) -> 19 | Break(_) -> 23 | Continue(_) -> 29 | If(_,b1,b2,_) -> 31 + 37*(stmtListSum b1.bstmts) + 41*(stmtListSum b2.bstmts) | Switch(_,b,_,_) -> 43 + 47*(stmtListSum b.bstmts) (* don't look at stmt list b/c is not part of tree *) | Loop(_,b,_,_,_) -> 49 + 53*(stmtListSum b.bstmts) | Block(b) -> 59 + 61*(stmtListSum b.bstmts) | TryExcept (b, (_, _), h, _) -> 67 + 83*(stmtListSum b.bstmts) + 97*(stmtListSum h.bstmts) | TryFinally (b, h, _) -> 103 + 113*(stmtListSum b.bstmts) + 119*(stmtListSum h.bstmts) in (* disabled 2nd and 3rd measure because they appear to get different * values, for the same code, depending on whether the code was just * parsed into CIL or had previously been parsed into CIL, printed * out, then re-parsed into CIL *) let a,b,c,d,e = (List.length dec.sformals), (* # formals *) 0 (*(List.length dec.slocals)*), (* # locals *) 0 (*dec.smaxid*), (* estimate of internal statement count *) (List.length dec.sbody.bstmts), (* number of statements at outer level *) (stmtListSum dec.sbody.bstmts) in (* checksum of statement structure *) 2*a + 3*b + 5*c + 7*d + 11*e end (* sm: equality for initializers, etc.; this is like '=', except * when we reach shared pieces (like references into the type * structure), we use '==', to prevent circularity *) (* update: that's no good; I'm using this to find things which * are equal but from different CIL trees, so nothing will ever * be '=='.. as a hack I'll just change those places to 'true', * so these functions are not now checking proper equality.. * places where equality is not complete are marked "INC" *) let rec equalInits (x: init) (y: init) : bool = begin match x,y with | SingleInit(xe), SingleInit(ye) -> (equalExps xe ye) | CompoundInit(_xt, xoil), CompoundInit(_yt, yoil) -> (*(xt == yt) &&*) (* INC *) (* types need to be identically equal *) let rec equalLists xoil yoil : bool = match xoil,yoil with | ((xo,xi) :: xrest), ((yo,yi) :: yrest) -> (equalOffsets xo yo) && (equalInits xi yi) && (equalLists xrest yrest) | [], [] -> true | _, _ -> false in (equalLists xoil yoil) | _, _ -> false end and equalOffsets (x: offset) (y: offset) : bool = begin match x,y with | NoOffset, NoOffset -> true | Field(xfi,xo), Field(yfi,yo) -> (xfi.fname = yfi.fname) && (* INC: same fieldinfo name.. *) (equalOffsets xo yo) | Index(xe,xo), Index(ye,yo) -> (equalExps xe ye) && (equalOffsets xo yo) | _,_ -> false end and equalExps (x: exp) (y: exp) : bool = begin match x.enode,y.enode with | Const(xc), Const(yc) -> Cil.compareConstant xc yc || ((* CIL changes (unsigned)0 into 0U during printing.. *) match xc,yc with | CInt64(xv,_,_),CInt64(yv,_,_) -> (Integer.equal xv Integer.zero) && (* ok if they're both 0 *) (Integer.equal yv Integer.zero) | _,_ -> false ) | Lval(xl), Lval(yl) -> (equalLvals xl yl) | SizeOf(_xt), SizeOf(_yt) -> true (*INC: xt == yt*) (* identical types *) | SizeOfE(xe), SizeOfE(ye) -> (equalExps xe ye) | AlignOf(_xt), AlignOf(_yt) -> true (*INC: xt == yt*) | AlignOfE(xe), AlignOfE(ye) -> (equalExps xe ye) | UnOp(xop,xe,_xt), UnOp(yop,ye,_yt) -> xop = yop && (equalExps xe ye) && true (*INC: xt == yt*) | BinOp(xop,xe1,xe2,_xt), BinOp(yop,ye1,ye2,_yt) -> xop = yop && (equalExps xe1 ye1) && (equalExps xe2 ye2) && true (*INC: xt == yt*) | CastE(_xt,xe), CastE(_yt,ye) -> (*INC: xt == yt &&*) (equalExps xe ye) | AddrOf(xl), AddrOf(yl) -> (equalLvals xl yl) | StartOf(xl), StartOf(yl) -> (equalLvals xl yl) (* initializers that go through CIL multiple times sometimes lose casts they * had the first time; so allow a different of a cast *) | CastE(_xt,xe),_ -> (equalExps xe y) | _, CastE(_yt,ye) -> (equalExps x ye) | _,_ -> false end and equalLvals (x: lval) (y: lval) : bool = begin match x,y with | (Var _xv,xo), (Var _yv,yo) -> (* I tried, I really did.. the problem is I see these names * before merging collapses them, so __T123 != __T456, * so whatever *) (*(xv.vname = vy.vname) && (* INC: same varinfo names.. *)*) (equalOffsets xo yo) | (Mem(xe),xo), (Mem(ye),yo) -> (equalExps xe ye) && (equalOffsets xo yo) | _,_ -> false end let equalInitOpts (x: init option) (y: init option) : bool = begin match x,y with | None,None -> true | Some(xi), Some(yi) -> (equalInits xi yi) | _,_ -> false end (* Now we go once more through the file and we rename the globals that we * keep. We also scan the entire body and we replace references to the * representative types or variables. We set the referenced flags once we * have replaced the names. *) let oneFilePass2 (f: file) = Kernel.feedback ~level:2 "Final merging phase: %s" f.fileName; currentDeclIdx := 0; (* Even though we don't need it anymore *) H.clear varUsedAlready; H.clear originalVarNames; (* If we find inline functions that are used before being defined, and thus * before knowing that we can throw them away, then we mark this flag so * that we can make another pass over the file *) let repeatPass2 = ref false in (* set to true if we need to make an additional path for changing tentative definition into plain declaration because a real definition has been found. *) let replaceTentativeDefn = ref false in (* Keep a pointer to the contents of the file so far *) let savedTheFile = !theFile in let processOneGlobal (g: global) : unit = (* Process a varinfo. Reuse an old one, or rename it if necessary *) let processVarinfo (vi: varinfo) (vloc: location) : varinfo = if vi.vreferenced then vi (* Already done *) else begin (* Maybe it is static. Rename it then *) if vi.vstorage = Static then begin let newName, _ = A.newAlphaName vtAlpha None vi.vname (CurrentLoc.get ()) in let formals_decl = try ignore (Cil.getFormalsDecl vi); true with Not_found -> false in (* Remember the original name *) H.add originalVarNames newName vi.vname; if debugMerge then Kernel.debug "renaming %s at %a to %s" vi.vname Cil_printer.pp_location vloc newName; vi.vname <- newName; vi.vreferenced <- true; Cil_const.set_vid vi; if formals_decl then Cil.setFormalsDecl vi vi.vtype; vi end else begin (* Find the representative *) match PlainMerging.findReplacement true vEq !currentFidx vi.vname with None -> vi (* This is the representative *) | Some (vi', _) -> (* Reuse some previous one *) vi'.vreferenced <- true; (* Mark it as done already *) vi'.vaddrof <- vi.vaddrof || vi'.vaddrof; vi'.vdefined <- vi.vdefined || vi'.vdefined; if Extlib.xor vi'.vghost vi.vghost then Kernel.abort "Cannot merge: Global %a has both ghost and non-ghost status" Cil_printer.pp_varinfo vi'; (* If vi has a logic binding, add one to the representative if needed. *) (match vi'.vlogic_var_assoc, vi.vlogic_var_assoc with | _, None -> () | Some _, _ -> () | None, Some _ -> ignore (Cil.cvar_to_lvar vi')); vi' end end in match g with | GVarDecl (spec,vi, l) as g -> CurrentLoc.set l; incr currentDeclIdx; let vi' = processVarinfo vi l in let spec' = visitCilFunspec renameVisitor spec in if vi != vi' then begin (* Drop the decl, keep the spec *) mergeSpec vi' vi spec'; (try (* if the reference varinfo already has formals, everything is renamed accordingly. *) ignore (Cil.getFormalsDecl vi') with Not_found -> (* Otherwise, if we have formals here, register them with the reference varinfo *) try let my_formals = Cil.getFormalsDecl vi in Cil.unsafeSetFormalsDecl vi' my_formals with Not_found -> () (* Neither decl has formals. Do nothing. *)); Cil.removeFormalsDecl vi end else if H.mem emittedVarDecls vi'.vname then begin mergeSpec vi' vi spec' end else begin H.add emittedVarDecls vi'.vname true; (* Remember that we emitted * it *) mergePushGlobals (visitCilGlobal renameVisitor g) end | GVar (vi, init, l) -> CurrentLoc.set l; incr currentDeclIdx; let vi' = processVarinfo vi l in (* We must keep this definition even if we reuse this varinfo, * because maybe the previous one was a declaration *) H.add emittedVarDecls vi.vname true; (* Remember that we emitted it*) let emitIt:bool = (not mergeGlobals) || try let _prevVar, prevInitOpt, prevLoc = (H.find emittedVarDefn vi'.vname) in (* previously defined; same initializer? *) if (equalInitOpts prevInitOpt init.init) || (init.init = None) then ( false (* do not emit *) ) else if prevInitOpt = None then ( (* The previous occurence was only a tentative defn. Now, we have a real one. Set the correct value in the table, and tell that we need to change the previous into a GVarDecl *) H.replace emittedVarDefn vi'.vname(vi',init.init,l); replaceTentativeDefn:=true; true ) else ( (* Both GVars have initializers. *) Kernel.error ~current:true "global var %s at %a has different initializer than %a" vi'.vname Cil_printer.pp_location l Cil_printer.pp_location prevLoc; false ) with Not_found -> begin (* no previous definition *) H.add emittedVarDefn vi'.vname (vi', init.init, l); true (* emit it *) end in if emitIt then mergePushGlobals (visitCilGlobal renameVisitor (GVar(vi', init, l))) | GFun (fdec, l) as g -> CurrentLoc.set l; incr currentDeclIdx; (* We apply the renaming *) let vi = processVarinfo fdec.svar l in if fdec.svar != vi then begin (try add_alpha_renaming vi (Cil.getFormalsDecl vi) fdec.sformals with Not_found -> ()); fdec.svar <- vi end; (* Get the original name. *) let origname = try H.find originalVarNames fdec.svar.vname with Not_found -> fdec.svar.vname in (* Go in there and rename everything as needed *) let fdec' = match visitCilGlobal renameVisitor g with | [ GFun(fdec', _) ] -> fdec' | _ -> Kernel.fatal "renameVisitor for GFun returned something else" in let g' = GFun(fdec', l) in (* Now restore the parameter names *) let _, args, _, _ = splitFunctionTypeVI fdec'.svar in let oldnames, foundthem = try H.find formalNames (!currentFidx, origname), true with Not_found -> begin Kernel.debug ~level:3 "Cannot find %s in formalNames" origname; [], false end in if foundthem then begin let _argl = argsToList args in if List.length oldnames <> List.length fdec.sformals then Kernel.fatal ~current:true "After merging the function has different arguments"; List.iter2 (fun oldn a -> if oldn <> "" then a.vname <- oldn) oldnames fdec.sformals; (* Reflect them in the type *) setFormals fdec fdec.sformals end; (** See if we can remove this inline function *) if fdec'.svar.vinline && mergeInlines then begin let printout = (* Temporarily turn of printing of lines *) let oldprintln = miscState.lineDirectiveStyle in miscState.lineDirectiveStyle <- None; (* Temporarily set the name to all functions in the same way *) let newname = fdec'.svar.vname in (* If we must do alpha conversion then temporarily set the * names of the function, local variables and formals in a * standard way *) if mergeInlinesWithAlphaConvert then fdec'.svar.vname <- "@@alphaname@@"; let nameId = ref 0 in let oldNames : string list ref = ref [] in let renameOne (v: varinfo) = oldNames := v.vname :: !oldNames; incr nameId; v.vname <- "___alpha" ^ string_of_int !nameId in let undoRenameOne (v: varinfo) = match !oldNames with n :: rest -> oldNames := rest; v.vname <- n | _ -> Kernel.fatal "undoRenameOne" in (* Remember the original type *) let origType = fdec'.svar.vtype in if mergeInlinesWithAlphaConvert then begin (* Rename the formals *) List.iter renameOne fdec'.sformals; (* Reflect in the type *) setFormals fdec' fdec'.sformals; (* Now do the locals *) List.iter renameOne fdec'.slocals end; (* Now print it *) let res = Pretty_utils.sfprintf "%a" Cil_printer.pp_global g' in miscState.lineDirectiveStyle <- oldprintln; fdec'.svar.vname <- newname; if mergeInlinesWithAlphaConvert then begin (* Do the locals in reverse order *) List.iter undoRenameOne (List.rev fdec'.slocals); (* Do the formals in reverse order *) List.iter undoRenameOne (List.rev fdec'.sformals); (* Restore the type *) fdec'.svar.vtype <- origType; end; res in (* Make a node for this inline function using the original name. *) let inode = PlainMerging.getNode vEq vSyn !currentFidx origname fdec'.svar (Some (l, !currentDeclIdx)) in if debugInlines then begin Kernel.debug "getNode %s(%d) with loc=%a. declidx=%d" inode.nname inode.nfidx d_nloc inode.nloc !currentDeclIdx; Kernel.debug "Looking for previous definition of inline %s(%d)" origname !currentFidx; end; try let oldinode = H.find inlineBodies printout in if debugInlines then Kernel.debug " Matches %s(%d)" oldinode.nname oldinode.nfidx; (* There is some other inline function with the same printout. * We should reuse this, but watch for the case when the inline * was already used. *) if H.mem varUsedAlready fdec'.svar.vname then begin if mergeInlinesRepeat then begin repeatPass2 := true end else begin Kernel.warning ~current:true "Inline function %s because it is used before it is defined" fdec'.svar.vname; raise Not_found end end; let _ = union oldinode inode in (* Clean up the vreferenced bit in the new inline, so that we * can rename it. Reset the name to the original one so that * we can find the replacement name. *) fdec'.svar.vreferenced <- false; fdec'.svar.vname <- origname; () (* Drop this definition *) with Not_found -> begin if debugInlines then Kernel.debug " Not found"; H.add inlineBodies printout inode; mergePushGlobal g' end end else begin (* either the function is not inline, or we're not attempting to * merge inlines *) if mergeGlobals && not fdec'.svar.vinline && fdec'.svar.vstorage <> Static then begin (* sm: this is a non-inline, non-static function. I want to * consider dropping it if a same-named function has already * been put into the merged file *) let curSum = (functionChecksum fdec') in try let _prevFun, prevLoc, prevSum = (H.find emittedFunDefn fdec'.svar.vname) in (* previous was found *) if (curSum = prevSum) then Kernel.warning ~current:true "dropping duplicate def'n of func %s at %a in favor of \ that at %a" fdec'.svar.vname Cil_printer.pp_location l Cil_printer.pp_location prevLoc else begin (* the checksums differ, so print a warning but keep the * older one to avoid a link error later. I think this is * a reasonable approximation of what ld does. *) Kernel.warning ~current:true "def'n of func %s at %a (sum %d) conflicts with the one \ at %a (sum %d); keeping the one at %a." fdec'.svar.vname Cil_printer.pp_location l curSum Cil_printer.pp_location prevLoc prevSum Cil_printer.pp_location prevLoc end with Not_found -> begin (* there was no previous definition *) (mergePushGlobal g'); (H.add emittedFunDefn fdec'.svar.vname (fdec', l, curSum)) end end else begin (* not attempting to merge global functions, or it was static * or inline *) mergePushGlobal g' end; end | GCompTag (ci, l) as g -> begin CurrentLoc.set l; incr currentDeclIdx; if ci.creferenced then () else begin match PlainMerging.findReplacement true sEq !currentFidx ci.cname with None -> (* A new one, we must rename it and keep the definition *) (* Make sure this is root *) (try let nd = PlainMerging.find_eq_table sEq (!currentFidx, ci.cname) in if nd.nrep != nd then Kernel.fatal "Setting creferenced for struct %s which is \ not root!" ci.cname; with Not_found -> begin Kernel.fatal "Setting creferenced for struct %s which \ is not in the sEq!" ci.cname; end); let newname, _ = A.newAlphaName sAlpha None ci.cname (CurrentLoc.get ()) in ci.cname <- newname; ci.creferenced <- true; (* Now we should visit the fields as well *) H.add emittedCompDecls ci.cname true; (* Remember that we * emitted it *) mergePushGlobals (visitCilGlobal renameVisitor g) | Some (_oldci, _oldfidx) -> begin (* We are not the representative. Drop this declaration * because we'll not be using it. *) () end end end | GEnumTag (ei, l) as g -> begin CurrentLoc.set l; incr currentDeclIdx; if ei.ereferenced then () else begin match EnumMerging.findReplacement true eEq !currentFidx ei with None -> (* We must rename it *) let newname, _ = A.newAlphaName eAlpha None ei.ename (CurrentLoc.get ()) in ei.ename <- newname; ei.ereferenced <- true; (* And we must rename the items to using the same name space * as the variables *) List.iter (fun item -> let newname,_= A.newAlphaName vtAlpha None item.einame item.eiloc in item.einame <- newname) ei.eitems; mergePushGlobals (visitCilGlobal renameVisitor g); | Some (_ei', _) -> (* Drop this since we are reusing it from * before *) () end end | GCompTagDecl (ci, l) -> begin CurrentLoc.set l; (* This is here just to introduce an undefined * structure. But maybe the structure was defined * already. *) (* Do not increment currentDeclIdx because it is not incremented in * pass 1*) if H.mem emittedCompDecls ci.cname then () (* It was already declared *) else begin H.add emittedCompDecls ci.cname true; (* Keep it as a declaration *) mergePushGlobal g; end end | GEnumTagDecl (_ei, l) -> CurrentLoc.set l; (* Do not increment currentDeclIdx because it is not incremented in * pass 1*) (* Keep it as a declaration *) mergePushGlobal g | GType (ti, l) as g -> begin CurrentLoc.set l; incr currentDeclIdx; if ti.treferenced then () else begin match PlainMerging.findReplacement true tEq !currentFidx ti.tname with None -> (* We must rename it and keep it *) let newname, _ = A.newAlphaName vtAlpha None ti.tname (CurrentLoc.get ()) in ti.tname <- newname; ti.treferenced <- true; mergePushGlobals (visitCilGlobal renameVisitor g); | Some (_ti', _) ->(* Drop this since we are reusing it from * before *) () end end | GAnnot (a, l) as g -> CurrentLoc.set l; incr currentDeclIdx; global_annot_pass2 g a | g -> mergePushGlobals (visitCilGlobal renameVisitor g) in (* Now do the real PASS 2 *) List.iter processOneGlobal f.globals; (* Replace tentative definition by a declaration when we found a real definition somewhere else *) if !replaceTentativeDefn then begin (* Stay tail-recursive, the list of globals can be huge. *) theFile := List.rev (List.rev_map (function GVar(vi,{init=None},loc) as g -> (try let (_,real_init,_) = H.find emittedVarDefn vi.vname in (match real_init with None -> g | Some _ -> GVarDecl(empty_funspec(),vi,loc)) with Not_found -> g) | g -> g) !theFile) end; (* See if we must re-visit the globals in this file because an inline that * is being removed was used before we saw the definition and we decided to * remove it *) if mergeInlinesRepeat && !repeatPass2 then begin Kernel.feedback "Repeat final merging phase: %s" f.fileName; (* We are going to rescan the globals we have added while processing this * file. *) let theseGlobals : global list ref = ref [] in (* Scan a list of globals until we hit a given tail *) let rec scanUntil (tail: 'a list) (l: 'a list) = if tail == l then () else match l with | [] -> Kernel.fatal "mergecil: scanUntil could not find the marker" | g :: rest -> theseGlobals := g :: !theseGlobals; scanUntil tail rest in (* Collect in theseGlobals all the globals from this file *) theseGlobals := []; scanUntil savedTheFile !theFile; (* Now reprocess them *) theFile := savedTheFile; List.iter (fun g -> theFile := (visitCilGlobal renameInlinesVisitor g) @ !theFile) !theseGlobals; (* Now check if we have inlines that we could not remove H.iter (fun name _ -> if not (H.mem inlinesRemoved name) then ignore (warn "Could not remove inline %s. I have no idea why!\n" name)) inlinesToRemove *) end let merge_specs orig to_merge = let initial = { orig with spec_behavior = orig.spec_behavior } in let merge_one_spec spec = if is_same_spec initial spec then () else Logic_utils.merge_funspec orig spec in List.iter merge_one_spec to_merge let global_merge_spec g = Kernel.debug "Merging global %a" Cil_printer.pp_global g; match g with | GFun(fdec,loc) -> (try Kernel.debug "Merging global definition %a" Cil_printer.pp_global g; let specs = Cil_datatype.Varinfo.Hashtbl.find spec_to_merge fdec.svar in List.iter (fun s -> Kernel.debug "Found spec to merge %a" Cil_printer.pp_funspec s) specs; Kernel.debug "Merging with %a" Cil_printer.pp_funspec fdec.sspec ; Cil.CurrentLoc.set loc; merge_specs fdec.sspec specs with Not_found -> Kernel.debug "No spec_to_merge") | GVarDecl(spec,v,loc) -> Kernel.debug "Merging global declaration %a" Cil_printer.pp_global g; let rename spec = try let alpha = Cil_datatype.Varinfo.Hashtbl.find formals_renaming v in ignore (visitCilFunspec alpha spec) with Not_found -> () in (try let specs = Cil_datatype.Varinfo.Hashtbl.find spec_to_merge v in List.iter (fun s -> Kernel.debug "Found spec to merge %a" Cil_printer.pp_funspec s) specs; Kernel.debug "Renaming %a" Cil_printer.pp_funspec spec ; rename spec; (* The registered specs might also need renaming up to definition's formals instead of declaration's ones. *) List.iter rename specs; Kernel.debug "Renamed to %a" Cil_printer.pp_funspec spec; Cil.CurrentLoc.set loc; merge_specs spec specs; Kernel.debug "Merged into %a" Cil_printer.pp_funspec spec ; with Not_found -> Kernel.debug "No spec_to_merge for declaration" ; rename spec; Kernel.debug "Renamed to %a" Cil_printer.pp_funspec spec ; ) | _ -> () let find_decls g = let c_res = ref Cil_datatype.Varinfo.Set.empty in let res = ref Cil_datatype.Logic_var.Set.empty in let visit = object(self) inherit Cil.nopCilVisitor method vvdec v = c_res:=Cil_datatype.Varinfo.Set.add v !c_res; DoChildren method vlogic_var_decl lv = res := Cil_datatype.Logic_var.Set.add lv !res; SkipChildren method vspec _ = SkipChildren method vfunc f = ignore (self#vvdec f.svar); Extlib.may (ignore $ self#vlogic_var_decl) f.svar.vlogic_var_assoc; SkipChildren end in ignore (visitCilGlobal visit g); !c_res, !res let used_vars g = let res = ref Cil_datatype.Logic_var.Set.empty in let locals = ref Cil_datatype.Logic_var.Set.empty in let visit = object inherit Cil.nopCilVisitor method vlogic_var_decl lv = locals := Cil_datatype.Logic_var.Set.add lv !locals; SkipChildren method vlogic_var_use lv = if not (Cil_datatype.Logic_var.Set.mem lv !locals) && not (Logic_env.is_builtin_logic_function lv.lv_name) && not (lv.lv_name = "\\exit_status") then begin res:=Cil_datatype.Logic_var.Set.add lv !res end; SkipChildren end in ignore (visitCilGlobal visit g); !res let print_missing fmt to_declare = let print_one_binding fmt s = Cil_datatype.Logic_var.Set.iter (fun x -> Format.fprintf fmt "%a;@ " Cil_printer.pp_logic_var x) s in let print_entry fmt v (_,s) = Format.fprintf fmt "@[%a:@[%a@]@]@\n" Cil_printer.pp_varinfo v print_one_binding s in Cil_datatype.Varinfo.Map.iter (print_entry fmt) to_declare let move_spec globals = let all_declared known v (g,missing) (can_declare,to_declare) = let missing = Cil_datatype.Logic_var.Set.diff missing known in if Cil_datatype.Logic_var.Set.is_empty missing then (g::can_declare,to_declare) else (can_declare, Cil_datatype.Varinfo.Map.add v (g,missing) to_declare) in let aux (res,c_known,known,to_declare) g = let my_c_decls, my_decls = find_decls g in let known = Cil_datatype.Logic_var.Set.union my_decls known in let can_declare, to_declare = Cil_datatype.Varinfo.Map.fold (all_declared known) to_declare ([],Cil_datatype.Varinfo.Map.empty) in let res, to_declare = match g with GVarDecl (_,v,l) -> let needs = used_vars g in let missing = Cil_datatype.Logic_var.Set.diff needs known in if Cil_datatype.Logic_var.Set.is_empty missing then g::res, to_declare else (GVarDecl(Cil.empty_funspec (),v,l)::res, Cil_datatype.Varinfo.Map.add v (g,missing) to_declare) | GFun (f,l) -> let needs = used_vars g in let missing = Cil_datatype.Logic_var.Set.diff needs known in if Cil_datatype.Logic_var.Set.is_empty missing then g::res,to_declare else let res = if Cil_datatype.Varinfo.Set.mem f.svar c_known then res else GVarDecl(Cil.empty_funspec (),f.svar,l)::res in res, Cil_datatype.Varinfo.Map.add f.svar (g,missing) to_declare | _ -> (g::res,to_declare) in let c_known = Cil_datatype.Varinfo.Set.union my_c_decls c_known in (can_declare @ res, c_known, known, to_declare) in let (res,_,_,to_declare) = List.fold_left aux ([], Cil_datatype.Varinfo.Set.empty, Cil_datatype.Logic_var.Set.empty, Cil_datatype.Varinfo.Map.empty) globals in assert (Kernel.verify (Cil_datatype.Varinfo.Map.is_empty to_declare) "Some globals contain dangling references after link:@\n%a" print_missing to_declare); List.rev res let merge (files: file list) (newname: string) : file = init (); Cilmsg.push_errors (); (* Make the first pass over the files *) currentFidx := 0; List.iter (fun f -> oneFilePass1 f; incr currentFidx) files; (* Now maybe try to force synonyms to be equal *) if mergeSynonyms then begin doMergeSynonyms sSyn matchCompInfo; EnumMerging.doMergeSynonyms eSyn matchEnumInfo; doMergeSynonyms tSyn matchTypeInfo; doMergeSynonyms lfSyn matchLogicInfo; doMergeSynonyms ltSyn matchLogicType; doMergeSynonyms lcSyn matchLogicCtor; doMergeSynonyms laSyn matchLogicAxiomatic; doMergeSynonyms llSyn matchLogicLemma; VolatileMerging.doMergeSynonyms lvSyn matchVolatileClause; ModelMerging.doMergeSynonyms mfSyn matchModelField; if mergeInlines then begin (* Copy all the nodes from the iEq to vEq as well. This is needed * because vEq will be used for variable renaming *) PlainMerging.iter_eq_table (fun k n -> PlainMerging.add_eq_table vEq k n) iEq; doMergeSynonyms iSyn matchInlines; end end; (* Now maybe dump the graph *) if debugMerge then begin dumpGraph "type" tEq; dumpGraph "struct and union" sEq; EnumMerging.dumpGraph "enum" eEq; dumpGraph "variable" vEq; if mergeInlines then dumpGraph "inline" iEq; end; (* Make the second pass over the files. This is when we start rewriting the * file *) currentFidx := 0; List.iter (fun f -> oneFilePass2 f; incr currentFidx) files; (* Now reverse the result and return the resulting file *) let rec revonto acc = function [] -> acc | x :: t -> revonto (x :: acc) t in let res = { fileName = newname; globals = revonto (revonto [] !theFile) !theFileTypes; globinit = None; globinitcalled = false } in List.iter global_merge_spec res.globals; let globals = move_spec res.globals in res.globals <- globals; init ~all:false (); (* Make the GC happy BUT KEEP some tables *) (* We have made many renaming changes and sometimes we have just guessed a * name wrong. Make sure now that the local names are unique. *) uniqueVarNames res; let res = if Cilmsg.had_errors () then begin Kernel.error "Error during linking@." ; { fileName = newname; globals = []; globinit = None; globinitcalled = false } end else res in Cilmsg.pop_errors (); res (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/cil/src/machdep_x86_16.mli0000644000175000017500000000645212155630367020471 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) val gcc : Cil_types.mach val msvc : Cil_types.mach frama-c-Fluorine-20130601/cil/src/cil_types.mli0000644000175000017500000021701512155630367020047 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** The Abstract Syntax of CIL. @plugin development guide *) (**************************** WARNING ***************************************) (* Remember to reflect any change here into the visitor and pretty-printer *) (* in cil.ml. In particular, if a type becomes mutable, it is necessary to *) (* adapt the Cil.behavior type and the copy_behavior accordingly. *) (* A first test to see if something has been broken by a change is to launch*) (* ptests.byte -add-options '-files-debug "-check -copy"' *) (* In addition, it is a good idea to add some invariant checks in the *) (* check_file class in frama-c/src/file.ml (before lauching the tests) *) (****************************************************************************) (* ************************************************************************* *) (** {2 Root of the AST} *) (* ************************************************************************* *) (** In Frama-C, the whole AST is accessible through {!Ast.get}. *) (** The top-level representation of a CIL source file (and the result of the parsing and elaboration). Its main contents is the list of global declarations and definitions. You can iterate over the globals in a {!Cil_types.file} using the following iterators: {!Cil.mapGlobals}, {!Cil.iterGlobals} and {!Cil.foldGlobals}. You can also use the {!Cil.dummyFile} when you need a {!Cil_types.file} as a placeholder. For each global item CIL stores the source location where it appears (using the type {!Cil_types.location}) @plugin development guide *) type file = { mutable fileName: string; (** The complete file name *) mutable globals: global list; (** List of globals as they will appear in the printed file *) mutable globinit: fundec option; (** An optional global initializer function. This is a function where you can put stuff that must be executed before the program is started. This function, is conceptually at the end of the file, although it is not part of the globals list. Use {!Cil.getGlobInit} to create/get one. *) mutable globinitcalled: bool; (** Whether the global initialization function is called in main. This should always be false if there is no global initializer. When you create a global initialization CIL will try to insert code in main to call it. *) } (** The main type for representing global declarations and definitions. A list of these form a CIL file. The order of globals in the file is generally important. @plugin development guide *) and global = | GType of typeinfo * location (** A typedef. All uses of type names (through the [TNamed] constructor) must be preceeded in the file by a definition of the name. The string is the defined name and always not-empty. *) | GCompTag of compinfo * location (** Defines a struct/union tag with some fields. There must be one of these for each struct/union tag that you use (through the [TComp] constructor) since this is the only context in which the fields are printed. Consequently nested structure tag definitions must be broken into individual definitions with the innermost structure defined first. *) | GCompTagDecl of compinfo * location (** Declares a struct/union tag. Use as a forward declaration. This is printed without the fields. *) | GEnumTag of enuminfo * location (** Declares an enumeration tag with some fields. There must be one of these for each enumeration tag that you use (through the [TEnum] constructor) since this is the only context in which the items are printed. *) | GEnumTagDecl of enuminfo * location (** Declares an enumeration tag. Use as a forward declaration. This is printed without the items. *) | GVarDecl of funspec * varinfo * location (** A variable declaration (not a definition). If the variable has a function type then this is a prototype. There can be several declarations and at most one definition for a given variable. If both forms appear then they must share the same varinfo structure. A prototype shares the varinfo with the fundec of the definition. Either has storage Extern or there must be a definition in this file *) | GVar of varinfo * initinfo * location (** A variable definition. Can have an initializer. The initializer is updateable so that you can change it without requiring to recreate the list of globals. There can be at most one definition for a variable in an entire program. Cannot have storage Extern or function type. *) | GFun of fundec * location (** A function definition. *) | GAsm of string * location (** Global asm statement. These ones can contain only a template *) | GPragma of attribute * location (** Pragmas at top level. Use the same syntax as attributes *) | GText of string (** Some text (printed verbatim) at top level. E.g., this way you can put comments in the output. *) | GAnnot of global_annotation * location (** a global annotation. Can be - an axiom or a lemma - a predicate declaration or definition - a global type invariant - a global invariant - a logic function declaration or definition. *) (* ************************************************************************* *) (** {2 Types} *) (* ************************************************************************* *) (** A C type is represented in CIL using the type {!Cil_types.typ}. Among types we differentiate the integral types (with different kinds denoting the sign and precision), floating point types, enumeration types, array and pointer types, and function types. Every type is associated with a list of attributes, which are always kept in sorted order. Use {!Cil.addAttribute} and {!Cil.addAttributes} to construct list of attributes. If you want to inspect a type, you should use {!Cil.unrollType} or {!Cil.unrollTypeDeep} to see through the uses of named types. CIL is configured at build-time with the sizes and alignments of the underlying compiler (GCC or MSVC). CIL contains functions that can compute the size of a type (in bits) {!Cil.bitsSizeOf}, the alignment of a type (in bytes) {!Cil.alignOf_int}, and can convert an offset into a start and width (both in bits) using the function {!Cil.bitsOffset}. At the moment these functions do not take into account the [packed] attributes and pragmas. *) and typ = | TVoid of attributes (** Void type. Also predefined as {!Cil.voidType} *) | TInt of ikind * attributes (** An integer type. The kind specifies the sign and width. Several useful variants are predefined as {!Cil.intType}, {!Cil.uintType}, {!Cil.longType}, {!Cil.charType}. *) | TFloat of fkind * attributes (** A floating-point type. The kind specifies the precision. You can also use the predefined constant {!Cil.doubleType}. *) | TPtr of typ * attributes (** Pointer type. Several useful variants are predefined as {!Cil.charPtrType}, {!Cil.charConstPtrType} (pointer to a constant character), {!Cil.voidPtrType}, {!Cil.intPtrType} *) | TArray of typ * exp option * bitsSizeofTypCache * attributes (** Array type. It indicates the base type and the array length. *) | TFun of typ * (string * typ * attributes) list option * bool * attributes (** Function type. Indicates the type of the result, the name, type and name attributes of the formal arguments ([None] if no arguments were specified, as in a function whose definition or prototype we have not seen; [Some \[\]] means void). Use {!Cil.argsToList} to obtain a list of arguments. The boolean indicates if it is a variable-argument function. If this is the type of a varinfo for which we have a function declaration then the information for the formals must match that in the function's sformals. Use {!Cil.setFormals}, or {!Cil.setFunctionType}, or {!Cil.makeFormalVar} for this purpose. *) | TNamed of typeinfo * attributes (** The use of a named type. All uses of the same type name must share the typeinfo. Each such type name must be preceeded in the file by a [GType] global. This is printed as just the type name. The actual referred type is not printed here and is carried only to simplify processing. To see through a sequence of named type references, use {!Cil.unrollType}. The attributes are in addition to those given when the type name was defined. *) | TComp of compinfo * bitsSizeofTypCache * attributes (** A reference to a struct or a union type. All references to the same struct or union must share the same compinfo among them and with a [GCompTag] global that preceeds all uses (except maybe those that are pointers to the composite type). The attributes given are those pertaining to this use of the type and are in addition to the attributes that were given at the definition of the type and which are stored in the compinfo. *) | TEnum of enuminfo * attributes (** A reference to an enumeration type. All such references must share the enuminfo among them and with a [GEnumTag] global that preceeds all uses. The attributes refer to this use of the enumeration and are in addition to the attributes of the enumeration itself, which are stored inside the enuminfo *) | TBuiltin_va_list of attributes (** This is the same as the gcc's type with the same name *) (** Various kinds of integers *) and ikind = IBool (** [_Bool] *) | IChar (** [char] *) | ISChar (** [signed char] *) | IUChar (** [unsigned char] *) | IInt (** [int] *) | IUInt (** [unsigned int] *) | IShort (** [short] *) | IUShort (** [unsigned short] *) | ILong (** [long] *) | IULong (** [unsigned long] *) | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *) | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft Visual C) *) (** Various kinds of floating-point numbers*) and fkind = FFloat (** [float] *) | FDouble (** [double] *) | FLongDouble (** [long double] *) (** This is used to cache the computation of the size of types in bits. *) and bitsSizeofTyp = | Not_Computed | Computed of int | Not_Computable of (string * typ) (** Explanation of the error *) and bitsSizeofTypCache = { mutable scache : bitsSizeofTyp} (* ************************************************************************* *) (** {2 Attributes} *) (* ************************************************************************* *) and attribute = | Attr of string * attrparam list (** An attribute has a name and some optional parameters. The name should not start or end with underscore. When CIL parses attribute names it will strip leading and ending underscores (to ensure that the multitude of GCC attributes such as const, __const and __const__ all mean the same thing.) *) | AttrAnnot of string (** Attributes are lists sorted by the attribute name. Use the functions {!Cil.addAttribute} and {!Cil.addAttributes} to insert attributes in an attribute list and maintain the sortedness. *) and attributes = attribute list (** The type of parameters of attributes *) and attrparam = | AInt of Integer.t (** An integer constant *) | AStr of string (** A string constant *) | ACons of string * attrparam list (** Constructed attributes. These are printed [foo(a1,a2,...,an)]. The list of parameters can be empty and in that case the parentheses are not printed. *) | ASizeOf of typ (** A way to talk about types *) | ASizeOfE of attrparam | AAlignOf of typ | AAlignOfE of attrparam | AUnOp of unop * attrparam | ABinOp of binop * attrparam * attrparam | ADot of attrparam * string (** a.foo **) | AStar of attrparam (** * a *) | AAddrOf of attrparam (** & a **) | AIndex of attrparam * attrparam (** a1[a2] *) | AQuestion of attrparam * attrparam * attrparam (** a1 ? a2 : a3 **) (* ************************************************************************* *) (** {2 Structures} *) (* ************************************************************************* *) (** The {!Cil_types.compinfo} describes the definition of a structure or union type. Each such {!Cil_types.compinfo} must be defined at the top-level using the [GCompTag] constructor and must be shared by all references to this type (using either the [TComp] type constructor or from the definition of the fields. If all you need is to scan the definition of each composite type once, you can do that by scanning all top-level [GCompTag]. Constructing a {!Cil_types.compinfo} can be tricky since it must contain fields that might refer to the host {!Cil_types.compinfo} and furthermore the type of the field might need to refer to the {!Cil_types.compinfo} for recursive types. Use the {!Cil.mkCompInfo} function to create a {!Cil_types.compinfo}. You can easily fetch the {!Cil_types.fieldinfo} for a given field in a structure with {!Cil.getCompField}. *) (** The definition of a structure or union type. Use {!Cil.mkCompInfo} to make one and use {!Cil.copyCompInfo} to copy one (this ensures that a new key is assigned and that the fields have the right pointers to parents.). @plugin development guide *) and compinfo = { mutable cstruct: bool; (** [true] if struct, [false] if union *) corig_name: string; (** Original name as found in C file. Will never be changed *) mutable cname: string; (** The name. Always non-empty. Use {!Cil.compFullName} to get the full name of a comp (along with the struct or union) *) mutable ckey: int; (** A unique integer. This is assigned by {!Cil.mkCompInfo} using a global variable in the Cil module. Thus two identical structs in two different files might have different keys. Use {!Cil.copyCompInfo} to copy structures so that a new key is assigned. *) mutable cfields: fieldinfo list; (** Information about the fields. Notice that each fieldinfo has a pointer back to the host compinfo. This means that you should not share fieldinfo's between two compinfo's *) mutable cattr: attributes; (** The attributes that are defined at the same time as the composite type. These attributes can be supplemented individually at each reference to this [compinfo] using the [TComp] type constructor. *) mutable cdefined: bool; (** This boolean flag can be used to distinguish between structures that have not been defined and those that have been defined but have no fields (such things are allowed in gcc). *) mutable creferenced: bool; (** [true] if used. Initially set to [false]. *) } (* ************************************************************************* *) (** {2 Structure fields} *) (* ************************************************************************* *) (** The {!Cil_types.fieldinfo} structure is used to describe a structure or union field. Fields, just like variables, can have attributes associated with the field itself or associated with the type of the field (stored along with the type of the field). *) (** Information about a struct/union field. @plugin development guide *) and fieldinfo = { mutable fcomp: compinfo; (** The host structure that contains this field. There can be only one [compinfo] that contains the field. *) forig_name: string; (** original name as found in C file. *) mutable fname: string; (** The name of the field. Might be the value of {!Cil.missingFieldName} in which case it must be a bitfield and is not printed and it does not participate in initialization *) mutable ftype: typ; (** The type. If the field is a bitfield, a special attribute [FRAMA_C_BITFIELD_SIZE] indicating the width of the bitfield is added. *) mutable fbitfield: int option; (** If a bitfield then ftype should be an integer type and the width of the bitfield must be 0 or a positive integer smaller or equal to the width of the integer type. A field of width 0 is used in C to control the alignment of fields. *) mutable fattr: attributes; (** The attributes for this field (not for its type) *) mutable floc: location; (** The location where this field is defined *) mutable faddrof: bool; (** Adapted from CIL [vaddrof] field for variables. Only set for non-array fields. Variable whose field address is taken is not marked anymore as having its own address taken. True if the address of this field is taken. CIL will set these flags when it parses C, but you should make sure to set the flag whenever your transformation create [AddrOf] expression. *) mutable fsize_in_bits: int option; (** Similar to [fbitfield] for all types of fields. Useful when the type of the field is changed in the analyzer, to recall the size of the original field. @deprecated only Jessie uses this *) mutable foffset_in_bits: int option; (** Store the offset at which the field starts in the structure. @deprecated only Jessie uses this *) mutable fpadding_in_bits: int option; (** Store the size of the padding that follows the field, if any. @deprecated only Jessie uses this *) } (* ************************************************************************* *) (** {2 Enumerations} *) (* ************************************************************************* *) (** Information about an enumeration. This is shared by all references to an enumeration. Make sure you have a [GEnumTag] for each of these. *) (** Information about an enumeration. @plugin development guide *) and enuminfo = { eorig_name: string; (** original name as found in C file. *) mutable ename: string; (** The name. Always non-empty. *) mutable eitems: enumitem list; (** Items. The list must be non-empty *) mutable eattr: attributes; (** The attributes that are defined at the same time as the enumeration type. These attributes can be supplemented individually at each reference to this [enuminfo] using the [TEnum] type constructor. *) mutable ereferenced: bool; (** [true] if used. Initially set to [false]. *) mutable ekind: ikind (** The integer kind used to represent this enum. MSVC always assumes IInt but this is not the case for gcc. See ISO C 6.7.2.2 *) } and enumitem = { eiorig_name: string; (** original name as found in C file. *) mutable einame: string; (** the name, always non-empty. *) mutable eival: exp; (** value of the item. Must be a compile-time constant *) mutable eihost: enuminfo; (** the host enumeration in which the item is declared. *) eiloc: location; } (** Information about a defined type. @plugin development guide *) and typeinfo = { torig_name: string; (** original name as found in C file. *) mutable tname: string; (** The name. Can be empty only in a [GType] when introducing a composite or enumeration tag. If empty cannot be refered to from the file *) mutable ttype: typ; (** The actual type. This includes the attributes that were present in the typedef *) mutable treferenced: bool; (** [true] if used. Initially set to [false]. *) } (* ************************************************************************* *) (** {2 Variables} *) (* ************************************************************************* *) (** Each local or global variable is represented by a unique {!Cil_types.varinfo} structure. A global {!Cil_types.varinfo} can be introduced with the [GVarDecl] or [GVar] or [GFun] globals. A local varinfo can be introduced as part of a function definition {!Cil_types.fundec}. All references to a given global or local variable must refer to the same copy of the [varinfo]. Each [varinfo] has a globally unique identifier that can be used to index maps and hashtables (the name can also be used for this purpose, except for locals from different functions). This identifier is constructor using a global counter. It is very important that you construct [varinfo] structures using only one of the following functions: - {!Cil.makeGlobalVar} : to make a global variable - {!Cil.makeTempVar} : to make a temporary local variable whose name will be generated so that to avoid conflict with other locals. - {!Cil.makeLocalVar} : like {!Cil.makeTempVar} but you can specify the exact name to be used. - {!Cil.copyVarinfo}: make a shallow copy of a varinfo assigning a new name and a new unique identifier A [varinfo] is also used in a function type to denote the list of formals. *) (** Information about a variable. @plugin development guide *) and varinfo = { mutable vname: string; (** The name of the variable. Cannot be empty. It is primarily your responsibility to ensure the uniqueness of a variable name. For local variables {!Cil.makeTempVar} helps you ensure that the name is unique. *) vorig_name: string; (** the original name of the variable. Need not be unique. *) mutable vtype: typ; (** The declared type of the variable. *) mutable vattr: attributes; (** A list of attributes associated with the variable.*) mutable vstorage: storage; (** The storage-class *) mutable vglob: bool; (** True if this is a global variable*) mutable vdefined: bool; (** True if the variable or function is defined in the file. Only relevant for functions and global variables. Not used in particular for local variables and logic variables. *) mutable vformal: bool; (** True if the variable is a formal parameter of a function. *) mutable vinline: bool; (** Whether this varinfo is for an inline function. *) mutable vdecl: location; (** Location of variable declaration. *) mutable vid: int; (** A unique integer identifier. This field will be set for you if you use one of the {!Cil.makeFormalVar}, {!Cil.makeLocalVar}, {!Cil.makeTempVar}, {!Cil.makeGlobalVar}, or {!Cil.copyVarinfo}. *) mutable vaddrof: bool; (** [true] if the address of this variable is taken. CIL will set these flags when it parses C, but you should make sure to set the flag whenever your transformation create [AddrOf] expression. *) mutable vreferenced: bool; (** [true] if this variable is ever referenced. This is computed by [removeUnusedVars]. It is safe to just initialize this to [false]. *) vgenerated: bool; (** [true] for temporary variables generated by CIL normalization. [false] for variables coming directly from user input. *) mutable vdescr: string option; (** For most temporary variables, a description of what the var holds. (e.g. for temporaries used for function call results, this string is a representation of the function call.) *) mutable vdescrpure: bool; (** Indicates whether the vdescr above is a pure expression or call. True for all CIL expressions and Lvals, but false for e.g. function calls. Printing a non-pure vdescr more than once may yield incorrect results. *) mutable vghost: bool; (** Indicates if the variable is declared in ghost code *) vlogic: bool; (** [false] iff this variable is a C variable. *) mutable vlogic_var_assoc: logic_var option (** logic variable representing this variable in the logic world*) } (** Storage-class information *) and storage = NoStorage (** The default storage. Nothing is printed *) | Static | Register | Extern (* ************************************************************************* *) (** {2 Expressions} *) (* ************************************************************************* *) (** The CIL expression language contains only the side-effect free expressions of C. They are represented as the type {!Cil_types.exp}. There are several interesting aspects of CIL expressions: Integer and floating point constants can carry their textual representation. This way the integer 15 can be printed as 0xF if that is how it occurred in the source. CIL uses arbitrary precision integers to represent the integer constants and also stores the width of the integer type. Care must be taken to ensure that the constant is representable with the given width. Use the functions {!Cil.kinteger}, {!Cil.kinteger64} and {!Cil.integer} to construct constant expressions. CIL predefines the constants {!Cil.zero}, {!Cil.one} and {!Cil.mone} (for -1). Use the functions {!Cil.isConstant} and {!Cil.isInteger} to test if an expression is a constant and a constant integer respectively. CIL keeps the type of all unary and binary expressions. You can think of that type qualifying the operator. Furthermore there are different operators for arithmetic and comparisons on arithmetic types and on pointers. Another unusual aspect of CIL is that the implicit conversion between an expression of array type and one of pointer type is made explicit, using the [StartOf] expression constructor (which is not printed). If you apply the [AddrOf]constructor to an lvalue of type [T] then you will be getting an expression of type [TPtr(T)]. You can find the type of an expression with {!Cil.typeOf}. You can perform constant folding on expressions using the function {!Cil.constFold}. *) (** Expressions (Side-effect free)*) and exp = { eid: int; (** unique identifier *) enode: exp_node; (** the expression itself *) eloc: location; (** location of the expression. *) } and exp_node = | Const of constant (** Constant *) | Lval of lval (** Lvalue *) | SizeOf of typ (** sizeof(). Has [unsigned int] type (ISO 6.5.3.4). This is not turned into a constant because some transformations might want to change types *) | SizeOfE of exp (** sizeof() *) | SizeOfStr of string (** sizeof(string_literal). We separate this case out because this is the only instance in which a string literal should not be treated as having type pointer to character. *) | AlignOf of typ (** This corresponds to the GCC __alignof_. Has [unsigned int] type *) | AlignOfE of exp | UnOp of unop * exp * typ (** Unary operation. Includes the type of the result. *) | BinOp of binop * exp * exp * typ (** Binary operation. Includes the type of the result. The arithmetic conversions are made explicit for the arguments. @plugin development guide *) | CastE of typ * exp (** Use {!Cil.mkCast} to make casts. *) | AddrOf of lval (** Always use {!Cil.mkAddrOf} to construct one of these. Apply to an lvalue of type [T] yields an expression of type [TPtr(T)] *) | StartOf of lval (** Conversion from an array to a pointer to the beginning of the array. Given an lval of type [TArray(T)] produces an expression of type [TPtr(T)]. In C this operation is implicit, the [StartOf] operator is not printed. We have it in CIL because it makes the typing rules simpler. *) | Info of exp * exp_info (** Additional information on the underlying expression *) (** Additional information on an expression *) and exp_info = { exp_type : logic_type; (** when used as placeholder for a term *) exp_name: string list; } (* ************************************************************************* *) (** {2 Constants} *) (* ************************************************************************* *) (** Literal constants *) and constant = | CInt64 of Integer.t * ikind * string option (** Integer constant. Give the ikind (see ISO9899 6.1.3.2) and the textual representation. Textual representation is always set to Some s when it comes from user code. This allows us to print a constant as it was represented in the code, for example, 0xF instead of 15. It is usually None for constant generated by Cil itself. Use {!Cil.integer} or {!Cil.kinteger} to create these. *) | CStr of string (** String constant. The escape characters inside the string have been already interpreted. This constant has pointer to character type! The only case when you would like a string literal to have an array type is when it is an argument to sizeof. In that case you should use SizeOfStr. *) | CWStr of int64 list (** Wide character string constant. Note that the local interpretation of such a literal depends on {!Cil.theMachine.wcharType} and {!Cil.theMachine.wcharKind}. Such a constant has type pointer to {!Cil.theMachine.wcharType}. The escape characters in the string have not been "interpreted" in the sense that L"A\xabcd" remains "A\xabcd" rather than being represented as the wide character list with two elements: 65 and 43981. That "interpretation" depends on the underlying wide character type. *) | CChr of char (** Character constant. This has type int, so use charConstToInt to read the value in case sign-extension is needed. *) | CReal of float * fkind * string option (** Floating point constant. Give the fkind (see ISO 6.4.4.2) and also the textual representation, if available. *) | CEnum of enumitem (** An enumeration constant. Use [Cillower.lowerEnumVisitor] to replace these with integer constants. *) (** Unary operators *) and unop = Neg (** Unary minus *) | BNot (** Bitwise complement (~) *) | LNot (** Logical Not (!) *) (** Binary operations *) and binop = PlusA (** arithmetic + *) | PlusPI (** pointer + integer *) | IndexPI (** pointer + integer but only when it arises from an expression [e\[i\]] when [e] is a pointer and not an array. This is semantically the same as PlusPI but CCured uses this as a hint that the integer is probably positive. *) | MinusA (** arithmetic - *) | MinusPI (** pointer - integer *) | MinusPP (** pointer - pointer *) | Mult (** * *) | Div (** / @plugin development guide *) | Mod (** % @plugin development guide *) | Shiftlt (** shift left *) | Shiftrt (** shift right *) | Lt (** < (arithmetic comparison) *) | Gt (** > (arithmetic comparison) *) | Le (** <= (arithmetic comparison) *) | Ge (** >= (arithmetic comparison) *) | Eq (** == (arithmetic comparison) *) | Ne (** != (arithmetic comparison) *) | BAnd (** bitwise and *) | BXor (** exclusive-or *) | BOr (** inclusive-or *) | LAnd (** logical and. Unlike other expressions this one does not always evaluate both operands. If you want to use these, you must set {!Cil.useLogicalOperators}. *) | LOr (** logical or. Unlike other expressions this one does not always evaluate both operands. If you want to use these, you must set {!Cil.useLogicalOperators}. *) (* ************************************************************************* *) (** {2 Left values} *) (* ************************************************************************* *) (** Left values (aka Lvalues) are the sublanguage of expressions that can appear at the left of an assignment or as operand to the address-of operator. In C the syntax for lvalues is not always a good indication of the meaning of the lvalue. For example the C value {v a[0][1][2] v} might involve 1, 2 or 3 memory reads when used in an expression context, depending on the declared type of the variable [a]. If [a] has type [int \[4\]\[4\]\[4\]] then we have one memory read from somewhere inside the area that stores the array [a]. On the other hand if [a] has type [int ***] then the expression really means [* ( * ( * (a + 0) + 1) + 2)], in which case it is clear that it involves three separate memory operations. An lvalue denotes the contents of a range of memory addresses. This range is denoted as a host object along with an offset within the object. The host object can be of two kinds: a local or global variable, or an object whose address is in a pointer expression. We distinguish the two cases so that we can tell quickly whether we are accessing some component of a variable directly or we are accessing a memory location through a pointer. To make it easy to tell what an lvalue means CIL represents lvalues as a host object and an offset (see {!Cil_types.lval}). The host object (represented as {!Cil_types.lhost}) can be a local or global variable or can be the object pointed-to by a pointer expression. The offset (represented as {!Cil_types.offset}) is a sequence of field or array index designators. Both the typing rules and the meaning of an lvalue is very precisely specified in CIL. The following are a few useful function for operating on lvalues: - {!Cil.mkMem} - makes an lvalue of [Mem] kind. Use this to ensure that certain equivalent forms of lvalues are canonized. For example, [*&x = x]. - {!Cil.typeOfLval} - the type of an lvalue - {!Cil.typeOffset} - the type of an offset, given the type of the host. - {!Cil.addOffset} and {!Cil.addOffsetLval} - extend sequences of offsets. - {!Cil.removeOffset} and {!Cil.removeOffsetLval} - shrink sequences of offsets. The following equivalences hold {v Mem(AddrOf(Mem a, aoff)), off = Mem a, aoff + off Mem(AddrOf(Var v, aoff)), off = Var v, aoff + off AddrOf (Mem a, NoOffset) = a v} *) and lval = lhost * offset (** The host part of an {!Cil_types.lval}. *) and lhost = | Var of varinfo (** The host is a variable. *) | Mem of exp (** The host is an object of type [T] when the expression has pointer [TPtr(T)]. *) (** The offset part of an {!Cil_types.lval}. Each offset can be applied to certain kinds of lvalues and its effect is that it advances the starting address of the lvalue and changes the denoted type, essentially focussing to some smaller lvalue that is contained in the original one. @plugin development guide *) and offset = | NoOffset (** No offset. Can be applied to any lvalue and does not change either the starting address or the type. This is used when the lval consists of just a host or as a terminator in a list of other kinds of offsets. *) | Field of fieldinfo * offset (** A field offset. Can be applied only to an lvalue that denotes a structure or a union that contains the mentioned field. This advances the offset to the beginning of the mentioned field and changes the type to the type of the mentioned field. *) | Index of exp * offset (** An array index offset. Can be applied only to an lvalue that denotes an array. This advances the starting address of the lval to the beginning of the mentioned array element and changes the denoted type to be the type of the array element *) (* ************************************************************************* *) (** {2 Initializers} *) (* ************************************************************************* *) (** A special kind of expressions are those that can appear as initializers for global variables (initialization of local variables is turned into assignments). The initializers are represented as type {!Cil_types.init}. You can create initializers with {!Cil.makeZeroInit} and you can conveniently scan compound initializers them with {!Cil.foldLeftCompound}. *) (** Initializers for global variables. *) and init = | SingleInit of exp (** A single initializer *) | CompoundInit of typ * (offset * init) list (** Used only for initializers of structures, unions and arrays. The offsets are all of the form [Field(f, NoOffset)] or [Index(i, NoOffset)] and specify the field or the index being initialized. For structures all fields must have an initializer (except the unnamed bitfields), in the proper order. This is necessary since the offsets are not printed. For arrays the list must contain a prefix of the initializers; the rest are 0-initialized. For unions there must be exactly one initializer. If the initializer is not for the first field then a field designator is printed, so you better be on GCC since MSVC does not understand this. You can scan an initializer list with {!Cil.foldLeftCompound}. *) (** We want to be able to update an initializer in a global variable, so we define it as a mutable field *) and initinfo = { mutable init : init option } (* ************************************************************************* *) (** {2 Function definitions} *) (* ************************************************************************* *) (** A function definition is always introduced with a [GFun] constructor at the top level. All the information about the function is stored into a {!Cil_types.fundec}. Some of the information (e.g. its name, type, storage, attributes) is stored as a {!Cil_types.varinfo} that is a field of the [fundec]. To refer to the function from the expression language you must use the [varinfo]. The function definition contains, in addition to the body, a list of all the local variables and separately a list of the formals. Both kind of variables can be referred to in the body of the function. The formals must also be shared with the formals that appear in the function type. For that reason, to manipulate formals you should use the provided functions {!Cil.makeFormalVar} and {!Cil.setFormals}. *) (** Function definitions. *) and fundec = { mutable svar: varinfo; (** Holds the name and type as a variable, so we can refer to it easily from the program. All references to this function either in a function call or in a prototype must point to the same [varinfo]. *) mutable sformals: varinfo list; (** Formals. These must be in the same order and with the same information as the formal information in the type of the function. Use {!Cil.setFormals} or {!Cil.setFunctionType} to set these formals and ensure that they are reflected in the function type. Do not make copies of these because the body refers to them. *) mutable slocals: varinfo list; (** Locals. Does NOT include the sformals. Do not make copies of these because the body refers to them. *) mutable smaxid: int; (** Max local id. Starts at 0. Used for creating the names of new temporary variables. Updated by {!Cil.makeLocalVar} and {!Cil.makeTempVar}. You can also use {!Cil.setMaxId} to set it after you have added the formals and locals. *) mutable sbody: block; (** The function body. *) mutable smaxstmtid: int option; (** max id of a (reachable) statement in this function, if we have computed it. range = 0 ... (smaxstmtid-1). This is computed by {!Cfg.computeCFGInfo}. *) mutable sallstmts: stmt list; (** After you call {!Cfg.computeCFGInfo} this field is set to contain all statements in the function. *) mutable sspec: funspec; } (** A block is a sequence of statements with the control falling through from one element to the next *) and block = { mutable battrs: attributes; (** Attributes for the block *) mutable blocals: varinfo list; (** variables that are local to the block. It is a subset of the slocals of the enclosing function. *) mutable bstmts: stmt list; (** The statements comprising the block. *) } (* ************************************************************************* *) (** {2 Statements} *) (* ************************************************************************* *) (** CIL statements are the structural elements that make the CFG. They are represented using the type {!Cil_types.stmt}. Every statement has a (possibly empty) list of labels. The {!Cil_types.stmtkind} field of a statement indicates what kind of statement it is. Use {!Cil.mkStmt} to make a statement and the fill-in the fields. CIL also comes with support for control-flow graphs. The [sid] field in [stmt] can be used to give unique numbers to statements, and the [succs] and [preds] fields can be used to maintain a list of successors and predecessors for every statement. The CFG information is not computed by default. Instead you must explicitly use the functions {!Cfg.prepareCFG} and {!Cfg.computeCFGInfo} to do it. *) (** Statements. @plugin development guide *) and stmt = { mutable labels: label list; (** Whether the statement starts with some labels, case statements or default statements. *) mutable skind: stmtkind; (** The kind of statement *) mutable sid: int; (** A number (>= 0) that is unique in a function. Filled in only after the CFG is computed. *) mutable succs: stmt list; (** The successor statements. They can always be computed from the skind and the context in which this statement appears. Filled in only after the CFG is computed. *) mutable preds: stmt list; (** The inverse of the succs function. *) mutable ghost : bool } (** Labels *) and label = | Label of string * location * bool (** A real label. If the bool is "true", the label is from the input source program. If the bool is "false", the label was created by CIL or some other transformation *) | Case of exp * location (** A case statement. This expression is lowered into a constant if {!Cil.lowerConstants} is set to [true]. *) | Default of location (** A default statement *) (* The various kinds of statements *) and stmtkind = | Instr of instr (** An instruction that does not contain control flow. Control implicitly falls through. *) | Return of exp option * location (** The return statement. This is a leaf in the CFG. *) | Goto of stmt ref * location (** A goto statement. Appears from actual goto's in the code or from goto's that have been inserted during elaboration. The reference points to the statement that is the target of the Goto. This means that you have to update the reference whenever you replace the target statement. The target statement MUST have at least a label. *) | Break of location (** A break to the end of the nearest enclosing Loop or Switch *) | Continue of location (** A continue to the start of the nearest enclosing [Loop] *) | If of exp * block * block * location (** A conditional. Two successors, the "then" and the "else" branches. Both branches fall-through to the successor of the If statement. *) | Switch of exp * block * (stmt list) * location (** A switch statement. [exp] is the index of the switch. [block] is the body of the switch. [stmt list] contains the set of statements whose [labels] are cases of the switch (i.e. for each case, the corresponding statement is in [stmt list], a statement cannot appear more than once in the list, and statements in [stmt list] can have several labels corresponding to several cases. *) | Loop of code_annotation list * block * location * (stmt option) * (stmt option) (** A [while(1)] loop. The termination test is implemented in the body of a loop using a [Break] statement. If {!Cfg.prepareCFG} has been called, the first stmt option will point to the stmt containing the continue label for this loop and the second will point to the stmt containing the break label for this loop. *) | Block of block (** Just a block of statements. Use it as a way to keep some block attributes local *) | UnspecifiedSequence of (stmt * lval list * lval list * lval list * stmt ref list) list (** statements whose order of execution is not specified by ISO/C. This is important for the order of side effects during evaluation of expressions. Each statement comes together with three list of lval - lvals that are written during the sequence and whose future value depends upon the statement (it is legal to read from them) - lvals that are written during the evaluation of the statement itself - lval that are read. - Function calls in the corresponding statement Note that this include only a subset of the affectations of the statement. Namely, the temporary variables generated by cil are excluded (i.e. it is assumed that the "compilation" is correct). In addition, side effects caused by function applications are not taken into account in the list. For a single statement, the written lvals are supposed to be ordered (or their order of evaluation doesn't matter), so that an alarm should be emitted only if the lvals read by a statement overlap with the lvals written (or read) by another statement of the sequence. At this time this feature is experimental and may miss some unspecified sequences. In case you do not care about this feature just handle it like a block (see {!Cil.block_from_unspecified_sequence}) *) | TryFinally of block * block * location (** On MSVC we support structured exception handling. This is what you might expect. Control can get into the finally block either from the end of the body block, or if an exception is thrown. *) | TryExcept of block * (instr list * exp) * block * location (** On MSVC we support structured exception handling. The try/except statement is a bit tricky: {v __try \{ blk \} __except (e) \{ handler \} v} The argument to __except must be an expression. However, we keep a list of instructions AND an expression in case you need to make function calls. We'll print those as a comma expression. The control can get to the __except expression only if an exception is thrown. After that, depending on the value of the expression the control goes to the handler, propagates the exception, or retries the exception. The location corresponds to the try keyword. *) (** Instructions. They may cause effects directly but may not have control flow.*) and instr = | Set of lval * exp * location (** An assignment. A cast is present if the exp has different type from lval *) | Call of lval option * exp * exp list * location (** optional: result is an lval. A cast might be necessary if the declared result type of the function is not the same as that of the destination. Actual arguments must have a type equivalent (i.e. {!Cil.need_cast} must return [false]) to the one of the formals of the function. If the type of the result variable is not the same as the declared type of the function result then an implicit cast exists. *) (* See the GCC specification for the meaning of ASM. If the source is MS VC then only the templates are used. [sm] I've added a notes.txt file which contains more information on interpreting Asm instructions *) | Asm of attributes (* Really only const and volatile can appear here *) * string list (* templates (CR-separated) *) * (string option * string * lval) list (* outputs must be lvals with optional names and constraints. I would like these to be actually variables, but I run into some trouble with ASMs in the Linux sources *) * (string option * string * exp) list (* inputs with optional names and constraints *) * string list (* register clobbers *) * location (** An inline assembly instruction. The arguments are (1) a list of attributes (only const and volatile can appear here and only for GCC) (2) templates (CR-separated) (3) a list of outputs, each of which is an lvalue with optional names and constraints. (4) a list of input expressions along with constraints (5) clobbered registers (6) location information *) | Skip of location | Code_annot of code_annotation * location (** Describes a location in a source file *) and location = Lexing.position * Lexing.position (** {1 Abstract syntax trees for annotations} *) and logic_constant = | Integer of Integer.t * string option (** Integer constant with a textual representation. *) | LStr of string (** String constant. *) | LWStr of int64 list (** Wide character string constant. *) | LChr of char (** Character constant. *) | LReal of logic_real | LEnum of enumitem (** An enumeration constant.*) (** Real constants. *) and logic_real = { r_literal : string ; (** Initial string representation [s]. *) r_nearest : float ; (** Nearest approximation of [s] in double precision. *) r_upper : float ; (** Smallest double [u] such that [s <= u]. *) r_lower : float ; (** Greatest double [l] such that [l <= s]. *) } (** Types of logic terms. *) and logic_type = | Ctype of typ (** a C type *) | Ltype of logic_type_info * logic_type list (** an user-defined logic type with its parameters *) | Lvar of string (** a type variable. *) | Linteger (** mathematical integers, {i i.e.} Z *) | Lreal (** mathematical reals, {i i.e.} R *) | Larrow of logic_type list * logic_type (** (n-ary) function type *) (** tsets with an unique identifier. Use [Logic_const.new_location] to generate a new id. *) and identified_term = { it_id: int; (** the identifier. *) it_content: term (** the term *) } (** logic label referring to a particular program point. *) and logic_label = | StmtLabel of stmt ref (** label of a C statement. *) | LogicLabel of (stmt option * string) (* [JS 2011/05/13] why a tuple here? *) (** builtin logic label ({t Here, Pre}, ...) *) (* ************************************************************************* *) (** {2 Terms} *) (* ************************************************************************* *) (** C Expressions as logic terms follow C constructs (with prefix T) *) (** Logic terms. *) and term = { term_node : term_node; (** kind of term. *) term_loc : Lexing.position * Lexing.position; (** position in the source file. *) term_type : logic_type; (** type of the term. *) term_name: string list; (** names of the term if any. *) } (** the various kind of terms. *) and term_node = (* same constructs as exp *) | TConst of logic_constant (** a constant. *) | TLval of term_lval (** an L-value *) | TSizeOf of typ (** size of a given C type. *) | TSizeOfE of term (** size of the type of an expression. *) | TSizeOfStr of string (** size of a string constant. *) | TAlignOf of typ (** alignment of a type. *) | TAlignOfE of term (** alignment of the type of an expression. *) | TUnOp of unop * term (** unary operator. *) | TBinOp of binop * term * term (** binary operators. *) | TCastE of typ * term (** cast to a C type. *) | TAddrOf of term_lval (** address of a term. *) | TStartOf of term_lval (** beginning of an array. *) (* additional constructs *) | Tapp of logic_info * (logic_label * logic_label) list * term list (** application of a logic function. *) | Tlambda of quantifiers * term (** lambda abstraction. *) | TDataCons of logic_ctor_info * term list (** constructor of logic sum-type. *) | Tif of term * term * term (** conditional operator*) | Tat of term * logic_label (** term refers to a particular program point. *) | Tbase_addr of logic_label * term (** base address of a pointer. *) | Toffset of logic_label * term (** offset from the base address of a pointer. *) | Tblock_length of logic_label * term (** length of the block pointed to by the term. *) | Tnull (** the null pointer. *) | TLogic_coerce of logic_type * term (** implicit conversion from a C type to a logic type. The logic type must not be a Ctype. In particular, used to denote lifting to Linteger and Lreal. *) | TCoerce of term * typ (** coercion to a given C type. *) | TCoerceE of term * term (** coercion to the type of a given term. *) | TUpdate of term * term_offset * term (** functional update of a field. *) | Ttypeof of term (** type tag for a term. *) | Ttype of typ (** type tag for a C type. *) | Tempty_set (** the empty set. *) | Tunion of term list (** union of terms. *) | Tinter of term list (** intersection of terms. *) | Tcomprehension of term * quantifiers * predicate named option (** set defined in comprehension ({t \{ t[i] | integer i; 0 <= i < 5\}}) *) | Trange of term option * term option (** range of integers. *) | Tlet of logic_info * term (** local binding *) (** lvalue: base address and offset. *) and term_lval = term_lhost * term_offset (** base address of an lvalue. *) and term_lhost = | TVar of logic_var (** a variable. *) | TResult of typ (** value returned by a C function. Only used in post-conditions or assigns *) | TMem of term (** memory access. *) (** model field. *) and model_info = { mi_name: string; (** name *) mi_field_type: logic_type; (** type of the field *) mi_base_type: typ; (** type to which the field is associated. *) mi_decl: location; (** where the field has been declared. *) } (** offset of an lvalue. *) and term_offset = | TNoOffset (** no further offset. *) | TField of fieldinfo * term_offset (** access to the field of a compound type. *) | TModel of model_info * term_offset (** access to a model field. *) | TIndex of term * term_offset (** index. Note that a range is denoted by [TIndex(Trange(i1,i2),ofs)] *) (** description of a logic function or predicate. @plugin development guide *) and logic_info = { (* mutable l_name : string; (** name of the function. *) *) mutable l_var_info : logic_var; (** we use only fields lv_name and lv_id of l_var_info we should factorize lv_type and l_type+l_profile below *) mutable l_labels : logic_label list; (** label arguments of the function. *) mutable l_tparams : string list; (** type parameters *) mutable l_type : logic_type option; (** return type. None for predicates *) mutable l_profile : logic_var list; (** type of the arguments. *) mutable l_body : logic_body; (** body of the function. *) } and builtin_logic_info = { mutable bl_name: string; mutable bl_labels: logic_label list; mutable bl_params: string list; mutable bl_type: logic_type option; mutable bl_profile: (string * logic_type) list; } and logic_body = | LBnone (** no definition and no reads clause *) | LBreads of identified_term list (** read accesses performed by a function. *) | LBterm of term (** direct definition of a function. *) | LBpred of predicate named (** direct definition of a predicate. *) | LBinductive of (string * logic_label list * string list * predicate named) list (** inductive definition *) (** Description of a logic type. @plugin development guide *) and logic_type_info = { lt_name: string; lt_params : string list; (** type parameters*) mutable lt_def: logic_type_def option (** definition of the type. None for abstract types. *) } (* will be expanded when dealing with concrete types *) and logic_type_def = | LTsum of logic_ctor_info list (** sum type with its constructors. *) | LTsyn of logic_type (** Synonym of another type. *) (** origin of a logic variable. *) and logic_var_kind = | LVGlobal (** global logic function or predicate. *) | LVC (** Logic counterpart of a C variable. *) | LVFormal (** formal parameter of a logic function / predicate *) | LVQuant (** Bound by a quantifier or a Lambda abstraction. *) | LVLocal (** local \let *) (** description of a logic variable @plugin development guide *) and logic_var = { mutable lv_name : string; (** name of the variable. *) mutable lv_id : int; (** unique identifier *) mutable lv_type : logic_type; (** type of the variable. *) mutable lv_kind: logic_var_kind; (** kind of the variable *) mutable lv_origin : varinfo option (** when the logic variable stems from a C variable, set to the original C variable. *) } (** Description of a constructor of a logic sum-type. @plugin development guide *) and logic_ctor_info = { ctor_name: string; (** name of the constructor. *) ctor_type: logic_type_info; (** type to which the constructor belongs. *) ctor_params: logic_type list (** types of the parameters of the constructor. *) } (* ************************************************************************* *) (** {2 Predicates} *) (* ************************************************************************* *) (** variables bound by a quantifier. *) and quantifiers = logic_var list (** comparison relations*) and relation = | Rlt | Rgt | Rle | Rge | Req | Rneq (** @plugin development guide *) (** predicates *) and predicate = | Pfalse (** always-false predicate. *) | Ptrue (** always-true predicate. *) | Papp of logic_info * (logic_label * logic_label) list * term list (** application of a predicate. *) | Pseparated of term list | Prel of relation * term * term (** comparison of two terms. *) | Pand of predicate named * predicate named (** conjunction *) | Por of predicate named * predicate named (** disjunction. *) | Pxor of predicate named * predicate named (** logical xor. *) | Pimplies of predicate named * predicate named (** implication. *) | Piff of predicate named * predicate named (** equivalence. *) | Pnot of predicate named (** negation. *) | Pif of term * predicate named * predicate named (** conditional *) | Plet of logic_info * predicate named (** definition of a local variable *) | Pforall of quantifiers * predicate named (** universal quantification. *) | Pexists of quantifiers * predicate named (** existential quantification. *) | Pat of predicate named * logic_label (** predicate refers to a particular program point. *) | Pvalid_read of logic_label * term (** the given locations are valid for reading. *) | Pvalid of logic_label * term (** the given locations are valid. *) (** | Pvalid_index of term * term {b deprecated:} Use [Pvalid(TBinOp(PlusPI,p,i))] instead. [Pvalid_index(p,i)] indicates that accessing the [i]th element of [p] is valid. | Pvalid_range of term * term * term {b deprecated:} Use [Pvalid(TBinOp(PlusPI(p,Trange(i1,i2))))] instead. similar to [Pvalid_index] but for a range of indices.*) | Pinitialized of logic_label * term (** the given locations are initialized. *) | Pallocable of logic_label * term (** the given locations can be allocated. *) | Pfreeable of logic_label * term (** the given locations can be free. *) | Pfresh of logic_label * logic_label * term * term (** \fresh(pointer, n) A memory block of n bytes is newly allocated to the pointer.*) | Psubtype of term * term (** First term is a type tag that is a subtype of the second. *) (** predicate with an unique identifier. Use [Logic_const.new_predicate] to create fresh predicates *) and identified_predicate = { ip_name: string list; (** names given to the predicate if any.*) ip_loc: location; (** location in the source code. *) ip_id: int; (** identifier *) ip_content: predicate; (** the predicate itself*) } (* Polymorphic types shared with parsed trees (Logic_ptree) *) (** variant of a loop or a recursive function. Type shared with Logic_ptree. *) and 'term variant = 'term * string option (** allocates and frees. @since Oxygen-20120901 *) and 'locs allocation = | FreeAlloc of 'locs list * 'locs list (** tsets. Empty list means \nothing. *) | FreeAllocAny (** Nothing specified. Semantics depends on where it is written. *) (** dependencies of an assigned location. Shared with Logic_ptree. *) and 'locs deps = | From of 'locs list (** tsets. Empty list means \nothing. *) | FromAny (** Nothing specified. Any location can be involved. *) and 'locs from = ('locs * 'locs deps) (** zone assigned with its dependencies. Type shared with Logic_ptree. *) and 'locs assigns = | WritesAny (** Nothing specified. Anything can be written. *) | Writes of 'locs from list (** list of locations that can be written. Empty list means \nothing. *) (** object that can be named (in particular predicates). *) and 'a named = { name : string list; (** list of given names *) loc : location; (** position in the source code. *) content : 'a; (** content *) } (** Function contract. Type shared with Logic_ptree. *) and ('term,'pred,'locs) spec = { mutable spec_behavior : ('pred,'locs) behavior list; (** behaviors *) mutable spec_variant : 'term variant option; (** variant for recursive functions. *) mutable spec_terminates: 'pred option; (** termination condition. *) mutable spec_complete_behaviors: string list list; (** list of complete behaviors. It is possible to have more than one set of complete behaviors *) mutable spec_disjoint_behaviors: string list list; (** list of disjoint behaviors. It is possible to have more than one set of disjoint behaviors *) } (** Behavior of a function. Type shared with Logic_ptree. @since Oxygen-20120901 [b_allocation] has been added. @since Carbon-20101201 [b_requires] has been added. @modify Boron-20100401 [b_ensures] is replaced by [b_post_cond]. Old [b_ensures] represent the [Normal] case of [b_post_cond]. *) and ('pred,'locs) behavior = { mutable b_name : string; (** name of the behavior. *) mutable b_requires : 'pred list; (** require clauses. *) mutable b_assumes : 'pred list; (** assume clauses. *) mutable b_post_cond : (termination_kind * 'pred) list; (** post-condition. *) mutable b_assigns : 'locs assigns; (** assignments. *) mutable b_allocation : 'locs allocation; (** frees, allocates. *) mutable b_extended : (string * int * 'pred list) list (** Grammar extensions *) } (** kind of termination a post-condition applies to. See ACSL manual. *) and termination_kind = Normal | Exits | Breaks | Continues | Returns (** Pragmas for the value analysis plugin of Frama-C. Type shared with Logic_ptree.*) and 'term loop_pragma = | Unroll_specs of 'term list | Widen_hints of 'term list | Widen_variables of 'term list (** Pragmas for the slicing plugin of Frama-C. Type shared with Logic_ptree.*) and 'term slice_pragma = | SPexpr of 'term | SPctrl | SPstmt (** Pragmas for the impact plugin of Frama-C. Type shared with Logic_ptree.*) and 'term impact_pragma = | IPexpr of 'term | IPstmt (** The various kinds of pragmas. Type shared with Logic_ptree. *) and 'term pragma = | Loop_pragma of 'term loop_pragma | Slice_pragma of 'term slice_pragma | Impact_pragma of 'term impact_pragma (** all annotations that can be found in the code. Type shared with Logic_ptree. *) and ('term, 'pred, 'spec_pred, 'locs) code_annot = | AAssert of string list * 'pred (** assertion to be checked. The list of strings is the list of behaviors to which this assertion applies. *) | AStmtSpec of string list * ('term, 'spec_pred, 'locs) spec (** statement contract eventualy for some behaviors. *) | AInvariant of string list * bool * 'pred (** loop/code invariant. The list of strings is the list of behaviors to which this invariant applies. The boolean flag is true for normal loop invariants and false for invariant-as-assertions. *) | AVariant of 'term variant (** loop variant. Note that there can be at most one variant associated to a given statement *) | AAssigns of string list * 'locs assigns (** loop assigns. (see [b_assigns] in the behaviors for other assigns). At most one clause associated to a given (statement, behavior) couple. *) | AAllocation of string list * 'locs allocation (** loop allocation clause. (see [b_allocation] in the behaviors for other allocation clauses). At most one clause associated to a given (statement, behavior) couple. @since Oxygen-20120901 when [b_allocation] has been added. *) | APragma of 'term pragma (** pragma. *) (** function contract. *) and funspec = (term, identified_predicate, identified_term) spec (** code annotation with an unique identifier. Use [Logic_const.new_code_annotation] to create new code annotations with a fresh id. *) and code_annotation = { annot_id: int; (** identifier. *) annot_content : (term, predicate named, identified_predicate, identified_term) code_annot; (** content of the annotation. *) } (** behavior of a function. *) and funbehavior = (identified_predicate,identified_term) behavior (** global annotations, not attached to a statement or a function. *) and global_annotation = | Dfun_or_pred of logic_info * location | Dvolatile of identified_term list * varinfo option * varinfo option * location (** associated terms, reading function, writing function *) | Daxiomatic of string * global_annotation list * location | Dtype of logic_type_info * location (** declaration of a logic type. *) | Dlemma of string * bool * logic_label list * string list * predicate named * location (** definition of a lemma. The boolean flag is [true] if the property should be taken as an axiom and [false] if it must be proved. *) | Dinvariant of logic_info * location (** global invariant. The predicate does not have any argument. *) | Dtype_annot of logic_info * location (** type invariant. The predicate has exactly one argument. *) | Dmodel_annot of model_info * location (** Model field for a type t, seen as a logic function with one argument of type t *) | Dcustom_annot of custom_tree * string* location (*Custom declaration*) and custom_tree = CustomDummy (* | CustomType of logic_type | CustomLexpr of lexpr | CustomOther of string * (custom_tree list) *) type kinstr = | Kstmt of stmt | Kglobal (** Internal representation of decorated C functions *) type cil_function = | Definition of (fundec * location) (** defined function *) | Declaration of (funspec * varinfo * varinfo list option * location) (** Declaration(spec,f,args,loc) represents a leaf function [f] with specification [spec] and arguments [args], at location [loc]. As with the [TFun] constructor of {!Cil_types.typ}, the arg list is optional, to distinguish [void f()] ([None]) from [void f(void)] ([Some []]). *) (** Except field [fundec], do not use the other fields directly. Prefer to use {!Kernel_function.find_return}, {!Annotations.funspec}, [Annotations.add_*] or [Annotations.remove_*]. *) type kernel_function = { mutable fundec : cil_function; mutable return_stmt : stmt option; mutable spec : funspec; } (* [VP] TODO: VLocal should be attached to a particular block, not a whole function. *) type localisation = | VGlobal | VLocal of kernel_function | VFormal of kernel_function type mach = { version_major: int; (* Major version number *) version_minor: int; (* Minor version number *) version: string; (* version number *) underscore_name: bool; (* If assembly names have leading underscore *) sizeof_short: int; (* Size of "short" *) sizeof_int: int; (* Size of "int" *) sizeof_long: int ; (* Size of "long" *) sizeof_longlong: int; (* Size of "long long" *) sizeof_ptr: int; (* Size of pointers *) sizeof_float: int; (* Size of "float" *) sizeof_double: int; (* Size of "double" *) sizeof_longdouble: int; (* Size of "long double" *) sizeof_void: int; (* Size of "void" *) sizeof_fun: int; (* Size of function *) size_t: string; (* Type of "sizeof(T)" *) wchar_t: string; (* Type of "wchar_t" *) ptrdiff_t: string; (* Type of "ptrdiff_t" *) alignof_short: int; (* Alignment of "short" *) alignof_int: int; (* Alignment of "int" *) alignof_long: int; (* Alignment of "long" *) alignof_longlong: int; (* Alignment of "long long" *) alignof_ptr: int; (* Alignment of pointers *) alignof_float: int; (* Alignment of "float" *) alignof_double: int; (* Alignment of "double" *) alignof_longdouble: int; (* Alignment of "long double" *) alignof_str: int; (* Alignment of strings *) alignof_fun: int; (* Alignment of function *) char_is_unsigned: bool; (* Whether "char" is unsigned *) const_string_literals: bool; (* Whether string literals have const chars *) little_endian: bool; (* whether the machine is little endian *) alignof_aligned: int (* Alignment of a type with aligned attribute *); has__builtin_va_list: bool (* Whether [__builtin_va_list] is a known type *); __thread_is_keyword: bool (* Whether [__thread] is a keyword *); } (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/cil/src/machdep_x86_16.ml0000644000175000017500000001262712155630367020321 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) open Cil_types let gcc = { (* Generated by code in cil/src/machdep.c *) version_major = 1; version_minor = 0; version = "x86 16 bits mode (gcc like compiler) with big or huge memory model"; sizeof_short = 2; sizeof_int = 2; sizeof_long = 4; sizeof_longlong = 8; sizeof_ptr = 4; sizeof_float = 4; sizeof_double = 8; sizeof_longdouble = 16; (*sizeof_wchar = 4;*) (*sizeof_sizeof = 4;*) sizeof_void = 1; sizeof_fun = 1; alignof_short = 2; alignof_int = 2; alignof_long = 4; alignof_longlong = 4; alignof_ptr = 4; alignof_float = 4; alignof_double = 8; alignof_longdouble = 16; alignof_str = 1; alignof_fun = 1; alignof_aligned= 8; (* I don't know if attribute aligned is supported by any 16bits compiler. *) char_is_unsigned = false; const_string_literals = true; little_endian = true; underscore_name = true ; size_t = "unsigned int"; wchar_t = "int"; ptrdiff_t = "int"; has__builtin_va_list = true; __thread_is_keyword = true; } let msvc = { (* Generated by code in cil/src/machdep.c *) version_major = 1; version_minor = 0; version = "x86 16 bits mode (msvc like compiler) with big or huge memory model"; sizeof_short = 2; sizeof_int = 2; sizeof_long = 4; sizeof_longlong = 8; sizeof_ptr = 4; sizeof_float = 4; sizeof_double = 8; sizeof_longdouble = 16; (*sizeof_wchar = 4;*) (*sizeof_sizeof = 4;*) sizeof_void = 1; sizeof_fun = 1; alignof_short = 2; alignof_int = 2; alignof_long = 4; alignof_longlong = 4; alignof_ptr = 4; alignof_float = 4; alignof_double = 8; alignof_longdouble = 16; alignof_str = 1; alignof_fun = 1; alignof_aligned= 8; (* I don't know if attribute aligned is supported by any 16bits compiler. *) char_is_unsigned = false; const_string_literals = true; little_endian = true; underscore_name = true ; size_t = "unsigned int"; wchar_t = "int"; ptrdiff_t = "int"; has__builtin_va_list = false; __thread_is_keyword = false; } frama-c-Fluorine-20130601/cil/src/escape.mli0000644000175000017500000001222412155630367017307 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* * * Copyright (c) 2003, * Ben Liblit * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * 3. The names of the contributors may not be used to endorse or promote * products derived from this software without specific prior written * permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * *) (* * Character and string escaping utilities *) (** OCaml types used to represent wide characters and strings *) type wchar = int64 type wstring = wchar list (** escape various constructs in accordance with C lexical rules *) val escape_char : char -> string val escape_string : string -> string val escape_wchar : wchar -> string val escape_wstring : wstring -> string frama-c-Fluorine-20130601/cil/src/cil.mli0000644000175000017500000026001012155630367016614 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** CIL main API. CIL original API documentation is available as an html version at http://manju.cs.berkeley.edu/cil. @plugin development guide *) open Cil_types open Cil_datatype (* ************************************************************************* *) (** {2 Builtins management} *) (* ************************************************************************* *) (** This module associates the name of a built-in function that might be used during elaboration with the corresponding varinfo. This is done when parsing ${FRAMAC_SHARE}/libc/__fc_builtins.h, which is always performed before processing the actual list of files provided on the command line (see {!File.init_from_c_files}). Actual list of such built-ins is managed in {!Cabs2cil}. *) module Frama_c_builtins: State_builder.Hashtbl with type key = string and type data = Cil_types.varinfo val is_builtin: Cil_types.varinfo -> bool (** @return true if the given variable refers to a Frama-C builtin that is not used in the current program. Plugins may (and in fact should) hide this builtin from their outputs @since Fluorine-20130401 *) val is_unused_builtin: Cil_types.varinfo -> bool (** @return true if the given variable refers to a Frama-C builtin that is not used in the current program. Plugins may (and in fact should) hide this builtin from their outputs *) val is_special_builtin: string -> bool (** @return [true] if the given name refers to a special built-in function. A special built-in function can have any number of arguments. It is up to the plug-ins to know what to do with it. @since Boron-20100401-dev *) (** register a new special built-in function *) val add_special_builtin: string -> unit (** register a new family of special built-in functions. @since Carbon-20101201 *) val add_special_builtin_family: (string -> bool) -> unit (** initialize the C built-ins. Should be called once per project, after the machine has been set. *) val init_builtins: unit -> unit (** Description of the machine as seen in GCC and MSVC modes. *) module type Machdeps = sig val gcc : Cil_types.mach val msvc : Cil_types.mach end (** Call this function to perform some initialization, and only after you have set [Cil.msvcMode]. [initLogicBuiltins] is the function to call to init logic builtins. The [Machdeps] argument is a description of the hardware platform and of the compiler used. *) val initCIL: initLogicBuiltins:(unit -> unit) -> (module Machdeps) -> unit (* ************************************************************************* *) (** {2 Customization} *) (* ************************************************************************* *) type theMachine = private { (** Whether the pretty printer should print output for the MS VC compiler. Default is GCC *) mutable msvcMode: bool; (** Whether to use the logical operands LAnd and LOr. By default, do not use them because they are unlike other expressions and do not evaluate both of their operands *) mutable useLogicalOperators: bool; mutable theMachine: mach; mutable lowerConstants: bool; (** Do lower constants (default true) *) mutable insertImplicitCasts: bool; (** Do insert implicit casts (default true) *) (** Whether the compiler generates assembly labels by prepending "_" to the identifier. That is, will function foo() have the label "foo", or "_foo"? *) mutable underscore_name: bool; mutable stringLiteralType: typ; mutable upointKind: ikind (** An unsigned integer type that fits pointers. *); mutable upointType: typ; mutable wcharKind: ikind; (** An integer type that fits wchar_t. *) mutable wcharType: typ; mutable ptrdiffKind: ikind; (** An integer type that fits ptrdiff_t. *) mutable ptrdiffType: typ; mutable typeOfSizeOf: typ; (** An integer type that is the type of sizeof. *) mutable kindOfSizeOf: ikind (** The integer kind of {!Cil.typeOfSizeOf}. *) } val theMachine : theMachine (** Current machine description *) val selfMachine: State.t val selfMachine_is_computed: ?project:Project.project -> unit -> bool (** whether current project has set its machine description. *) val set_msvcMode: bool -> unit (** Must be called before {!Cil.initCIL}. *) (** Styles of printing line directives *) type lineDirectiveStyle = | LineComment (** Before every element, print the line * number in comments. This is ignored by * processing tools (thus errors are reproted * in the CIL output), but useful for * visual inspection *) | LineCommentSparse (** Like LineComment but only print a line * directive for a new source line *) | LinePreprocessorInput (** Use #line directives *) | LinePreprocessorOutput (** Use # nnn directives (in gcc mode) *) type miscState = { (** How to print line directives *) mutable lineDirectiveStyle: lineDirectiveStyle option; (** Whether we print something that will only be used as input to our own parser. In that case we are a bit more liberal in what we print *) mutable print_CIL_Input: bool; (** Whether to print the CIL as they are, without trying to be smart and print nicer code. Normally this is false, in which case the pretty printer will turn the while(1) loops of CIL into nicer loops, will not print empty "else" blocks, etc. These is one case howewer in which if you turn this on you will get code that does not compile: if you use varargs the __builtin_va_arg function will be printed in its internal form. *) mutable printCilAsIs: bool; (** The length used when wrapping output lines. Setting this variable to a large integer will prevent wrapping and make #line directives more accurate. *) mutable lineLength: int; (** Emit warnings when truncating integer constants (default true) *) mutable warnTruncate: bool } val miscState: miscState (** To be able to add/remove features easily, each feature should be package as an interface with the following interface. *) type featureDescr = { fd_enabled: bool ref; (** The enable flag. Set to default value *) fd_name: string; (** This is used to construct an option "--doxxx" and "--dontxxx" that * enable and disable the feature *) fd_description: string; (** A longer name that can be used to document the new options *) fd_extraopt: (string * Arg.spec * string) list; (** Additional command line options *) fd_doit: (file -> unit); (** This performs the transformation *) fd_post_check: bool; (** Whether to perform a CIL consistency checking after this stage, if * checking is enabled (--check is passed to cilly). Set this to true if * your feature makes any changes for the program. *) } (* ************************************************************************* *) (** {2 Values for manipulating globals} *) (* ************************************************************************* *) (** Make an empty function from an existing global varinfo. @since Nitrogen-20111001 *) val emptyFunctionFromVI: varinfo -> fundec (** Make an empty function *) val emptyFunction: string -> fundec (** Update the formals of a [fundec] and make sure that the function type has the same information. Will copy the name as well into the type. *) val setFormals: fundec -> varinfo list -> unit (** Takes as input a function type (or a typename on it) and return its return type. *) val getReturnType: typ -> typ (** Change the return type of the function passed as 1st argument to be the type passed as 2nd argument. *) val setReturnTypeVI: varinfo -> typ -> unit val setReturnType: fundec -> typ -> unit (** Set the types of arguments and results as given by the function type * passed as the second argument. Will not copy the names from the function * type to the formals *) val setFunctionType: fundec -> typ -> unit (** Set the type of the function and make formal arguments for them *) val setFunctionTypeMakeFormals: fundec -> typ -> unit (** Update the smaxid after you have populated with locals and formals * (unless you constructed those using {!Cil.makeLocalVar} or * {!Cil.makeTempVar}. *) val setMaxId: fundec -> unit (** Strip const attribute from the type. This is useful for any type used as the type of a local variable which may be assigned. Note that the type attributes are mutated in place. @since Nitrogen-20111001 *) val stripConstLocalType : Cil_types.typ -> Cil_types.typ val selfFormalsDecl: State.t (** state of the table associating formals to each prototype. *) val makeFormalsVarDecl: (string * typ * attributes) -> varinfo (** creates a new varinfo for the parameter of a prototype. *) (** Update the formals of a function declaration from its identifier and its type. For a function definition, use {!Cil.setFormals}. Do nothing if the type is not a function type or if the list of argument is empty. *) val setFormalsDecl: varinfo -> typ -> unit (** remove a binding from the table. @since Oxygen-20120901 *) val removeFormalsDecl: varinfo -> unit (** replace to formals of a function declaration with the given list of varinfo. *) val unsafeSetFormalsDecl: varinfo -> varinfo list -> unit (** iters the given function on declared prototypes. @since Oxygen-20120901 *) val iterFormalsDecl: (varinfo -> varinfo list -> unit) -> unit (** Get the formals of a function declaration registered with {!Cil.setFormalsDecl}. @raise Not_found if the function is not registered (this is in particular the case for prototypes with an empty list of arguments. See {!Cil.setFormalsDecl}) *) val getFormalsDecl: varinfo -> varinfo list (** A dummy file *) val dummyFile: file (** Get the global initializer and create one if it does not already exist. When it creates a global initializer it attempts to place a call to it in the main function named by the optional argument (default "main"). @deprecated using this function is incorrect since it modifies the current AST (see Plug-in Development Guide, Section "Using Projects"). *) val getGlobInit: ?main_name:string -> file -> fundec (** Iterate over all globals, including the global initializer *) val iterGlobals: file -> (global -> unit) -> unit (** Fold over all globals, including the global initializer *) val foldGlobals: file -> ('a -> global -> 'a) -> 'a -> 'a (** Map over all globals, including the global initializer and change things in place *) val mapGlobals: file -> (global -> global) -> unit (** Find a function or function prototype with the given name in the file. * If it does not exist, create a prototype with the given type, and return * the new varinfo. This is useful when you need to call a libc function * whose prototype may or may not already exist in the file. * * Because the new prototype is added to the start of the file, you shouldn't * refer to any struct or union types in the function type.*) val findOrCreateFunc: file -> string -> typ -> varinfo module Sid: sig val next: unit -> int end module Eid: sig val next: unit -> int end (** creates an expression with a fresh id *) val new_exp: loc:location -> exp_node -> exp (** performs a deep copy of an expression (especially, avoid eid sharing). @since Nitrogen-20111001 *) val copy_exp: exp -> exp (** creates an expression with a dummy id. Use with caution, {i i.e.} not on expressions that may be put in the AST. *) val dummy_exp: exp_node -> exp (** Return [true] on case and default labels, [false] otherwise. *) val is_case_label: label -> bool (** CIL keeps the types at the beginning of the file and the variables at the * end of the file. This function will take a global and add it to the * corresponding stack. Its operation is actually more complicated because if * the global declares a type that contains references to variables (e.g. in * sizeof in an array length) then it will also add declarations for the * variables to the types stack *) val pushGlobal: global -> types: global list ref -> variables: global list ref -> unit (** An empty statement. Used in pretty printing *) val invalidStmt: stmt (** A list of the built-in functions for the current compiler (GCC or * MSVC, depending on [!msvcMode]). Maps the name to the * result and argument types, and whether it is vararg. * Initialized by {!Cil.initCIL} * * This map replaces [gccBuiltins] and [msvcBuiltins] in previous * versions of CIL.*) module Builtin_functions : State_builder.Hashtbl with type key = string and type data = typ * typ list * bool (** This is used as the location of the prototypes of builtin functions. *) val builtinLoc: location (** Returns a location that ranges over the two locations in arguments. *) val range_loc: location -> location -> location (* ************************************************************************* *) (** {2 Values for manipulating initializers} *) (* ************************************************************************* *) (** Make a initializer for zero-ing a data type *) val makeZeroInit: loc:location -> typ -> init (** Fold over the list of initializers in a Compound (not also the nested * ones). [doinit] is called on every present initializer, even if it is of * compound type. The parameters of [doinit] are: the offset in the compound * (this is [Field(f,NoOffset)] or [Index(i,NoOffset)]), the initializer * value, expected type of the initializer value, accumulator. In the case of * arrays there might be missing zero-initializers at the end of the list. * These are scanned only if [implicit] is true. This is much like * [List.fold_left] except we also pass the type of the initializer. * This is a good way to use it to scan even nested initializers : {v let rec myInit (lv: lval) (i: init) (acc: 'a) : 'a = match i with SingleInit e -> ... do something with lv and e and acc ... | CompoundInit (ct, initl) -> foldLeftCompound ~implicit:false ~doinit:(fun off' i' t' acc -> myInit (addOffsetLval lv off') i' acc) ~ct:ct ~initl:initl ~acc:acc v} *) val foldLeftCompound: implicit:bool -> doinit: (offset -> init -> typ -> 'a -> 'a) -> ct: typ -> initl: (offset * init) list -> acc: 'a -> 'a (* ************************************************************************* *) (** {2 Values for manipulating types} *) (* ************************************************************************* *) (** void *) val voidType: typ (** is the given type "void"? *) val isVoidType: typ -> bool (** is the given type "void *"? *) val isVoidPtrType: typ -> bool (** int *) val intType: typ (** unsigned int *) val uintType: typ (** long *) val longType: typ (** unsigned long *) val ulongType: typ (** unsigned long long *) val ulongLongType: typ (** Any unsigned integer type of size 16 bits. It is equivalent to the ISO C uint16_t type but without using the corresponding header. Shall not be called if not such type exists in the current architecture. @since Nitrogen-20111001 *) val uint16_t: unit -> typ (** Any unsigned integer type of size 32 bits. It is equivalent to the ISO C uint32_t type but without using the corresponding header. Shall not be called if not such type exists in the current architecture. @since Nitrogen-20111001 *) val uint32_t: unit -> typ (** Any unsigned integer type of size 64 bits. It is equivalent to the ISO C uint64_t type but without using the corresponding header. Shall not be called if no such type exists in the current architecture. @since Nitrogen-20111001 *) val uint64_t: unit -> typ (** char *) val charType: typ (** char * *) val charPtrType: typ (** char const * *) val charConstPtrType: typ (** void * *) val voidPtrType: typ (** void const * *) val voidConstPtrType: typ (** int * *) val intPtrType: typ (** unsigned int * *) val uintPtrType: typ (** float *) val floatType: typ (** double *) val doubleType: typ (** long double *) val longDoubleType: typ (** Returns true if and only if the given type is a signed integer type. *) val isSignedInteger: typ -> bool (** Returns true if and only if the given type is an unsigned integer type. @since Oxygen-20120901 *) val isUnsignedInteger: typ -> bool (** Returns true if and only if the given type is a pointer to another type @since Oxygen-20120901 *) val isPtrType: typ -> bool (** Creates a a (potentially recursive) composite type. The arguments are: * (1) a boolean indicating whether it is a struct or a union, (2) the name * (always non-empty), (3) a function that when given a representation of the * structure type constructs the type of the fields recursive type (the first * argument is only useful when some fields need to refer to the type of the * structure itself), and (4) a list of attributes to be associated with the * composite type. The resulting compinfo has the field "cdefined" only if * the list of fields is non-empty. *) val mkCompInfo: bool -> (* whether it is a struct or a union *) string -> (* name of the composite type; cannot be empty *) ?norig:string -> (* original name of the composite type, empty when anonymous *) (compinfo -> (string * typ * int option * attributes * location) list) -> (* a function that when given a forward representation of the structure type constructs the type of the fields. The function can ignore this argument if not constructing a recursive type. *) attributes -> compinfo (** Makes a shallow copy of a {!Cil_types.compinfo} changing the name and the key.*) val copyCompInfo: compinfo -> string -> compinfo (** This is a constant used as the name of an unnamed bitfield. These fields do not participate in initialization and their name is not printed. *) val missingFieldName: string (** Get the full name of a comp *) val compFullName: compinfo -> string (** Returns true if this is a complete type. This means that sizeof(t) makes sense. Incomplete types are not yet defined structures and empty arrays. *) val isCompleteType: typ -> bool (** Unroll a type until it exposes a non * [TNamed]. Will collect all attributes appearing in [TNamed]!!! *) val unrollType: typ -> typ (** Unroll all the TNamed in a type (even under type constructors such as * [TPtr], [TFun] or [TArray]. Does not unroll the types of fields in [TComp] * types. Will collect all attributes *) val unrollTypeDeep: typ -> typ (** Separate out the storage-modifier name attributes *) val separateStorageModifiers: attribute list -> attribute list * attribute list (** returns the type of the result of an arithmetic operator applied to values of the corresponding input types. @since Nitrogen-20111001 (moved from Cabs2cil) *) val arithmeticConversion : Cil_types.typ -> Cil_types.typ -> Cil_types.typ (** performs the usual integral promotions mentioned in C reference manual. @since Nitrogen-20111001 (moved from Cabs2cil) *) val integralPromotion : Cil_types.typ -> Cil_types.typ (** True if the argument is a character type (i.e. plain, signed or unsigned) *) val isCharType: typ -> bool (** True if the argument is a short type (i.e. signed or unsigned) *) val isShortType: typ -> bool (** True if the argument is a pointer to a character type (i.e. plain, signed or unsigned) *) val isCharPtrType: typ -> bool (** True if the argument is an array of a character type (i.e. plain, signed or unsigned) *) val isCharArrayType: typ -> bool (** True if the argument is an integral type (i.e. integer or enum) *) val isIntegralType: typ -> bool (** True if the argument is an integral type (i.e. integer or enum), either C or mathematical one *) val isLogicIntegralType: logic_type -> bool (** True if the argument is a floating point type *) val isFloatingType: typ -> bool (** True if the argument is a floating point type *) val isLogicFloatType: logic_type -> bool (** True if the argument is a C floating point type or logic 'real' type *) val isLogicRealOrFloatType: logic_type -> bool (** True if the argument is the logic 'real' type *) val isLogicRealType: logic_type -> bool (** True if the argument is an arithmetic type (i.e. integer, enum or floating point *) val isArithmeticType: typ -> bool (** True if the argument is a logic arithmetic type (i.e. integer, enum or floating point, either C or mathematical one *) val isLogicArithmeticType: logic_type -> bool (** True if the argument is a pointer type *) val isPointerType: typ -> bool (** True if the argument is the type for reified C types *) val isTypeTagType: logic_type -> bool (** True if the argument is a function type. *) val isFunctionType: typ -> bool (** True if the argument denotes the type of ... in a variadic function. @since Nitrogen-20111001 moved from cabs2cil *) val isVariadicListType: typ -> bool (** Obtain the argument list ([] if None) *) val argsToList: (string * typ * attributes) list option -> (string * typ * attributes) list (** True if the argument is an array type *) val isArrayType: typ -> bool (** True if the argument is a struct of union type *) val isStructOrUnionType: typ -> bool (** Raised when {!Cil.lenOfArray} fails either because the length is [None] * or because it is a non-constant expression *) exception LenOfArray (** Call to compute the array length as present in the array type, to an * integer. Raises {!Cil.LenOfArray} if not able to compute the length, such * as when there is no length or the length is not a constant. *) val lenOfArray: exp option -> int val lenOfArray64: exp option -> Integer.t (** Return a named fieldinfo in compinfo, or raise Not_found *) val getCompField: compinfo -> string -> fieldinfo (** A datatype to be used in conjunction with [existsType] *) type existsAction = ExistsTrue (** We have found it *) | ExistsFalse (** Stop processing this branch *) | ExistsMaybe (** This node is not what we are * looking for but maybe its * successors are *) (** Scans a type by applying the function on all elements. When the function returns ExistsTrue, the scan stops with true. When the function returns ExistsFalse then the current branch is not scanned anymore. Care is taken to apply the function only once on each composite type, thus avoiding circularity. When the function returns ExistsMaybe then the types that construct the current type are scanned (e.g. the base type for TPtr and TArray, the type of fields for a TComp, etc). *) val existsType: (typ -> existsAction) -> typ -> bool (** Given a function type split it into return type, * arguments, is_vararg and attributes. An error is raised if the type is not * a function type *) val splitFunctionType: typ -> typ * (string * typ * attributes) list option * bool * attributes (** Same as {!Cil.splitFunctionType} but takes a varinfo. Prints a nicer * error message if the varinfo is not for a function *) val splitFunctionTypeVI: varinfo -> typ * (string * typ * attributes) list option * bool * attributes (*********************************************************) (** LVALUES *) (** Make a varinfo. Use this (rarely) to make a raw varinfo. Use other * functions to make locals ({!Cil.makeLocalVar} or {!Cil.makeFormalVar} or * {!Cil.makeTempVar}) and globals ({!Cil.makeGlobalVar}). Note that this * function will assign a new identifier. * The [logic] argument defaults to [false] * and should be used to create a varinfo such that [varinfo.vlogic=true]. * The [generated] argument defaults to [true] (in fact, only front-ends have * the need to set it to false), and tells whether the variable is generated * or comes directly from user input (the [vgenerated] flag). * The first unnmamed argument specifies whether the varinfo is for a global and * the second is for formals. *) val makeVarinfo: ?logic:bool -> ?generated:bool -> bool -> bool -> string -> typ -> varinfo (** Make a formal variable for a function declaration. Insert it in both the sformals and the type of the function. You can optionally specify where to insert this one. If where = "^" then it is inserted first. If where = "$" then it is inserted last. Otherwise where must be the name of a formal after which to insert this. By default it is inserted at the end. A formal var is never generated. *) val makeFormalVar: fundec -> ?where:string -> string -> typ -> varinfo (** Make a local variable and add it to a function's slocals and to the given block (only if insert = true, which is the default). Make sure you know what you are doing if you set insert=false. [generated] is passed to {!Cil.makeVarinfo}. The variable is attached to the toplevel block if [scope] is not specified. @since Nitrogen-20111001 This function will strip const attributes of its type in place in order for local variable to be assignable at least once. *) val makeLocalVar: fundec -> ?scope:block -> ?generated:bool -> ?insert:bool -> string -> typ -> varinfo (** Make a pseudo-variable to use as placeholder in term to expression conversions. Its logic field is set. They are always generated. *) val makePseudoVar: typ -> varinfo (** Make a temporary variable and add it to a function's slocals. The name of the temporary variable will be generated based on the given name hint so that to avoid conflicts with other locals. Optionally, you can give the variable a description of its contents. Temporary variables are always considered as generated variables. If [insert] is true (the default), the variable will be inserted among other locals of the function. The value for [insert] should only be changed if you are completely sure this is not useful. *) val makeTempVar: fundec -> ?insert:bool -> ?name:string -> ?descr:string -> ?descrpure:bool -> typ -> varinfo (** Make a global variable. Your responsibility to make sure that the name is unique. [logic] defaults to [false]. [generated] defaults to [true].*) val makeGlobalVar: ?logic:bool -> ?generated:bool -> string -> typ -> varinfo (** Make a shallow copy of a [varinfo] and assign a new identifier. If the original varinfo has an associated logic var, it is copied too and associated to the copied varinfo *) val copyVarinfo: varinfo -> string -> varinfo (** Is an lvalue a bitfield? *) val isBitfield: lval -> bool (** Returns the last offset in the chain. *) val lastOffset: offset -> offset (** Add an offset at the end of an lvalue. Make sure the type of the lvalue * and the offset are compatible. *) val addOffsetLval: offset -> lval -> lval (** [addOffset o1 o2] adds [o1] to the end of [o2]. *) val addOffset: offset -> offset -> offset (** Equivalent to [lastOffset] for terms. @deprecated Oxygen-20120901 use Logic_const.addTermOffsetLval *) val lastTermOffset: term_offset -> term_offset (** Equivalent to [addOffsetLval] for terms. @deprecated Oxygen-20120901 use Logic_const.addTermOffsetLval *) val addTermOffsetLval: term_offset -> term_lval -> term_lval (** Equivalent to [addOffset] for terms. @deprecated Oxygen-20120901 use Logic_const. *) val addTermOffset: term_offset -> term_offset -> term_offset (** Remove ONE offset from the end of an lvalue. Returns the lvalue with the * trimmed offset and the final offset. If the final offset is [NoOffset] * then the original [lval] did not have an offset. *) val removeOffsetLval: lval -> lval * offset (** Remove ONE offset from the end of an offset sequence. Returns the * trimmed offset and the final offset. If the final offset is [NoOffset] * then the original [lval] did not have an offset. *) val removeOffset: offset -> offset * offset (** Compute the type of an lvalue *) val typeOfLval: lval -> typ (** Compute the type of an lhost (with no offset) *) val typeOfLhost: lhost -> typ (** Equivalent to [typeOfLval] for terms. *) val typeOfTermLval: term_lval -> logic_type (** Compute the type of an offset from a base type *) val typeOffset: typ -> offset -> typ (** Equivalent to [typeOffset] for terms. *) val typeTermOffset: logic_type -> term_offset -> logic_type (** Compute the type of an initializer *) val typeOfInit: init -> typ (* ************************************************************************* *) (** {2 Values for manipulating expressions} *) (* ************************************************************************* *) (* Construct integer constants *) (** 0 *) val zero: loc:Location.t -> exp (** 1 *) val one: loc:Location.t -> exp (** -1 *) val mone: loc:Location.t -> exp (** Construct an integer of a given kind, using OCaml's int64 type. If needed * it will truncate the integer to be within the representable range for the * given kind. The integer can have an optional literal representation. *) val kinteger64_repr: loc:location -> ikind -> Integer.t -> string option -> exp (** Construct an integer of a given kind without literal representation. *) val kinteger64: loc:location -> ikind -> Integer.t -> exp (** Construct an integer of a given kind. Converts the integer to int64 and * then uses kinteger64. This might truncate the value if you use a kind * that cannot represent the given integer. This can only happen for one of * the Char or Short kinds *) val kinteger: loc:location -> ikind -> int -> exp (** Construct an integer of kind IInt. You can use this always since the OCaml integers are 31 bits and are guaranteed to fit in an IInt *) val integer: loc:location -> int -> exp (** Constructs a floating point constant. @since Oxygen-20120901 *) val kfloat: loc:location -> fkind -> float -> exp (** True if the given expression is a (possibly cast'ed) character or an integer constant *) val isInteger: exp -> Integer.t option (** Convert a 64-bit int to an OCaml int, or raise an exception if that can't be done. *) val i64_to_int: int64 -> int (** True if the expression is a compile-time constant *) val isConstant: exp -> bool (** True if the expression is a compile-time integer constant *) val isIntegerConstant: exp -> bool (** True if the given offset contains only field nanmes or constant indices. *) val isConstantOffset: offset -> bool (** True if the given expression is a (possibly cast'ed) integer or character constant with value zero *) val isZero: exp -> bool (** True if the term is the constant 0 *) val isLogicZero: term -> bool (** True if the given term is [\null] or a constant null pointer*) val isLogicNull: term -> bool (** gives the value of a wide char literal. *) val reduce_multichar: Cil_types.typ -> int64 list -> int64 (** gives the value of a char literal. *) val interpret_character_constant: int64 list -> Cil_types.constant * Cil_types.typ (** Given the character c in a (CChr c), sign-extend it to 32 bits. (This is the official way of interpreting character constants, according to ISO C 6.4.4.4.10, which says that character constants are chars cast to ints) Returns CInt64(sign-extened c, IInt, None) *) val charConstToInt: char -> constant (** Do constant folding on an expression. If the first argument is [true] then will also compute compiler-dependent expressions such as sizeof. See also {!Cil.constFoldVisitor}, which will run constFold on all expressions in a given AST node. *) val constFold: bool -> exp -> exp (** Do constant folding on an term at toplevel only. This uses compiler-dependent informations and will remove all sizeof and alignof. *) val constFoldTermNodeAtTop: term_node -> term_node (** Do constant folding on an term at toplevel only. If the first argument is true then will also compute compiler-dependent expressions such as [sizeof] and [alignof]. *) val constFoldTerm: bool -> term -> term (** Do constant folding on a binary operation. The bulk of the work done by [constFold] is done here. If the second argument is true then will also compute compiler-dependent expressions such as [sizeof]. *) val constFoldBinOp: loc:location -> bool -> binop -> exp -> exp -> typ -> exp (** [true] if the two constant are equal. @since Nitrogen-20111001 *) val compareConstant: constant -> constant -> bool (** [true] if the two expressions are syntactically the same. @deprecated Oxygen-20120901 use {!Cil_datatype.ExpStructEq.compare} *) val compareExp: exp -> exp -> bool (** [true] if the two lval are syntactically the same. @deprecated Oxygen-20120901 use {!Cil_datatype.LvalStructEq.compare} *) val compareLval: lval -> lval -> bool (** [true] if the two offsets are syntactically the same. @deprecated Oxygen-20120901 use {!Cil_datatype.OffsetStructEq.compare} *) val compareOffset: offset -> offset -> bool (** Increment an expression. Can be arithmetic or pointer type *) val increm: exp -> int -> exp (** Increment an expression. Can be arithmetic or pointer type *) val increm64: exp -> Integer.t -> exp (** Makes an lvalue out of a given variable *) val var: varinfo -> lval (** Creates an expr representing the variable. @since Nitrogen-20111001 *) val evar: ?loc:location -> varinfo -> exp (** Make an AddrOf. Given an lvalue of type T will give back an expression of type ptr(T). It optimizes somewhat expressions like "& v" and "& v[0]" *) val mkAddrOf: loc:location -> lval -> exp (** Creates an expression corresponding to "&v". @since Oxygen-20120901 *) val mkAddrOfVi: varinfo -> exp (** Like mkAddrOf except if the type of lval is an array then it uses StartOf. This is the right operation for getting a pointer to the start of the storage denoted by lval. *) val mkAddrOrStartOf: loc:location -> lval -> exp (** Make a Mem, while optimizing AddrOf. The type of the addr must be TPtr(t) and the type of the resulting lval is t. Note that in CIL the implicit conversion between an array and the pointer to the first element does not apply. You must do the conversion yourself using StartOf *) val mkMem: addr:exp -> off:offset -> lval (** makes a binary operation and performs const folding. Inserts casts between arithmetic types as needed, or between pointer types, but do not attempt to cast pointer to int or vice-versa. Use appropriate binop (PlusPI & friends) for that. *) val mkBinOp: loc:location -> binop -> exp -> exp -> exp (** Equivalent to [mkMem] for terms. *) val mkTermMem: addr:term -> off:term_offset -> term_lval (** Make an expression that is a string constant (of pointer type) *) val mkString: loc:location -> string -> exp (** [true] if both types are not equivalent. if [force] is [true], returns [true] whenever both types are not equal (modulo typedefs). If [force] is [false] (the default), other equivalences are considered, in particular between an enum and its representative integer type. @modify Fluorine-20130401 added [force] argument *) val need_cast: ?force:bool -> typ -> typ -> bool (** Construct a cast when having the old type of the expression. If the new type is the same as the old type, then no cast is added, unless [force] is [true] (default is [false]) @modify Fluorine-20130401 add [force] argument *) val mkCastT: ?force:bool -> e:exp -> oldt:typ -> newt:typ -> exp (** Like {!Cil.mkCastT} but uses typeOf to get [oldt] *) val mkCast: ?force:bool -> e:exp -> newt:typ -> exp (** Equivalent to [stripCasts] for terms. *) val stripTermCasts: term -> term (** Removes casts from this expression, but ignores casts within other expression constructs. So we delete the (A) and (B) casts from "(A)(B)(x + (C)y)", but leave the (C) cast. *) val stripCasts: exp -> exp (** Removes info wrappers and return underlying expression *) val stripInfo: exp -> exp (** Removes casts and info wrappers and return underlying expression *) val stripCastsAndInfo: exp -> exp (** Removes casts and info wrappers,except last info wrapper, and return underlying expression *) val stripCastsButLastInfo: exp -> exp (** Extracts term information in an expression information *) val exp_info_of_term: term -> exp_info (** Constructs a term from a term node and an expression information *) val term_of_exp_info: location -> term_node -> exp_info -> term (** Map some function on underlying expression if Info or else on expression *) val map_under_info: (exp -> exp) -> exp -> exp (** Apply some function on underlying expression if Info or else on expression *) val app_under_info: (exp -> unit) -> exp -> unit val typeOf: exp -> typ (** Compute the type of an expression. *) val typeOf_pointed : typ -> typ (** Returns the type pointed by the given type. Asserts it is a pointer type. *) val typeOf_array_elem : typ -> typ (** Returns the type of the array elements of the given type. Asserts it is an array type. *) val is_fully_arithmetic: typ -> bool (** Returns [true] whenever the type contains only arithmetic types *) (** Convert a string representing a C integer literal to an expression. Handles the prefixes 0x and 0 and the suffixes L, U, UL, LL, ULL. *) val parseInt: string -> Integer.t val parseIntExp: loc:location -> string -> exp val parseIntLogic: loc:location -> string -> term (** Convert a string representing a C integer literal to an expression. Handles the prefixes 0x and 0 and the suffixes L, U, UL, LL, ULL *) val appears_in_expr: varinfo -> exp -> bool (** @return true if the given variable appears in the expression. *) (**********************************************) (** {3 Values for manipulating statements} *) (**********************************************) (** Construct a statement, given its kind. Initialize the [sid] field to -1 if [valid_sid] is false (the default), or to a valid sid if [valid_sid] is true, and [labels], [succs] and [preds] to the empty list *) val mkStmt: ?ghost:bool -> ?valid_sid:bool -> stmtkind -> stmt (* make the [new_stmtkind] changing the CFG relatively to [ref_stmt] *) val mkStmtCfg: before:bool -> new_stmtkind:stmtkind -> ref_stmt:stmt -> stmt (** Construct a block with no attributes, given a list of statements *) val mkBlock: stmt list -> block (** Construct a block with no attributes, given a list of statements and wrap it into the Cfg. *) val mkStmtCfgBlock: stmt list -> stmt (** Construct a statement consisting of just one instruction See {!Cil.mkStmt} for the signification of the optional args. *) val mkStmtOneInstr: ?ghost:bool -> ?valid_sid:bool -> instr -> stmt (** Try to compress statements so as to get maximal basic blocks. * use this instead of List.@ because you get fewer basic blocks *) (*val compactStmts: stmt list -> stmt list*) (** Returns an empty statement (of kind [Instr]) *) val mkEmptyStmt: ?ghost:bool -> ?loc:location -> unit -> stmt (** A instr to serve as a placeholder *) val dummyInstr: instr (** A statement consisting of just [dummyInstr]. @plugin development guide *) val dummyStmt: stmt (** Make a while loop. Can contain Break or Continue *) val mkWhile: guard:exp -> body:stmt list -> stmt list (** Make a for loop for(i=start; i first:exp -> stopat:exp -> incr:exp -> body:stmt list -> stmt list (** Make a for loop for(start; guard; next) \{ ... \}. The body can contain Break but not Continue !!! *) val mkFor: start:stmt list -> guard:exp -> next: stmt list -> body: stmt list -> stmt list (** creates a block with empty attributes from an unspecified sequence. *) val block_from_unspecified_sequence: (stmt * lval list * lval list * lval list * stmt ref list) list -> block (* ************************************************************************* *) (** {2 Values for manipulating attributes} *) (* ************************************************************************* *) (** Various classes of attributes *) type attributeClass = AttrName of bool (** Attribute of a name. If argument is true and we are on MSVC then the attribute is printed using __declspec as part of the storage specifier *) | AttrFunType of bool (** Attribute of a function type. If argument is true and we are on MSVC then the attribute is printed just before the function name *) | AttrType (** Attribute of a type *) val register_shallow_attribute: string -> unit (** Register an attribute that will never be pretty printed. *) val registerAttribute: string -> attributeClass -> unit (** Add a new attribute with a specified class *) val removeAttribute: string -> unit (** Remove an attribute previously registered. *) val attributeClass: string -> attributeClass (** Return the class of an attributes. *) (** Partition the attributes into classes:name attributes, function type, and type attributes *) val partitionAttributes: default:attributeClass -> attributes -> attribute list * (* AttrName *) attribute list * (* AttrFunType *) attribute list (* AttrType *) (** Add an attribute. Maintains the attributes in sorted order of the second argument *) val addAttribute: attribute -> attributes -> attributes (** Add a list of attributes. Maintains the attributes in sorted order. The second argument must be sorted, but not necessarily the first *) val addAttributes: attribute list -> attributes -> attributes (** Remove all attributes with the given name. Maintains the attributes in sorted order. *) val dropAttribute: string -> attributes -> attributes (** Remove all attributes with names appearing in the string list. * Maintains the attributes in sorted order *) val dropAttributes: string list -> attributes -> attributes (** Remove attributes whose name appears in the first argument that are present anywhere in the fully expanded version of the type. @since Oxygen-20120901 *) val typeDeepDropAttributes: string list -> typ -> typ (** Remove any attribute appearing somewhere in the fully expanded version of the type. @since Oxygen-20120901 *) val typeDeepDropAllAttributes: typ -> typ (** Retains attributes with the given name *) val filterAttributes: string -> attributes -> attributes (** True if the named attribute appears in the attribute list. The list of attributes must be sorted. *) val hasAttribute: string -> attributes -> bool (** returns the complete name for an attribute annotation. *) val mkAttrAnnot: string -> string (** Returns the name of an attribute. *) val attributeName: attribute -> string (** Returns the list of parameters associated to an attribute. The list is empty if there is no such attribute or it has no parameters at all. *) val findAttribute: string -> attribute list -> attrparam list (** Returns all the attributes contained in a type. This requires a traversal of the type structure, in case of composite, enumeration and named types *) val typeAttrs: typ -> attribute list (** Returns the attributes of a type. *) val typeAttr: typ -> attribute list (** Sets the attributes of the type to the given list. Previous attributes are discarded. *) val setTypeAttrs: typ -> attributes -> typ (** Add some attributes to a type *) val typeAddAttributes: attribute list -> typ -> typ (** Remove all attributes with the given names from a type. Note that this does not remove attributes from typedef and tag definitions, just from their uses *) val typeRemoveAttributes: string list -> typ -> typ val typeHasAttributeDeep: string -> typ -> bool (** Does the type or one of its subtypes have the given attribute. Does not recurse through pointer types, nor inside function prototypes. @since Oxygen-20120901 *) (** Remove all attributes relative to const, volatile and restrict attributes @since Nitrogen-20111001 *) val type_remove_qualifier_attributes: typ -> typ (** Remove all attributes relative to const, volatile and restrict attributes when building a C cast @since Oxygen-20120901 *) val type_remove_attributes_for_c_cast: typ -> typ (** Remove all attributes relative to const, volatile and restrict attributes when building a logic cast @since Oxygen-20120901 *) val type_remove_attributes_for_logic_type: typ -> typ (** retains attributes corresponding to type qualifiers (6.7.3) *) val filter_qualifier_attributes: attributes -> attributes (** given some attributes on an array type, split them into those that belong to the type of the elements of the array (currently, qualifiers such as const and volatile), and those that must remain on the array, in that order @since Oxygen-20120901 *) val splitArrayAttributes: attributes -> attributes * attributes val bitfield_attribute_name: string (** Name of the attribute that is automatically inserted (with an [AINT size] argument when querying the type of a field that is a bitfield *) (** Convert an expression into an attrparam, if possible. Otherwise raise NotAnAttrParam with the offending subexpression *) val expToAttrParam: exp -> attrparam exception NotAnAttrParam of exp (* ************************************************************************* *) (** {2 The visitor} *) (* ************************************************************************* *) (** Different visiting actions. 'a will be instantiated with [exp], [instr], etc. @plugin development guide *) type 'a visitAction = | SkipChildren (** Do not visit the children. Return the node as it is. @plugin development guide *) | DoChildren (** Continue with the children of this node. Rebuild the node on return if any of the children changes (use == test). @plugin development guide *) | DoChildrenPost of ('a -> 'a) (** visit the children, and apply the given function to the result. @plugin development guide *) | JustCopy (** visit the children, but only to make the necessary copies (only useful for copy visitor). @plugin development guide *) | JustCopyPost of ('a -> 'a) (** same as JustCopy + applies the given function to the result. @plugin development guide*) | ChangeTo of 'a (** Replace the expression with the given one. @plugin development guide *) | ChangeToPost of 'a * ('a -> 'a) (** applies the expression to the function and gives back the result. Useful to insert some actions in an inheritance chain. @plugin development guide *) | ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire exp is replaced by the first parameter. Then continue with the children. On return rebuild the node if any of the children has changed and then apply the function on the node. @plugin development guide *) val mk_behavior : ?name:string -> ?assumes:('a list) -> ?requires:('a list) -> ?post_cond:((termination_kind * 'a) list) -> ?assigns:('b Cil_types.assigns ) -> ?allocation:('b Cil_types.allocation option) -> ?extended:((string * int * 'a list) list) -> unit -> ('a, 'b) Cil_types.behavior (** @since Carbon-20101201 returns a dummy behavior with the default name [Cil.default_behavior_name]. invariant: [b_assumes] must always be empty for behavior named [Cil.default_behavior_name] *) val default_behavior_name: string (** @since Carbon-20101201 *) val is_default_behavior: ('a,'b) behavior -> bool val find_default_behavior: funspec -> funbehavior option (** @since Carbon-20101201 *) val find_default_requires: ('a, 'b) behavior list -> 'a list (** @since Carbon-20101201 *) (* ************************************************************************* *) (** {2 Visitor mechanism} *) (* ************************************************************************* *) (** {3 Visitor behavior} *) type visitor_behavior (** How the visitor should behave in front of mutable fields: in place modification or copy of the structure. This type is abstract. Use one of the two values below in your classes. @plugin development guide *) val inplace_visit: unit -> visitor_behavior (** In-place modification. Behavior of the original cil visitor. @plugin development guide *) val copy_visit: Project.t -> visitor_behavior (** Makes fresh copies of the mutable structures. - preserves sharing for varinfo. - makes fresh copy of varinfo only for declarations. Variables that are only used in the visited AST are thus still shared with the original AST. This allows for instance to copy a function with its formals and local variables, and to keep the references to other globals in the function's body. @plugin development guide *) (** true iff the behavior is a copy behavior. *) val is_copy_behavior: visitor_behavior -> bool val reset_behavior_varinfo: visitor_behavior -> unit (** resets the internal tables used by the given visitor_behavior. If you use fresh instances of visitor for each round of transformation, this should not be needed. In place modifications do not need that at all. *) val reset_behavior_compinfo: visitor_behavior -> unit val reset_behavior_enuminfo: visitor_behavior -> unit val reset_behavior_enumitem: visitor_behavior -> unit val reset_behavior_typeinfo: visitor_behavior -> unit val reset_behavior_stmt: visitor_behavior -> unit val reset_behavior_logic_info: visitor_behavior -> unit val reset_behavior_logic_type_info: visitor_behavior -> unit val reset_behavior_fieldinfo: visitor_behavior -> unit val reset_behavior_model_info: visitor_behavior -> unit val reset_logic_var: visitor_behavior -> unit val reset_behavior_kernel_function: visitor_behavior -> unit val reset_behavior_fundec: visitor_behavior -> unit val get_varinfo: visitor_behavior -> varinfo -> varinfo (** retrieve the representative of a given varinfo in the current state of the visitor *) val get_compinfo: visitor_behavior -> compinfo -> compinfo val get_enuminfo: visitor_behavior -> enuminfo -> enuminfo val get_enumitem: visitor_behavior -> enumitem -> enumitem val get_typeinfo: visitor_behavior -> typeinfo -> typeinfo val get_stmt: visitor_behavior -> stmt -> stmt (** @plugin development guide *) val get_logic_info: visitor_behavior -> logic_info -> logic_info val get_logic_type_info: visitor_behavior -> logic_type_info -> logic_type_info val get_fieldinfo: visitor_behavior -> fieldinfo -> fieldinfo val get_model_info: visitor_behavior -> model_info -> model_info val get_logic_var: visitor_behavior -> logic_var -> logic_var val get_kernel_function: visitor_behavior -> kernel_function -> kernel_function (** @plugin development guide *) val get_fundec: visitor_behavior -> fundec -> fundec val get_original_varinfo: visitor_behavior -> varinfo -> varinfo (** retrieve the original representative of a given copy of a varinfo in the current state of the visitor. *) val get_original_compinfo: visitor_behavior -> compinfo -> compinfo val get_original_enuminfo: visitor_behavior -> enuminfo -> enuminfo val get_original_enumitem: visitor_behavior -> enumitem -> enumitem val get_original_typeinfo: visitor_behavior -> typeinfo -> typeinfo val get_original_stmt: visitor_behavior -> stmt -> stmt val get_original_logic_info: visitor_behavior -> logic_info -> logic_info val get_original_logic_type_info: visitor_behavior -> logic_type_info -> logic_type_info val get_original_fieldinfo: visitor_behavior -> fieldinfo -> fieldinfo val get_original_model_info: visitor_behavior -> model_info -> model_info val get_original_logic_var: visitor_behavior -> logic_var -> logic_var val get_original_kernel_function: visitor_behavior -> kernel_function -> kernel_function val get_original_fundec: visitor_behavior -> fundec -> fundec val set_varinfo: visitor_behavior -> varinfo -> varinfo -> unit (** change the representative of a given varinfo in the current state of the visitor. Use with care (i.e. makes sure that the old one is not referenced anywhere in the AST, or sharing will be lost. *) val set_compinfo: visitor_behavior -> compinfo -> compinfo -> unit val set_enuminfo: visitor_behavior -> enuminfo -> enuminfo -> unit val set_enumitem: visitor_behavior -> enumitem -> enumitem -> unit val set_typeinfo: visitor_behavior -> typeinfo -> typeinfo -> unit val set_stmt: visitor_behavior -> stmt -> stmt -> unit val set_logic_info: visitor_behavior -> logic_info -> logic_info -> unit val set_logic_type_info: visitor_behavior -> logic_type_info -> logic_type_info -> unit val set_fieldinfo: visitor_behavior -> fieldinfo -> fieldinfo -> unit val set_model_info: visitor_behavior -> model_info -> model_info -> unit val set_logic_var: visitor_behavior -> logic_var -> logic_var -> unit val set_kernel_function: visitor_behavior -> kernel_function -> kernel_function -> unit val set_fundec: visitor_behavior -> fundec -> fundec -> unit val set_orig_varinfo: visitor_behavior -> varinfo -> varinfo -> unit (** change the reference of a given new varinfo in the current state of the visitor. Use with care *) val set_orig_compinfo: visitor_behavior -> compinfo -> compinfo -> unit val set_orig_enuminfo: visitor_behavior -> enuminfo -> enuminfo -> unit val set_orig_enumitem: visitor_behavior -> enumitem -> enumitem -> unit val set_orig_typeinfo: visitor_behavior -> typeinfo -> typeinfo -> unit val set_orig_stmt: visitor_behavior -> stmt -> stmt -> unit val set_orig_logic_info: visitor_behavior -> logic_info -> logic_info -> unit val set_orig_logic_type_info: visitor_behavior -> logic_type_info -> logic_type_info -> unit val set_orig_fieldinfo: visitor_behavior -> fieldinfo -> fieldinfo -> unit val set_orig_model_info: visitor_behavior -> model_info -> model_info -> unit val set_orig_logic_var: visitor_behavior -> logic_var -> logic_var -> unit val set_orig_kernel_function: visitor_behavior -> kernel_function -> kernel_function -> unit val set_orig_fundec: visitor_behavior -> fundec -> fundec -> unit val memo_varinfo: visitor_behavior -> varinfo -> varinfo (** finds a binding in new project for the given varinfo, creating one if it does not already exists. *) val memo_compinfo: visitor_behavior -> compinfo -> compinfo val memo_enuminfo: visitor_behavior -> enuminfo -> enuminfo val memo_enumitem: visitor_behavior -> enumitem -> enumitem val memo_typeinfo: visitor_behavior -> typeinfo -> typeinfo val memo_stmt: visitor_behavior -> stmt -> stmt val memo_logic_info: visitor_behavior -> logic_info -> logic_info val memo_logic_type_info: visitor_behavior -> logic_type_info -> logic_type_info val memo_fieldinfo: visitor_behavior -> fieldinfo -> fieldinfo val memo_model_info: visitor_behavior -> model_info -> model_info val memo_logic_var: visitor_behavior -> logic_var -> logic_var val memo_kernel_function: visitor_behavior -> kernel_function -> kernel_function val memo_fundec: visitor_behavior -> fundec -> fundec (** [iter_visitor_varinfo vis f] iterates [f] over each pair of varinfo registered in [vis]. Varinfo for the old AST is presented to [f] first. @since Oxygen-20120901 *) val iter_visitor_varinfo: visitor_behavior -> (varinfo -> varinfo -> unit) -> unit val iter_visitor_compinfo: visitor_behavior -> (compinfo -> compinfo -> unit) -> unit val iter_visitor_enuminfo: visitor_behavior -> (enuminfo -> enuminfo -> unit) -> unit val iter_visitor_enumitem: visitor_behavior -> (enumitem -> enumitem -> unit) -> unit val iter_visitor_typeinfo: visitor_behavior -> (typeinfo -> typeinfo -> unit) -> unit val iter_visitor_stmt: visitor_behavior -> (stmt -> stmt -> unit) -> unit val iter_visitor_logic_info: visitor_behavior -> (logic_info -> logic_info -> unit) -> unit val iter_visitor_logic_type_info: visitor_behavior -> (logic_type_info -> logic_type_info -> unit) -> unit val iter_visitor_fieldinfo: visitor_behavior -> (fieldinfo -> fieldinfo -> unit) -> unit val iter_visitor_model_info: visitor_behavior -> (model_info -> model_info -> unit) -> unit val iter_visitor_logic_var: visitor_behavior -> (logic_var -> logic_var -> unit) -> unit val iter_visitor_kernel_function: visitor_behavior -> (kernel_function -> kernel_function -> unit) -> unit val iter_visitor_fundec: visitor_behavior -> (fundec -> fundec -> unit) -> unit (** [fold_visitor_varinfo vis f] folds [f] over each pair of varinfo registered in [vis]. Varinfo for the old AST is presented to [f] first. @since Oxygen-20120901 *) val fold_visitor_varinfo: visitor_behavior -> (varinfo -> varinfo -> 'a -> 'a) -> 'a -> 'a val fold_visitor_compinfo: visitor_behavior -> (compinfo -> compinfo -> 'a -> 'a) -> 'a -> 'a val fold_visitor_enuminfo: visitor_behavior -> (enuminfo -> enuminfo -> 'a -> 'a) -> 'a -> 'a val fold_visitor_enumitem: visitor_behavior -> (enumitem -> enumitem -> 'a -> 'a) -> 'a -> 'a val fold_visitor_typeinfo: visitor_behavior -> (typeinfo -> typeinfo -> 'a -> 'a) -> 'a -> 'a val fold_visitor_stmt: visitor_behavior -> (stmt -> stmt -> 'a -> 'a) -> 'a -> 'a val fold_visitor_logic_info: visitor_behavior -> (logic_info -> logic_info -> 'a -> 'a) -> 'a -> 'a val fold_visitor_logic_type_info: visitor_behavior -> (logic_type_info -> logic_type_info -> 'a -> 'a) -> 'a -> 'a val fold_visitor_fieldinfo: visitor_behavior -> (fieldinfo -> fieldinfo -> 'a -> 'a) -> 'a -> 'a val fold_visitor_model_info: visitor_behavior -> (model_info -> model_info -> 'a -> 'a) -> 'a -> 'a val fold_visitor_logic_var: visitor_behavior -> (logic_var -> logic_var -> 'a -> 'a) -> 'a -> 'a val fold_visitor_kernel_function: visitor_behavior -> (kernel_function -> kernel_function -> 'a -> 'a) -> 'a -> 'a val fold_visitor_fundec: visitor_behavior -> (fundec -> fundec -> 'a -> 'a) -> 'a -> 'a (** {3 Visitor class} *) (** A visitor interface for traversing CIL trees. Create instantiations of this type by specializing the class {!nopCilVisitor}. Each of the specialized visiting functions can also call the [queueInstr] to specify that some instructions should be inserted before the current instruction or statement. Use syntax like [self#queueInstr] to call a method associated with the current object. {b Important Note for Frama-C Users:} Unless you really know what you are doing, you should probably inherit from the {!Visitor.generic_frama_c_visitor} instead of {!genericCilVisitor} or {!nopCilVisitor} @plugin development guide *) class type cilVisitor = object method behavior: visitor_behavior (** the kind of behavior expected for the behavior. @plugin development guide *) method project: Project.t option (** Project the visitor operates on. Non-nil for copy visitor. @since Oxygen-20120901 *) method plain_copy_visitor: cilVisitor (** a visitor who only does copies of the nodes according to [behavior] *) method vfile: file -> file visitAction (** visit a whole file. *) method vvdec: varinfo -> varinfo visitAction (** Invoked for each variable declaration. The subtrees to be traversed are those corresponding to the type and attributes of the variable. Note that variable declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo] in formals of function types, and the formals and locals for function definitions. This means that the list of formals in a function definition will be traversed twice, once as part of the function type and second as part of the formals in a function definition. @plugin development guide *) method vvrbl: varinfo -> varinfo visitAction (** Invoked on each variable use. Here only the [SkipChildren] and [ChangeTo] actions make sense since there are no subtrees. Note that the type and attributes of the variable are not traversed for a variable use. @plugin development guide *) method vexpr: exp -> exp visitAction (** Invoked on each expression occurrence. The subtrees are the subexpressions, the types (for a [Cast] or [SizeOf] expression) or the variable use. @plugin development guide *) method vlval: lval -> lval visitAction (** Invoked on each lvalue occurrence *) method voffs: offset -> offset visitAction (** Invoked on each offset occurrence that is *not* as part of an initializer list specification, i.e. in an lval or recursively inside an offset. @plugin development guide *) method vinitoffs: offset -> offset visitAction (** Invoked on each offset appearing in the list of a CompoundInit initializer. *) method vinst: instr -> instr list visitAction (** Invoked on each instruction occurrence. The [ChangeTo] action can replace this instruction with a list of instructions *) method vstmt: stmt -> stmt visitAction (** Control-flow statement. The default [DoChildren] action does not create a new statement when the components change. Instead it updates the contents of the original statement. This is done to preserve the sharing with [Goto] and [Case] statements that point to the original statement. If you use the [ChangeTo] action then you should take care of preserving that sharing yourself. @plugin development guide *) method vblock: block -> block visitAction (** Block. *) method vfunc: fundec -> fundec visitAction (** Function definition. Replaced in place. *) method vglob: global -> global list visitAction (** Global (vars, types, etc.) @plugin development guide *) method vinit: varinfo -> offset -> init -> init visitAction (** Initializers for globals, pass the global where this occurs, and the offset *) method vtype: typ -> typ visitAction (** Use of some type. For typedef, struct, union and enum, the visit is done once at the global defining the type. Thus, children of [TComp], [TEnum] and [TNamed] are not visited again. *) method vcompinfo: compinfo -> compinfo visitAction (** declaration of a struct/union *) method venuminfo: enuminfo -> enuminfo visitAction (** declaration of an enumeration *) method vfieldinfo: fieldinfo -> fieldinfo visitAction (** visit the declaration of a field of a structure or union *) method venumitem: enumitem -> enumitem visitAction (** visit the declaration of an enumeration item *) method vattr: attribute -> attribute list visitAction (** Attribute. Each attribute can be replaced by a list *) method vattrparam: attrparam -> attrparam visitAction (** Attribute parameters. *) method queueInstr: instr list -> unit (** Add here instructions while visiting to queue them to preceede the current statement or instruction being processed. Use this method only when you are visiting an expression that is inside a function body, or a statement, because otherwise there will no place for the visitor to place your instructions. *) (** Gets the queue of instructions and resets the queue. This is done automatically for you when you visit statments. *) method unqueueInstr: unit -> instr list method current_stmt: stmt option (** link to the current statement being visited. {b NB:} for copy visitor, the stmt is the original one (use [get_stmt] to obtain the corresponding copy) @deprecated Carbon-20101201 use current_kinstr instead *) method current_kinstr: kinstr (** [Kstmt stmt] when visiting statement stmt, [Kglobal] when called outside of a statement. @since Carbon-20101201 @plugin development guide *) method push_stmt : stmt -> unit method pop_stmt : stmt -> unit method current_func: fundec option (** link to the current function being visited. {b NB:} for copy visitors, the fundec is the original one. *) method set_current_func: fundec -> unit method reset_current_func: unit -> unit method vlogic_type: logic_type -> logic_type visitAction method vmodel_info: model_info -> model_info visitAction method videntified_term: identified_term -> identified_term visitAction method vterm: term -> term visitAction method vterm_node: term_node -> term_node visitAction method vterm_lval: term_lval -> term_lval visitAction method vterm_lhost: term_lhost -> term_lhost visitAction method vterm_offset: term_offset -> term_offset visitAction method vlogic_label: logic_label -> logic_label visitAction method vlogic_info_decl: logic_info -> logic_info visitAction (** @plugin development guide *) method vlogic_info_use: logic_info -> logic_info visitAction (** @plugin development guide *) method vlogic_type_info_decl: logic_type_info -> logic_type_info visitAction (** @plugin development guide *) method vlogic_type_info_use: logic_type_info -> logic_type_info visitAction (** @plugin development guide *) method vlogic_type_def: logic_type_def -> logic_type_def visitAction method vlogic_ctor_info_decl: logic_ctor_info -> logic_ctor_info visitAction (** @plugin development guide *) method vlogic_ctor_info_use: logic_ctor_info -> logic_ctor_info visitAction (** @plugin development guide *) method vlogic_var_decl: logic_var -> logic_var visitAction (** @plugin development guide *) method vlogic_var_use: logic_var -> logic_var visitAction (** @plugin development guide *) method vquantifiers: quantifiers -> quantifiers visitAction method videntified_predicate: identified_predicate -> identified_predicate visitAction (** @since Fluorine-20130401 the child of an identified predicate is treated as a predicate named: if you wish to modify names, you only have to override vpredicate_named, not both videntified_predicate and vpredicate_named. *) method vpredicate: predicate -> predicate visitAction method vpredicate_named: predicate named -> predicate named visitAction method vbehavior: funbehavior -> funbehavior visitAction method vspec: funspec -> funspec visitAction method vassigns: identified_term assigns -> identified_term assigns visitAction method vfrees: identified_term list -> identified_term list visitAction (** @since Oxygen-20120901 *) method vallocates: identified_term list -> identified_term list visitAction (** @since Oxygen-20120901 *) method vallocation: identified_term allocation -> identified_term allocation visitAction (** @since Oxygen-20120901 *) method vloop_pragma: term loop_pragma -> term loop_pragma visitAction method vslice_pragma: term slice_pragma -> term slice_pragma visitAction method vimpact_pragma: term impact_pragma -> term impact_pragma visitAction method vdeps: identified_term deps -> identified_term deps visitAction method vfrom: identified_term from -> identified_term from visitAction method vcode_annot: code_annotation -> code_annotation visitAction method vannotation: global_annotation -> global_annotation visitAction method fill_global_tables: unit (** fill the global environment tables at the end of a full copy in a new project. @plugin development guide *) method get_filling_actions: (unit -> unit) Queue.t (** get the queue of actions to be performed at the end of a full copy. @plugin development guide *) end (**/**) class internal_genericCilVisitor: fundec option ref -> visitor_behavior -> (unit->unit) Queue.t -> cilVisitor (**/**) (** generic visitor, parameterized by its copying behavior. Traverses the CIL tree without modifying anything *) class genericCilVisitor: visitor_behavior -> cilVisitor (** Default in place visitor doing nothing and operating on current project. *) class nopCilVisitor: cilVisitor (** {3 Generic visit functions} *) (** [doVisit vis deepCopyVisitor copy action children node] visits a [node] (or its copy according to the result of [copy]) and if needed its [children]. {b Do not use it if you don't understand Cil visitor mechanism} @param vis the visitor performing the needed transformations. The open type allows for extensions to Cil to be visited by the same mechanisms. @param deepCopyVisitor a generator for a visitor of the same type of the current one that performs a deep copy of the AST. Needed when the visitAction is [SkipChildren] or [ChangeTo] and [vis] is a copy visitor (we need to finish the copy anyway) @param copy function that may return a copy of the actual node. @param action the visiting function for the current node @param children what to do on the children of the current node @param node the current node *) val doVisit: 'visitor -> 'visitor -> ('a -> 'a) -> ('a -> 'a visitAction) -> ('visitor -> 'a -> 'a) -> 'a -> 'a (** same as above, but can return a list of nodes *) val doVisitList: 'visitor -> 'visitor -> ('a -> 'a) -> ('a -> 'a list visitAction) -> ('visitor -> 'a -> 'a) -> 'a -> 'a list (* other cil constructs *) (** {3 Visitor's entry points} *) (** Visit a file. This will will re-cons all globals TWICE (so that it is * tail-recursive). Use {!Cil.visitCilFileSameGlobals} if your visitor will * not change the list of globals. @plugin development guide *) val visitCilFileCopy: cilVisitor -> file -> file (** Same thing, but the result is ignored. The given visitor must thus be an inplace visitor. Nothing is done if the visitor is a copy visitor. @plugin development guide *) val visitCilFile: cilVisitor -> file -> unit (** A visitor for the whole file that does not change the globals (but maybe * changes things inside the globals). Use this function instead of * {!Cil.visitCilFile} whenever appropriate because it is more efficient for * long files. @plugin development guide *) val visitCilFileSameGlobals: cilVisitor -> file -> unit (** Visit a global *) val visitCilGlobal: cilVisitor -> global -> global list (** Visit a function definition *) val visitCilFunction: cilVisitor -> fundec -> fundec (* Visit an expression *) val visitCilExpr: cilVisitor -> exp -> exp val visitCilEnumInfo: cilVisitor -> enuminfo -> enuminfo (** Visit an lvalue *) val visitCilLval: cilVisitor -> lval -> lval (** Visit an lvalue or recursive offset *) val visitCilOffset: cilVisitor -> offset -> offset (** Visit an initializer offset *) val visitCilInitOffset: cilVisitor -> offset -> offset (** Visit an instruction *) val visitCilInstr: cilVisitor -> instr -> instr list (** Visit a statement *) val visitCilStmt: cilVisitor -> stmt -> stmt (** Visit a block *) val visitCilBlock: cilVisitor -> block -> block (** Visit a type *) val visitCilType: cilVisitor -> typ -> typ (** Visit a variable declaration *) val visitCilVarDecl: cilVisitor -> varinfo -> varinfo (** Visit an initializer, pass also the global to which this belongs and the * offset. *) val visitCilInit: cilVisitor -> varinfo -> offset -> init -> init (** Visit a list of attributes *) val visitCilAttributes: cilVisitor -> attribute list -> attribute list val visitCilAnnotation: cilVisitor -> global_annotation -> global_annotation val visitCilCodeAnnotation: cilVisitor -> code_annotation -> code_annotation val visitCilDeps: cilVisitor -> identified_term deps -> identified_term deps val visitCilFrom: cilVisitor -> identified_term from -> identified_term from val visitCilAssigns: cilVisitor -> identified_term assigns -> identified_term assigns (** @since Oxygen-20120901 *) val visitCilFrees: cilVisitor -> identified_term list -> identified_term list (** @since Oxygen-20120901 *) val visitCilAllocates: cilVisitor -> identified_term list -> identified_term list (** @since Oxygen-20120901 *) val visitCilAllocation: cilVisitor -> identified_term allocation -> identified_term allocation val visitCilFunspec: cilVisitor -> funspec -> funspec val visitCilBehavior: cilVisitor -> funbehavior -> funbehavior val visitCilBehaviors: cilVisitor -> funbehavior list -> funbehavior list (** visit an extended clause of a behavior. @since Nitrogen-20111001 *) val visitCilExtended: cilVisitor -> (string * int * identified_predicate list) -> (string * int * identified_predicate list) val visitCilModelInfo: cilVisitor -> model_info -> model_info val visitCilLogicType: cilVisitor -> logic_type -> logic_type val visitCilIdPredicate: cilVisitor -> identified_predicate -> identified_predicate val visitCilPredicate: cilVisitor -> predicate -> predicate val visitCilPredicateNamed: cilVisitor -> predicate named -> predicate named val visitCilPredicates: cilVisitor -> identified_predicate list -> identified_predicate list val visitCilTerm: cilVisitor -> term -> term (** visit identified_term. @since Oxygen-20120901 *) val visitCilIdTerm: cilVisitor -> identified_term -> identified_term (** visit term_lval. @since Nitrogen-20111001 *) val visitCilTermLval: cilVisitor -> term_lval -> term_lval val visitCilTermLhost: cilVisitor -> term_lhost -> term_lhost val visitCilTermOffset: cilVisitor -> term_offset -> term_offset val visitCilLogicInfo: cilVisitor -> logic_info -> logic_info val visitCilLogicVarUse: cilVisitor -> logic_var -> logic_var val visitCilLogicVarDecl: cilVisitor -> logic_var -> logic_var (** {3 Visiting children of a node} *) val childrenBehavior: cilVisitor -> funbehavior -> funbehavior (* And some generic visitors. The above are built with these *) (* ************************************************************************* *) (** {2 Utility functions} *) (* ************************************************************************* *) val is_skip: stmtkind -> bool (** A visitor that does constant folding. Pass as argument whether you want * machine specific simplifications to be done, or not. *) val constFoldVisitor: bool -> cilVisitor (** Return the string 's' if we're printing output for gcc, suppres * it if we're printing for CIL to parse back in. the purpose is to * hide things from gcc that it complains about, but still be able * to do lossless transformations when CIL is the consumer *) val forgcc: string -> string (* ************************************************************************* *) (** {2 Debugging support} *) (* ************************************************************************* *) (** A reference to the current location. If you are careful to set this to * the current location then you can use some built-in logging functions that * will print the location. *) module CurrentLoc: State_builder.Ref with type data = location (** Pretty-print the [(Cil.CurrentLoc.get ())] *) val pp_thisloc: Format.formatter -> unit (** A reference to the current global being visited *) val currentGlobal: global ref (** @return a dummy specification *) val empty_funspec : unit -> funspec (** @return true if the given spec is empty. *) val is_empty_funspec: funspec -> bool (** @return true if the given behavior is empty. *) val is_empty_behavior: funbehavior -> bool (* ************************************************************************* *) (** {2 ALPHA conversion} has been moved to the Alpha module. *) (* ************************************************************************* *) (** Assign unique names to local variables. This might be necessary after you transformed the code and added or renamed some new variables. Names are not used by CIL internally, but once you print the file out the compiler downstream might be confused. You might have added a new global that happens to have the same name as a local in some function. Rename the local to ensure that there would never be confusioin. Or, viceversa, you might have added a local with a name that conflicts with a global *) val uniqueVarNames: file -> unit (* ************************************************************************* *) (** {2 Optimization Passes} *) (* ************************************************************************* *) (** A peephole optimizer that processes two adjacent statements and possibly replaces them both. If some replacement happens and [agressive] is true, then the new statements are themselves subject to optimization. Each statement in the list is optimized independently. *) val peepHole2: agressive:bool -> (stmt * stmt -> stmt list option) -> stmt list -> stmt list (** Similar to [peepHole2] except that the optimization window consists of one statement, not two *) val peepHole1: (instr -> instr list option) -> stmt list -> unit (* ************************************************************************* *) (** {2 Machine dependency} *) (* ************************************************************************* *) (** Raised when one of the bitsSizeOf functions cannot compute the size of a type. This can happen because the type contains array-length expressions that we don't know how to compute or because it is a type whose size is not defined (e.g. TFun or an undefined compinfo). The string is an explanation of the error *) exception SizeOfError of string * typ (** Create a fresh size cache with [Not_Computed] *) val empty_size_cache : unit -> bitsSizeofTypCache (** Give the unsigned kind corresponding to any integer kind *) val unsignedVersionOf : ikind -> ikind (** The signed integer kind for a given size (unsigned if second argument * is true). Raises Not_found if no such kind exists *) val intKindForSize : int -> bool -> ikind (** The float kind for a given size. Raises Not_found * if no such kind exists *) val floatKindForSize : int-> fkind (** The size of a type, in bits. Trailing padding is added for structs and * arrays. Raises {!Cil.SizeOfError} when it cannot compute the size. This * function is architecture dependent, so you should only call this after you * call {!Cil.initCIL}. Remember that on GCC sizeof(void) is 1! *) val bitsSizeOf: typ -> int (** Returns the number of bytes (resp. bits) to represent the given integer kind depending on the current machdep. *) val bytesSizeOfInt: ikind -> int val bitsSizeOfInt: ikind -> int (** Returns the signedness of the given integer kind depending on the current machdep. *) val isSigned: ikind -> bool (** Returns a unique number representing the integer conversion rank. *) val rank: ikind -> int (** [intTypeIncluded i1 i2] returns [true] iff the range of values representable in [i1] is included in the one of [i2] *) val intTypeIncluded: ikind -> ikind -> bool (** Returns a unique number representing the floating-point conversion rank. @since Oxygen-20120901 *) val frank: fkind -> int (** Represents an integer as for a given kind. * Returns a flag saying whether the value was changed * during truncation (because it was too large to fit in k). *) val truncateInteger64: ikind -> Integer.t -> Integer.t * bool (** Returns the maximal value representable in a signed integer type of the given size (in bits) *) val max_signed_number: int -> Integer.t (** Returns the smallest value representable in a signed integer type of the given size (in bits) *) val min_signed_number: int -> Integer.t (** Returns the maximal value representable in a unsigned integer type of the given size (in bits) *) val max_unsigned_number: int -> Integer.t (** True if the integer fits within the kind's range *) val fitsInInt: ikind -> Integer.t -> bool (** Return the smallest kind that will hold the integer's value. The kind will be unsigned if the 2nd argument is true. @raise Not_found if the bigint is not representable. *) val intKindForValue: Integer.t -> bool -> ikind (** The size of a type, in bytes. Returns a constant expression or a "sizeof" * expression if it cannot compute the size. This function is architecture * dependent, so you should only call this after you call {!Cil.initCIL}. *) val sizeOf: loc:location -> typ -> exp exception SizeOfError of string * typ (** [SizeOfError(reason, typ)] is raised when the size of [typ] for some [reason] *) (** The size of a type, in bytes. Raises {!Cil.SizeOfError} when it cannot compute the size. *) val sizeOf_int: typ -> int (** The minimum alignment (in bytes) for a type. This function is * architecture dependent, so you should only call this after you call * {!Cil.initCIL}. *) val bytesAlignOf: typ -> int (** Give a type of a base and an offset, returns the number of bits from the * base address and the width (also expressed in bits) for the subobject * denoted by the offset. Raises {!Cil.SizeOfError} when it cannot compute * the size. This function is architecture dependent, so you should only call * this after you call {!Cil.initCIL}. *) val bitsOffset: typ -> offset -> int * int (** Generate an {!Cil_types.exp} to be used in case of errors. *) val dExp:string -> exp (** Generate an {!Cil_types.instr} to be used in case of errors. *) val dInstr: string -> location -> instr (** Generate a {!Cil_types.global} to be used in case of errors. *) val dGlobal: string -> location -> global (** Like map but try not to make a copy of the list *) val mapNoCopy: ('a -> 'a) -> 'a list -> 'a list (** same as mapNoCopy for options*) val optMapNoCopy: ('a -> 'a) -> 'a option -> 'a option (** Like map but each call can return a list. Try not to make a copy of the list *) val mapNoCopyList: ('a -> 'a list) -> 'a list -> 'a list (** sm: return true if the first is a prefix of the second string *) val startsWith: string -> string -> bool (* ************************************************************************* *) (** {2 An Interpreter for constructing CIL constructs} *) (* ************************************************************************* *) (** The type of argument for the interpreter *) type formatArg = Fe of exp | Feo of exp option (** For array lengths *) | Fu of unop | Fb of binop | Fk of ikind | FE of exp list (** For arguments in a function call *) | Ff of (string * typ * attributes) (** For a formal argument *) | FF of (string * typ * attributes) list (** For formal argument lists *) | Fva of bool (** For the ellipsis in a function type *) | Fv of varinfo | Fl of lval | Flo of lval option | Fo of offset | Fc of compinfo | Fi of instr | FI of instr list | Ft of typ | Fd of int | Fg of string | Fs of stmt | FS of stmt list | FA of attributes | Fp of attrparam | FP of attrparam list | FX of string val d_formatarg : Format.formatter -> formatArg -> unit (* ************************************************************************* *) (** {2 Misc} *) (* ************************************************************************* *) val stmt_of_instr_list : ?loc:location -> instr list -> stmtkind (** Convert a C variable into the corresponding logic variable. The returned logic variable is unique for a given C variable. *) val cvar_to_lvar : varinfo -> logic_var (** Make a temporary variable to use in annotations *) val make_temp_logic_var: logic_type -> logic_var (** The constant logic term zero. @plugin development guide *) val lzero : ?loc:location -> unit -> term (** The constant logic term 1. *) val lone : ?loc:location -> unit -> term (** The constant logic term -1. *) val lmone : ?loc:location -> unit -> term (** The given constant logic term *) val lconstant : ?loc:location -> Integer.t -> term (** Bind all free variables with an universal quantifier *) val close_predicate : predicate named -> predicate named (** extract [varinfo] elements from an [exp] *) val extract_varinfos_from_exp : exp -> Varinfo.Set.t (** extract [varinfo] elements from an [lval] *) val extract_varinfos_from_lval : lval -> Varinfo.Set.t (** extract [logic_var] elements from a [term] *) val extract_free_logicvars_from_term : term -> Logic_var.Set.t (** extract [logic_var] elements from a [predicate] *) val extract_free_logicvars_from_predicate : predicate named -> Logic_var.Set.t (** extract [logic_label] elements from a [code_annotation] *) val extract_labels_from_annot: code_annotation -> Cil_datatype.Logic_label.Set.t (** extract [logic_label] elements from a [term] *) val extract_labels_from_term: term -> Cil_datatype.Logic_label.Set.t (** extract [logic_label] elements from a [pred] *) val extract_labels_from_pred: predicate named -> Cil_datatype.Logic_label.Set.t (** extract [stmt] elements from [logic_label] elements *) val extract_stmts_from_labels: Cil_datatype.Logic_label.Set.t -> Cil_datatype.Stmt.Set.t (** creates a visitor that will replace in place uses of var in the first list by their counterpart in the second list. @raise Invalid_argument if the lists have different lengths. *) val create_alpha_renaming: varinfo list -> varinfo list -> cilVisitor (** Provided [s] is a switch, [separate_switch_succs s] returns the subset of [s.succs] that correspond to the labels of [s], and an optional statement that is [None] if the switch has a default label, or [Some s'] where [s'] is the syntactic successor of [s] otherwise *) val separate_switch_succs: stmt -> stmt list * stmt option (**/**) val register_ast_dependencies : State.t -> unit (** Used to postpone some dependencies on [Ast.self], which is initialized afterwards. *) val pp_typ_ref: (Format.formatter -> typ -> unit) ref val pp_global_ref: (Format.formatter -> global -> unit) ref val pp_exp_ref: (Format.formatter -> exp -> unit) ref val pp_lval_ref: (Format.formatter -> lval -> unit) ref val pp_ikind_ref: (Format.formatter -> ikind -> unit) ref val pp_attribute_ref: (Format.formatter -> attribute -> unit) ref val pp_attributes_ref: (Format.formatter -> attribute list -> unit) ref (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/cil/src/rmtmps.ml0000644000175000017500000006373612155630367017236 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) let level=666 open Extlib open Cil_types open Cil module H = Hashtbl (* Set on the command-line: *) let keepUnused = ref false let rmUnusedInlines = ref false let rmUnusedStatic = ref false (*********************************************************************** * * Clearing of "referenced" bits * *) let clearReferencedBits file = let considerGlobal global = match global with | GType (info, _) -> (*trace (dprintf "clearing mark: %a\n" d_shortglobal global);*) info.treferenced <- false | GEnumTag (info, _) | GEnumTagDecl (info, _) -> Kernel.debug ~level "clearing mark: %a" Cil_printer.pp_global global; info.ereferenced <- false | GCompTag (info, _) | GCompTagDecl (info, _) -> (*trace (dprintf "clearing mark: %a\n" d_shortglobal global);*) info.creferenced <- false | GVar ({vname = _name} as info, _, _) | GVarDecl (_,({vname = _name} as info), _) -> (*trace (dprintf "clearing mark: %a\n" d_shortglobal global);*) info.vreferenced <- false | GFun ({svar = info} as func, _) -> (*trace (dprintf "clearing mark: %a\n" d_shortglobal global);*) info.vreferenced <- false; let clearMark local = (*trace (dprintf "clearing mark: local %s\n" local.vname);*) local.vreferenced <- false in List.iter clearMark func.slocals | _ -> () in iterGlobals file considerGlobal (*********************************************************************** * * Scanning and categorization of pragmas * *) (* collections of names of things to keep *) type collection = (string, unit) H.t type keepers = { typedefs : collection; enums : collection; structs : collection; unions : collection; defines : collection; } (* rapid transfer of control when we find a malformed pragma *) exception Bad_pragma let ccureddeepcopystring = "ccureddeepcopy" (* Save this length so we don't recompute it each time. *) let ccureddeepcopystring_length = String.length ccureddeepcopystring (* CIL and CCured define several pragmas which prevent removal of * various global varinfos. Here we scan for those pragmas and build * up collections of the corresponding varinfos' names. *) let categorizePragmas file = (* names of things which should be retained *) let keepers = { typedefs = H.create 1; enums = H.create 1; structs = H.create 1; unions = H.create 1; defines = H.create 1 } in (* populate these name collections in light of each pragma *) let considerPragma = let badPragma location pragma = Kernel.warning ~source:location "Invalid argument to pragma %s" pragma in function | GPragma (Attr ("cilnoremove" as directive, args), (location,_)) -> (* a very flexible pragma: can retain typedefs, enums, * structs, unions, or globals (functions or variables) *) begin let processArg arg = try match arg with | AStr specifier -> (* isolate and categorize one varinfo name *) let collection, name = (* Two words denotes a typedef, enum, struct, or * union, as in "type foo" or "enum bar". A * single word denotes a global function or * variable. *) let whitespace = Str.regexp "[ \t]+" in let words = Str.split whitespace specifier in match words with | ["type"; name] -> keepers.typedefs, name | ["enum"; name] -> keepers.enums, name | ["struct"; name] -> keepers.structs, name | ["union"; name] -> keepers.unions, name | [name] -> keepers.defines, name | _ -> raise Bad_pragma in H.add collection name () | _ -> raise Bad_pragma with Bad_pragma -> badPragma location directive in List.iter processArg args end | GVarDecl (_,v, _) -> begin (* Look for alias attributes, e.g. Linux modules *) match filterAttributes "alias" v.vattr with | [] -> () (* ordinary prototype. *) | [ Attr("alias", [AStr othername]) ] -> H.add keepers.defines othername () | _ -> Kernel.fatal ~current:true "Bad alias attribute at %a" Cil_printer.pp_location (CurrentLoc.get ()) end (*** Begin CCured-specific checks: ***) (* these pragmas indirectly require that we keep the function named in -- the first arguments of boxmodelof and ccuredwrapperof, and -- the third argument of ccureddeepcopy*. *) | GPragma (Attr("ccuredwrapper" as directive, attribute :: _), (location,_)) -> begin match attribute with | AStr name -> H.add keepers.defines name () | _ -> badPragma location directive end | GPragma (Attr("ccuredvararg", _funcname :: (ASizeOf t) :: _), _location) -> begin match t with | TComp(c,_,_) when c.cstruct -> (* struct *) H.add keepers.structs c.cname () | TComp(c,_,_) -> (* union *) H.add keepers.unions c.cname () | TNamed(ti,_) -> H.add keepers.typedefs ti.tname () | TEnum(ei, _) -> H.add keepers.enums ei.ename () | _ -> () end | GPragma (Attr(directive, _ :: _ :: attribute :: _), (location,_)) when String.length directive > ccureddeepcopystring_length && (Str.first_chars directive ccureddeepcopystring_length) = ccureddeepcopystring -> begin match attribute with | AStr name -> H.add keepers.defines name () | _ -> badPragma location directive end (** end CCured-specific stuff **) | _ -> () in iterGlobals file considerPragma; keepers (*********************************************************************** * * Root collection from pragmas * *) let isPragmaRoot keepers = function | GType ({tname = name}, _) -> H.mem keepers.typedefs name | GEnumTag ({ename = name}, _) | GEnumTagDecl ({ename = name}, _) -> H.mem keepers.enums name | GCompTag ({cname = name; cstruct = structure}, _) | GCompTagDecl ({cname = name; cstruct = structure}, _) -> let collection = if structure then keepers.structs else keepers.unions in H.mem collection name | GVar ({vname = name; vattr = attrs}, _, _) | GVarDecl (_,{vname = name; vattr = attrs}, _) | GFun ({svar = {vname = name; vattr = attrs}}, _) -> H.mem keepers.defines name || hasAttribute "used" attrs | _ -> false (*********************************************************************** * * Common root collecting utilities * *) (*TODO:remove let traceRoot _reason _global = (* trace (dprintf "root (%s): %a@!" reason d_shortglobal global);*) true let traceNonRoot _reason _global = (* trace (dprintf "non-root (%s): %a@!" reason d_shortglobal global);*) false *) let hasExportingAttribute funvar = let isExportingAttribute = function | Attr ("constructor", []) -> true | Attr ("destructor", []) -> true | _ -> false in List.exists isExportingAttribute funvar.vattr (*********************************************************************** * * Root collection from external linkage * *) (* Exported roots are those global varinfos which are visible to the * linker and dynamic loader. For variables, this consists of * anything that is not "static". For functions, this consists of: * * - functions bearing a "constructor" or "destructor" attribute * - functions declared extern but not inline * - functions declared neither inline nor static * - the function named "main" * gcc incorrectly (according to C99) makes inline functions visible to * the linker. So we can only remove inline functions on MSVC. *) let isExportedRoot global = let result, _reason = match global with | GVar ({vstorage = Static}, _, _) -> false, "static variable" | GVar _ -> true, "non-static variable" | GFun ({svar = v}, _) -> begin if hasExportingAttribute v then true, "constructor or destructor function" else if v.vstorage = Static then not !rmUnusedStatic, "static function" else if v.vinline && v.vstorage != Extern && (theMachine.msvcMode || !rmUnusedInlines) then false, "inline function" else true, "other function" end | GVarDecl(_,v,_) when hasAttribute "alias" v.vattr -> true, "has GCC alias attribute" | GAnnot _ -> true, "global annotation" | _ -> false, "neither function nor variable nor annotation" in (* trace (dprintf "isExportedRoot %a -> %b, %s@!" d_shortglobal global result reason);*) result (*********************************************************************** * * Root collection for complete programs * *) (* Exported roots are "main()" and functions bearing a "constructor" * or "destructor" attribute. These are the only things which must be * retained in a complete program. *) let isCompleteProgramRoot global = let result = match global with | GFun ({svar = {vname = "main"; vstorage = vstorage}}, _) -> vstorage <> Static | GFun (fundec, _) when hasExportingAttribute fundec.svar -> true | _ -> false in (* trace (dprintf "complete program root -> %b for %a@!" result d_shortglobal global);*) result (*********************************************************************** * * Transitive reachability closure from roots * *) (* This visitor recursively marks all reachable types and variables as used. *) class markReachableVisitor ((globalMap: (string, Cil_types.global) H.t), (currentFunc: Cil_types.fundec option ref)) = object (self) inherit nopCilVisitor method vglob = function | GType (typeinfo, _) -> typeinfo.treferenced <- true; DoChildren | GCompTag (compinfo, _) | GCompTagDecl (compinfo, _) -> compinfo.creferenced <- true; DoChildren | GEnumTag (enuminfo, _) | GEnumTagDecl (enuminfo, _) -> enuminfo.ereferenced <- true; DoChildren | GVar (varinfo, _, _) | GVarDecl (_,varinfo, _) | GFun ({svar = varinfo}, _) -> if not (hasAttribute "FC_BUILTIN" varinfo.vattr) then varinfo.vreferenced <- true; DoChildren | GAnnot _ -> DoChildren | _ -> SkipChildren method vinst = function Asm (_, tmpls, _, _, _, _) when theMachine.msvcMode -> (* If we have inline assembly on MSVC, we cannot tell which locals * are referenced. Keep thsem all *) (match !currentFunc with Some fd -> List.iter (fun v -> let vre = Str.regexp_string (Str.quote v.vname) in if List.exists (fun tmp -> try ignore (Str.search_forward vre tmp 0); true with Not_found -> false) tmpls then v.vreferenced <- true) fd.slocals | _ -> assert false); DoChildren | Call (None, {enode = Lval(Var {vname = name; vinline = true}, NoOffset)}, args,loc) -> let glob = Hashtbl.find globalMap name in begin match glob with GFun ({sbody = {bstmts = [] | [{skind = Return (None,_)}]}},_) -> if false then ChangeTo [Asm ([],["nop"],[],List.map (fun e -> None,"q",e) args ,[],loc)] else ChangeTo [] | _ -> DoChildren end | _ -> DoChildren method vvrbl v = if not v.vreferenced then begin let name = v.vname in if v.vglob then Kernel.debug ~level "marking transitive use: global %s" name else Kernel.debug ~level "marking transitive use: local %s" name; (* If this is a global, we need to keep everything used in its * definition and declarations. *) v.vreferenced <- true; if v.vglob then begin Kernel.debug ~level "descending: global %s" name; let descend global = ignore (visitCilGlobal (self :> cilVisitor) global) in let globals = Hashtbl.find_all globalMap name in List.iter descend globals end end; SkipChildren method private mark_enum e = if not e.ereferenced then begin Kernel.debug ~level "marking transitive use: enum %s\n" e.ename; e.ereferenced <- true; self#visitAttrs e.eattr; (* Must visit the value attributed to the enum constants *) ignore (visitCilEnumInfo (self:>cilVisitor) e); end else Kernel.debug ~level "not marking transitive use: enum %s\n" e.ename; method vexpr e = match e.enode with Const (CEnum {eihost = ei}) -> self#mark_enum ei; DoChildren | _ -> DoChildren method vterm_node t = match t with TConst (LEnum {eihost = ei}) -> self#mark_enum ei; DoChildren | _ -> DoChildren method private visitAttrs attrs = ignore (visitCilAttributes (self :> cilVisitor) attrs) method vtype typ = (match typ with | TEnum(e, attrs) -> self#visitAttrs attrs; self#mark_enum e | TComp(c, _, attrs) -> let old = c.creferenced in if not old then begin Kernel.debug ~level "marking transitive use: compound %s\n" c.cname; c.creferenced <- true; (* to recurse, we must ask explicitly *) let recurse f = ignore (self#vtype f.ftype) in List.iter recurse c.cfields; self#visitAttrs attrs; self#visitAttrs c.cattr end; | TNamed(ti, attrs) -> let old = ti.treferenced in if not old then begin Kernel.debug ~level "marking transitive use: typedef %s\n" ti.tname; ti.treferenced <- true; (* recurse deeper into the type referred-to by the typedef *) (* to recurse, we must ask explicitly *) ignore (self#vtype ti.ttype); self#visitAttrs attrs end; | TVoid a | TInt (_,a) | TFloat (_,a) | TBuiltin_va_list a -> self#visitAttrs a | TPtr(ty,a) -> ignore (self#vtype ty); self#visitAttrs a | TArray(ty,sz, _, a) -> ignore (self#vtype ty); self#visitAttrs a; Extlib.may (ignore $ (visitCilExpr (self:>cilVisitor))) sz | TFun (ty, args,_,a) -> ignore (self#vtype ty); Extlib.may (List.iter (fun (_,ty,_) -> ignore (self#vtype ty))) args; self#visitAttrs a ); SkipChildren end let markReachable file isRoot = (* build a mapping from global names back to their definitions & * declarations *) let globalMap = Hashtbl.create 137 in let considerGlobal global = match global with | GFun ({svar = info}, _) | GVar (info, _, _) | GVarDecl (_,info, _) -> Hashtbl.add globalMap info.vname global | _ -> () in iterGlobals file considerGlobal; let currentFunc = ref None in (* mark everything reachable from the global roots *) let visitor = new markReachableVisitor (globalMap, currentFunc) in let visitIfRoot global = if isRoot global then begin (* trace (dprintf "traversing root global: %a\n" d_shortglobal global);*) (match global with GFun(fd, _) -> currentFunc := Some fd | _ -> currentFunc := None); ignore (visitCilGlobal visitor global) end else (* trace (dprintf "skipping non-root global: %a\n" d_shortglobal global)*) () in iterGlobals file visitIfRoot (********************************************************************** * * Marking and removing of unused labels * **********************************************************************) (* We keep only one label, preferably one that was not introduced by CIL. * Scan a list of labels and return the data for the label that should be * kept, and the remaining filtered list of labels *) let labelsToKeep is_removable ll = let rec loop sofar = function [] -> sofar, [] | l :: rest -> let newlabel, keepl = match l with | Case _ | Default _ -> sofar, true | Label (ln, _, _) as lab -> begin match is_removable lab, sofar with | true, ("", _) -> (* keep this one only if we have no label so far *) (ln, lab), false | true, _ -> sofar, false | false, (_, lab') when is_removable lab' -> (* this is an original label; prefer it to temporary or * missing labels *) (ln, lab), false | false, _ -> sofar, false end in let newlabel', rest' = loop newlabel rest in newlabel', (if keepl then l :: rest' else rest') in loop ("", Label("", Cil_datatype.Location.unknown, false)) ll class markUsedLabels is_removable (labelMap: (string, unit) H.t) = let keep_label dest = let (ln, _), _ = labelsToKeep is_removable !dest.labels in if ln = "" then Kernel.fatal "Statement has no label:@\n%a" Cil_printer.pp_stmt !dest ; (* Mark it as used *) H.replace labelMap ln () in let keep_label_logic = function LogicLabel _ -> () | StmtLabel dest -> keep_label dest in object inherit nopCilVisitor method vstmt (s: stmt) = match s.skind with Goto (dest, _) -> keep_label dest; DoChildren | _ -> DoChildren method vterm_node t = begin match t with | Tat (_,lab) -> keep_label_logic lab | Tapp(_,labs,_) -> let labs = snd (List.split labs) in List.iter keep_label_logic labs | _ -> () end; DoChildren method vpredicate t = begin match t with | Pat (_,lab) -> keep_label_logic lab | Papp(_,labs,_) -> let labs = snd (List.split labs) in List.iter keep_label_logic labs | _ -> () end; DoChildren (* No need to go into expressions or types *) method vexpr _ = SkipChildren method vtype _ = SkipChildren end class removeUnusedLabels is_removable (labelMap: (string, unit) H.t) = object inherit nopCilVisitor method vstmt (s: stmt) = let (ln, lab), lrest = labelsToKeep is_removable s.labels in s.labels <- (if ln <> "" && (H.mem labelMap ln || not (is_removable lab)) (* keep user-provided labels *) then (* We had labels *) (lab :: lrest) else lrest); DoChildren (* No need to go into expressions or instructions *) method vexpr _ = SkipChildren method vinst _ = SkipChildren method vtype _ = SkipChildren end (*********************************************************************** * * Removal of unused varinfos * *) (* regular expression matching names of uninteresting locals *) let uninteresting = let names = [ (* Cil.makeTempVar *) "__cil_tmp"; (* sm: I don't know where it comes from but these show up all over. *) (* this doesn't seem to do what I wanted.. *) "iter"; (* various macros in glibc's *) "__result"; "__s"; "__s1"; "__s2"; "__s1_len"; "__s2_len"; "__retval"; "__len"; (* various macros in glibc's *) "__c"; "__res"; (* We remove the __malloc variables *) ] in (* optional alpha renaming *) let alpha = "\\(___[0-9]+\\)?" in let pattern = "\\(" ^ (String.concat "\\|" names) ^ "\\)" ^ alpha ^ "$" in Str.regexp pattern let label_removable = function Label (_,_,user) -> not user | Case _ | Default _ -> false let remove_unused_labels ?(is_removable=label_removable) func = (* We also want to remove unused labels. We do it all here, including * marking the used labels *) let usedLabels:(string, unit) H.t = H.create 13 in ignore (visitCilBlock (new markUsedLabels is_removable usedLabels) func.sbody); (* And now we scan again and we remove them *) ignore (visitCilBlock (new removeUnusedLabels is_removable usedLabels) func.sbody) let removeUnmarked isRoot file = let removedLocals = ref [] in let filterGlobal global = match global with (* unused global types, variables, and functions are simply removed *) | GType (t, _) -> t.treferenced || Cil.hasAttribute "FC_BUILTIN" (Cil.typeAttr t.ttype) || isRoot global | GCompTag (c,_) | GCompTagDecl (c,_) -> c.creferenced || Cil.hasAttribute "FC_BUILTIN" c.cattr || isRoot global | GEnumTag (e, _) | GEnumTagDecl (e,_) -> e.ereferenced || Cil.hasAttribute "FC_BUILTIN" e.eattr || isRoot global | GVar (v, _, _) -> v.vreferenced || Cil.hasAttribute "FC_BUILTIN" v.vattr || isRoot global | GVarDecl (_,({vreferenced = false} as v), _) -> Cil.hasAttribute "FC_BUILTIN" v.vattr || (Cil.removeFormalsDecl v; isRoot global) (* keep FC_BUILTIN, as some plug-ins might want to use them later for semi-legitimate reasons. *) (* retained functions may wish to discard some unused locals *) | GFun (func, _) -> let filterLocal local = if not local.vreferenced then begin (* along the way, record the interesting locals that were removed *) let name = local.vname in (Kernel.debug ~level "removing local: %s\n" name); if not (Str.string_match uninteresting name 0) then removedLocals := (func.svar.vname ^ "::" ^ name) :: !removedLocals; end; local.vreferenced in func.slocals <- List.filter filterLocal func.slocals; let remove_blocals = object inherit Cil.nopCilVisitor method vblock b = b.blocals <- List.filter filterLocal b.blocals; DoChildren end in (func.svar.vreferenced || Cil.hasAttribute "FC_BUILTIN" func.svar.vattr || isRoot global) && (ignore (visitCilBlock remove_blocals func.sbody); remove_unused_labels func; true) (* all other globals are retained *) | _ -> true in file.globals <- List.filter filterGlobal file.globals; !removedLocals (*********************************************************************** * * Exported interface * *) type rootsFilter = global -> bool let isDefaultRoot = isExportedRoot let removeUnusedTemps ?(isRoot : rootsFilter = isDefaultRoot) file = if not !keepUnused then begin Kernel.debug ~level "Removing unused temporaries" ; (* digest any pragmas that would create additional roots *) let keepers = categorizePragmas file in (* build up the root set *) let isRoot global = isPragmaRoot keepers global || isRoot global in (* mark everything reachable from the global roots *) clearReferencedBits file; markReachable file isRoot; (* take out the trash *) let removedLocals = removeUnmarked isRoot file in (* print which original source variables were removed *) if false && removedLocals != [] then let count = List.length removedLocals in if count > 2000 then (Kernel.warning "%d unused local variables removed" count) else (Kernel.warning "%d unused local variables removed:@!%a" count (Pretty_utils.pp_list ~sep:",@," Format.pp_print_string) removedLocals) end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/cil/src/cilmsg.mli0000644000175000017500000000702512155630367017330 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** CIL's internal stack of errors. The module name [Cilmsg] is misleading, but historical. *) val had_errors : unit -> bool val clear_errors : unit -> unit val push_errors : unit -> unit val pop_errors : unit -> unit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/cil/src/escape.ml0000644000175000017500000001203312155630367017134 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** OCaml types used to represent wide characters and strings *) type wchar = int64 type wstring = wchar list let escape_char = function | '\007' -> "\\a" | '\b' -> "\\b" | '\t' -> "\\t" | '\n' -> "\\n" | '\011' -> "\\v" | '\012' -> "\\f" | '\r' -> "\\r" | '"' -> "\\\"" | '\'' -> "\\'" | '\\' -> "\\\\" | ' ' .. '~' as printable -> String.make 1 printable | unprintable -> Printf.sprintf "\\%03o" (Char.code unprintable) let escape_string str = let length = String.length str in let buffer = Buffer.create length in for index = 0 to length - 1 do Buffer.add_string buffer (escape_char (String.get str index)) done; Buffer.contents buffer (* a wide char represented as an int64 *) let escape_wchar = (* limit checks whether upper > probe *) let limit upper probe = (Int64.to_float (Int64.sub upper probe)) > 0.5 in let fits_byte = limit (Int64.of_int 0x100) in let fits_octal_escape = limit (Int64.of_int 0o1000) in let fits_universal_4 = limit (Int64.of_int 0x10000) in let fits_universal_8 = limit (Int64.of_string "0x100000000") in fun charcode -> if fits_byte charcode then escape_char (Char.chr (Int64.to_int charcode)) else if fits_octal_escape charcode then Printf.sprintf "\\%03Lo" charcode else if fits_universal_4 charcode then Printf.sprintf "\\u%04Lx" charcode else if fits_universal_8 charcode then Printf.sprintf "\\u%04Lx" charcode else invalid_arg "Cprint.escape_string_intlist" (* a wide string represented as a list of int64s *) let escape_wstring (str : int64 list) = let length = List.length str in let buffer = Buffer.create length in let append charcode = let addition = escape_wchar charcode in Buffer.add_string buffer addition in List.iter append str; Buffer.contents buffer frama-c-Fluorine-20130601/cil/src/cil_const.ml0000644000175000017500000001207712155630367017661 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) open Cil_types module CurrentLoc = State_builder.Ref (Cil_datatype.Location) (struct let dependencies = [] let name = "CurrentLoc" let default () = Cil_datatype.Location.unknown end) let voidType = TVoid([]) module Vid = State_builder.SharedCounter(struct let name = "vid_counter" end) let set_vid v = let n = Vid.next () in v.vid <- n let copy_with_new_vid v = let n = Vid.next () in let new_v = { v with vid = n } in (match v.vlogic_var_assoc with | None -> () | Some lv -> let new_lv = { lv with lv_id = n } in new_v.vlogic_var_assoc <- Some new_lv; new_lv.lv_origin <- Some new_v); new_v let change_varinfo_name vi name = vi.vname <- name; match vi.vlogic_var_assoc with | None -> () | Some lv -> lv.lv_name <- name let new_raw_id = Vid.next let make_logic_var_kind x kind typ = {lv_name = x; lv_id = new_raw_id(); lv_type = typ; lv_kind = kind; lv_origin = None } let make_logic_var_global x t = make_logic_var_kind x LVGlobal t let make_logic_var_formal x t = make_logic_var_kind x LVFormal t let make_logic_var_quant x t = make_logic_var_kind x LVQuant t let make_logic_var_local x t = make_logic_var_kind x LVLocal t let make_logic_var = Kernel.deprecated "Cil_const.make_logic_var" ~now:"Use one of Cil_const.make_logic_var_* to indicate \ the origin of the variable" make_logic_var_quant let make_logic_info k x = { l_var_info = make_logic_var_kind x k (Ctype voidType); (* we should put the right type when fields l_profile, l_type will be factorized *) l_type = None; l_tparams = []; l_labels = []; l_profile = []; l_body = LBnone; } let make_logic_info_local = make_logic_info LVLocal let make_logic_info = make_logic_info LVGlobal (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/cil/src/ext/0000755000175000017500000000000012155634040016133 5ustar mehdimehdiframa-c-Fluorine-20130601/cil/src/ext/availexpslv.ml0000644000175000017500000003154712155630366021044 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* compute available expressions, although in a somewhat non-traditional way. the abstract state is a mapping from lvalues to expressions as opposed to a set of expressions *) open Cil_types open Cil let debug = ref (Kernel.debug_atleast 2) (* * When ignore_inst returns true, then * the instruction in question has no * effects on the abstract state. * When ignore_call returns true, then * the instruction only has side-effects * from the assignment if there is one. *) let ignore_inst = ref (fun _i -> false) let ignore_call = ref (fun _i -> false) let registerIgnoreInst (f : instr -> bool) : unit = let f' = !ignore_inst in ignore_inst := (fun i -> (f i) || (f' i)) let registerIgnoreCall (f : instr -> bool) : unit = let f' = !ignore_call in ignore_call := (fun i -> (f i) || (f' i)) module LvExpHash = Cil_datatype.LvalStructEq.Hashtbl (* exp LvExpHash.t -> exp LvExpHash.t -> bool *) let lvh_equals lvh1 lvh2 = if not(LvExpHash.length lvh1 = LvExpHash.length lvh2) then false else LvExpHash.fold (fun lv e b -> if not b then b else try let e2 = LvExpHash.find lvh2 lv in if not (Expcompare.compareExpStripCasts e e2) then false else true with Not_found -> false) lvh1 true let lvh_pretty fmt lvh = LvExpHash.iter (fun lv e -> Format.fprintf fmt "@\n%a -> %a" Cil_printer.pp_lval lv Cil_printer.pp_exp e) lvh (* the result must be the intersection of eh1 and eh2 *) let lvh_combine lvh1 lvh2 = if !debug then Kernel.debug ~level:2 "lvh_combine: combining %a\n and\n %a" lvh_pretty lvh1 lvh_pretty lvh2; let lvh' = LvExpHash.copy lvh1 in (* eh' gets all of eh1 *) LvExpHash.iter (fun lv e1 -> try let e2l = LvExpHash.find_all lvh2 lv in if not(List.exists (fun e2 -> Expcompare.compareExpStripCasts e1 e2) e2l) (* remove things from eh' that eh2 doesn't have *) then let e1l = LvExpHash.find_all lvh' lv in let e1l' = List.filter (fun e -> not(Expcompare.compareExpStripCasts e e1)) e1l in LvExpHash.remove lvh' lv; List.iter (fun e -> LvExpHash.add lvh' lv e) e1l' with Not_found -> LvExpHash.remove lvh' lv) lvh1; if !debug then Kernel.debug "with result %a" lvh_pretty lvh'; lvh' (* On a memory write, kill expressions containing memory reads variables whose address has been taken, and globals. *) class memReadOrAddrOfFinderClass br = object inherit nopCilVisitor method vexpr e = match e.enode with | Lval(Mem _, _) -> begin br := true; SkipChildren end | AddrOf(Var _vi, NoOffset) -> (* Writing to memory won't change the address of something *) SkipChildren | _ -> DoChildren method vvrbl vi = if vi.vaddrof || vi.vglob then (br := true; SkipChildren) else DoChildren end (* exp -> bool *) let exp_has_mem_read e = let br = ref false in let vis = new memReadOrAddrOfFinderClass br in ignore(visitCilExpr vis e); !br let lval_has_mem_read lv = let br = ref false in let vis = new memReadOrAddrOfFinderClass br in ignore(visitCilLval vis lv); !br let lvh_kill_mem lvh = LvExpHash.iter (fun lv e -> if exp_has_mem_read e || lval_has_mem_read lv then LvExpHash.remove lvh lv) lvh (* need to kill exps containing a particular vi sometimes *) class viFinderClass vi br = object inherit nopCilVisitor method vvrbl vi' = if vi.vid = vi'.vid then (br := true; SkipChildren) else DoChildren end let exp_has_vi vi e = let br = ref false in let vis = new viFinderClass vi br in ignore(visitCilExpr vis e); !br let lval_has_vi vi lv = let br = ref false in let vis = new viFinderClass vi br in ignore(visitCilLval vis lv); !br let lvh_kill_vi lvh vi = LvExpHash.iter (fun lv e -> if exp_has_vi vi e || lval_has_vi vi lv then LvExpHash.remove lvh lv) lvh (* need to kill exps containing a particular lval sometimes *) class lvalFinderClass lv br = object inherit nopCilVisitor method vlval l = if compareLval l lv then (br := true; SkipChildren) else DoChildren end let exp_has_lval lv e = let br = ref false in let vis = new lvalFinderClass lv br in ignore(visitCilExpr vis e); !br let lval_has_lval lv (host,hostoff) = let br = ref false in let vis = new lvalFinderClass lv br in (match host with | Mem e -> ignore(visitCilExpr vis e) | _ -> ()); ignore(visitCilOffset vis hostoff); !br let lvh_kill_lval lvh lv = LvExpHash.iter (fun lv' e -> if exp_has_lval lv e || lval_has_lval lv lv' then LvExpHash.remove lvh lv') lvh class volatileFinderClass br = object inherit nopCilVisitor method vexpr e = if (hasAttribute "volatile" (typeAttrs (typeOf e))) then (br := true; SkipChildren) else DoChildren end let exp_is_volatile e : bool = let br = ref false in let vis = new volatileFinderClass br in ignore(visitCilExpr vis e); !br class addrOfOrGlobalFinderClass br = object inherit nopCilVisitor method vvrbl vi = if vi.vaddrof || vi.vglob then (br := true; SkipChildren) else DoChildren end let lval_has_addrof_or_global lv = let br = ref false in let vis = new addrOfOrGlobalFinderClass br in ignore(visitCilLval vis lv); !br let lvh_kill_addrof_or_global lvh = LvExpHash.iter (fun lv _ -> if lval_has_addrof_or_global lv then LvExpHash.remove lvh lv) lvh let lvh_handle_inst i lvh = if (!ignore_inst) i then lvh else match i with Set(lv,e,_) -> begin match lv with | (Mem _, _) -> begin LvExpHash.replace lvh lv e; lvh_kill_mem lvh; lvh_kill_addrof_or_global lvh; lvh end | _ when not (exp_is_volatile e) -> begin (* ignore x = x *) if Expcompare.compareExpStripCasts (dummy_exp (Lval lv)) e then lvh else begin LvExpHash.replace lvh lv e; lvh_kill_lval lvh lv; lvh end end | _ -> begin (* e is volatile *) (* must remove mapping for lv *) if !debug then Kernel.debug "lvh_handle_inst: %a is volatile. killing %a" Cil_printer.pp_exp e Cil_printer.pp_lval lv; LvExpHash.remove lvh lv; lvh_kill_lval lvh lv; lvh end end | Call(Some lv,_,_,_) -> begin LvExpHash.remove lvh lv; lvh_kill_lval lvh lv; if not((!ignore_call) i) then begin lvh_kill_mem lvh; lvh_kill_addrof_or_global lvh end; lvh end | Call(_,_,_,_) -> begin if not((!ignore_call) i) then begin lvh_kill_mem lvh; lvh_kill_addrof_or_global lvh; end; lvh end | Asm(_,_,_,_,_,_) -> begin let _,d = Usedef.computeUseDefInstr i in Cil_datatype.Varinfo.Set.iter (fun vi -> lvh_kill_vi lvh vi) d; lvh end | Code_annot _ | Skip _ -> lvh module AvailableExps = struct let name = "Available Expressions" let debug = debug (* mapping from var id to expression *) type t = exp LvExpHash.t module StmtStartData = Dataflow.StartData(struct type t = exp LvExpHash.t let size = 64 end) let copy = LvExpHash.copy let pretty = lvh_pretty let computeFirstPredecessor _stm lvh = lvh let combinePredecessors (_stm:stmt) ~(old:t) (lvh:t) = if lvh_equals old lvh then None else Some(lvh_combine old lvh) let doInstr _ i _lvh = let action = lvh_handle_inst i in Dataflow.Post(action) let doStmt _stm _astate = Dataflow.SDefault let doGuard _ _c _astate = Dataflow.GDefault, Dataflow.GDefault let filterStmt _stm = true let stmt_can_reach _ _ = true let doEdge _ _ d = d end module AE = Dataflow.Forwards(AvailableExps) (* * Computes AEs for function fd. * * *) let computeAEs fd = try let slst = fd.sbody.bstmts in let first_stm = List.hd slst in AvailableExps.StmtStartData.clear (); AvailableExps.StmtStartData.add first_stm (LvExpHash.create 4); AE.compute [first_stm] with Failure "hd" -> if !debug then Kernel.debug "fn w/ no stmts?" | Not_found -> if !debug then Kernel.debug "no data for first_stm?" (* get the AE data for a statement *) let getAEs sid = try Some(AvailableExps.StmtStartData.find sid) with Not_found -> None (* get the AE data for an instruction list *) let instrAEs il _sid lvh _out = if !debug then Kernel.debug "instrAEs" ; let proc_one hil i = match hil with [] -> let lvh' = LvExpHash.copy lvh in let lvh'' = lvh_handle_inst i lvh' in lvh''::hil | lvh'::_ehrst as l -> let lvh' = LvExpHash.copy lvh' in let lvh'' = lvh_handle_inst i lvh' in lvh''::l in let folded = List.fold_left proc_one [lvh] il in let foldednotout = List.rev (List.tl folded) in foldednotout class aeVisitorClass = object (self) inherit nopCilVisitor val mutable ae_dat_lst = [] val mutable cur_ae_dat = None method vstmt stm = match getAEs stm with | None -> if !debug then Kernel.debug "aeVis: stm %d has no data" stm.sid ; cur_ae_dat <- None; DoChildren | Some eh -> match stm.skind with Instr il -> if !debug then Kernel.debug "aeVist: visit il" ; ae_dat_lst <- instrAEs [il] stm.sid eh false; DoChildren | _ -> if !debug then Kernel.debug "aeVisit: visit non-il" ; cur_ae_dat <- None; DoChildren method vinst i = if !debug then Kernel.debug "aeVist: before %a, ae_dat_lst is %d long" Cil_printer.pp_instr i (List.length ae_dat_lst); try let data = List.hd ae_dat_lst in cur_ae_dat <- Some(data); ae_dat_lst <- List.tl ae_dat_lst; if !debug then Kernel.debug "aeVisit: data is %a" lvh_pretty data; DoChildren with Failure "hd" -> if !debug then Kernel.debug "aeVis: il ae_dat_lst mismatch"; DoChildren method get_cur_eh () = match cur_ae_dat with | None -> getAEs (Extlib.the self#current_stmt) | Some eh -> Some eh end frama-c-Fluorine-20130601/cil/src/ext/deadcodeelim.ml0000644000175000017500000003566612155630366021113 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* Eliminate assignment instructions whose results are not used *) open Cil_types open Cil (*open Pretty*) module RD = Reachingdefs module UD = Usedef module IH = Datatype.Int.Hashtbl module IS = Set.Make( struct type t = int let compare = Datatype.Int.compare end) let debug = RD.debug (* This function should be set by the client if it * knows of functions returning a result that have * no side effects. If the result is not used, then * the call will be eliminated. *) let callHasNoSideEffects : (instr -> bool) ref = ref (fun _ -> false) (* the set of used definition ids *) let usedDefsSet = ref IS.empty (* a mapping d -> {u_1,...,u_n} where d is a * definition id, and the u's are definition * ids corresponding to definitions in which * d was used *) let defUseSetHash = IH.create 100 (* a mapping d -> {sid_1,...,sid_n} where d is * a definition id and the sids are statement ids * corresponding to non-Instr statements where d * was used *) let sidUseSetHash = IH.create 100 (* put used def ids into usedDefsSet *) (* assumes reaching definitions have already been computed *) class usedDefsCollectorClass = object(self) inherit RD.rdVisitorClass as super method add_defids iosh e u = UD.VS.iter (fun vi -> if IH.mem iosh vi.vid then let ios = IH.find iosh vi.vid in if !debug then Kernel.debug "DCE: IOS size for vname=%s at stmt=%d: %d\n" vi.vname (Extlib.the self#current_stmt).sid (RD.IOS.cardinal ios); RD.IOS.iter (function | Some(i) -> if !debug then Kernel.debug "DCE: def %d used: %a\n" i Cil_printer.pp_exp e; usedDefsSet := IS.add i (!usedDefsSet) | None -> ()) ios else if !debug then Kernel.debug "DCE: vid %d:%s not in stm:%d iosh at %a\n" vi.vid vi.vname (Extlib.the self#current_stmt).sid Cil_printer.pp_exp e) u method vexpr e = let u = UD.computeUseExp e in match self#get_cur_iosh() with Some(iosh) -> self#add_defids iosh e u; DoChildren | None -> if !debug then Kernel.debug "DCE: use but no rd data: %a\n" Cil_printer.pp_exp e; DoChildren method vstmt s = ignore(super#vstmt s); match s.skind with | Instr _ -> DoChildren | _ -> begin let u,_d = UD.computeUseDefStmtKind s.skind in match self#get_cur_iosh() with | Some iosh -> UD.VS.iter (fun vi -> if IH.mem iosh vi.vid then let ios = IH.find iosh vi.vid in RD.IOS.iter (function | Some i -> begin (* add s.sid to set for i *) try let set = IH.find sidUseSetHash i in IH.replace sidUseSetHash i (IS.add s.sid set) with Not_found -> IH.add sidUseSetHash i (IS.singleton s.sid) end | None -> ()) ios) u; DoChildren | None -> DoChildren end method vinst i = let cstmt = Extlib.the self#current_stmt in let handle_inst iosh i = match i with | Asm(_,_,slvl,_,_,_) -> List.iter (fun (_,s,lv) -> match lv with (Var v, off) -> if s.[0] = '+' then self#add_defids iosh (dummy_exp(Lval(Var v, off))) (UD.VS.singleton v) | _ -> ()) slvl | Call(_,ce,el,_) when not (!callHasNoSideEffects i) -> List.iter (fun e -> let u = UD.computeUseExp e in UD.VS.iter (fun vi -> if IH.mem iosh vi.vid then let ios = IH.find iosh vi.vid in RD.IOS.iter (function | Some i -> begin (* add sid to set for i *) try let set = IH.find sidUseSetHash i in IH.replace sidUseSetHash i (IS.add cstmt.sid set) with Not_found -> IH.add sidUseSetHash i (IS.singleton cstmt.sid) end | None -> ()) ios) u) (ce::el) | Set((Mem _,_) as lh, rhs,_l) -> List.iter (fun e -> let u = UD.computeUseExp e in UD.VS.iter (fun vi -> if IH.mem iosh vi.vid then let ios = IH.find iosh vi.vid in RD.IOS.iter (function | Some i -> begin (* add sid to set for i *) try let set = IH.find sidUseSetHash i in IH.replace sidUseSetHash i (IS.add cstmt.sid set) with Not_found -> IH.add sidUseSetHash i (IS.singleton cstmt.sid) end | None -> ()) ios) u) ([new_exp ~loc:Cil_datatype.Location.unknown (Lval(lh));rhs]) | _ -> () in ignore(super#vinst i); match cur_rd_dat with | None -> begin if !debug then (Kernel.debug "DCE: instr with no cur_rd_dat\n"); (* handle_inst *) DoChildren end | Some(_,s,iosh) -> begin let u,d = UD.computeUseDefInstr i in (* add things in d to the U sets for things in u *) let rec loop n = if n < 0 then () else begin UD.VS.iter (fun vi -> if IH.mem iosh vi.vid then let ios = IH.find iosh vi.vid in RD.IOS.iter (function | Some i -> begin (* add n + s to set for i *) try let set = IH.find defUseSetHash i in IH.replace defUseSetHash i (IS.add (n+s) set) with Not_found -> IH.add defUseSetHash i (IS.singleton (n+s)) end | None -> ()) ios else ()) u; loop (n-1) end in loop (UD.VS.cardinal d - 1); handle_inst iosh i; DoChildren end end let is_volatile_tp tp = List.exists (function (Attr("volatile",_)) -> true | _ -> false) (typeAttrs tp) let is_volatile_vi vi = let vi_vol = List.exists (function (Attr("volatile",_)) -> true | _ -> false) vi.vattr in vi_vol || is_volatile_tp vi.vtype (*************************************************** * Also need to find reads from volatiles * uses two functions above which * are basically what Zach wrote, except one is for * types and one is for vars. Another difference is * they filter out pointers to volatiles. This * handles DMA ***************************************************) class hasVolatile flag = object inherit nopCilVisitor method vlval l = let tp = typeOfLval l in if (is_volatile_tp tp) then flag := true; DoChildren method vexpr _e = DoChildren end let exp_has_volatile e = let flag = ref false in ignore (visitCilExpr (new hasVolatile flag) e); !flag let el_has_volatile = List.fold_left (fun b e -> b || (exp_has_volatile e)) false (***************************************************) let rec stripNopCasts (e:exp): exp = match e.enode with CastE(t, e') -> begin match unrollType (typeOf e'), unrollType t with TPtr _, TPtr _ -> (* okay to strip *) stripNopCasts e' (* strip casts from pointers to unsigned int/long*) | (TPtr _ as t1), (TInt(ik,_) as t2) when bitsSizeOf t1 = bitsSizeOf t2 && not (isSigned ik) -> stripNopCasts e' | (TInt _ as t1), (TInt _ as t2) when bitsSizeOf t1 = bitsSizeOf t2 -> (* Okay to strip.*) stripNopCasts e' | _ -> e end | _ -> e let compareExpStripCasts (e1: exp) (e2: exp) : bool = compareExp (stripNopCasts e1) (stripNopCasts e2) let removedCount = ref 0 (* Filter out instructions whose definition ids are not in usedDefsSet *) class uselessInstrElim : cilVisitor = object inherit nopCilVisitor method vstmt stm = (* give a set of varinfos and an iosh and get * the set of definition ids definining the vars *) let viSetToDefIdSet iosh vis = UD.VS.fold (fun vi s -> if IH.mem iosh vi.vid then let ios = IH.find iosh vi.vid in RD.IOS.fold (fun io s -> match io with None -> s | Some i -> IS.add i s) ios s else s) vis IS.empty in (* false when U(defid)\subeq instruses and SU(d) = empty *) let check_defid i instruses iosh defid = IS.mem defid (!usedDefsSet) && try let defuses = IH.find defUseSetHash defid in (*let siduses = IH.find sidUseSetHash defid in*) if IH.mem sidUseSetHash defid then begin if !debug then Kernel.debug "siduses not empty: %a\n" Cil_printer.pp_instr i; true end else begin (* true if there is something in defuses not in instruses or when * something from defuses is in instruses and is also used somewhere else *) let instruses = viSetToDefIdSet iosh instruses in IS.fold (fun i' b -> if not(IS.mem i' instruses) then begin if !debug then Kernel.debug "i not in instruses: %a\n" Cil_printer.pp_instr i; true end else (* can only use the definition i' at the definition defid *) let i'_uses = IH.find defUseSetHash i' in IH.mem sidUseSetHash i' || if not(IS.equal i'_uses (IS.singleton defid)) then begin IS.iter (fun iu -> match RD.getSimpRhs iu with | Some(RD.RDExp e) -> if !debug then Kernel.debug "i' had other than one use: %d: %a\n" (IS.cardinal i'_uses) Cil_printer.pp_exp e | Some(RD.RDCall i) -> if !debug then Kernel.debug "i' had other than one use: %d: %a\n" (IS.cardinal i'_uses) Cil_printer.pp_instr i | None -> ()) i'_uses; true end else b) defuses false end with Not_found -> true in let test (i,(_,s,iosh)) = match i with | Call(Some(Var vi,NoOffset),{enode = Lval(Var _vf,NoOffset)},el,_l) -> if not(!callHasNoSideEffects i) then begin if !debug then Kernel.debug "found call w/ side effects: %a\n" Cil_printer.pp_instr i; true end else begin if !debug then Kernel.debug "found call w/o side effects: %a\n" Cil_printer.pp_instr i; (vi.vglob || (is_volatile_vi vi) || (el_has_volatile el) || let uses, defd = UD.computeUseDefInstr i in let rec loop n = n >= 0 && (check_defid i uses iosh (n+s) || loop (n-1)) in loop (UD.VS.cardinal defd - 1) || (incr removedCount; false)) end | Call _ -> true | Set(lh,e,_) when compareExpStripCasts (dummy_exp (Lval lh)) e -> false (* filter x = x *) | Set((Var vi,NoOffset),e,_) -> vi.vglob || (is_volatile_vi vi) || (exp_has_volatile e) || let uses, defd = UD.computeUseDefInstr i in let rec loop n = n >= 0 && (check_defid i uses iosh (n+s) || loop (n-1)) in loop (UD.VS.cardinal defd - 1) || (incr removedCount; false) | _ -> true in let filter il stmdat = match let rd_dat_lst = RD.instrRDs il stm.sid stmdat false in let ildatlst = List.combine [il] rd_dat_lst in let ildatlst' = List.filter test ildatlst in let (newil,_) = List.split ildatlst' in newil with | [] -> Skip Cil_datatype.Location.unknown | [ x ] -> x | _ :: _ :: _ -> assert false in match RD.getRDs stm with None -> DoChildren | Some(_,s,iosh) -> match stm.skind with Instr il -> stm.skind <- Instr(filter il ((),s,iosh)); SkipChildren | _ -> DoChildren end (* until fixed point is reached *) let elim_dead_code_fp (fd : fundec) : fundec = (* fundec -> fundec *) let rec loop fd = usedDefsSet := IS.empty; IH.clear defUseSetHash; IH.clear sidUseSetHash; removedCount := 0; RD.computeRDs fd; ignore(visitCilFunction (new usedDefsCollectorClass :> cilVisitor) fd); let fd' = visitCilFunction (new uselessInstrElim) fd in if !removedCount = 0 then fd' else loop fd' in loop fd (* just once *) let elim_dead_code (fd : fundec) : fundec = (* fundec -> fundec *) usedDefsSet := IS.empty; IH.clear defUseSetHash; IH.clear sidUseSetHash; removedCount := 0; RD.computeRDs fd; if !debug then (Kernel.debug "DCE: collecting used definitions\n"); ignore(visitCilFunction (new usedDefsCollectorClass :> cilVisitor) fd); if !debug then (Kernel.debug "DCE: eliminating useless instructions\n"); visitCilFunction (new uselessInstrElim) fd class deadCodeElimClass full : cilVisitor = object inherit nopCilVisitor method vfunc fd = let fd' = (if full then elim_dead_code_fp else elim_dead_code) fd in ChangeTo(fd') end let dce ~full f = if !debug then (Kernel.debug "DCE: starting dead code elimination\n"); visitCilFile (new deadCodeElimClass full) f frama-c-Fluorine-20130601/cil/src/ext/callgraph.ml0000644000175000017500000002240212155630366020431 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* callgraph.ml *) (* code for callgraph.mli *) (* see copyright notice at end of this file *) open Cil_types open Cil module IH = Datatype.Int.Hashtbl module H = Hashtbl (* ------------------- interface ------------------- *) (* a call node describes the local calling structure for a * single function: which functions it calls, and which * functions call it *) type callnode = { (* An id *) cnid: int; (* the function this node describes *) cnInfo: nodeinfo; (* set of functions this one calls, indexed by the node id *) cnCallees: callnode IH.t; (* set of functions that call this one , indexed by the node id *) cnCallers: callnode IH.t; } and nodeinfo = NIVar of varinfo * bool ref (* Node corresponding to a function. If the boolean * is true, then the function is defined, otherwise * it is external *) | NIIndirect of string (* Indirect nodes have a string associated to them. * These strings must be invalid function names *) * varinfo list ref (* A list of functions that this indirect node might * denote *) let nodeName (n: nodeinfo) : string = match n with NIVar (v, _) -> v.vname | NIIndirect (n, _) -> n (* a call graph is a hashtable, mapping a function name to * the node which describes that function's call structure *) type callgraph = (string, callnode) Hashtbl.t (* given the name of a function, retrieve its callnode; this will create a * node if one doesn't already exist. Will use the given nodeinfo only when * creating nodes. *) let nodeId = ref 0 let getNodeByName (cg: callgraph) (ni: nodeinfo) : callnode = let name = nodeName ni in try H.find cg name with Not_found -> ( (* make a new node *) let ret:callnode = { cnInfo = ni; cnid = !nodeId; cnCallees = IH.create 5; cnCallers = IH.create 5; } in incr nodeId; (* add it to the table, then return it *) H.add cg name ret; ret ) (* Get the node for a variable *) let getNodeForVar (cg: callgraph) (v: varinfo) : callnode = getNodeByName cg (NIVar (v, ref false)) let getNodeForIndirect (cg: callgraph) (_e: exp) : callnode = getNodeByName cg (NIIndirect ("", ref [])) (* Find the name of an indirect node that a function whose address is taken * belongs *) let markFunctionAddrTaken (cg: callgraph) (f: varinfo) : unit = (* ignore (E.log "markFunctionAddrTaken %s\n" f.vname); *) let n = getNodeForIndirect cg (dummy_exp (AddrOf (Var f, NoOffset))) in match n.cnInfo with NIIndirect (_, r) -> r := f :: !r | _ -> assert false class cgComputer (graph: callgraph) = object inherit nopCilVisitor (* the current function we're in, so when we visit a call node * we know who is the caller *) val mutable curFunc: callnode option = None (* begin visiting a function definition *) method vfunc (f:fundec) : fundec visitAction = begin Kernel.feedback ~level:2 "Callgraph for function %s" f.svar.vname ; let node = getNodeForVar graph f.svar in (match node.cnInfo with NIVar (_v, r) -> r := true | _ -> assert false); curFunc <- (Some node); DoChildren end (* visit an instruction; we're only interested in calls *) method vinst (i:instr) : instr list visitAction = begin (*(trace "callgraph" (P.dprintf "visiting instruction: %a\n" dn_instr i));*) let caller : callnode = match curFunc with None -> assert false | Some c -> c in (*let callerName: string = nodeName caller.cnInfo in*) (match i with Call(_,f,_,_) -> ( let callee: callnode = match f.enode with | Lval(Var(vi),NoOffset) -> (*(trace "callgraph" (P.dprintf "I see a call by %s to %s\n" callerName vi.vname));*) getNodeForVar graph vi | _ -> (* (trace "callgraph" (P.dprintf "indirect call: %a\n" dn_instr i));*) getNodeForIndirect graph f in (* add one entry to each node's appropriate list *) IH.replace caller.cnCallees callee.cnid callee; IH.replace callee.cnCallers caller.cnid caller ) | _ -> ()); (* ignore other kinds instructions *) DoChildren end method vexpr (e: exp) = (match e.enode with AddrOf (Var fv, NoOffset) when isFunctionType fv.vtype -> markFunctionAddrTaken graph fv | _ -> ()); DoChildren end let computeGraph (f:file) : callgraph = begin let graph = H.create 37 in let obj:cgComputer = new cgComputer graph in (* visit the whole file, computing the graph *) visitCilFileSameGlobals (obj :> cilVisitor) f; (* return the computed graph *) graph end let printGraph (out:out_channel) (g:callgraph) : unit = begin let printEntry _ (n:callnode) : unit = let name = nodeName n.cnInfo in (Printf.fprintf out " %s" name) in let printCalls (node:callnode) : unit = (Printf.fprintf out " calls:"); (IH.iter printEntry node.cnCallees); (Printf.fprintf out "\n is called by:"); (IH.iter printEntry node.cnCallers); (Printf.fprintf out "\n") in H.iter (fun (_name: string) (node: callnode) -> match node.cnInfo with NIVar (v, def) -> (Printf.fprintf out "%s (%s):\n" v.vname (if !def then "defined" else "external")); printCalls node | NIIndirect (n, funcs) -> Printf.fprintf out "Indirect %s:\n" n; Printf.fprintf out " possible aliases: "; List.iter (fun a -> Printf.fprintf out "%s " a.vname) !funcs; Printf.fprintf out "\n") g end let doCallGraph = ref false let feature : featureDescr = { fd_name = "callgraph"; fd_enabled = doCallGraph; fd_description = "generation of a static call graph"; fd_extraopt = []; fd_doit = (function (f: file) -> let graph:callgraph = computeGraph f in printGraph stdout graph); fd_post_check = false; } frama-c-Fluorine-20130601/cil/src/ext/dataflow.ml0000755000175000017500000006643412155630366020315 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (*module E = Errormsg*) open Cil_types open Cil (* open Pretty *) (** A framework for data flow analysis for CIL code. Before using this framework, you must initialize the Control-flow Graph for your program, e.g using {!Cfg.computeFileCFG} *) type 't action = Default (** The default action *) | Done of 't (** Do not do the default action. Use this result *) | Post of ('t -> 't) (** The default action, followed by the given * transformer *) type 't stmtaction = SDefault (** The default action *) | SDone (** Do not visit this statement or its successors *) | SUse of 't (** Visit the instructions and successors of this statement as usual, but use the specified state instead of the one that was passed to doStmt *) (* For if statements *) type 't guardaction = GDefault (** The default state *) | GUse of 't (** Use this data for the branch *) | GUnreachable (** The branch will never be taken. *) module type StmtStartData = sig type data val clear: unit -> unit val mem: Cil_types.stmt -> bool val find: Cil_types.stmt -> data val replace: Cil_types.stmt -> data -> unit val add: Cil_types.stmt -> data -> unit val iter: (Cil_types.stmt -> data -> unit) -> unit val length: unit -> int end module StartData(X: sig type t val size: int end) = struct type data = X.t open Cil_datatype.Stmt.Hashtbl let stmtStartData = create X.size let clear () = clear stmtStartData let mem = mem stmtStartData let find = find stmtStartData let replace = replace stmtStartData let add = add stmtStartData let iter f = iter f stmtStartData let length () = length stmtStartData end exception True let qexists f q = try Queue.iter (fun v -> if f v then raise True) q; false with True -> true (****************************************************************** ********** ********** FORWARDS ********** ********************************************************************) module type ForwardsTransferAux = sig val name: string (** For debugging purposes, the name of the analysis *) val debug: bool ref (** Whether to turn on debugging *) type t (** The type of the data we compute for each block start. May be * imperative. *) val copy: t -> t (** Make a deep copy of the data *) val pretty: Format.formatter -> t -> unit (** Pretty-print the state *) val computeFirstPredecessor: stmt -> t -> t (** Give the first value for a predecessors, compute the value to be set * for the block *) val combinePredecessors: stmt -> old:t -> t -> t option (** Take some old data for the start of a statement, and some new data for * the same point. Return None if the combination is identical to the old * data. Otherwise, compute the combination, and return it. *) val doInstr: stmt -> instr -> t -> t action (** The (forwards) transfer function for an instruction. The * {!Cil.currentLoc} is set before calling this. The default action is to * continue with the state unchanged. * [stmt] is the englobing statement *) val doGuard: stmt -> exp -> t -> t guardaction * t guardaction (** Generate the successors [th, el] to an * If statement assuming the given expression * is respectively nonzero and zero. * Analyses that don't need guard information can return * GDefault, GDefault; this is equivalent to returning GUse of the input. * A return value of GUnreachable indicates that this half of the branch * will not be taken and should not be explored. This will be called * once per If. * [stmt] is the corresponding [If] statement FYI only. *) val doStmt: stmt -> t -> t stmtaction (** The (forwards) transfer function for a statement. The {!Cil.currentLoc} * is set before calling this. The default action is to continue with the * successors of this block, but only for the ... statements. For other * kinds of branches you must handle it, and return {!Dataflow.Done}. *) val filterStmt: stmt -> bool (** Whether to put this statement in the worklist. This is called when a * block would normally be put in the worklist. *) val stmt_can_reach : stmt -> stmt -> bool val doEdge: stmt -> stmt -> t -> t (** what to do when following the edge between the two given statements. Can default to identity if nothing special is required. *) end module type ForwardsTransfer = sig include ForwardsTransferAux module StmtStartData: StmtStartData with type data = t (** For each statement id, the data at the start. Not found in the hash * table means nothing is known about the state at this point. At the end * of the analysis this means that the block is not reachable. *) end module Forwards(T : ForwardsTransfer) = struct (** Keep a worklist of statements to process. It is best to keep a queue, * because this way it is more likely that we are going to process all * predecessors of a statement before the statement itself. *) let worklist: stmt Queue.t = Queue.create () (** We call this function when we have encountered a statement, with some * state. *) let reachedStatement pred (s: stmt) (d: T.t) : unit = (** see if we know about it already *) let d = T.doEdge pred s d in let newdata: T.t option = try let old = T.StmtStartData.find s in match T.combinePredecessors s ~old:old d with None -> (* We are done here *) if !T.debug then Kernel.debug "FF(%s): reached stmt %d with %a\n implies the old state %a\n" T.name s.sid T.pretty d T.pretty old; None | Some d' -> begin (* We have changed the data *) if !T.debug then Kernel.debug "FF(%s): weaken data for block %d: %a\n" T.name s.sid T.pretty d'; Some d' end with Not_found -> (* was bottom before *) let d' = T.computeFirstPredecessor s d in if !T.debug then Kernel.debug "FF(%s): set data for block %d: %a\n" T.name s.sid T.pretty d'; Some d' in match newdata with None -> () | Some d' -> T.StmtStartData.replace s d'; if T.filterStmt s && not (Queue.fold (fun exists s' -> exists || s'.sid = s.sid) false worklist) then Queue.add s worklist (** Get the two successors of an If statement *) let ifSuccs (s:stmt) : stmt * stmt = let fstStmt blk = match blk.bstmts with [] -> Cil.dummyStmt | fst::_ -> fst in match s.skind with If(_e, b1, b2, _) -> let thenSucc = fstStmt b1 in let elseSucc = fstStmt b2 in let oneFallthrough () = let fallthrough = List.filter (fun s' -> thenSucc != s' && elseSucc != s') s.succs in match fallthrough with [] -> Kernel.fatal ~current:true "Bad CFG: missing fallthrough for If." | [s'] -> s' | _ -> Kernel.fatal ~current:true "Bad CFG: multiple fallthrough for If." in (* If thenSucc or elseSucc is Cil.dummyStmt, it's an empty block. So the successor is the statement after the if *) let stmtOrFallthrough s' = if s' == Cil.dummyStmt then oneFallthrough () else s' in (stmtOrFallthrough thenSucc, stmtOrFallthrough elseSucc) | _-> Kernel.fatal ~current:true "ifSuccs on a non-If Statement." (** Process a statement *) let processStmt (s: stmt) : unit = CurrentLoc.set (Cil_datatype.Stmt.loc s); if !T.debug then Kernel.debug "FF(%s).stmt %d at %t@\n" T.name s.sid Cil.pp_thisloc; (* It must be the case that the block has some data *) let init: T.t = try T.copy (T.StmtStartData.find s) with Not_found -> Kernel.fatal ~current:true "FF(%s): processing block without data" T.name in (** See what the custom says *) match T.doStmt s init with | SDone -> () | (SDefault | SUse _) as act -> begin let curr = match act with | SDefault -> init | SUse d -> d | SDone -> assert false and do_succs state = List.iter (fun s' -> reachedStatement s s' state) s.succs in CurrentLoc.set (Cil_datatype.Stmt.loc s); match s.skind with | Instr i -> CurrentLoc.set (Cil_datatype.Instr.loc i); let action = T.doInstr s i curr in let after = match action with | Done s' -> s' | Default -> curr (* do nothing *) | Post f -> f curr in do_succs after | UnspecifiedSequence _ | Goto _ | Break _ | Continue _ | TryExcept _ | TryFinally _ | Loop _ | Return _ | Block _ -> do_succs curr | If (e, _, _, _) -> let thenGuard, elseGuard = T.doGuard s e curr in if thenGuard = GDefault && elseGuard = GDefault then (* this is the common case *) do_succs curr else begin let doBranch succ guard = match guard with GDefault -> reachedStatement s succ curr | GUse d -> reachedStatement s succ d | GUnreachable -> if !T.debug then (Kernel.debug "FF(%s): Not exploring branch to %d\n" T.name succ.sid) in let thenSucc, elseSucc = ifSuccs s in doBranch thenSucc thenGuard; doBranch elseSucc elseGuard; end | Switch (exp_sw, _, _, _) -> let cases, next_sw = Cil.separate_switch_succs s in (* Auxiliary function that iters on all the labels of the switch. The accumulator is the state after the evaluation of the label, and the default case *) let iter_all_labels f = List.fold_left (fun (rem_state, _default as acc) succ -> if rem_state = None then acc else List.fold_left (fun (rem_state, default as acc) label -> match rem_state with | None -> acc | Some state -> f succ label state default ) acc succ.labels ) (Some curr, next_sw) cases in (* Compute a successor of the switch, starting with the state [before], supposing we are considering the label [exp] *) let explore_succ before succ exp_case = let exp = match exp_case.enode with | Const (CInt64 (z,_,_)) when Integer.equal z Integer.zero -> new_exp ~loc:exp_sw.eloc (UnOp(LNot,exp_sw,intType)) | _ -> Cil.new_exp exp_case.eloc (BinOp (Eq, exp_sw, exp_case, Cil.intType)) in let branch_case, branch_not_case = T.doGuard s exp before in (match branch_case with | GDefault -> reachedStatement s succ before; | GUse d -> reachedStatement s succ d; | GUnreachable -> if !T.debug then Kernel.debug "FF(%s): Not exploring branch to %d\n" T.name succ.sid; ); (* State corresponding to the negation of [exp], to be used for the remaining labels *) match branch_not_case with | GDefault -> Some before | GUse d -> Some d | GUnreachable -> None in (* Evaluate all of the labels one after the other, refining the state after each case *) let after, default = iter_all_labels (fun succ label before default -> match label with | Label _ -> (* Label not related to the switch *) (Some before, default) | Cil_types.Default _loc -> if default <> None then Kernel.fatal ~current:true "Bad CFG: switch with multiple \ successors or default cases."; (Some before, Some succ) | Case (exp_case, _) -> let after = explore_succ before succ exp_case in (after, default) ) in (* If [after] is different from [None], we must evaluate the default case, be it a default label, or the successor of the switch *) (match after with | None -> () | Some state -> match default with | None -> Kernel.fatal ~current:true "Bad CFG: switch without \ successor or default case." | Some succ -> reachedStatement s succ state) end exception Good of stmt let find_next_in_queue worklist = let nok_queue = Queue.create () in try while true do let s = Queue.take worklist in if (let nb_preds = List.length s.preds in nb_preds > 1 || (nb_preds = 1 && List.length (List.hd s.preds).succs > 1)) && qexists (fun v -> T.stmt_can_reach v s && not (T.stmt_can_reach s v)) worklist then ((* prerr_endline "REORDER\n" ; *) Queue.add s nok_queue) else raise (Good s) done; assert false with | Not_found -> assert false (*; (* the relation "stmt_can_reach v s && not (stmt_can_reach s v)" is a partial order so this shouldn't happen *) let r = Queue.take nok_queue in Queue.transfer nok_queue worklist; r *) | Good r -> Queue.transfer nok_queue worklist; r (** Compute the data flow. Must have the CFG initialized *) let compute (sources: stmt list) = Queue.clear worklist; List.iter (fun s -> Queue.add s worklist) sources; (** All initial stmts must have non-bottom data *) List.iter (fun s -> if not (T.StmtStartData.mem s) then Kernel.fatal ~current:true "FF(%s): initial stmt %d does not have data" T.name s.sid) sources; if !T.debug then (Kernel.debug "FF(%s): processing" T.name); let rec fixedpoint () = if !T.debug && not (Queue.is_empty worklist) then (Kernel.debug "FF(%s): worklist= %a" T.name (Pretty_utils.pp_list (fun fmt s -> Format.fprintf fmt "%d" s.sid)) (List.rev (Queue.fold (fun acc s -> s :: acc) [] worklist))); let s = find_next_in_queue worklist in processStmt s; fixedpoint () in (try fixedpoint () with Queue.Empty -> if !T.debug then (Kernel.debug "FF(%s): done" T.name)) end (****************************************************************** ********** ********** BACKWARDS ********** ********************************************************************) module type BackwardsTransferAux = sig val name: string (* For debugging purposes, the name of the analysis *) val debug: bool ref (** Whether to turn on debugging *) type t (** The type of the data we compute for each block start. In many * presentations of backwards data flow analysis we maintain the * data at the block end. This is not easy to do with JVML because * a block has many exceptional ends. So we maintain the data for * the statement start. *) val pretty: Format.formatter -> t -> unit (** Pretty-print the state *) val funcExitData: t (** The data at function exit. Used for statements with no successors. This is usually bottom, since we'll also use doStmt on Return statements. *) val combineStmtStartData: Cil_types.stmt -> old:t -> t -> t option (** When the analysis reaches the start of a block, combine the old data * with the one we have just computed. Return None if the combination is * the same as the old data, otherwise return the combination. In the * latter case, the predecessors of the statement are put on the working * list. *) val combineSuccessors: t -> t -> t (** Take the data from two successors and combine it *) val doStmt: stmt -> t action (** The (backwards) transfer function for a branch. The {!Cil.CurrentLoc} is * set before calling this. If it returns None, then we have some default * handling. Otherwise, the returned data is the data before the branch * (not considering the exception handlers) *) val doInstr: stmt -> instr -> t -> t action (** The (backwards) transfer function for an instruction. The * {!Cil.CurrentLoc} is set before calling this. If it returns None, then we * have some default handling. Otherwise, the returned data is the data * before the branch (not considering the exception handlers) *) val filterStmt: stmt -> stmt -> bool (** Whether to put this predecessor block in the worklist. We give the * predecessor and the block whose predecessor we are (and whose data has * changed) *) val stmt_can_reach : stmt -> stmt -> bool end module type BackwardsTransfer = sig include BackwardsTransferAux module StmtStartData: StmtStartData with type data = t (** For each block id, the data at the start. This data structure must be * initialized with the initial data for each block *) end module Backwards(T : BackwardsTransfer) = struct let getStmtStartData (s: stmt) : T.t = try T.StmtStartData.find s with Not_found -> Kernel.fatal ~current:true "BF(%s): stmtStartData is not initialized for %d" T.name s.sid (** Process a statement and return true if the set of live return * addresses on its entry has changed. *) let processStmt (s: stmt) : bool = if !T.debug then (Kernel.debug "FF(%s).stmt %d\n" T.name s.sid); (* Find the state before the branch *) CurrentLoc.set (Cil_datatype.Stmt.loc s); let d: T.t = match T.doStmt s with Done d -> d | (Default | Post _) as action -> begin (* Compute the default state, by combining the successors *) let res = (* We restrict ourselves to the successors we are interested in. If T.filterStmt is deterministic, this should not make the list empty if s.succs is not empty, as we would not have reached s otherwise *) match List.filter (T.filterStmt s) s.succs with | [] -> T.funcExitData | fst :: rest -> List.fold_left (fun acc succ -> T.combineSuccessors acc (getStmtStartData succ)) (getStmtStartData fst) rest in (* Now do the instructions *) let res' = match s.skind with Instr il -> (* Now scan the instructions in reverse order. This may * Stack_overflow on very long blocks ! *) let handleInstruction (i: instr) (state: T.t) : T.t = CurrentLoc.set (Cil_datatype.Instr.loc i); (* First handle the instruction itself *) let action = T.doInstr s i state in match action with | Done s' -> s' | Default -> state (* do nothing *) | Post f -> f state in handleInstruction il res | _ -> res in match action with Post f -> f res' | _ -> res' end in (* See if the state has changed. The only changes are that it may grow.*) let s0 = getStmtStartData s in match T.combineStmtStartData s ~old:s0 d with None -> (* The old data is good enough *) false | Some d' -> (* We have changed the data *) if !T.debug then Kernel.debug "BF(%s): set data for block %d: %a\n" T.name s.sid T.pretty d'; T.StmtStartData.replace s d'; true exception Good of stmt (* This function is the exact dual to the one in the forward dataflow *) let find_next_in_queue worklist = let nok_queue = Queue.create () in try while true do let s = Queue.take worklist in if (let nb_succs = List.length s.succs in nb_succs > 1 || (nb_succs = 1 && List.length (List.hd s.succs).preds > 1)) && qexists (fun v -> T.stmt_can_reach s v && not (T.stmt_can_reach v s)) worklist then Queue.add s nok_queue else raise (Good s) done; assert false with | Not_found -> assert false | Good r -> Queue.transfer nok_queue worklist; r (** Compute the data flow. Must have the CFG initialized *) let compute (sinks: stmt list) = let worklist: stmt Queue.t = Queue.create () in List.iter (fun s -> Queue.add s worklist) sinks; if !T.debug && not (Queue.is_empty worklist) then (Kernel.debug "\nBF(%s): processing\n" T.name); let rec fixedpoint () = if !T.debug && not (Queue.is_empty worklist) then (Kernel.debug "BF(%s): worklist= %a\n" T.name (Pretty_utils.pp_list (fun fmt s -> Format.fprintf fmt "%d " s.sid)) (List.rev (Queue.fold (fun acc s -> s :: acc) [] worklist))); let s = find_next_in_queue worklist in let changes = processStmt s in if changes then begin (* We must add all predecessors of block b, only if not already * in and if the filter accepts them. *) List.iter (fun p -> if T.filterStmt p s && (try Queue.iter (fun s' -> if p.sid = s'.sid then raise Exit) worklist; true with Exit -> false) then Queue.add p worklist) s.preds; end; fixedpoint () in try fixedpoint () with Queue.Empty -> if !T.debug then (Kernel.debug "BF(%s): done\n\n" T.name) end (** Helper utility that finds all of the statements of a function. It also lists the return statments (including statements that fall through the end of a void function). Useful when you need an initial set of statements for BackwardsDataFlow.compute. *) let sinkFinder sink_stmts all_stmts = object inherit nopCilVisitor method vstmt s = all_stmts := s ::(!all_stmts); match s.succs with [] -> (sink_stmts := s :: (!sink_stmts); DoChildren) | _ -> DoChildren end (* returns (all_stmts, return_stmts). *) let find_stmts (fdec:fundec) : (stmt list * stmt list) = let sink_stmts = ref [] and all_stmts = ref [] in ignore(visitCilFunction (sinkFinder sink_stmts all_stmts) fdec); !all_stmts, !sink_stmts (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/ext/obfuscate.ml0000644000175000017500000001272512155630366020456 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) open Cil open Cil_types open Cil_datatype class renamer prefix dictionary = object val prefix = prefix val mutable index = 0 method fresh (name:string) = index <- index + 1; let fresh = prefix ^ string_of_int index in Hashtbl.add dictionary fresh name; fresh end class obfuscateVisitor dictionary = object inherit nopCilVisitor val var = new renamer "G" dictionary val field = new renamer "M" dictionary val typ = new renamer "T" dictionary val enum = new renamer "E" dictionary val local = new renamer "V" dictionary val functions = new renamer "F" dictionary val formals = new renamer "f" dictionary val varinfos_visited = Varinfo.Hashtbl.create 17 method vglob global = begin match global with | GType (ty,_) -> ty.tname <- typ#fresh ty.tname; DoChildren | GVarDecl (_, v, _) | GVar (v, _, _) | GFun ({svar = v}, _) when Cil.is_unused_builtin v -> SkipChildren | _ -> DoChildren end method vcompinfo ci = ci.cname <- typ#fresh ci.cname; DoChildren method vfieldinfo fi = fi.fname <- field#fresh fi.fname; DoChildren method venuminfo ei = ei.ename <- typ#fresh ei.ename; DoChildren method venumitem ei = ei.einame <- enum#fresh ei.einame; DoChildren method vvdec vi = (* Varinfo can be visited (and obfuscated) more than once: functions for their declaration and definition, variables as parts of the type of the function, and in the body of the function declaration, etc. Thus we make sure that the obfuscator does not visit them twice *) try Varinfo.Hashtbl.find varinfos_visited vi; SkipChildren with Not_found -> if isFunctionType vi.vtype then begin if vi.vname <> "main" then vi.vname <- functions#fresh vi.vname end else vi.vname <- if vi.vglob then var#fresh vi.vname else if vi.vformal then formals#fresh vi.vname else local#fresh vi.vname; Varinfo.Hashtbl.add varinfos_visited vi (); DoChildren end let obfuscate file = let dictionary = Hashtbl.create 7 in let v = new obfuscateVisitor dictionary in visitCilFileSameGlobals (v:>cilVisitor) file; dictionary (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/ext/cfg.mli0000644000175000017500000001365412155630366017415 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Code to compute the control-flow graph of a function or file. This will fill in the [preds] and [succs] fields of {!Cil.stmt} This is required for several other extensions, such as {!Dataflow}. @plugin development guide *) open Cil_types (** Compute the CFG for an entire file, by calling cfgFun on each function. *) val computeFileCFG: file -> unit (** clear the sid (except when clear_id is explicitly set to false), succs, and preds fields of each statement. *) val clearFileCFG: ?clear_id:bool -> file -> unit (** Compute a control flow graph for fd. Stmts in fd have preds and succs filled in *) val cfgFun : fundec -> unit (** clear the sid, succs, and preds fields of each statment in a function *) val clearCFGinfo: ?clear_id:bool -> fundec -> unit (** print control flow graph (in dot form) for fundec to channel *) val printCfgChannel : Format.formatter -> fundec -> unit (** Print control flow graph (in dot form) for fundec to file *) val printCfgFilename : string -> fundec -> unit (* [VP] These two functions were initially in Cil, but now depends on stuff in Logic_utils. Put there to avoid circular dependencies. *) (** Prepare a function for CFG information computation by * {!Cil.computeCFGInfo}. This function converts all [Break], [Switch], * [Default] and [Continue] {!Cil_types.stmtkind}s and {!Cil_types.label}s into [If]s * and [Goto]s, giving the function body a very CFG-like character. This * function modifies its argument in place. *) val prepareCFG: ?keepSwitch:bool -> fundec -> unit (** Compute the CFG information for all statements in a fundec and return a * list of the statements. The input fundec cannot have [Break], [Switch], * [Default], or [Continue] {!Cil_types.stmtkind}s or {!Cil_types.label}s. Use * {!Cil.prepareCFG} to transform them away. The second argument should * be [true] if you wish a global statement number, [false] if you wish a * local (per-function) statement numbering. The list of statements is set * in the sallstmts field of a fundec. * * NOTE: unless you want the simpler control-flow graph provided by * prepareCFG, or you need the function's smaxstmtid and sallstmt fields * filled in, we recommend you use [Cfg.computeFileCFG] instead of this * function to compute control-flow information. * [Cfg.computeFileCFG] is newer and will handle switch, break, and * continue correctly.*) val computeCFGInfo: fundec -> bool -> unit (* [VP] End import from Cil *) val clear_sid_info_ref: (unit -> unit) ref (* (* Next statement id that will be assigned. *) val start_id: int ref (** All of the nodes in a file. *) val nodeList : stmt list ref (** number of nodes in the CFG *) val numNodes : int ref *) frama-c-Fluorine-20130601/cil/src/ext/deadcodeelim.mli0000644000175000017500000000760212155630366021251 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Dead code elimination. Note this is legacy Cil code, which is probably incorrect wrt. Frama-C invariants. In particular, it uses inplace visitors to modify the AST. Use with caution *) val elim_dead_code : Cil_types.fundec -> Cil_types.fundec (** Perform one pass of dead code elimination *) val elim_dead_code_fp : Cil_types.fundec -> Cil_types.fundec (** Perform dead code elimination until a fixpoint is reach *) val dce : full:bool -> Cil_types.file -> unit (** Perform dead code elimination on the entire file. If [full] is [false], only one pass is performed. Otherwise, elimination is performed until a fixpoint is reached. *) frama-c-Fluorine-20130601/cil/src/ext/oneret.ml0000644000175000017500000003411512155630366017774 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) open Cil_types open Cil open Logic_const let adjust_assigns_clause loc var code_annot = let change_result = object inherit Cil.nopCilVisitor method vterm_lhost = function | TResult _ -> ChangeTo (TVar var) | TVar _ | TMem _ -> DoChildren end in let change_term t = Cil.visitCilTerm change_result t in let module M = struct exception Found end in let check_var = object inherit Cil.nopCilVisitor method vterm_lhost = function | TVar v when Cil_datatype.Logic_var.equal var v -> raise M.Found | TVar _ | TResult _ | TMem _ -> DoChildren end in let contains_var l = try ignore (Cil.visitCilAssigns check_var (Writes l)); false with M.Found -> true in let change_from = function | FromAny -> FromAny | From l -> From (List.map Logic_const.refresh_identified_term l) in let adjust_lval (_,assigns as acc) (loc,from) = if Logic_utils.contains_result loc.it_content then begin true, (Logic_const.new_identified_term (change_term loc.it_content), change_from from)::assigns end else acc in let adjust_clause b = match b.b_assigns with | WritesAny -> () | Writes l -> if not (contains_var l) then begin let (changed, a) = List.fold_left adjust_lval (false,l) l in let a = if changed then a else (Logic_const.new_identified_term (Logic_const.tvar ~loc var), FromAny) :: a in b.b_assigns <- Writes a end in match code_annot with | AStmtSpec (_,s) -> List.iter adjust_clause s.spec_behavior | _ -> () let oneret (f: fundec) : unit = let fname = f.svar.vname in (* Get the return type *) let retTyp = match f.svar.vtype with TFun(rt, _, _, _) -> rt | _ -> Kernel.abort "Function %s does not have a function type" f.svar.vname in (* Does it return anything ? *) let hasRet = match unrollType retTyp with TVoid _ -> false | _ -> true in (* Memoize the return result variable. Use only if hasRet *) let lastloc = ref Cil_datatype.Location.unknown in let getRetVar = let retVar : varinfo option ref = ref None in fun () -> match !retVar with Some rv -> rv | None -> begin let rv = makeLocalVar f "__retres" retTyp in (* don't collide *) retVar := Some rv; rv end in let convert_result p = let vis = object inherit Cil.nopCilVisitor method vterm_lhost = function | TResult _ -> let v = getRetVar () in ChangeTo (TVar (cvar_to_lvar v)) | TMem _ | TVar _ -> DoChildren end in visitCilPredicateNamed vis p in let assert_of_returns ca = match ca.annot_content with | AAssert _ | AInvariant _ | AVariant _ | AAssigns _ | AAllocation _ | APragma _ -> ptrue | AStmtSpec (_bhvs,s) -> let res = List.fold_left (fun acc bhv -> pand (acc, pimplies (pands (List.map (fun p -> pold ~loc:p.ip_loc (Logic_utils.named_of_identified_predicate p)) bhv.b_assumes), pands (List.fold_left (fun acc (kind,p) -> match kind with Returns -> Logic_utils.named_of_identified_predicate p :: acc | Normal | Exits | Breaks | Continues -> acc) [ptrue] bhv.b_post_cond) ))) ptrue s.spec_behavior in convert_result res in (* Remember if we have introduced goto's *) let haveGoto = ref false in (* Memoize the return statement *) let retStmt : stmt ref = ref dummyStmt in let getRetStmt (_x: unit) : stmt = if !retStmt == dummyStmt then begin let sr = let getLastLoc () = (* CEA modified to have a good [!lastloc] *) let rec setLastLoc = function | [] -> () | {skind=Block b} :: [] -> setLastLoc b.bstmts | {skind=UnspecifiedSequence seq}::[] -> setLastLoc (List.map (fun (x,_,_,_,_) -> x) seq) | {skind= _} as s :: [] -> lastloc := Cil_datatype.Stmt.loc s | {skind=_s} :: l -> setLastLoc l in setLastLoc f.sbody.bstmts; !lastloc in let loc = getLastLoc () in (* Must create a statement *) let rv = if hasRet then Some (new_exp ~loc (Lval(Var (getRetVar ()), NoOffset))) else None in mkStmt (Return (rv, loc)) in retStmt := sr; sr end else !retStmt in (* Stack of predicates that must hold in case of returns (returns clause with \old transformed into \at(,L) for a suitable L). TODO: split that into behaviors and generates for foo,bar: assert instead of plain assert. *) let returns_clause_stack = Stack.create () in let stmt_contract_stack = Stack.create () in let rec popn n = if n > 0 then begin assert (not (Stack.is_empty returns_clause_stack)); ignore (Stack.pop returns_clause_stack); ignore (Stack.pop stmt_contract_stack); popn (n-1) end in (* Now scan all the statements. Know if you are the main body of the * function and be prepared to add new statements at the end. * popstack indicates whether we should pop the stack after having analyzed current statement. It is an int since nothing in ACSL prevents from having multiple statement contracts on top of each other before finding an actual statement... *) let rec scanStmts acc (mainbody: bool) popstack = function | [] when mainbody -> (* We are at the end of the function. Now it is * time to add the return statement *) let rs = getRetStmt () in if !haveGoto then rs.labels <- (Label("return_label", !lastloc, false)) :: rs.labels; List.rev (rs :: acc) | [] -> List.rev acc | [{skind=Return (Some ({enode = Lval(Var _,NoOffset)}), _l)} as s] when mainbody && not !haveGoto -> (* We're not changing the return into goto, so returns clause will still have effect. *) popn popstack; List.rev (s::acc) | ({skind=Return (retval, loc)} as s) :: rests -> Cil.CurrentLoc.set loc; (* ignore (E.log "Fixing return(%a) at %a\n" insert (match retval with None -> text "None" | Some e -> d_exp () e) d_loc l); *) if hasRet && retval = None then Kernel.error ~current:true "Found return without value in function %s" fname; if not hasRet && retval <> None then Kernel.error ~current:true "Found return in subroutine %s" fname; (* Keep this statement because it might have labels. But change it to * an instruction that sets the return value (if any). *) s.skind <- begin match retval with Some rval -> Instr (Set((Var (getRetVar ()), NoOffset), rval, loc)) | None -> Instr (Skip loc) end; let returns_assert = ref ptrue in Stack.iter (fun p -> returns_assert := pand ~loc (p, !returns_assert)) returns_clause_stack; (match retval with | Some _ -> Stack.iter (adjust_assigns_clause loc (Cil.cvar_to_lvar (getRetVar()))) stmt_contract_stack; | None -> () (* There's no \result: no need to adjust it *) ); let add_assert res = match !returns_assert with { content = Ptrue } -> res | p -> let a = Logic_const.new_code_annotation (AAssert ([],p)) in mkStmt (Instr(Code_annot (a,loc))) :: res in (* See if this is the last statement in function *) if mainbody && rests == [] then begin popn popstack; scanStmts (add_assert (s::acc)) mainbody 0 rests end else begin (* Add a Goto *) let sgref = ref (getRetStmt ()) in let sg = mkStmt (Goto (sgref, loc)) in haveGoto := true; popn popstack; scanStmts (sg :: (add_assert (s::acc))) mainbody 0 rests end | ({skind=If(eb,t,e,l)} as s) :: rests -> (*CEA currentLoc := l;*) s.skind <- If(eb, scanBlock false t, scanBlock false e, l); popn popstack; scanStmts (s::acc) mainbody 0 rests | ({skind=Loop(a,b,l,lb1,lb2)} as s) :: rests -> (*CEA currentLoc := l;*) s.skind <- Loop(a,scanBlock false b, l,lb1,lb2); popn popstack; scanStmts (s::acc) mainbody 0 rests | ({skind=Switch(e, b, cases, l)} as s) :: rests -> (*CEA currentLoc := l;*) s.skind <- Switch(e, scanBlock false b, cases, l); popn popstack; scanStmts (s::acc) mainbody 0 rests | [{skind=Block b} as s] -> s.skind <- Block (scanBlock mainbody b); popn popstack; List.rev (s::acc) | ({skind=Block b} as s) :: rests -> s.skind <- Block (scanBlock false b); popn popstack; scanStmts (s::acc) mainbody 0 rests | [{skind = UnspecifiedSequence seq} as s] -> s.skind <- UnspecifiedSequence (List.concat (List.map (fun (s,m,w,r,c) -> let res = scanStmts [] mainbody 0 [s] in (List.hd res,m,w,r,c):: (List.map (fun x -> x,[],[],[],[]) (List.tl res))) seq)); popn popstack; List.rev (s::acc) | ({skind = UnspecifiedSequence seq} as s) :: rests -> s.skind <- UnspecifiedSequence (List.concat (List.map (fun (s,m,w,r,c) -> let res = scanStmts [] false 0 [s] in (List.hd res,m,w,r,c):: (List.map (fun x -> x,[],[],[],[]) (List.tl res))) seq)); popn popstack; scanStmts (s::acc) mainbody 0 rests | {skind=Instr(Code_annot (ca,_))} as s :: rests -> let returns = assert_of_returns ca in let returns = Logic_utils.translate_old_label s returns in Stack.push returns returns_clause_stack; Stack.push ca.annot_content stmt_contract_stack; scanStmts (s::acc) mainbody (popstack + 1) rests | ({skind=(Goto _ | Instr _ | Continue _ | Break _ | TryExcept _ | TryFinally _)} as s) :: rests -> popn popstack; scanStmts (s::acc) mainbody 0 rests and scanBlock (mainbody: bool) (b: block) = { b with bstmts = scanStmts [] mainbody 0 b.bstmts;} in (*CEA since CurrentLoc isn't set ignore (visitCilBlock dummyVisitor f.sbody) ; *)(* sets CurrentLoc *) (*CEA so, [scanBlock] will set [lastloc] when necessary lastloc := !currentLoc ; *) (* last location in the function *) f.sbody <- scanBlock true f.sbody (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/ext/liveness.ml0000644000175000017500000001645512155630366020337 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* Calculate which variables are live at * each statememnt. * * * *) open Cil_types open Cil module UD = Usedef module VS = Cil_datatype.Varinfo.Set let debug = ref false let live_label = ref "" let live_func = ref "" let debug_print fmt vs = VS.fold (fun vi _d -> Format.fprintf fmt "name: %s id:%d " vi.vname vi.vid) vs (); Format.fprintf fmt "@\n" let min_print fmt vs = VS.iter (fun vi -> Format.fprintf fmt "%s(%a)," vi.vname Cil_printer.pp_typ vi.vtype) vs; Format.fprintf fmt "@\n" let printer = ref debug_print module LiveFlow = struct let name = "Liveness" let debug = debug type t = VS.t module StmtStartData = Dataflow.StartData(struct type t = VS.t let size = 32 end) let pretty fmt vs = let fn = !printer in fn fmt vs let funcExitData = VS.empty let combineStmtStartData (_stm:stmt) ~(old:t) (now:t) = if not(VS.compare old now = 0) then Some(VS.union old now) else None let combineSuccessors = VS.union let doStmt stmt = if !debug then Kernel.debug "looking at: %a\n" Cil_printer.pp_stmt stmt; match stmt.succs with [] -> let u,_d = UD.computeUseDefStmtKind stmt.skind in if !debug then (Kernel.debug "doStmt: no succs %d\n" stmt.sid); Dataflow.Done u | _ -> let handle_stm vs = match stmt.skind with Instr _ -> vs | s -> let u, d = UD.computeUseDefStmtKind s in VS.union u (VS.diff vs d) in Dataflow.Post handle_stm let doInstr _ i _vs = let transform vs' = let u,d = UD.computeUseDefInstr i in VS.union u (VS.diff vs' d) in Dataflow.Post transform let filterStmt _stm1 _stm2 = true let stmt_can_reach _ _ = true end module L = Dataflow.Backwards(LiveFlow) (* XXX: This does not compute the best ordering to * give to the work-list algorithm. *) let all_stmts = ref [] class nullAdderClass = object inherit nopCilVisitor method vstmt s = all_stmts := s :: (!all_stmts); LiveFlow.StmtStartData.add s VS.empty; DoChildren end let null_adder fdec = ignore(visitCilFunction (new nullAdderClass) fdec); !all_stmts let computeLiveness fdec = LiveFlow.StmtStartData.clear (); UD.onlyNoOffsetsAreDefs := false; all_stmts := []; let a = null_adder fdec in L.compute a let getLiveSet sid = try Some(LiveFlow.StmtStartData.find sid) with Not_found -> None let print_everything () = LiveFlow.StmtStartData.iter (fun s vs -> Format.printf "%d: %a" s.sid LiveFlow.pretty vs) let match_label lbl = match lbl with Label(str,_,_b) -> if !debug then (Kernel.debug "Liveness: label seen: %s\n" str); (*b && *)(String.compare str (!live_label) = 0) | _ -> false class doFeatureClass = object inherit nopCilVisitor method vfunc fd = if String.compare fd.svar.vname (!live_func) = 0 then (Cfg.clearCFGinfo fd; ignore(Cfg.cfgFun fd); computeLiveness fd; if String.compare (!live_label) "" = 0 then (printer := min_print; print_everything (); SkipChildren) else DoChildren) else SkipChildren method vstmt s = if List.exists match_label s.labels then try let vs = LiveFlow.StmtStartData.find s in (printer := min_print; Format.printf "%a" LiveFlow.pretty vs; SkipChildren) with Not_found -> if !debug then (Kernel.debug "Liveness: stmt: %d not found\n" s.sid); DoChildren else (if List.length s.labels = 0 then if !debug then (Kernel.debug "Liveness: no label at sid=%d\n" s.sid); DoChildren) end let do_live_feature (f:file) = visitCilFile (new doFeatureClass) f let feature = { fd_name = "Liveness"; fd_enabled = ref false; fd_description = "Spit out live variables at a label"; fd_extraopt = [ "--live_label", Arg.String (fun s -> live_label := s), "Output the variables live at this label"; "--live_func", Arg.String (fun s -> live_func := s), "Output the variables live at each statement in this function."; "--live_debug", Arg.Unit (fun _n -> debug := true), "Print lots of debugging info";]; fd_doit = do_live_feature; fd_post_check = false } frama-c-Fluorine-20130601/cil/src/ext/rmciltmps.ml0000644000175000017500000012552512155630366020520 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* These are functions etc. for removing CIL generated temporary variables. Some can be removed immediately, others must wait until pretty printing *) open Cil_types open Cil module RD = Reachingdefs module AELV = Availexpslv module UD = Usedef module IH = Datatype.Int.Hashtbl module IS = Datatype.Int.Set let debug = RD.debug (* Type for the form of temporary variable names *) type nameform = Suffix of string | Prefix of string | Exact of string (* take the id number of a definition and return the rhs of the definition if there is one. Returns None if, for example, the definition is caused by an assembly instruction *) (* int -> (rhs * int * IOS.t IH.t) option *) let getDefRhs = RD.getDefRhs RD.ReachingDef.defIdStmtHash (* exp_is_ok_replacement - Returns false if the argument contains a pointer dereference or a variable whose address is taken anywhere *) let exp_ok = ref true class memReadOrAddrOfFinderClass = object inherit nopCilVisitor method vexpr e = match e.enode with Lval(Mem _, _) -> exp_ok := false; SkipChildren | _ -> DoChildren method vvrbl vi = if vi.vglob then (if !debug then (Kernel.debug "memReadOrAddrOfFinder: %s is a global\n" vi.vname); exp_ok := false; SkipChildren) else if vi.vaddrof then (if !debug then (Kernel.debug "memReadOrAddrOfFinder: %s has its address taken\n" vi.vname); exp_ok := false; SkipChildren) else (if !debug then (Kernel.debug "memReadOrAddrOfFinder: %s does not have its address taken\n" vi.vname); DoChildren) end let memReadOrAddrOfFinder = new memReadOrAddrOfFinderClass (* exp -> bool *) let exp_is_ok_replacement e = if !debug then Kernel.debug "exp_is_ok_replacement: in exp_is_ok_replacement with %a\n" Cil_printer.pp_exp e; exp_ok := true; ignore(visitCilExpr memReadOrAddrOfFinder e); !exp_ok let emptyStmt = mkEmptyStmt () let fsr = ref emptyStmt class stmtFinderClass sid = object inherit nopCilVisitor method vstmt stm = if stm.sid = sid then (fsr := stm; SkipChildren) else DoChildren end let find_statement _f sid = RD.getStmt sid (* Are there writes to memory in between the two statements with the given ids *) (* fundec -> int -> int -> bool *) let wbHtbl = Hashtbl.create 256 let writes_between f dsid sid = if Hashtbl.mem wbHtbl (dsid,sid) then Hashtbl.find wbHtbl (dsid,sid) else let dstmo = find_statement f dsid in let stmo = find_statement f sid in let find_write s = match s.skind with Instr il -> List.exists (fun i -> match i with Set((Mem _,_),_,_) -> true (* pointer write *) | Set((_,Index (_,_)),_,_) -> true (* array write *) | Call(_,_,_,_) -> true | _ -> false) [il] | _ -> false in (* is there a path from start to goal that includes an instruction that writes to memory? Do a dfs *) let visited_sid_isr = ref IS.empty in let rec dfs goal b start = if !debug then Kernel.debug "writes_between: dfs visiting %a\n" Cil_printer.pp_stmt start; if start.sid = goal.sid then let wh = find_write start in (if !debug && b then Kernel.debug "writes_between: start=goal and found a write\n"; if !debug && (not b) then Kernel.debug "writes_between: start=goal and no write\n"; if !debug && wh then Kernel.debug "writes_between: start=goal and write here\n"; if !debug && (not wh) then Kernel.debug "writes_between: start=goal and no write here\n"; b || (find_write start)) else if IS.mem start.sid (!visited_sid_isr) then false else let w = find_write start in if !debug && w then Kernel.debug "writes_between: found write %a" Cil_printer.pp_stmt start; visited_sid_isr := IS.add start.sid (!visited_sid_isr); let rec proc_succs sl = match sl with [] -> false | s::rest -> if dfs goal (w || b) s then true else proc_succs rest in proc_succs start.succs in match stmo, dstmo with None, _ | _, None -> Kernel.fatal "writes_between: defining stmt not an instr" | Some stm, Some dstm -> let _ = visited_sid_isr := IS.singleton stm.sid in let from_stm = List.fold_left (dfs stm) false stm.succs in let _ = visited_sid_isr := IS.empty in let from_dstm = dfs stm false dstm in (Hashtbl.add wbHtbl (dsid,sid) (from_stm || from_dstm); from_stm || from_dstm) (* returns true when the variables in uses * have the same definition ids in both curiosh * and defiosh or are global and not defined in * the current function *) let verify_unmodified uses fdefs curiosh defiosh = UD.VS.fold (fun vi b -> let curido = RD.iosh_singleton_lookup curiosh vi in let defido = RD.iosh_singleton_lookup defiosh vi in match curido, defido with Some(curid), Some(defid) -> (if !debug then (Kernel.debug "verify_unmodified: curido: %d defido: %d" curid defid); curid = defid && b) | None, None -> if not(UD.VS.mem vi fdefs) then (if !debug then (Kernel.debug "verify_unmodified: %s not defined in function" vi.vname); b) else (* if the same set of definitions reaches, we can replace, also *) let curios = try IH.find curiosh vi.vid with Not_found -> RD.IOS.empty in let defios = try IH.find defiosh vi.vid with Not_found -> RD.IOS.empty in RD.IOS.compare curios defios == 0 && b | _, _ -> (if !debug then Kernel.debug "verify_unmodified: %s has conflicting definitions. cur: %a\n def: %a" vi.vname RD.ReachingDef.pretty ((),0,curiosh) RD.ReachingDef.pretty ((),0,defiosh); false)) uses true let fdefs = ref UD.VS.empty let udDeepSkindHtbl = IH.create 64 class defCollectorClass = object inherit nopCilVisitor method vstmt s = let _,d = if IH.mem udDeepSkindHtbl s.sid then IH.find udDeepSkindHtbl s.sid else let u',d' = UD.computeDeepUseDefStmtKind s.skind in IH.add udDeepSkindHtbl s.sid (u',d'); (u',d') in fdefs := UD.VS.union !fdefs d; DoChildren end let defCollector = new defCollectorClass let collect_fun_defs fd = fdefs := UD.VS.empty; ignore(visitCilFunction defCollector fd); !fdefs (* ok_to_replace *) (* is it alright to replace a variable use with the expression that the variable was defined to be? *) (* Takes the definitions that reached the place where the variable was defined and the definitions that reach the place the variable is used. If the same definitions for the variables used in the expression reach both places, then it is okay to replace the variable with the expression. *) (* With regards to globals and parameters there are two possibilities if the reverse lookup returns None for both sets of reaching definitions: 1) The global or parameter is actually not redefined. 2) At both points no one definition *must* reach there. For this reason, this function also takes the fundec, so that it can be figured out which is the case *) (* varinfo -> varinfo IH.t -> sid -> varinfo IH.t -> fundec -> rhs -> bool *) (* sid is an int that is the statement id of the statement where we are trying to do a replacement *) (* vi is the varinfo of the variable that we are trying to replace *) let ok_to_replace vi curiosh sid defiosh dsid f r = let uses, safe = match r with RD.RDExp e -> (UD.computeUseExp e, exp_is_ok_replacement e) | RD.RDCall (Call(_,_,el,_) as i) -> let safe = List.fold_left (fun b e -> (exp_is_ok_replacement e) && b) true el in let u,_d = UD.computeUseDefInstr i in u, safe | _ -> Kernel.fatal "ok_to_replace: got non Call in RDCall." in let target_addrof = if vi.vaddrof || vi.vglob then (if !debug then (Kernel.debug "ok_to_replace: target %s had its address taken or is a global" vi.vname); true) else (if !debug then (Kernel.debug "ok_to_replace: target %s does not have its address taken" vi.vname); false) in let writes = if safe && not(target_addrof) then false else (writes_between f dsid sid) in if (not safe || target_addrof) && writes then (if !debug then (Kernel.debug "ok_to_replace: replacement not safe because of pointers or addrOf"); false) else let fdefs = collect_fun_defs f in let _ = if !debug then (Kernel.debug "ok_to_replace: card fdefs = %d" (UD.VS.cardinal fdefs)) in let _ = if !debug then (Kernel.debug "ok_to_replace: card uses = %d" (UD.VS.cardinal uses)) in verify_unmodified uses fdefs curiosh defiosh let useList = ref [] (* Visitor for making a list of statements that use a definition *) class useListerClass (defid:int) (vi:varinfo) = object(self) inherit RD.rdVisitorClass method vexpr e = match e.enode with Lval(Var vi', _off) -> (match self#get_cur_iosh() with Some iosh -> let vido = RD.iosh_defId_find iosh defid in let exists = match vido with Some _ -> true | None -> false in if vi.vid = vi'.vid && exists then (useList := (Extlib.the self#current_stmt)::(!useList); DoChildren) else DoChildren | _ -> Kernel.fatal "useLister: no data for statement") | _ -> DoChildren end (* ok_to_replace_with_incdec *) (* Find out if it is alright to replace the use of a variable with a post-incrememnt/decrement of the variable it is assigned to be *) (* Takes the definitions reaching the variable use, the definitions reaching the place where the variable was defined, the fundec, the varinfo for the variable being considered and the right hand side of its definition. *) let ok_to_replace_with_incdec curiosh defiosh f id vi r = (* number of uses of vi where definition id reaches *) let num_uses () = let _ = useList := [] in let ulc = new useListerClass id vi in let _ = visitCilFunction (ulc :> cilVisitor) f in List.length (!useList) in (* Is e the addition or subtraction of one to vi? Return Some(PlusA) if it's an addition, Some(MinusA) if it's a subtraction, and None otherwise *) let inc_or_dec e vi = match e.enode with BinOp((PlusA|PlusPI|IndexPI), {enode = Lval(Var vi', NoOffset)}, {enode = Const(CInt64(one,_,_))},_) -> if vi.vid = vi'.vid && Integer.equal one Integer.one then Some(PlusA) else if vi.vid = vi'.vid && Integer.equal one Integer.minus_one then Some(MinusA) else None | BinOp((MinusA|MinusPI), {enode = Lval(Var vi', NoOffset)}, {enode = Const(CInt64(one,_,_))},_) -> if vi.vid = vi'.vid && Integer.equal one Integer.one then Some(MinusA) else None | _ -> None in match r with RD.RDExp({enode = Lval(Var rhsvi, NoOffset)}) -> let curido = RD.iosh_singleton_lookup curiosh rhsvi in let defido = RD.iosh_singleton_lookup defiosh rhsvi in (match curido, defido with Some(curid), _ -> let defios = try IH.find defiosh rhsvi.vid with Not_found -> RD.IOS.empty in let redefrhso = getDefRhs curid in (match redefrhso with None -> (if !debug then (Kernel.debug "ok_to_replace: couldn't get rhs for redef: %d" curid); None) | Some(redefrhs, _, redefiosh) -> let tmprdido = RD.iosh_singleton_lookup redefiosh vi in match tmprdido with None -> (if !debug then (Kernel.debug "ok_to_replace: conflicting defs of %s reach redef of %s" vi.vname rhsvi.vname); None) | Some tmprdid -> if not (tmprdid = id) then (if !debug then (Kernel.debug "ok_to_replace: initial def of %s doesn't reach redef of %s" vi.vname rhsvi.vname); None) else let redefios = try IH.find redefiosh rhsvi.vid with Not_found -> RD.IOS.empty in let curdef_stmt = try IH.find RD.ReachingDef.defIdStmtHash curid with Not_found -> Kernel.fatal "ok_to_replace: couldn't find statement defining %d" curid in if not (RD.IOS.compare defios redefios = 0) then (if !debug then (Kernel.debug "ok_to_replace: different sets of definitions of %s reach the def of %s and the redef of %s" rhsvi.vname vi.vname rhsvi.vname); None) else (match redefrhs with RD.RDExp(e) -> (match inc_or_dec e rhsvi with Some(PlusA) -> if num_uses () = 1 then Some(curdef_stmt.sid, curid, rhsvi, PlusA) else (if !debug then (Kernel.debug "ok_to_replace: tmp used more than once"); None) | Some(MinusA) -> if num_uses () = 1 then Some(curdef_stmt.sid, curid, rhsvi, MinusA) else (if !debug then (Kernel.debug "ok_to_replace: tmp used more than once"); None) | None -> (if !debug then (Kernel.debug "ok_to_replace: redef isn't adding or subtracting one from itself"); None) | _ -> (Kernel.fatal "ok_to_replace: unexpected op in inc/dec info.")) | _ -> (if !debug then (Kernel.debug "ok_to_replace: redef a call"); None))) | _ -> (if !debug then (Kernel.debug "ok_to_replace: %s has conflicting definitions" rhsvi.vname); None)) | _ -> (if !debug then (Kernel.debug "ok_to_replace: rhs not of correct form"); None) (* A hash from variable ids to Call instruction options. If a variable id is in this table, and it is mapped to Some(Call()), then the function call can be printed instead of the variable *) let iioh = IH.create 16 (* A hash from variable ids to information that can be used to print a post increment/decrement that can replace the variable *) let incdecHash = IH.create 16 (* A hash from variable ids to a list of statement ids. Because a post-inc/dec will be printed elsewhere, the assignments of the variable in these statements don't need to be printed *) let idDefHash = IH.create 16 (* Add a pair to the list for vid and create a list if one doesn't exist *) let id_dh_add vid p = if IH.mem idDefHash vid then let oldlist = IH.find idDefHash vid in let newlist = p::oldlist in IH.replace idDefHash vid newlist else IH.add idDefHash vid [p] (* check if a name matches a form *) (* string -> nameform -> bool *) let check_form s f = match f with Suffix sfx -> let frmlen = String.length sfx in let slen = String.length s in slen >= frmlen && String.compare (String.sub s (slen - frmlen) frmlen) sfx = 0 | Prefix pfx -> let frmlen = String.length pfx in String.length s >= frmlen && String.compare (String.sub s 0 frmlen) pfx = 0 | Exact ext -> let frmlen = String.length ext in String.length s = frmlen && String.compare s ext = 0 (* check a name against a list of forms if it matches any then return true *) (* string -> nameform list -> bool *) let check_forms s fl = List.fold_left (fun b f -> b || check_form s f) false fl let forms = [Exact "tmp"; Prefix "tmp___"; Prefix "__cil_tmp"; Suffix "__e"; Suffix "__b";] (* action: 'a -> varinfo -> fundec -> bool -> exp option * iosh: 'a * fd: fundec * nofrm: bool * * Replace Lval(Var vi, NoOffset) with * e where action iosh sid vi fd nofrm returns Some(e) *) let varXformClass action data sid fd nofrm = object inherit nopCilVisitor method vexpr e = match e.enode with Lval(Var vi, NoOffset) -> (match action data sid vi fd nofrm with None -> DoChildren | Some e' -> (* Cast e' to the correct type. *) let e'' = mkCast e' vi.vtype in ChangeTo e'') | Lval(Mem e', off) -> (* don't substitute constants in memory lvals *) let post e = match e.enode with Lval(Mem({enode = Const _}),off') -> { e with enode = Lval(Mem e', off')} | _ -> e in ChangeDoChildrenPost(new_exp ~loc:e.eloc (Lval(Mem e', off)), post) | _ -> DoChildren end (* action: 'a -> lval -> fundec -> bool -> exp option * lvh: 'a * fd: fundec * nofrm: bool * * Replace Lval(lv) with * e where action lvh sid lv fd nofrm returns Some(e) *) let lvalXformClass action data sid fd nofrm = object inherit nopCilVisitor method vexpr e = let castrm e = Expcompare.stripCastsDeepForPtrArith e in match e.enode with | Lval((Mem e', off) as lv)-> begin match action data sid lv fd nofrm with | None -> (* don't substitute constants in memory lvals *) let post e = match e.enode with | Lval(Mem({enode = Const _}),off') -> new_exp ~loc:e.eloc (Lval(Mem e', off')) | _ -> Expcompare.stripCastsDeepForPtrArith e in ChangeDoChildrenPost(new_exp ~loc:e.eloc (Lval(Mem e', off)), post) | Some e -> let newt = typeOf(new_exp ~loc:e.eloc (Lval lv)) in let e'' = mkCast e newt in ChangeDoChildrenPost(e'', castrm) end | Lval lv -> begin match action data sid lv fd nofrm with | None -> DoChildren | Some e' -> begin (* Cast e' to the correct type. *) let e'' = mkCast e' (typeOf(dummy_exp(Lval lv))) in ChangeDoChildrenPost(e'', castrm) end end | _ -> ChangeDoChildrenPost(castrm e, castrm) end (* Returns the set of definitions of vi in iosh that are not due to assignments of the form x = x *) (* IOS.t IH.t -> varinfo -> int option *) let iosh_get_useful_def iosh vi = if IH.mem iosh vi.vid then let ios = IH.find iosh vi.vid in let ios' = RD.IOS.filter (fun ido -> match ido with None -> true | Some(id) -> match getDefRhs id with Some(RD.RDExp({enode = Lval(Var vi',NoOffset)}),_,_) | Some(RD.RDExp ({enode = CastE(_,{enode = Lval(Var vi',NoOffset)})}),_,_) -> not(vi.vid = vi'.vid) (* false if they are the same *) | _ -> true) ios in if not(RD.IOS.cardinal ios' = 1) then (if !debug then (Kernel.debug "iosh_get_useful_def: multiple different defs of %d:%s(%d)" vi.vid vi.vname (RD.IOS.cardinal ios')); None) else RD.IOS.choose ios' else (if !debug then (Kernel.debug "iosh_get_useful_def: no def of %s reaches here" vi.vname); None) let ae_tmp_to_exp_change = ref false let ae_tmp_to_exp eh _sid vi _fd nofrm = if nofrm || (check_forms vi.vname forms) then try begin let e = IH.find eh vi.vid in if !debug then Kernel.debug "tmp_to_exp: changing %s to %a" vi.vname Cil_printer.pp_exp e; match e.enode with | Const(CStr _) | Const(CWStr _) -> None (* don't fwd subst str lits *) | _ -> begin ae_tmp_to_exp_change := true; Some e end end with Not_found -> None else None let ae_lval_to_exp_change = ref false let ae_lval_to_exp lvh _sid lv _fd nofrm = match lv, nofrm with | (Var vi, NoOffset), false -> (* If the var is not a temp, then don't replace *) if check_forms vi.vname forms then begin try let e = AELV.LvExpHash.find lvh lv in match e.enode with | Const(CStr _) | Const(CWStr _) -> None | _ -> begin ae_lval_to_exp_change := true; if !debug then Kernel.debug "ae: replacing %a with %a" Cil_printer.pp_lval lv Cil_printer.pp_exp e; Some e end with Not_found -> None end else None | _, true -> begin (* replace everything *) try let e = AELV.LvExpHash.find lvh lv in match e.enode with | Const(CStr _) | Const(CWStr _) -> None | _ -> begin ae_lval_to_exp_change := true; Kernel.debug "ae: replacing %a with %a" Cil_printer.pp_lval lv Cil_printer.pp_exp e; Some e end with Not_found -> None end | _, _ -> None (* if the temp with varinfo vi can be replaced by an expression then return Some of that expression. o/w None. If b is true, then don't check the form *) (* IOS.t IH.t -> sid -> varinfo -> fundec -> bool -> exp option *) let rd_tmp_to_exp_change = ref false let rd_tmp_to_exp iosh sid vi fd nofrm = if nofrm || (check_forms vi.vname forms) then let ido = iosh_get_useful_def iosh vi in match ido with None -> if !debug then (Kernel.debug "tmp_to_exp: non-single def: %s" vi.vname); None | Some(id) -> let defrhs = getDefRhs id in match defrhs with None -> if !debug then (Kernel.debug "tmp_to_exp: no def of %s" vi.vname); None | Some(RD.RDExp(e) as r, dsid , defiosh) -> if ok_to_replace vi iosh sid defiosh dsid fd r then (if !debug then Kernel.debug "tmp_to_exp: changing %s to %a" vi.vname Cil_printer.pp_exp e; match e.enode with | Const(CStr _) | Const(CWStr _) -> None | _ -> begin rd_tmp_to_exp_change := true; Some e end) else (if !debug then (Kernel.debug "tmp_to_exp: not ok to replace %s" vi.vname); None) | _ -> if !debug then (Kernel.debug "tmp_to_exp: rhs is call %s" vi.vname); None else (if !debug then (Kernel.debug "tmp_to_exp: %s didn't match form or nofrm" vi.vname); None) let rd_fwd_subst data sid e fd nofrm = rd_tmp_to_exp_change := false; let e' = visitCilExpr (varXformClass rd_tmp_to_exp data sid fd nofrm) e in (e', !rd_tmp_to_exp_change) let ae_fwd_subst data sid e fd nofrm = ae_tmp_to_exp_change := false; let e' = visitCilExpr (varXformClass ae_tmp_to_exp data sid fd nofrm) e in (e', !ae_tmp_to_exp_change) let ae_lv_fwd_subst data sid e fd nofrm = ae_lval_to_exp_change := false; let e' = visitCilExpr (lvalXformClass ae_lval_to_exp data sid fd nofrm) e in (e', !ae_lval_to_exp_change) let ae_simp_fwd_subst data e nofrm = ae_lv_fwd_subst data (-1) e (emptyFunction "@dummy@") nofrm let ae_tmp_to_const_change = ref false let ae_tmp_to_const eh _sid vi _fd nofrm = if nofrm || check_forms vi.vname forms then try begin let e = IH.find eh vi.vid in match e.enode with Const c -> begin ae_tmp_to_const_change := true; Some(new_exp ~loc:e.eloc (Const c)) end | _ -> None end with Not_found -> None else None (* See if vi can be replaced by a constant by checking all of the definitions reaching this use of vi *) let tmp_to_const_change = ref false let tmp_to_const iosh sid vi fd nofrm = if nofrm || check_forms vi.vname forms then match RD.iosh_lookup iosh vi with None -> None | Some(ios) -> let defido = try RD.IOS.choose ios with Not_found -> None in match defido with None -> None | Some defid -> match getDefRhs defid with None -> None | Some(RD.RDExp({enode = Const c;eloc=loc}), _, defiosh) -> (match RD.getDefIdStmt defid with None -> (Kernel.fatal "tmp_to_const: defid has no statement") | Some(stm) -> if ok_to_replace vi iosh sid defiosh stm.sid fd (RD.RDExp(dummy_exp (Const c))) then let same = RD.IOS.for_all (fun defido -> match defido with None -> false | Some defid -> match getDefRhs defid with None -> false | Some(RD.RDExp({enode = Const c'}),_,defiosh) -> if Cil_datatype.Constant.equal c c' then match RD.getDefIdStmt defid with None -> (Kernel.fatal "tmp_to_const: defid has no statement") | Some(stm) -> ok_to_replace vi iosh sid defiosh stm.sid fd (RD.RDExp(dummy_exp (Const c'))) else false | _ -> false) ios in if same then (tmp_to_const_change := true; Some(new_exp ~loc (Const c))) else None else None) | _ -> None else None let const_prop iosh sid e fd nofrm = tmp_to_const_change := false; let e' = visitCilExpr (varXformClass tmp_to_const iosh sid fd nofrm) e in (e', !tmp_to_const_change) let ae_const_prop eh sid e fd nofrm = ae_tmp_to_const_change := false; let e' = visitCilExpr (varXformClass ae_tmp_to_const eh sid fd nofrm) e in (e', !ae_tmp_to_const_change) class expTempElimClass (fd:fundec) = object (self) inherit RD.rdVisitorClass method vexpr e = let do_change iosh vi = let ido = RD.iosh_singleton_lookup iosh vi in (match ido with Some id -> let riviho = getDefRhs id in (match riviho with Some(RD.RDExp(e) as r, dsid, defiosh) -> if !debug then Kernel.debug "Can I replace %s with %a?" vi.vname Cil_printer.pp_exp e; if ok_to_replace vi iosh (Extlib.the self#current_stmt).sid defiosh dsid fd r then (if !debug then (Kernel.debug "Yes."); ChangeTo(e)) else (if !debug then (Kernel.debug "No."); DoChildren) | _ -> DoChildren) | _ -> DoChildren) in match e.enode with Lval (Var vi,NoOffset) -> (if check_forms vi.vname forms then (* only allowed to replace a tmp with a function call once *) (match cur_rd_dat with Some(_,_s,iosh) -> do_change iosh vi | None -> let iviho = RD.getRDs (Extlib.the self#current_stmt) in match iviho with Some(_,_s,iosh) -> (if !debug then (Kernel.debug "Try to change %s outside of instruction." vi.vname); do_change iosh vi) | None -> (if !debug then (Kernel.debug "%s in statement w/o RD info" vi.vname); DoChildren)) else DoChildren) | _ -> DoChildren end class expLvTmpElimClass (fd : fundec) = object(self) inherit AELV.aeVisitorClass method vexpr e = match self#get_cur_eh () with | None -> DoChildren | Some eh -> begin let e', _ = ae_lv_fwd_subst eh (Extlib.the self#current_stmt).sid e fd false in ChangeTo e' end end class incdecTempElimClass (fd:fundec) = object (self) inherit RD.rdVisitorClass method vexpr e = let do_change iosh vi = let ido = RD.iosh_singleton_lookup iosh vi in (match ido with Some id -> let riviho = getDefRhs id in (match riviho with Some(RD.RDExp _e as r, _, defiosh) -> (match ok_to_replace_with_incdec iosh defiosh fd id vi r with Some(curdef_stmt_id,redefid, rhsvi, b) -> (if !debug then (Kernel.debug "No, but I can replace it with a post-inc/dec"); if !debug then (Kernel.debug "cdsi: %d redefid: %d name: %s" curdef_stmt_id redefid rhsvi.vname); IH.add incdecHash vi.vid (redefid, rhsvi, b); id_dh_add rhsvi.vid (curdef_stmt_id, redefid); DoChildren) | None -> (if !debug then (Kernel.debug "No."); DoChildren)) | _ -> DoChildren) | _ -> DoChildren) in match e.enode with Lval (Var vi,NoOffset) -> (if check_forms vi.vname forms then (* only allowed to replace a tmp with an inc/dec if there is only one use *) (match cur_rd_dat with Some(_,_s,iosh) -> do_change iosh vi | None -> let iviho = RD.getRDs (Extlib.the self#current_stmt) in match iviho with Some(_,_s,iosh) -> (if !debug then (Kernel.debug "Try to change %s outside of instruction." vi.vname); do_change iosh vi) | None -> (if !debug then (Kernel.debug "%s in statement w/o RD info" vi.vname); DoChildren)) else DoChildren) | _ -> DoChildren end class callTempElimClass (fd:fundec) = object (self) inherit RD.rdVisitorClass method vexpr e = let do_change iosh vi = let ido = RD.iosh_singleton_lookup iosh vi in (match ido with Some id -> let riviho = getDefRhs id in (match riviho with Some(RD.RDCall(i) as r, dsid, defiosh) -> if !debug then Kernel.debug "Can I replace %s with %a?" vi.vname Cil_printer.pp_instr i; if ok_to_replace vi iosh (Extlib.the self#current_stmt).sid defiosh dsid fd r then (if !debug then (Kernel.debug "Yes."); IH.add iioh vi.vid (Some(i)); DoChildren) else (if !debug then (Kernel.debug "No."); DoChildren) | _ -> DoChildren) | _ -> DoChildren) in match e.enode with Lval (Var vi,NoOffset) -> (if check_forms vi.vname forms then (* only allowed to replace a tmp with a function call if there is only one use *) if IH.mem iioh vi.vid then (IH.replace iioh vi.vid None; DoChildren) else (match cur_rd_dat with Some(_,_s,iosh) -> do_change iosh vi | None -> let iviho = RD.getRDs (Extlib.the self#current_stmt) in match iviho with Some(_,_s,iosh) -> (if !debug then (Kernel.debug "Try to change %s:%d outside of instruction." vi.vname vi.vid); do_change iosh vi) | None -> (if !debug then (Kernel.debug "%s in statement w/o RD info" vi.vname); DoChildren)) else DoChildren) | _ -> DoChildren (* Unused definitions cause multiple replacements unless they are found and the replacement prevented. It will be possible to replace more temps if dead code elimination is performed before printing. *) method vinst i = (* Need to copy this from rdVisitorClass because we are overriding *) if !debug then Kernel.debug "rdVis: before %a, rd_dat_lst is %d long" Cil_printer.pp_instr i (List.length rd_dat_lst); (try cur_rd_dat <- Some(List.hd rd_dat_lst); rd_dat_lst <- List.tl rd_dat_lst with Failure "hd" -> if !debug then (Kernel.debug "rdVis: il rd_dat_lst mismatch")); match i with Set((Var vi,_off),_,_) -> if IH.mem iioh vi.vid then (IH.replace iioh vi.vid None; DoChildren) else (IH.add iioh vi.vid None; DoChildren) | _ -> DoChildren end (* Remove local declarations that aren't set or used *) (* fundec -> unit *) let rm_unused_locals fd = let oldIgnoreSizeof = !UD.ignoreSizeof in UD.ignoreSizeof := false; let used = List.fold_left (fun u s -> let u', d' = UD.computeDeepUseDefStmtKind s.skind in UD.VS.union u (UD.VS.union u' d')) UD.VS.empty fd.sbody.bstmts in UD.ignoreSizeof := oldIgnoreSizeof; let good_var vi = UD.VS.mem vi used in let good_locals = List.filter good_var fd.slocals in let remove_block_locals = object inherit Cil.nopCilVisitor method vblock b = b.blocals <- List.filter good_var b.blocals; DoChildren end in fd.slocals <- good_locals; ignore (visitCilBlock remove_block_locals fd.sbody) (* see if a vi is volatile *) let is_volatile vi = let vi_vol = List.exists (function (Attr("volatile",_)) -> true | _ -> false) vi.vattr in let typ_vol = List.exists (function (Attr("volatile",_)) -> true | _ -> false) (typeAttrs vi.vtype) in if !debug && (vi_vol || typ_vol) then (Kernel.debug "unusedRemover: %s is volatile" vi.vname); if !debug && not(vi_vol || typ_vol) then (Kernel.debug "unusedRemover: %s is not volatile" vi.vname); vi_vol || typ_vol (* Remove temp variables that are set but not used *) (* This is different from dead code elimination because temps that can be eliminated during pretty printing are also considered *) class unusedRemoverClass : cilVisitor = object(self) inherit nopCilVisitor val mutable unused_set = UD.VS.empty val mutable cur_func = emptyFunction "@dummy@" (* a filter function for picking out the local variables that need to be kept *) method private good_var vi = (is_volatile vi) || (not(UD.VS.mem vi unused_set) && (not(IH.mem iioh vi.vid) || (match IH.find iioh vi.vid with None -> true | Some _ -> false)) && not(IH.mem incdecHash vi.vid)) (* figure out which locals aren't used *) method vfunc f = cur_func <- f; (* the set of used variables *) let used = List.fold_left (fun u s -> let u', _ = UD.computeDeepUseDefStmtKind s.skind in UD.VS.union u u') UD.VS.empty f.sbody.bstmts in let used = UD.computeUseLocalTypes ~acc_used:used f in (* the set of unused locals *) let unused = List.fold_left (fun un vi -> if UD.VS.mem vi used then un else (if !debug then (Kernel.debug "unusedRemoverClass: %s is unused" vi.vname); UD.VS.add vi un)) UD.VS.empty f.slocals in unused_set <- unused; let good_locals = List.filter self#good_var f.slocals in f.slocals <- good_locals; DoChildren (* remove instructions that set variables that aren't used. Also remove instructions that set variables mentioned in iioh *) method vstmt stm = (* return the list of pairs with fst = f *) let findf_in_pl f (pl : (int * int) list) = List.filter (fun (fst,_snd) -> if fst = f then true else false) pl in (* Return true if the assignment of this variable in this statement is going to be replaced by a post-inc/dec *) let check_incdec vi e = if IH.mem idDefHash vi.vid then let pl = IH.find idDefHash vi.vid in match findf_in_pl stm.sid pl with (_sid,redefid)::_l -> let rhso = getDefRhs redefid in (match rhso with None -> (if !debug then (Kernel.debug "check_incdec: couldn't find rhs for def %d" redefid); false) | Some(rhs, _, _indiosh) -> (match rhs with RD.RDCall _ -> (if !debug then Kernel.debug "check_incdec: rhs not an expression"; false) | RD.RDExp e' -> if compareExp e e' then true else (if !debug then Kernel.debug "check_incdec: rhs of %d: %a, and needed redef %a \ not equal" redefid Cil_printer.pp_exp e' Cil_printer.pp_exp e; false))) | [] -> (if !debug then Kernel.debug "check_incdec: current statement not in list: %d. \ %s = %a" stm.sid vi.vname Cil_printer.pp_exp e; false) else (if !debug then Kernel.debug "check_incdec: %s not in idDefHash" vi.vname; false) in (* return true if the rhs will get pretty printed as a function call *) let will_be_call e = match e.enode with Lval(Var vi,NoOffset) -> if not(IH.mem iioh vi.vid) then false else (match IH.find iioh vi.vid with None -> false | Some _ -> true) | _ -> false in (* a filter function for picking out the instructions that we want to keep *) (* instr -> bool *) let good_instr i = match i with Set((Var(vi),_),e,_) -> if will_be_call e && not(List.mem vi cur_func.slocals) then cur_func.slocals <- vi::cur_func.slocals; is_volatile vi || (not (UD.VS.mem vi unused_set) && not (IH.mem incdecHash vi.vid) && not (check_incdec vi e)) || will_be_call e | Call (Some(Var(vi),_),_,_,_) -> (* If not in the table or entry is None, then it's good *) not (IH.mem iioh vi.vid) || (match IH.find iioh vi.vid with None -> true | Some _ -> false) | Asm(_,_,slvlst,_,_,_) -> (* make sure the outputs are in the locals list *) List.iter (fun (_,_s,lv) -> match lv with (Var vi,_) -> if List.mem vi cur_func.slocals then () else cur_func.slocals <- vi::cur_func.slocals |_ -> ()) slvlst; true | _ -> true in (* If the result of a function call isn't used, then change to Call(None,...) *) let call_fixer i = match i with Call (Some(Var(vi),_),e,el,l) as c -> if UD.VS.mem vi unused_set then Call(None,e,el,l) else c | _ -> i in match stm.skind with Instr il -> (*let newil = List.filter good_instr [il] in let newil' = List.map call_fixer newil in*) stm.skind <- Instr (if good_instr il then call_fixer il else Skip Cil_datatype.Location.unknown); SkipChildren | _ -> DoChildren method vblock b = b.blocals <- List.filter self#good_var b.blocals; DoChildren end (* from cleaner.ml *) (* Lifts child blocks into parents if the block has no attributes or labels *) let rec fold_blocks b = b.bstmts <- List.fold_right (fun s acc -> match s.skind with Block ib -> fold_blocks ib; if (List.length ib.battrs = 0 && List.length s.labels = 0) then ib.bstmts @ acc else s::acc | Instr (Skip _) when s.labels = [] -> acc | _ -> s::acc) b.bstmts [] class removeBrackets = object inherit nopCilVisitor method vblock b = fold_blocks b; DoChildren end (* clean up the code and eliminate some temporaries for pretty printing a whole function *) (* Cil.fundec -> Cil.fundec *) let eliminate_temps f = ignore(visitCilFunction (new removeBrackets) f); Cfg.clearCFGinfo f; ignore(Cfg.cfgFun f); UD.ignoreSizeof := false; RD.computeRDs f; IH.clear iioh; IH.clear incdecHash; IH.clear idDefHash; let etec = new expLvTmpElimClass f in let f' = visitCilFunction (etec :> cilVisitor) f in let idtec = new incdecTempElimClass f' in let f' = visitCilFunction (idtec :> cilVisitor) f' in let ctec = new callTempElimClass f' in let f' = visitCilFunction (ctec :> cilVisitor) f' in visitCilFunction (new unusedRemoverClass) f' (* same as above, but doesn't remove the obviated instructions and declarations. Use this before using zrapp to print expressions without temps *) let eliminateTempsForExpPrinting f = Cfg.clearCFGinfo f; ignore(Cfg.cfgFun f); UD.ignoreSizeof := false; RD.computeRDs f; IH.clear iioh; IH.clear incdecHash; IH.clear idDefHash; let etec = new expLvTmpElimClass f in let f' = visitCilFunction (etec :> cilVisitor) f in RD.clearMemos (); (* we changed instructions and invalidated the "cache" *) let idtec = new incdecTempElimClass f' in let f' = visitCilFunction (idtec :> cilVisitor) f' in let ctec = new callTempElimClass f' in let f' = visitCilFunction (ctec :> cilVisitor) f' in f' frama-c-Fluorine-20130601/cil/src/ext/reachingdefs.ml0000644000175000017500000004754012155630366021130 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* Calculate reaching definitions for each instruction. * Determine when it is okay to replace some variables with * expressions. * * After calling computeRDs on a fundec, * ReachingDef.stmtStartData will contain a mapping from * statement ids to data about which definitions reach each * statement. ReachingDef.defIdStmtHash will contain a * mapping from definition ids to the statement in which * that definition takes place. * * instrRDs takes a list of instructions, and the * definitions that reach the first instruction, and * for each instruction figures out which definitions * reach into or out of each instruction. * *) open Cil_types open Cil module DF = Dataflow module UD = Usedef module L = Liveness module IH = Datatype.Int.Hashtbl (* This module always uses "int = varinfo.vid", but generate some new ids at some point. Thus, it cannot be easily be replaced by Cil_datatype.Varinfo.Hashtbl... *) let debug_fn = ref "" module IOS = Set.Make(struct type t = int option let compare io1 io2 = match io1, io2 with Some i1, Some i2 -> Datatype.Int.compare i1 i2 | Some _i1, None -> 1 | None, Some _i2 -> -1 | None, None -> 0 end) let debug = ref false (* return the intersection of Datatype.Int.Hashtbles ih1 and ih2 *) let ih_inter ih1 ih2 = let ih' = IH.copy ih1 in IH.iter (fun id _vi -> if not(IH.mem ih2 id) then IH.remove ih' id else ()) ih1; ih' let ih_union ih1 ih2 = let ih' = IH.copy ih1 in IH.iter (fun id vi -> if not(IH.mem ih' id) then IH.add ih' id vi else ()) ih2; ih' (* Lookup varinfo in iosh. If the set contains None or is not a singleton, return None, otherwise return Some of the singleton *) (* IOS.t IH.t -> varinfo -> int option *) let iosh_singleton_lookup iosh vi = if IH.mem iosh vi.vid then let ios = IH.find iosh vi.vid in if not (IOS.cardinal ios = 1) then None else IOS.choose ios else None (* IOS.t IH.t -> varinfo -> IOS.t *) let iosh_lookup iosh vi = if IH.mem iosh vi.vid then Some(IH.find iosh vi.vid) else None (* return Some(vid) if iosh contains defId. return None otherwise *) (* IOS.t IH.t -> int -> int option *) let iosh_defId_find iosh defId = (* int -> IOS.t -> int option -> int option*) let get_vid vid ios io = match io with Some(i) -> Some(i) | None -> let there = IOS.exists (function None -> false | Some(i') -> defId = i') ios in if there then Some(vid) else None in IH.fold get_vid iosh None (* The resulting iosh will contain the union of the same entries from iosh1 and iosh2. If iosh1 has an entry that iosh2 does not, then the result will contain None in addition to the things from the entry in iosh1. *) (* XXX this function is a performance bottleneck *) let iosh_combine iosh1 iosh2 = let iosh' = IH.copy iosh1 in IH.iter (fun id ios1 -> try let ios2 = IH.find iosh2 id in let newset = IOS.union ios1 ios2 in IH.replace iosh' id newset; with Not_found -> let newset = IOS.add None ios1 in IH.replace iosh' id newset) iosh1; IH.iter (fun id ios2 -> try ignore(IH.find iosh1 id) with Not_found -> begin (*if not(IH.mem iosh1 id) then*) let newset = IOS.add None ios2 in IH.add iosh' id newset end) iosh2; iosh' (* determine if two IOS.t IH.t s are the same *) let iosh_equals iosh1 iosh2 = (* if IH.length iosh1 = 0 && not(IH.length iosh2 = 0) || IH.length iosh2 = 0 && not(IH.length iosh1 = 0)*) if not(IH.length iosh1 = IH.length iosh2) then (Kernel.debug "iosh_equals: length not same" ; false) else IH.fold (fun vid ios b -> if not b then b else try let ios2 = IH.find iosh2 vid in if not(IOS.compare ios ios2 = 0) then (Kernel.debug "iosh_equals: sets for vid %d not equal\n" vid ; false) else true with Not_found -> (Kernel.debug "iosh_equals: vid %d not in iosh2\n" vid ; false)) iosh1 true (* replace an entire set with a singleton. if nothing was there just add the singleton *) (* IOS.t IH.t -> int -> varinfo -> unit *) let iosh_replace iosh i vi = if IH.mem iosh vi.vid then let newset = IOS.singleton (Some i) in IH.replace iosh vi.vid newset else let newset = IOS.singleton (Some i) in IH.add iosh vi.vid newset let iosh_filter_dead iosh vs = IH.iter (fun vid _ -> if not(UD.VS.exists (fun vi -> vid = vi.vid) vs) then IH.remove iosh vid) iosh (* remove definitions that are killed. add definitions that are gend *) (* Takes the defs, the data, and a function for obtaining the next def id *) (* VS.t -> IOS.t IH.t -> (unit->int) -> unit *) let proc_defs vs iosh f = let pd vi = let newi = f() in (*if !debug then ignore (E.log "proc_defs: genning %d\n" newi);*) iosh_replace iosh newi vi in UD.VS.iter pd vs let idMaker () start = let counter = ref start in fun () -> let ret = !counter in counter := !counter + 1; ret (* given reaching definitions into a list of instructions, figure out the definitions that reach in/out of each instruction *) (* if out is true then calculate the definitions that go out of each instruction, if it is false then calculate the definitions reaching into each instruction *) (* instr list -> int -> (varinfo IH.t * int) -> bool -> (varinfo IH.t * int) list *) let iRDsHtbl = Hashtbl.create 128 let instrRDs il sid (_ivih, s, iosh) out = if Hashtbl.mem iRDsHtbl (sid,out) then Hashtbl.find iRDsHtbl (sid,out) else (* let print_instr i (_,s', iosh') = *) (* let d = d_instr () i ++ line in *) (* fprint stdout 80 d; *) (* flush stdout *) (* in *) let proc_one hil i = match hil with | [] -> let _, defd = UD.computeUseDefInstr i in if UD.VS.is_empty defd then ((*if !debug then print_instr i ((), s, iosh);*) [((), s, iosh)]) else let iosh' = IH.copy iosh in proc_defs defd iosh' (idMaker () s); (*if !debug then print_instr i ((), s + UD.VS.cardinal defd, iosh');*) ((), s + UD.VS.cardinal defd, iosh')::hil | (_, s', iosh')::_hrst as l -> let _, defd = UD.computeUseDefInstr i in if UD.VS.is_empty defd then ((*if !debug then print_instr i ((),s', iosh');*) ((), s', iosh')::l) else let iosh'' = IH.copy iosh' in proc_defs defd iosh'' (idMaker () s'); (*if !debug then print_instr i ((), s' + UD.VS.cardinal defd, iosh'');*) ((),s' + UD.VS.cardinal defd, iosh'')::l in let folded = List.fold_left proc_one [((),s,iosh)] [il] in let foldedout = List.tl (List.rev folded) in let foldednotout = List.rev (List.tl folded) in Hashtbl.add iRDsHtbl (sid,true) foldedout; Hashtbl.add iRDsHtbl (sid,false) foldednotout; if out then foldedout else foldednotout (* The right hand side of an assignment is either a function call or an expression *) type rhs = RDExp of exp | RDCall of instr module ReachingDef = struct let name = "Reaching Definitions" let debug = debug (* Should the analysis calculate may-reach or must-reach *) let mayReach = ref false (* An integer that tells the id number of the first definition *) (* Also a hash from variable ids to a set of definition ids that reach this statement. None means there is a path to this point on which there is no definition of the variable *) type t = (unit * int * IOS.t IH.t) module StmtStartData = Dataflow.StartData (struct type t = (unit * int * IOS.t IH.t) let size = 32 end) (* entries for starting statements must be added before calling compute *) let copy (_, i, iosh) = ((), i, Datatype.Int.Hashtbl.copy iosh) (* a mapping from definition ids to the statement corresponding to that id *) let defIdStmtHash = Datatype.Int.Hashtbl.create 32 (* mapping from statement ids to statements for better performance of ok_to_replace *) let sidStmtHash = Datatype.Int.Hashtbl.create 64 (* pretty printer *) let pretty _fmt _ = () (* prettyprint defIdStmtHash stmtStartData*) (* The first id to use when computeFirstPredecessor is next called *) let nextDefId = ref 0 (* Count the number of variable definitions in a statement *) let num_defs stm = match stm.skind with Instr(il) -> List.fold_left (fun s i -> let _, d = UD.computeUseDefInstr i in s + UD.VS.cardinal d) 0 [il] | _ -> let _, d = UD.computeUseDefStmtKind stm.skind in UD.VS.cardinal d (* the first predecessor is just the data in along with the id of the first definition of the statement, which we get from nextDefId *) let computeFirstPredecessor stm (_, s, iosh) = let startDefId = max !nextDefId s in let numds = num_defs stm in let rec loop n = if n < 0 then () else (Kernel.debug "RD: defId %d -> stm %d\n" (startDefId + n) stm.sid ; Datatype.Int.Hashtbl.add defIdStmtHash (startDefId + n) stm; loop (n-1)) in loop (numds - 1); nextDefId := startDefId + numds; ((), startDefId, Datatype.Int.Hashtbl.copy iosh) let combinePredecessors (_stm:stmt) ~(old:t) ((_, _s, iosh):t) = match old with (_, os, oiosh) -> begin if iosh_equals oiosh iosh then None else Some((), os, iosh_combine oiosh iosh) end (* return an action that removes things that are redefinied and adds the generated defs *) let doInstr _ inst (_, _s, _iosh) = let transform (_, s', iosh') = let _, defd = UD.computeUseDefInstr inst in proc_defs defd iosh' (idMaker () s'); ((), s' + UD.VS.cardinal defd, iosh') in DF.Post transform (* all the work gets done at the instruction level *) let doStmt stm (_, _s, iosh) = if not(Datatype.Int.Hashtbl.mem sidStmtHash stm.sid) then Datatype.Int.Hashtbl.add sidStmtHash stm.sid stm; if !debug then Kernel.debug "RD: looking at %a\n" Cil_printer.pp_stmt stm; match L.getLiveSet stm with | None -> DF.SDefault | Some vs -> begin iosh_filter_dead iosh vs; DF.SDefault end let doGuard _ _condition _ = DF.GDefault, DF.GDefault let filterStmt _stm = true let stmt_can_reach _ _ = true let doEdge _ _ d = d end module RD = Dataflow.Forwards(ReachingDef) (* take the id number of a definition and return the rhs of the definition if there is one. Returns None if, for example, the definition is caused by an assembly instruction *) (* stmt IH.t -> (()*int*IOS.t IH.t) IH.t -> int -> (rhs * int * IOS.t IH.t) option *) let rhsHtbl = IH.create 64 (* to avoid recomputation *) let getDefRhs didstmh defId = if IH.mem rhsHtbl defId then IH.find rhsHtbl defId else let stm = try IH.find didstmh defId with Not_found -> Kernel.fatal "getDefRhs: defId %d not found\n" defId in let (_,s,iosh) = try ReachingDef.StmtStartData.find stm with Not_found -> Kernel.fatal "getDefRhs: sid %d not found \n" stm.sid in match stm.skind with Instr il -> let ivihl = instrRDs il stm.sid ((),s,iosh) true in (* defs that reach out of each instr *) let ivihl_in = instrRDs il stm.sid ((),s,iosh) false in (* defs that reach into each instr *) begin try let iihl = List.combine (List.combine [il] ivihl) ivihl_in in (try let ((i,(_,_,_diosh)),(_,_,iosh_in)) = List.find (fun ((i,(_,_,iosh')),_) -> match iosh_defId_find iosh' defId with Some vid -> (match i with Set((Var vi',NoOffset),_,_) -> vi'.vid = vid (* _ -> NoOffset *) | Call(Some(Var vi',NoOffset),_,_,_) -> vi'.vid = vid (* _ -> NoOffset *) | Call(None,_,_,_) -> false | Asm(_,_,sll,_,_,_) -> List.exists (function (_,_,(Var vi',NoOffset)) -> vi'.vid = vid | _ -> false) sll | _ -> false) | None -> false) iihl in (match i with Set((lh,_),e,_) -> (match lh with Var _vi' -> (IH.add rhsHtbl defId (Some(RDExp(e),stm.sid,iosh_in)); Some(RDExp(e), stm.sid, iosh_in)) | _ -> Kernel.fatal "Reaching Defs getDefRhs: right vi not first") | Call(_lvo,_e,_el,_) -> (IH.add rhsHtbl defId (Some(RDCall(i),stm.sid,iosh_in)); Some(RDCall(i), stm.sid, iosh_in)) | Skip _ | Code_annot _ -> None | Asm(_a,_sl,_slvl,_sel,_sl',_) -> None) (* ? *) with Not_found -> (if !debug then (Kernel.debug "getDefRhs: No instruction defines %d" defId); IH.add rhsHtbl defId None; None)) with Invalid_argument _ -> None end | _ -> Kernel.fatal "getDefRhs: defining statement not an instruction list %d" defId (*None*) let prettyprint _fmt _didstmh _stmdat () (_,_s,_iosh) = () (*seq line (fun (vid,ios) -> num vid ++ text ": " ++ IOS.fold (fun io d -> match io with None -> d ++ text "None " | Some i -> let stm = IH.find didstmh i in match getDefRhs didstmh stmdat i with None -> d ++ num i | Some(RDExp(e),_,_) -> d ++ num i ++ text " " ++ (d_exp () e) | Some(RDCall(c),_,_) -> d ++ num i ++ text " " ++ (d_instr () c)) ios nil) (IH.tolist iosh)*) (* map all variables in vil to a set containing None in iosh *) (* IOS.t IH.t -> varinfo list -> () *) let iosh_none_fill iosh vil = List.iter (fun vi -> IH.add iosh vi.vid (IOS.singleton None)) vil let clearMemos () = IH.clear rhsHtbl; Hashtbl.clear iRDsHtbl (* Computes the reaching definitions for a function. *) (* Cil.fundec -> unit *) let computeRDs fdec = try if String.compare fdec.svar.vname (!debug_fn) = 0 then (debug := true; Kernel.debug "%s =\n%a\n" (!debug_fn) Cil_printer.pp_block fdec.sbody); let bdy = fdec.sbody in let slst = bdy.bstmts in ReachingDef.StmtStartData.clear (); IH.clear ReachingDef.defIdStmtHash; IH.clear rhsHtbl; Hashtbl.clear iRDsHtbl; ReachingDef.nextDefId := 0; let fst_stm = List.hd slst in let fst_iosh = IH.create 32 in UD.onlyNoOffsetsAreDefs := false; ReachingDef.StmtStartData.add fst_stm ((), 0, fst_iosh); L.computeLiveness fdec; ignore(ReachingDef.computeFirstPredecessor fst_stm ((), 0, fst_iosh)); if !debug then Kernel.debug "computeRDs: fst_stm.sid=%d\n" fst_stm.sid ; RD.compute [fst_stm]; if String.compare fdec.svar.vname (!debug_fn) = 0 then debug := false (* now ReachingDef.stmtStartData has the reaching def data in it *) with Failure "hd" -> if String.compare fdec.svar.vname (!debug_fn) = 0 then debug := false (* return the definitions that reach the statement with statement id sid *) let getRDs sid = try Some (ReachingDef.StmtStartData.find sid) with Not_found -> None (* E.s (E.error "getRDs: sid %d not found\n" sid) *) let getDefIdStmt defid = try Some(IH.find ReachingDef.defIdStmtHash defid) with Not_found -> None let getStmt sid = try Some(IH.find ReachingDef.sidStmtHash sid) with Not_found -> None (* returns the rhs for the definition *) let getSimpRhs defId = let rhso = getDefRhs ReachingDef.defIdStmtHash defId in match rhso with None -> None | Some(r,_,_) -> Some(r) (* check if i is responsible for defId *) (* instr -> int -> bool *) let isDefInstr i defId = match getSimpRhs defId with Some(RDCall i') -> Cil_datatype.Instr.equal i i' | _ -> false (* (* Pretty print the reaching definition data for a function *) let ppFdec fdec = seq line (fun stm -> let ivih = IH.find ReachingDef.stmtStartData stm.sid in ReachingDef.pretty () ivih) fdec.sbody.bstmts *) (* If this class is extended with a visitor on expressions, then the current rd data is available at each expression *) class rdVisitorClass = object (self) inherit nopCilVisitor (* if a list of instructions is being processed, then this is the corresponding list of reaching definitions *) val mutable rd_dat_lst = [] (* these are the reaching defs for the current instruction if there is one *) val mutable cur_rd_dat = None method vstmt stm = match getRDs stm with | None -> if !debug then (Kernel.debug "rdVis: stm %d had no data\n" stm.sid); cur_rd_dat <- None; DoChildren | Some(_,s,iosh) -> match stm.skind with Instr il -> if !debug then (Kernel.debug "rdVis: visit il\n"); rd_dat_lst <- instrRDs il stm.sid ((),s,iosh) false; DoChildren | _ -> if !debug then (Kernel.debug "rdVis: visit non-il\n"); cur_rd_dat <- None; DoChildren method vinst i = if !debug then Kernel.debug "rdVis: before %a, rd_dat_lst is %d long\n" Cil_printer.pp_instr i (List.length rd_dat_lst); try cur_rd_dat <- Some(List.hd rd_dat_lst); rd_dat_lst <- List.tl rd_dat_lst; DoChildren with Failure "hd" -> if !debug then (Kernel.debug "rdVis: il rd_dat_lst mismatch\n"); DoChildren method get_cur_iosh () = match cur_rd_dat with None -> (match getRDs (Extlib.the self#current_stmt) with None -> None | Some(_,_,iosh) -> Some iosh) | Some(_,_,iosh) -> Some iosh end frama-c-Fluorine-20130601/cil/src/ext/usedef.ml0000755000175000017500000002470412155630366017761 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) open Cil_types open Cil (** compute use/def information *) module VS = Cil_datatype.Varinfo.Set (** Set this global to how you want to handle function calls. This also returns a modified argument list which will be used for the purpose of Use analysis, in case you have a function that needs special treatment of its args. *) let getUseDefFunctionRef: (exp -> exp list -> VS.t * VS.t * exp list) ref = ref (fun _func args -> (VS.empty, VS.empty, args)) (** Say if you want to consider a variable use. This applies to variable reads only; see also considerVariableAddrOfAsUse *) let considerVariableUse: (varinfo -> bool) ref = ref (fun _ -> true) (** Say if you want to consider a variable def *) let considerVariableDef: (varinfo -> bool) ref = ref (fun _ -> true) (** Say if you want to consider a variable addrof as a use *) let considerVariableAddrOfAsUse: (varinfo -> bool) ref = ref (fun _ -> true) (** Return any vars that should be considered "used" by an expression, other than the ones it refers to directly. Deputy uses this for variables in Cast annotations. *) let extraUsesOfExpr: (exp -> VS.t) ref = ref (fun _ -> VS.empty) (* When this is true, only definitions of a variable without an offset are counted as definitions. So: a = 5; would be a definition, but a[1] = 5; would not. Exception: writing to a union field is considered to be a definition of the union even if this is set to true.*) let onlyNoOffsetsAreDefs: bool ref = ref false (** Should we ignore the contents of sizeof and alignof? *) let ignoreSizeof: bool ref = ref true let varUsed: VS.t ref = ref VS.empty let varDefs: VS.t ref = ref VS.empty class useDefVisitorClass : cilVisitor = object (self) inherit nopCilVisitor (** this will be invoked on variable definitions only because we intercept * all uses of variables in expressions ! *) method vvrbl (v: varinfo) = if (!considerVariableDef) v && not(!onlyNoOffsetsAreDefs) then varDefs := VS.add v !varDefs; SkipChildren (** If onlyNoOffsetsAreDefs is true, then we need to see the * varinfo in an lval along with the offset. Otherwise just * DoChildren *) method vlval (l: lval) = if !onlyNoOffsetsAreDefs then match l with (Var vi, NoOffset) -> if (!considerVariableDef) vi then varDefs := VS.add vi !varDefs; SkipChildren | (Var vi, Field(fi, NoOffset)) when not fi.fcomp.cstruct -> (* If we are writing to a union field, treat that the same as a write to a union. *) if (!considerVariableDef) vi then varDefs := VS.add vi !varDefs; SkipChildren | _ -> DoChildren else DoChildren method vexpr (e:exp) = let extra = (!extraUsesOfExpr) e in if not (VS.is_empty extra) then varUsed := VS.union extra !varUsed; match e.enode with Lval (Var v, off) -> ignore (visitCilOffset (self :> cilVisitor) off); if (!considerVariableUse) v then varUsed := VS.add v !varUsed; SkipChildren (* So that we do not see the v *) | AddrOf (Var v, off) | StartOf (Var v, off) -> ignore (visitCilOffset (self :> cilVisitor) off); if (!considerVariableAddrOfAsUse) v then varUsed := VS.add v !varUsed; SkipChildren | SizeOfE _ | AlignOfE _ when !ignoreSizeof -> SkipChildren | _ -> DoChildren (* For function calls, do the transitive variable read/defs *) method vinst = function Call (lvo, f, args, _) -> begin (* we will compute the use and def that appear in * this instruction. We also add in the stuff computed by * getUseDefFunctionRef *) let use, def, args' = !getUseDefFunctionRef f args in varUsed := VS.union !varUsed use; varDefs := VS.union !varDefs def; (* Now visit the children of "Call (lvo, f, args', _)" *) let self: cilVisitor = (self :> cilVisitor) in (match lvo with None -> () | Some lv -> ignore (visitCilLval self lv)); ignore (visitCilExpr self f); List.iter (fun arg -> ignore (visitCilExpr self arg)) args'; SkipChildren; end | Asm(_,_,slvl,_,_,_) -> List.iter (fun (_,s,lv) -> match lv with (Var v, _off) -> if s.[0] = '+' then varUsed := VS.add v !varUsed; | _ -> ()) slvl; DoChildren | _ -> DoChildren end let useDefVisitor = new useDefVisitorClass (** Compute the use information for an expression (accumulate to an existing * set) *) let computeUseExp ?(acc=VS.empty) (e: exp) : VS.t = varUsed := acc; ignore (visitCilExpr useDefVisitor e); !varUsed (** Compute the use/def information for an instruction *) let computeUseDefInstr ?(acc_used=VS.empty) ?(acc_defs=VS.empty) (i: instr) : VS.t * VS.t = varUsed := acc_used; varDefs := acc_defs; ignore (visitCilInstr useDefVisitor i); !varUsed, !varDefs (** Compute the use/def information for a statement kind. Do not descend into * the nested blocks. *) let computeUseDefStmtKind ?(acc_used=VS.empty) ?(acc_defs=VS.empty) (sk: stmtkind) : VS.t * VS.t = varUsed := acc_used; varDefs := acc_defs; let ve e = ignore (visitCilExpr useDefVisitor e) in let _ = match sk with Return (None, _) -> () | Return (Some e, _) -> ve e | If (e, _, _, _) -> ve e | Break _ | Goto _ | Continue _ -> () | Loop (_,_, _, _, _) -> () | Switch (e, _, _, _) -> ve e | Instr il -> ignore (visitCilInstr useDefVisitor il) | TryExcept _ | TryFinally _ -> () | Block _ | UnspecifiedSequence _ -> () in !varUsed, !varDefs (* Compute the use/def information for a statement kind. DO descend into nested blocks *) let rec computeDeepUseDefStmtKind ?(acc_used=VS.empty) ?(acc_defs=VS.empty) (sk: stmtkind) : VS.t * VS.t = let handle_block b = List.fold_left (fun (u,d) s -> let u',d' = computeDeepUseDefStmtKind s.skind in (VS.union u u', VS.union d d')) (VS.empty, VS.empty) b.bstmts in varUsed := acc_used; varDefs := acc_defs; let ve e = ignore (visitCilExpr useDefVisitor e) in match sk with Return (None, _) -> !varUsed, !varDefs | Return (Some e, _) -> let _ = ve e in !varUsed, !varDefs | If (e, tb, fb, _) -> let _ = ve e in let u, d = !varUsed, !varDefs in let u', d' = handle_block tb in let u'', d'' = handle_block fb in (VS.union (VS.union u u') u'', VS.union (VS.union d d') d'') | Break _ | Goto _ | Continue _ -> !varUsed, !varDefs | Loop (_,b, _, _, _) -> handle_block b | Switch (e, b, _, _) -> let _ = ve e in let u, d = !varUsed, !varDefs in let u', d' = handle_block b in (VS.union u u', VS.union d d') | Instr il -> ignore (visitCilInstr useDefVisitor il); !varUsed, !varDefs | TryExcept _ | TryFinally _ -> !varUsed, !varDefs | Block b -> handle_block b | UnspecifiedSequence seq -> handle_block (block_from_unspecified_sequence seq) let computeUseLocalTypes ?(acc_used=VS.empty) (fd : fundec) = List.fold_left (fun u vi -> ignore(visitCilType useDefVisitor vi.vtype); VS.union u (!varUsed)) acc_used fd.slocals frama-c-Fluorine-20130601/cil/src/ext/expcompare.ml0000644000175000017500000001775712155630366020660 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) open Cil_types open Cil (* Remove casts that do not effect the value of the expression, such * as casts between different pointer types. Of course, these casts * change the type, so don't use this within e.g. an arithmetic * expression. * * We remove casts from pointer types to unsigned int or unsigned long. * * We also prune casts between equivalent integer types, such as a * difference in sign or int vs long. But we keep other arithmetic casts, * since they actually change the value of the expression. *) let rec stripNopCasts (e:exp): exp = match e.enode with CastE(t, e') -> begin match unrollType (typeOf e'), unrollType t with TPtr _, TPtr _ -> (* okay to strip *) stripNopCasts e' (* strip casts from pointers to unsigned int/long*) | (TPtr _ as t1), (TInt(ik,_) as t2) when bitsSizeOf t1 = bitsSizeOf t2 && not (isSigned ik) -> stripNopCasts e' | (TInt _ as t1), (TInt _ as t2) when bitsSizeOf t1 = bitsSizeOf t2 -> (* Okay to strip.*) stripNopCasts e' | _ -> e end | _ -> e let compareExpStripCasts (e1: exp) (e2: exp) : bool = compareExp (stripNopCasts e1) (stripNopCasts e2) (* A more conservative form of stripNopCasts. Here, we only strip pointer casts if the base types have the same width. Using this on the left operand of pointer arithmetic shouldn't change the resulting value. *) let rec stripCastsForPtrArith (e:exp): exp = match e.enode with | CastE(t, e') -> begin match unrollType (typeOf e'), unrollType t with TPtr (bt1, _), TPtr (bt2, _) -> begin try if bitsSizeOf bt1 = bitsSizeOf bt2 then (* Okay to strip *) stripCastsForPtrArith e' else e with SizeOfError _ -> (* bt1 or bt2 is abstract; don't strip. *) e end (* strip casts from pointers to unsigned int/long*) | (TPtr _ as t1), (TInt(ik,_) as t2) when bitsSizeOf t1 = bitsSizeOf t2 && not (isSigned ik) -> stripCastsForPtrArith e' | (TInt _ as t1), (TInt _ as t2) when bitsSizeOf t1 = bitsSizeOf t2 -> (* Okay to strip.*) stripCastsForPtrArith e' | _ -> e end | _ -> e class volatileFinderClass br = object inherit nopCilVisitor method vtype (t : typ) = if hasAttribute "volatile" (typeAttrs t) then begin br := true; SkipChildren end else DoChildren end let isTypeVolatile t = let br = ref false in let vis = new volatileFinderClass br in ignore(visitCilType vis t); !br (* strip every cast between equal pointer types *) let rec stripCastsDeepForPtrArith (e:exp): exp = match e.enode with | CastE(t, e') when not(isTypeVolatile t) -> begin let e' = stripCastsDeepForPtrArith e' in match unrollType (typeOf e'), unrollType t with | TPtr (bt1, _), TPtr (bt2, _) -> begin try if bitsSizeOf bt1 = bitsSizeOf bt2 then (* Okay to strip *) e' else new_exp ~loc:e.eloc (CastE(t,e')) with SizeOfError _ -> (* bt1 or bt2 is abstract; don't strip. *) new_exp ~loc:e.eloc (CastE(t,e')) end | _, _ -> new_exp ~loc:e.eloc (CastE(t,e')) end | UnOp(op,e',t) -> let e' = stripCastsDeepForPtrArith e' in new_exp ~loc:e.eloc (UnOp(op, e', t)) | BinOp(MinusPP,e1,e2,t) -> let e1 = stripCastsDeepForPtrArith e1 in let e2 = stripCastsDeepForPtrArith e2 in if not(Cil_datatype.Typ.equal (typeOf e1) (typeOf e2)) then new_exp ~loc:e.eloc (BinOp(MinusPP, mkCast e1 (typeOf e2), e2, t)) else new_exp ~loc:e.eloc (BinOp(MinusPP, e1, e2, t)) | BinOp(op,e1,e2,t) -> let e1 = stripCastsDeepForPtrArith e1 in let e2 = stripCastsDeepForPtrArith e2 in new_exp ~loc:e.eloc (BinOp(op,e1,e2,t)) | Lval lv -> new_exp ~loc:e.eloc (Lval(stripCastsForPtrArithLval lv)) | AddrOf lv -> new_exp ~loc:e.eloc (AddrOf(stripCastsForPtrArithLval lv)) | StartOf lv -> new_exp ~loc:e.eloc (StartOf(stripCastsForPtrArithLval lv)) | _ -> e and stripCastsForPtrArithLval (lv : lval) : lval = match lv with | (Var vi, off) -> (Var vi, stripCastsForPtrArithOff off) | (Mem e, off) -> let e = stripCastsDeepForPtrArith e in let off = stripCastsForPtrArithOff off in (Mem e, off) and stripCastsForPtrArithOff (off : offset ) : offset = match off with | NoOffset -> NoOffset | Field(fi, off) -> Field(fi, stripCastsForPtrArithOff off) | Index(e, off) -> let e = stripCastsDeepForPtrArith e in let off = stripCastsForPtrArithOff off in Index(e, off) let compareExpDeepStripCasts (e1 : exp) (e2 : exp) : bool = compareExp (stripCastsDeepForPtrArith e1) (stripCastsDeepForPtrArith e2) frama-c-Fluorine-20130601/cil/src/ext/cfg.ml0000644000175000017500000007524612155630366017251 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* Authors: Aman Bhargava, S. P. Rahul *) (* sfg: this stuff was stolen from optim.ml - the code to print the cfg as a dot graph is mine *) open Cil open Cil_types open Cil_datatype (* entry points: cfgFun, printCfgChannel, printCfgFilename *) (* known issues: * -sucessors of if somehow end up with two edges each *) (*------------------------------------------------------------*) (* Notes regarding CFG computation: 1) Initially only succs and preds are computed. sid's are filled in later, in whatever order is suitable (e.g. for forward problems, reverse depth-first postorder). 2) If a stmt (return, break or continue) has no successors, then function return must follow. No predecessors means it is the start of the function 3) We use the fact that initially all the succs and preds are assigned [] *) (* Fill in the CFG info for the stmts in a block next = succ of the last stmt in this block break = succ of any Break in this block cont = succ of any Continue in this block None means the succ is the function return. It does not mean the break/cont is invalid. We assume the validity has already been checked. *) (* At the end of CFG computation, - numNodes = total number of CFG nodes - length(nodeList) = numNodes *) (*let numNodes = ref 0 (* number of nodes in the CFG *)*) let nodeList : stmt list ref = ref [] (* All the nodes in a flat list *) (* ab: Added to change dfs from quadratic to linear *) class caseLabeledStmtFinder slr = object inherit nopCilVisitor method vstmt s = if List.exists (fun l -> match l with | Case(_, _) | Default _ -> true | _ -> false) s.labels then begin slr := s :: (!slr); match s.skind with | Switch(_,_,_,_) -> SkipChildren | _ -> DoChildren end else match s.skind with | Switch(_,_,_,_) -> SkipChildren | _ -> DoChildren end let findCaseLabeledStmts (b : block) : stmt list = let slr = ref [] in let vis = new caseLabeledStmtFinder slr in ignore(visitCilBlock vis b); !slr (* entry point *) (** Compute a control flow graph for fd. Stmts in fd have preds and succs filled in *) let rec cfgFun (fd : fundec) = nodeList := []; cfgBlock fd.sbody None None None; fd.smaxstmtid <- Some(Cil.Sid.next ()); fd.sallstmts <- List.rev !nodeList; nodeList := [] and cfgStmts (ss: stmt list) (next:stmt option) (break:stmt option) (cont:stmt option) = match ss with [] -> (); | [s] -> cfgStmt s next break cont | hd::tl -> cfgStmt hd (Some (List.hd tl)) break cont; cfgStmts tl next break cont and cfgBlock (blk: block) (next:stmt option) (break:stmt option) (cont:stmt option) = cfgStmts blk.bstmts next break cont (* Fill in the CFG info for a stmt Meaning of next, break, cont should be clear from earlier comment *) and cfgStmt (s: stmt) (next:stmt option) (break:stmt option) (cont:stmt option) = if s.sid = -1 then s.sid <- Cil.Sid.next (); nodeList := s :: !nodeList; (* Future traversals can be made in linear time. e.g. *) if s.succs <> [] then Kernel.fatal "CFG must be cleared before being computed! Stmt %d '%a' \ has %d successors" s.sid Cil_printer.pp_stmt s (List.length s.succs); let addSucc (n: stmt) = if not (List.memq n s.succs) then s.succs <- n::s.succs; if not (List.memq s n.preds) then n.preds <- s::n.preds in let addOptionSucc (n: stmt option) = match n with None -> () | Some n' -> addSucc n' in let addBlockSucc (b: block) = match b.bstmts with [] -> addOptionSucc next | hd::_ -> addSucc hd in let addBlockSuccFull (next:stmt) (b: block) = match b.bstmts with [] -> addSucc next | hd::_ -> addSucc hd in let instrFallsThrough (i : instr) : bool = match i with Call (_, {enode = Lval (Var vf, NoOffset)}, _, _) -> (* See if this has the noreturn attribute *) not (hasAttribute "noreturn" vf.vattr) | Call (_, f, _, _) -> not (hasAttribute "noreturn" (typeAttrs (typeOf f))) | _ -> true in match s.skind with Instr il -> if instrFallsThrough il then addOptionSucc next else () | Return _ -> () | Goto (p,_) -> addSucc !p | Break _ -> addOptionSucc break | Continue _ -> addOptionSucc cont | If (_, blk1, blk2, _) -> (* The succs of If is [true branch;false branch] *) addBlockSucc blk2; addBlockSucc blk1; cfgBlock blk1 next break cont; cfgBlock blk2 next break cont | UnspecifiedSequence seq -> addBlockSucc (block_from_unspecified_sequence seq); cfgBlock (block_from_unspecified_sequence seq) next break cont | Block b -> addBlockSucc b; cfgBlock b next break cont | Switch(_,blk,_l,_) -> let bl = findCaseLabeledStmts blk in List.iter addSucc (List.rev bl(*l*)); (* Add successors in order *) (* sfg: if there's no default, need to connect s->next *) if not (List.exists (fun stmt -> List.exists (function Default _ -> true | _ -> false) stmt.labels) bl) then addOptionSucc next; cfgBlock blk next next cont | Loop(_,blk,_,_,_) -> addBlockSuccFull s blk; cfgBlock blk (Some s) next (Some s) (* Since all loops have terminating condition true, we don't put any direct successor to stmt following the loop *) | TryExcept _ | TryFinally _ -> Kernel.fatal "try/except/finally" (*------------------------------------------------------------*) (**************************************************************) (* do something for all stmts in a fundec *) let forallStmts todo (fd : fundec) = let vis = object inherit nopCilVisitor method vstmt stmt = ignore (todo stmt); DoChildren end in ignore (visitCilFunction vis fd) (**************************************************************) (* printing the control flow graph - you have to compute it first *) let d_cfgnodename fmt (s : stmt) = Format.fprintf fmt "%d" s.sid let d_cfgnodelabel fmt (s : stmt) = let label = begin match s.skind with | If (_, _, _, _) -> "if" (*sprint ~width:999 (dprintf "if %a" d_exp e)*) | Loop _ -> "loop" | Break _ -> "break" | Continue _ -> "continue" | Goto _ -> "goto" | Instr _ -> "instr" | Switch _ -> "switch" | Block _ -> "block" | Return _ -> "return" | TryExcept _ -> "try-except" | TryFinally _ -> "try-finally" | UnspecifiedSequence _ -> "unspecifiedsequence" end in Format.fprintf fmt "%d: %s" s.sid label let d_cfgedge src fmt dest = Format.fprintf fmt "%a -> %a" d_cfgnodename src d_cfgnodename dest let d_cfgnode fmt (s : stmt) = Format.fprintf fmt "%a [label=\"%a\"]\n\t@[%a@]" d_cfgnodename s d_cfgnodelabel s (Pretty_utils.pp_list ~sep:"@." (d_cfgedge s)) s.succs (**********************************************************************) (* entry points *) (** print control flow graph (in dot form) for fundec to channel *) let printCfgChannel fmt (fd : fundec) = let pnode (s:stmt) = Format.fprintf fmt "%a\n" d_cfgnode s in begin Format.fprintf fmt "digraph CFG_%s {\n" fd.svar.vname ; forallStmts pnode fd; Format.fprintf fmt "}\n" ; end (** Print control flow graph (in dot form) for fundec to file *) let printCfgFilename (filename : string) (fd : fundec) = let chan = open_out filename in begin printCfgChannel (Format.formatter_of_out_channel chan) fd ; close_out chan; end ;; (**********************************************************************) let clearCFGinfo ?(clear_id=true) (fd : fundec) = let clear s = if clear_id then s.sid <- -1; s.succs <- []; s.preds <- []; in forallStmts clear fd let clearFileCFG ?(clear_id=true) (f : file) = iterGlobals f (fun g -> match g with GFun(fd,_) -> clearCFGinfo ~clear_id fd | _ -> ()) let clear_sid_info_ref = Extlib.mk_fun "Cfg.clear_sid_info_ref" let computeFileCFG (f : file) = !clear_sid_info_ref (); iterGlobals f (fun g -> match g with GFun(fd,_) -> cfgFun fd | _ -> ()) (* Cfg computation *) open Cil_types open Logic_const open Cil let statements : stmt list ref = ref [] (* Clear all info about the CFG in statements *) class clear : cilVisitor = object inherit nopCilVisitor method vstmt s = begin s.sid <- Sid.next (); statements := s :: !statements; s.succs <- [] ; s.preds <- [] ; DoChildren end method vexpr _ = SkipChildren method vtype _ = SkipChildren method vinst _ = SkipChildren end let link source dest = begin if not (List.mem dest source.succs) then source.succs <- dest :: source.succs ; if not (List.mem source dest.preds) then dest.preds <- source :: dest.preds end let trylink source dest_option = match dest_option with None -> () | Some(dest) -> link source dest (** Compute the successors and predecessors of a block, given a fallthrough *) let rec succpred_block b fallthrough = let rec handle sl = match sl with [] -> () | [a] -> succpred_stmt a fallthrough | hd :: ((next :: _) as tl) -> succpred_stmt hd (Some next) ; handle tl in handle b.bstmts and succpred_stmt s fallthrough = match s.skind with Instr _ -> trylink s fallthrough | Return _ -> () | Goto(dest,_) -> link s !dest | Break _ | Continue _ | Switch _ -> failwith "computeCFGInfo: cannot be called on functions with break, continue or switch statements. Use prepareCFG first to remove them." | If(_e1,b1,b2,_) -> (match b1.bstmts with [] -> trylink s fallthrough | hd :: _ -> (link s hd ; succpred_block b1 fallthrough )) ; (match b2.bstmts with [] -> trylink s fallthrough | hd :: _ -> (link s hd ; succpred_block b2 fallthrough )) | Loop(_,b,_,_,_) -> begin match b.bstmts with [] -> failwith "computeCFGInfo: empty loop" | hd :: _ -> link s hd ; succpred_block b (Some(hd)) end | Block(b) -> begin match b.bstmts with [] -> trylink s fallthrough | hd :: _ -> link s hd ; succpred_block b fallthrough end | UnspecifiedSequence (((s1,_,_,_,_)::_) as seq) -> link s s1; succpred_block (block_from_unspecified_sequence seq) fallthrough | UnspecifiedSequence [] -> trylink s fallthrough | TryExcept _ | TryFinally _ -> failwith "computeCFGInfo: structured exception handling not implemented" (* This alphaTable is used to prevent collision of label names when transforming switch statements and loops. It uses a *unit* alphaTableData ref because there isn't any information we need to carry around. *) let labelAlphaTable : (string, unit Alpha.alphaTableData ref) Hashtbl.t = Hashtbl.create 11 let freshLabel (base:string) = fst (Alpha.newAlphaName labelAlphaTable None base ()) let xform_switch_block ?(keepSwitch=false) b = let breaks_stack = Stack.create () in let continues_stack = Stack.create () in (* NB: these are two stacks of stack, as the scope of breaks/continues clauses depends on two things: First, /*@ breaks P */ while(1) {} is not the same thing as while(1) { /*@ breaks P */ }: only the latter applies to the break of the current loop. Second while(1) { /*@ breaks P1 */ { /*@ breaks P2 */{}}} requires maintaining an inner stack, since the breaks of the current loop are under two different, nested, breaks clauses *) let () = Stack.push (Stack.create()) breaks_stack in let () = Stack.push (Stack.create()) continues_stack in let assert_of_clause f ca = match ca.annot_content with | AAssert _ | AInvariant _ | AVariant _ | AAssigns _ | AAllocation _ | APragma _ -> ptrue | AStmtSpec (_bhv,s) -> List.fold_left (fun acc bhv -> pand (acc, pimplies (pands (List.map (fun p -> pold ~loc:p.ip_loc (Logic_utils.named_of_identified_predicate p)) bhv.b_assumes), pands (List.fold_left (fun acc (kind,p) -> if f kind then Logic_utils.named_of_identified_predicate p :: acc else acc) [ptrue] bhv.b_post_cond) ))) ptrue s.spec_behavior in let assert_of_continues ca = assert_of_clause (function Continues -> true | _ -> false) ca in let assert_of_breaks ca = assert_of_clause (function Breaks -> true | _ -> false) ca in let add_clause s ca = let cont_clause = assert_of_continues ca in let break_clause = assert_of_breaks ca in if not (Stack.is_empty continues_stack) then begin let old_clause = Stack.top continues_stack in let cont_clause = Logic_utils.translate_old_label s cont_clause in Stack.push cont_clause old_clause; end else begin Kernel.fatal "No stack where to put continues clause" end; if not (Stack.is_empty breaks_stack) then begin let old_clause = Stack.top breaks_stack in let break_clause = Logic_utils.translate_old_label s break_clause in Stack.push break_clause old_clause; end else begin Kernel.fatal "No stack where to put breaks clause" end in let rec popn n = if n > 0 then begin if Stack.is_empty breaks_stack || Stack.is_empty continues_stack then Kernel.fatal ~current:true "Cannot remove breaks/continues in clause stack"; let breaks = Stack.top breaks_stack in if Stack.is_empty breaks then Kernel.fatal ~current:true "Cannot remove breaks in toplevel clause stack"; ignore (Stack.pop breaks); let continues = Stack.top continues_stack in if Stack.is_empty continues then Kernel.fatal ~current:true "Cannot remove continues in toplevel clause stack"; ignore (Stack.pop continues); popn (n-1); end in let rec xform_switch_stmt stmts break_dest cont_dest label_index popstack = match stmts with [] -> [] | s :: rest -> begin CurrentLoc.set (Stmt.loc s); if not keepSwitch then s.labels <- List.map (fun lab -> match lab with Label _ -> lab | Case(e,l) -> let suffix = match isInteger e with | Some value -> if Integer.lt value Integer.zero then "neg_" ^ Integer.to_string (Integer.neg value) else Integer.to_string value | None -> "exp" in let str = Format.sprintf "switch_%d_%s" label_index suffix in (Label(freshLabel str,l,false)) | Default(l) -> Label(freshLabel (Printf.sprintf "switch_%d_default" label_index), l, false) ) s.labels ; match s.skind with | Instr (Code_annot (ca,_)) -> add_clause s ca; s:: xform_switch_stmt rest break_dest cont_dest label_index (popstack+1) | Instr _ | Return _ | Goto _ -> popn popstack; s:: xform_switch_stmt rest break_dest cont_dest label_index 0 | Break(l) -> if Stack.is_empty breaks_stack then Kernel.fatal "empty breaks stack"; s.skind <- Goto(break_dest (),l); let breaks = Stack.top breaks_stack in let assertion = ref ptrue in Stack.iter (fun p -> assertion := pand (p,!assertion)) breaks; (match !assertion with { content = Ptrue } -> popn popstack; s :: xform_switch_stmt rest break_dest cont_dest label_index 0 | p -> let a = Logic_const.new_code_annotation (AAssert ([],p)) in let assertion = mkStmt (Instr(Code_annot(a,l))) in popn popstack; assertion:: s :: xform_switch_stmt rest break_dest cont_dest label_index 0) | Continue(l) -> if Stack.is_empty continues_stack then Kernel.fatal "empty continues stack"; s.skind <- Goto(cont_dest (),l); let continues = Stack.top continues_stack in let assertion = ref ptrue in Stack.iter (fun p -> assertion := pand(p,!assertion)) continues; (match !assertion with { content = Ptrue } -> popn popstack; s :: xform_switch_stmt rest break_dest cont_dest label_index 0 | p -> let a = Logic_const.new_code_annotation (AAssert([],p)) in let assertion = mkStmt (Instr(Code_annot(a,l))) in popn popstack; assertion :: s :: xform_switch_stmt rest break_dest cont_dest label_index 0) | If(e,b1,b2,l) -> let b1 = xform_switch_block b1 break_dest cont_dest label_index in let b2 = xform_switch_block b2 break_dest cont_dest label_index in popn popstack; s.skind <- If(e,b1,b2,l); s:: xform_switch_stmt rest break_dest cont_dest label_index 0 | Switch(e,b,sl,(_, snd_l as l)) -> let loc = snd_l, snd_l in if keepSwitch then begin let label_index = label_index + 1 in let break_stmt = mkStmt (Instr (Skip loc)) in break_stmt.labels <- [Label (freshLabel (Printf.sprintf "switch_%d_break" label_index), l, false)] ; Stack.push (Stack.create()) breaks_stack; let b = xform_switch_block b (fun () -> ref break_stmt) cont_dest label_index in ignore (Stack.pop breaks_stack); popn popstack; s.skind <- Switch (e,b,sl,l); s::break_stmt:: xform_switch_stmt rest break_dest cont_dest label_index 0 end else begin (* change * switch (se) { * case 0: s0 ; * case 1: s1 ; break; * ... * } * * into: * * if (se == 0) goto label_0; * else if (se == 1) goto label_1; * ... * else goto label_break; * { // body_block * label_0: s0; * label_1: s1; goto label_break; * ... * } * label_break: ; // break_stmt * *) let label_index = label_index + 1 in let break_stmt = mkStmt (Instr (Skip loc)) in break_stmt.labels <- [Label(freshLabel (Printf.sprintf "switch_%d_break" label_index), l, false)] ; (* The default case, if present, must be used only if *all* non-default cases fail [ISO/IEC 9899:1999, 6.8.4.2, 5]. As a result, we sort the order in which we handle the labels (but not the order in which we print out the statements, so fall-through still works as expected). *) let compare_choices s1 s2 = match s1.labels, s2.labels with | (Default(_) :: _), _ -> 1 | _, (Default(_) :: _) -> -1 | _, _ -> 0 in let rec handle_choices sl = match sl with [] -> (* If there's no case that matches and no default, we just skip the entire switch (6.8.4.2.5)*) Goto (ref break_stmt,l) | stmt_hd :: stmt_tl -> let rec handle_labels lab_list = match lab_list with [] -> handle_choices stmt_tl | Case(ce,cl) :: lab_tl -> (* begin replacement: *) let pred = match ce.enode with Const (CInt64 (z,_,_)) when Integer.equal z Integer.zero -> new_exp ~loc:ce.eloc (UnOp(LNot,e,intType)) | _ -> new_exp ~loc:ce.eloc (BinOp(Eq,e,ce,intType)) in (* end replacement *) let then_block = mkBlock [ mkStmt (Goto(ref stmt_hd,cl)) ] in let else_block = mkBlock [ mkStmt (handle_labels lab_tl) ] in If(pred,then_block,else_block,cl) | Default(dl) :: lab_tl -> (* ww: before this was 'if (1) goto label', but as Ben points out this might confuse someone down the line who doesn't have special handling for if(1) into thinking that there are two paths here. The simpler 'goto label' is what we want. *) Block(mkBlock [ mkStmt (Goto(ref stmt_hd,dl)) ; mkStmt (handle_labels lab_tl) ]) | Label(_,_,_) :: lab_tl -> handle_labels lab_tl in handle_labels stmt_hd.labels in let sl = List.sort compare_choices sl in let ifblock = mkStmt (handle_choices sl) in Stack.push (Stack.create()) breaks_stack; let switch_block = xform_switch_block b (fun () -> ref break_stmt) cont_dest label_index in ignore (Stack.pop breaks_stack); popn popstack; s.skind <- Block switch_block; (match switch_block.bstmts with ({ skind = Instr(Code_annot _) } as ca):: tl -> (* We move the annotation outside of the block, since the \old would otherwise be attached to a label which by construction is never reached. *) switch_block.bstmts <- ca :: ifblock :: tl | l -> switch_block.bstmts <- ifblock :: l); s :: break_stmt :: xform_switch_stmt rest break_dest cont_dest label_index 0 end | Loop(a,b,(fst_l, snd_l as l),_,_) -> let label_index = label_index + 1 in let loc_break = snd_l, snd_l in let break_stmt = mkStmt (Instr (Skip loc_break)) in break_stmt.labels <- [Label(freshLabel (Printf.sprintf "while_%d_break" label_index),l,false)] ; let cont_loc = fst_l, fst_l in let cont_stmt = mkStmt (Instr (Skip cont_loc)) in cont_stmt.labels <- [Label (freshLabel (Printf.sprintf "while_%d_continue" label_index),l,false)] ; b.bstmts <- cont_stmt :: b.bstmts ; let my_break_dest () = ref break_stmt in let my_cont_dest () = ref cont_stmt in Stack.push (Stack.create ()) breaks_stack; Stack.push (Stack.create ()) continues_stack; let b = xform_switch_block b my_break_dest my_cont_dest label_index in s.skind <- Loop(a,b,l,Some(cont_stmt),Some(break_stmt)); break_stmt.succs <- s.succs ; ignore (Stack.pop breaks_stack); ignore (Stack.pop continues_stack); popn popstack; s :: break_stmt :: xform_switch_stmt rest break_dest cont_dest label_index 0 | Block b -> let b = xform_switch_block b break_dest cont_dest label_index in popn popstack; s.skind <- Block b; s :: xform_switch_stmt rest break_dest cont_dest label_index 0 | UnspecifiedSequence seq -> let seq = xform_switch_unspecified seq break_dest cont_dest label_index in popn popstack; s.skind <- UnspecifiedSequence seq; s :: xform_switch_stmt rest break_dest cont_dest label_index 0 | TryExcept _ | TryFinally _ -> Kernel.fatal "xform_switch_statement: \ structured exception handling not implemented" end and xform_switch_block b break_dest cont_dest label_index = (* [VP] I fail to understand what link_succs is supposed to do. The head of the block has as successors all the statements in the block? *) (* let rec link_succs sl = match sl with | [] -> () | hd :: tl -> (if hd.succs = [] then hd.succs <- tl) ; link_succs tl in link_succs b.bstmts ; *) { b with bstmts = xform_switch_stmt b.bstmts break_dest cont_dest label_index 0 } and xform_switch_unspecified seq break_dest cont_dest label_index = let treat_one (s,m,w,r,c) = (* NB: this assumes that we don't have any statement contract in an unspecified sequence. *) let res = xform_switch_stmt [s] break_dest cont_dest label_index 0 in (List.hd res, m,w,r,c) ::(List.map (fun s -> (s,[],[],[],[])) (List.tl res)) in (List.concat (List.map treat_one seq)) in xform_switch_block b (fun () -> Kernel.abort "break outside of loop or switch") (fun () -> Kernel.abort "continues outside of loop") (-1) (* Enter all the labels in a function into an alpha renaming table to prevent duplicate labels when transforming loops and switch statements. *) class registerLabelsVisitor : cilVisitor = object inherit nopCilVisitor method vstmt { labels = labels } = begin List.iter (function | Label (name,_,_) -> Alpha.registerAlphaName labelAlphaTable None name () | _ -> ()) labels; DoChildren end method vexpr _ = SkipChildren method vtype _ = SkipChildren method vinst _ = SkipChildren end (* prepare a function for computeCFGInfo by removing break, continue, * default and switch statements/labels and replacing them with Ifs and * Gotos. *) let prepareCFG ?(keepSwitch=false) (fd : fundec) : unit = (* Labels are local to a function, so start with a clean slate by clearing labelAlphaTable. Then register all labels. *) Hashtbl.clear labelAlphaTable; ignore (visitCilFunction (new registerLabelsVisitor) fd); let b = xform_switch_block ~keepSwitch fd.sbody in fd.sbody <- b (* make the cfg and return a list of statements *) let computeCFGInfo (f : fundec) (_global_numbering : bool) : unit = statements := []; let clear_it = new clear in ignore (visitCilBlock clear_it f.sbody) ; f.smaxstmtid <- Some (Sid.next ()) ; succpred_block f.sbody (None); let res = List.rev !statements in statements := []; f.sallstmts <- res; () (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/ext/oneret.mli0000644000175000017500000001225112155630366020142 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* * * Copyright (c) 2001-2002, * George C. Necula * Scott McPeak * Wes Weimer * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * 3. The names of the contributors may not be used to endorse or promote * products derived from this software without specific prior written * permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * *) (** Make sure that there is only one Return statement in the whole body. Replace all the other returns with Goto. Make sure that there is a return if the function is supposed to return something, and it is not declared to not return. *) val oneret: Cil_types.fundec -> unit frama-c-Fluorine-20130601/cil/src/ext/callgraph.mli0000644000175000017500000001165612155630366020613 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Compute a static call graph. @plugin development guide *) (* module maintainer: scott *) (* see copyright notice at end of this file *) open Cil_types (* ------------------ types ------------------- *) (** a call node describes the local calling structure for a * single function: which functions it calls, and which * functions call it *) type callnode = { (** An id *) cnid: int; (** the function this node describes *) cnInfo: nodeinfo; (** set of functions this one calls, indexed by the node id *) cnCallees: callnode Datatype.Int.Hashtbl.t; (** set of functions that call this one , indexed by the node id *) cnCallers: callnode Datatype.Int.Hashtbl.t; } and nodeinfo = NIVar of Cil_types.varinfo * bool ref (** Node corresponding to a function. If the boolean * is true, then the function is defined, otherwise * it is external *) | NIIndirect of string (* Indirect nodes have a string associated to them. * These strings must be invalid function names *) * Cil_types.varinfo list ref (* A list of functions that this indirect node might * denote *) val nodeName: nodeinfo -> string (** a call graph is a hashtable, mapping a function name to * the node which describes that function's call structure *) type callgraph = (string, callnode) Hashtbl.t (* ----------------- functions ------------------- *) (** given a CIL file, compute its static call graph *) val computeGraph : file -> callgraph (** print the callgraph in a human-readable format to a channel *) val printGraph : out_channel -> callgraph -> unit val feature: Cil.featureDescr frama-c-Fluorine-20130601/cil/src/ext/obfuscate.mli0000644000175000017500000000656412155630366020633 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) val obfuscate : Cil_types.file ->(string, string) Hashtbl.t (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/ext/dominators.mli0000755000175000017500000001127112155630366021031 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Compute dominators using data flow analysis. @author George Necula @date 5/28/2004 **) (** complete rewrite in order not to rely on data flow analysis (bad time-complexity). Now based on "A Simple, Fast Dominance Algorithm" by K. D. Cooper et al *) val computeIDom: Cil_types.fundec -> Cil_types.stmt option Datatype.Int.Hashtbl.t (** Invoke on a code after filling in the CFG info and it computes the immediate dominator information. We map each statement to its immediate dominator (None for the start statement, and for the unreachable statements). *) val getIdom: Cil_types.stmt option Datatype.Int.Hashtbl.t -> Cil_types.stmt -> Cil_types.stmt option (** This is like Datatype.Int.Hashtbl.find but gives an error if the information is Not_found *) val dominates: Cil_types.stmt option Datatype.Int.Hashtbl.t -> Cil_types.stmt -> Cil_types.stmt -> bool (** Check whether one statement dominates another. *) val findNaturalLoops: Cil_types.fundec -> Cil_types.stmt option Datatype.Int.Hashtbl.t -> (Cil_types.stmt * Cil_types.stmt list) list (** Compute the start of the natural loops. This assumes that the "idom" field has been computed. For each start, keep a list of origin of a back edge. The loop consists of the loop start and all predecessors of the origins of back edges, up to and including the loop start *) (* Local Variables: compile-command: "LC_ALL=C make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/ext/dominators.ml0000755000175000017500000005165712155630366020674 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Compute dominator information for the statements in a function *) open Cil_types module IH = Datatype.Int.Hashtbl module DF = Dataflow let debug = false (* For each statement we maintain a set of statements that dominate it *) module BS = Cil_datatype.Stmt.Hptset (** Customization module for dominators *) module DT = struct let name = "dom" let debug = ref debug type t = BS.t module StmtStartData = Dataflow.StartData(struct type t = BS.t let size = 17 end) (** For each statement in a function we keep the set of dominator blocks. * Indexed by statement id *) let copy (d: t) = d let pretty fmt (d: t) = Pretty_utils.pp_list ~pre:"@[{" ~sep:",@," ~suf:"}@]" (fun fmt s -> Format.fprintf fmt "%d" s.sid) fmt (BS.elements d) let computeFirstPredecessor (s: stmt) (d: BS.t) : BS.t = (* Make sure we add this block to the set *) BS.add s d let combinePredecessors (s: stmt) ~(old: BS.t) (d: BS.t) : BS.t option = (* First, add this block to the data from the predecessor *) let d' = BS.add s d in if BS.subset old d' then None else Some (BS.inter old d') let doInstr _ (_i: instr) (_d: t) = DF.Default let doStmt (_s: stmt) (_d: t) = DF.SDefault let doGuard _ _condition _ = DF.GDefault, DF.GDefault let filterStmt _ = true let stmt_can_reach _ _ = true let doEdge _ _ d = d end module NDom = struct module G = struct module V = struct type t = stmt let equal s1 s2 = (s1.sid == s2.sid) (* sid unique in same function *) let hash s1 = s1.sid let compare s1 s2 = Pervasives.compare s1.sid s2.sid end (* module E = struct type t = V.t * V.t (* (src,dest) *) let src e = fst e let dst e = snd e let make src dst = (src,dst) let equal e1 e2 = (V.equal (fst e1) (fst e2)) && (V.equal (snd e1) (snd e2)) let hash e = V.hash (fst e) + 971 * V.hash (snd e) let compare e1 e2 = let cmp = V.compare (src e1) (src e2) in if (cmp == 0) then V.compare (dst e1) (dst e2) else cmp end *) let get_start_vertices (f : fundec) = match f.sbody.bstmts with | [] -> [] | start :: _ -> [ start ] let succs stmt = stmt.succs let preds stmt = stmt.preds end module HV = Hashtbl.Make(G.V) module SV = Set.Make(G.V) (* module SE = Set.Make(G.E) *) module MI = Datatype.Int.Map module DFS = struct (* depth-first search enabling *) (* also tags exit nodes (i.e. nodes which have no successor in the DFS tree, and are Return statements) *) (* TODO: memoize per fundec ; also won't compute if there are statements unreachable from the first statement of the function, e.g. after a while(1) *) let build ( f:fundec ) = let depth_last_comp_parent_tbl = HV.create 997 and is_exit_list = ref [] and todo_set = ref SV.empty and isdone_set = ref SV.empty and time = ref 0 and ccomp = ref 0 in let rec search v voption = let lsuccs = G.succs v in HV.add depth_last_comp_parent_tbl v (!time,-1,!ccomp,voption) ; incr time ; todo_set := SV.remove v !todo_set ; isdone_set := SV.add v !isdone_set ; let is_exit = ref true in List.iter (fun w -> if not(SV.mem w !isdone_set) then ( is_exit := false ; search w (Some v) ) ) lsuccs ; (* ( match lsuccs with | [] -> is_exit_list := v :: !is_exit_list | [ w ] when G.V.equal v w (* case while(1) ; *) -> is_exit_list := v :: !is_exit_list | _ -> () ) ; *) if !is_exit then is_exit_list := v :: !is_exit_list ; let h = HV.find depth_last_comp_parent_tbl v in match h with (d,_,c,o) -> HV.replace depth_last_comp_parent_tbl v (d,!time,c,o) ; Kernel.debug "depth of vertex %d is %d" v.sid d (*; incr time*) in match G.get_start_vertices f with | [] -> None | start_v :: _ -> List.iter (fun v -> todo_set := SV.add v !todo_set) (G.get_start_vertices f) ; while not(SV.is_empty !todo_set) do let v = SV.choose !todo_set in search v None ; incr ccomp done ; (* order wrt depth *) let depth_to_vertex = HV.fold (fun (v : G.V.t) info acc_map -> match info with (d,_,_,_) -> MI.add d v acc_map) depth_last_comp_parent_tbl MI.empty in let depths_vec = Array.make (HV.length depth_last_comp_parent_tbl) start_v in let _ = MI.fold (fun _d v acc_cnt -> depths_vec.(acc_cnt) <- v ; acc_cnt +1) depth_to_vertex 0 in Some (depths_vec, depth_last_comp_parent_tbl, !is_exit_list) end module PostDominator = struct exception ExitFound type pdom_vertex = Exit | V of G.V.t let build (f : fundec) = let pdoms = HV.create 997 in match DFS.build f with | None -> None | Some (depths_vec, depth_last_comp_parent_tbl, exit_vertices_list) -> let reverse_dfs_prefix (f : G.V.t -> unit) = for i = Array.length depths_vec -1 downto 0 do f (Array.unsafe_get depths_vec i) done in let get_depth (v : G.V.t) = try let (d,_,_,_) = HV.find depth_last_comp_parent_tbl v in d with Not_found -> assert false in let is_exit_vertex (v : G.V.t) = try let _ = List.find (G.V.equal v) exit_vertices_list in true with Not_found -> false in List.iter (fun v -> HV.add pdoms v (V v)) exit_vertices_list ; let rchanged = ref true and max_finger = (Array.length depths_vec) + 1 in let intersect b1 b2 = let finger1 = ref b1 and finger2 = ref b2 and dfinger1 = ref (get_depth b1) and dfinger2 = ref (get_depth b2) in Kernel.debug "intersect sid %d with sid %d" b1.sid b2.sid ; while(!dfinger1 <> !dfinger2) do Kernel.debug "finger1 = %d finger2 = %d" !finger1.sid !finger2.sid ; while (!dfinger1 < !dfinger2) do Kernel.debug "*) finger1 = %d(%d) finger2 = %d(%d)" !finger1.sid !dfinger1 !finger2.sid !dfinger2 ; let dom1 = HV.find pdoms !finger1 in Kernel.debug "looking for dom of %d" !finger1.sid ; match dom1 with Exit -> raise ExitFound | V v1 -> Kernel.debug "found %d\n" v1.sid ; if (G.V.equal v1 !finger1) then ( Kernel.debug "Same node max_finger = %d" max_finger ; dfinger1 := max_finger ) else ( finger1 := v1 ; dfinger1 := get_depth v1 ; Kernel.debug "* NSN %d(%d)" v1.sid (get_depth v1) ) done ; Kernel.debug "half intersect dfinger1 = %d dfinger2 = %d" !dfinger1 !dfinger2 ; while (!dfinger2 < !dfinger1) do Kernel.debug "+) finger1 = %d(%d) finger2 = %d(%d)" !finger1.sid !dfinger1 !finger2.sid !dfinger2; let dom2 = HV.find pdoms !finger2 in Kernel.debug "looking for dom of %d" !finger2.sid ; match dom2 with Exit -> raise ExitFound | V v2 -> Kernel.debug "** found %d\n" v2.sid ; if (G.V.equal v2 !finger2) then ( Kernel.debug "Same node max_finger = %d" max_finger ; dfinger2 := max_finger ) else ( Kernel.debug "** NSN"; finger2 := v2 ; dfinger2 := get_depth v2 ) done done ; Kernel.debug "end intersect dfinger1 = %d dfinger2 = %d" !dfinger1 !dfinger2 ; !finger1 in while(!rchanged) do rchanged := false; reverse_dfs_prefix (fun b -> Kernel.debug "treating %d" b.sid ; if not(is_exit_vertex b) then ( let lsuccs = List.filter (fun v -> HV.mem pdoms v) (G.succs b) in match lsuccs with | [] -> assert false | hd :: tl_succs -> let rnew_ipdom = ref hd and ripdom = ref Exit in ( try List.iter (fun p -> if (HV.mem pdoms p) then rnew_ipdom := intersect p !rnew_ipdom) tl_succs ; Kernel.debug "new pdom of %d is %d\n" b.sid !rnew_ipdom.sid ; ripdom := V !rnew_ipdom with ExitFound -> Kernel.debug "ExitFound for pdom of %d" b.sid; ripdom := Exit ) ; if not(HV.mem pdoms b) then ( HV.add pdoms b !ripdom ; rchanged := true ) else ( match HV.find pdoms b, !ripdom with | Exit, Exit -> () | V v1, V v2 when G.V.equal v1 v2 -> () | _ -> try HV.replace pdoms b !ripdom ; rchanged := true with Not_found -> () ) ) else Kernel.debug "%d is an exit vertex" b.sid ) done ; Kernel.debug "end of Pdom comp"; let pdoms_final = HV.create 997 in for i = Array.length depths_vec -1 downto 0 do let v = Array.unsafe_get depths_vec i in let pdom_v = HV.find pdoms v in match pdom_v with | Exit -> HV.add pdoms_final v None | V w -> HV.add pdoms_final v (Some w) done ; Some pdoms_final end module Dominator = struct let build (f : fundec) = (* based on "A Simple, Fast Dominance Algorithm" by K.D. Cooper et al *) let doms = HV.create 997 in match DFS.build f with | None -> None | Some (depths_vec, depth_last_comp_parent_tbl, _) -> let dfs_prefix (f : G.V.t -> unit) = for i = 0 to Array.length depths_vec -1 do f (Array.unsafe_get depths_vec i) done in let get_depth (v : G.V.t) = try let (d,_,_,_) = HV.find depth_last_comp_parent_tbl v in d with Not_found -> assert false in let is_start_vertex (v : G.V.t) = G.V.equal v (Array.unsafe_get depths_vec 0) in List.iter (fun v -> HV.add doms v (Some v)) (G.get_start_vertices f) ; let rchanged = ref true and intersect b1 b2 = let finger1 = ref b1 and finger2 = ref b2 and dfinger1 = ref (get_depth b1) and dfinger2 = ref (get_depth b2) in while(!dfinger1 <> !dfinger2) do while (!dfinger1 > !dfinger2) do let dom1 = HV.find doms !finger1 in match dom1 with None -> assert false | Some v1 -> finger1 := v1 ; dfinger1 := get_depth v1 done ; while (!dfinger2 > !dfinger1) do let dom2 = HV.find doms !finger2 in match dom2 with None -> assert false | Some v2 -> finger2 := v2; dfinger2 := get_depth v2 done done ; !finger1 in while(!rchanged) do rchanged := false; dfs_prefix (fun b -> if not(is_start_vertex b) then ( let lpreds = List.filter (fun v -> HV.mem doms v) (G.preds b) in try let rnew_idom = ref (List.hd lpreds) and ridom = ref None in List.iter (fun p -> if (HV.mem doms p) then rnew_idom := intersect p !rnew_idom) (List.tl lpreds) ; ridom := Some !rnew_idom ; if not(HV.mem doms b) then ( HV.add doms b !ridom ; rchanged := true ) else ( match HV.find doms b, !ridom with | None, None -> () | Some v1, Some v2 when G.V.equal v1 v2 -> () | _ -> try HV.replace doms b !ridom ; rchanged := true with Not_found -> () ) with Not_found -> assert false ) ) done ; List.iter (fun v -> HV.replace doms v None) (G.get_start_vertices f) ; Some doms end end module Dom = Dataflow.Forwards(DT) let getStmtDominators (s: stmt) : BS.t = try DT.StmtStartData.find s with Not_found -> BS.empty (* Not reachable *) let getIdom (idomInfo: stmt option IH.t) (s: stmt) = try IH.find idomInfo s.sid with Not_found -> Kernel.fatal "Immediate dominator information not set for statement %d" s.sid (** Check whether one block dominates another. This assumes that the "idom" * field has been computed. *) let rec dominates idomData (s1: stmt) (s2: stmt) = s1.sid = s2.sid || (let s2idom = fillOneIdom idomData s2 in match s2idom with None -> false | Some s2idom -> dominates idomData s1 s2idom) (* Now fill the immediate dominators for all nodes *) and fillOneIdom idomData (s: stmt) = try IH.find idomData s.sid (* Already set *) with Not_found -> begin (* Get the dominators *) let sdoms = getStmtDominators s in (* Fill the idom for the dominators first *) let idom = BS.fold (fun d (sofar: stmt option) -> if d.sid = s.sid then sofar (* Ignore the block itself *) else begin match sofar with None -> Some d | Some sofar' -> (* See if d is dominated by sofar. We know that the * idom information has been computed for both sofar * and for d*) if dominates idomData sofar' d then Some d else sofar end) sdoms None in IH.replace idomData s.sid idom; idom end let computeIDom (f: fundec) : stmt option IH.t = (* CEA : DO NOT DO IT AGAIN (* We must prepare the CFG info first *) prepareCFG f; computeCFGInfo f false; *) let compute_ipdom () = match NDom.PostDominator.build f with | None -> IH.create 13 | Some pdoms -> let sz = NDom.HV.length pdoms in let ipdomData : stmt option IH.t = IH.create sz in NDom.HV.iter (fun stmt ipdom_opt -> IH.add ipdomData stmt.sid ipdom_opt ) pdoms ; ipdomData in let compute_idom_new () = match NDom.Dominator.build f with | None -> IH.create 13 | Some doms -> let sz = NDom.HV.length doms in let idomData : stmt option IH.t = IH.create sz in NDom.HV.iter (fun stmt idom_opt -> IH.add idomData stmt.sid idom_opt ) doms ; idomData in let _compute_idom_old () = DT.StmtStartData.clear (); let idomData : stmt option IH.t = IH.create 13 in let _ = match f.sbody.bstmts with [] -> () (* function has no body *) | start :: _ -> begin (* We start with only the start block *) DT.StmtStartData.add start (BS.singleton start); Dom.compute [start]; (* Dump the dominators information *) if debug then List.iter (fun s -> let sdoms = getStmtDominators s in if not (BS.mem s sdoms) then begin (* It can be that the block is not reachable *) if s.preds <> [] then (Kernel.error "Statement %d is not in its list of dominators" s.sid); end; Kernel.debug "Dominators for %d: %a\n" s.sid DT.pretty (BS.remove s sdoms)) f.sallstmts; (* Scan all blocks and compute the idom *) List.iter (fun x -> ignore (fillOneIdom idomData x)) f.sallstmts end in idomData in let _check_equivalence idomData idomData_mine = (* compare results of old vs new algorithm *) IH.iter (fun stmt_sid idom_opt -> try let idom_opt2 = IH.find idomData_mine stmt_sid in match idom_opt,idom_opt2 with | None , None -> () | Some v1, Some v2 when (v1.sid == v2.sid) -> () | None, Some v -> Kernel.debug "no former idom for %d / new idom is %d" (stmt_sid) v.sid | Some v, None -> Kernel.debug "former idom for %d was %d / no new idom" (stmt_sid) v.sid | Some v1, Some v2 -> Kernel.debug "former idom for %d=%d / new idom is %d" stmt_sid v1.sid v2.sid with Not_found -> ( match idom_opt with | None -> () | Some v -> Kernel.debug "no idom for %d (former was %d)" stmt_sid v.sid ) ) idomData; IH.iter (fun stmt_sid idom_opt -> try let idom_opt2 = IH.find idomData stmt_sid in match idom_opt,idom_opt2 with | None , None -> () | Some v1, Some v2 when (v1.sid == v2.sid) -> () | None, Some v -> Kernel.debug "no new idom for %d / former idom is %d" (stmt_sid) v.sid | Some v, None -> Kernel.debug "new idom for %d was %d / no former idom" (stmt_sid) v.sid | Some v1, Some v2 -> Kernel.debug "new idom for %d=%d / former idom is %d" stmt_sid v1.sid v2.sid with Not_found -> ( match idom_opt with | None -> () | Some v -> Kernel.debug "no idom for %d (new is %d)" stmt_sid v.sid ) ) idomData_mine in let check_pdoms pdoms = IH.iter (fun stmt_sid ipdom_opt -> match ipdom_opt with | None -> Kernel.debug "no pdom for %d" stmt_sid | Some v -> Kernel.debug "pdom for %d is %d" stmt_sid v.sid ) pdoms in let doms = compute_idom_new () and pdoms= compute_ipdom () in check_pdoms pdoms ; doms (* this code can be used to check both algorithms give the same result: let data1 = compute_idom_new () and data2 = _compute_idom_old () in _check_equivalence data1 data2 ; data1 *) (** Compute the start of the natural loops. For each start, keep a list of * origin of a back edge. The loop consists of the loop start and all * predecessors of the origins of back edges, up to and including the loop * start *) let findNaturalLoops (f: fundec) (idomData: stmt option IH.t) : (stmt * stmt list) list = let loops = List.fold_left (fun acc b -> (* Iterate over all successors, and see if they are among the * dominators for this block *) List.fold_left (fun acc s -> if dominates idomData s b then (* s is the start of a natural loop *) let rec addNaturalLoop = function [] -> [(s, [b])] | (s', backs) :: rest when s'.sid = s.sid -> (s', b :: backs) :: rest | l :: rest -> l :: addNaturalLoop rest in addNaturalLoop acc else acc) acc b.succs) [] f.sallstmts in if debug then begin let pp_back fmt b = Format.pp_print_int fmt b.sid in let pp_loop fmt (s,backs) = Format.fprintf fmt "Start:%d, backs:%a" s.sid (Pretty_utils.pp_list pp_back) backs in Kernel.debug "Natural loops:\n%a" (Pretty_utils.pp_list ~sep:"@\n" pp_loop) loops end ; loops frama-c-Fluorine-20130601/cil/src/ext/dataflow.mli0000755000175000017500000003064212155630366020456 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** A framework for implementing data flow analysis. @plugin development guide *) type 't action = Default (** The default action *) | Done of 't (** Do not do the default action. Use this result *) | Post of ('t -> 't) (** The default action, followed by the given * transformer *) type 't stmtaction = SDefault (** The default action *) | SDone (** Do not visit this statement or its successors *) | SUse of 't (** Visit the instructions and successors of this statement as usual, but use the specified state instead of the one that was passed to doStmt *) (** For if statements *) type 't guardaction = GDefault (** The default state *) | GUse of 't (** Use this data for the branch *) | GUnreachable (** The branch will never be taken. *) module type StmtStartData = sig type data val clear: unit -> unit val mem: Cil_types.stmt -> bool val find: Cil_types.stmt -> data val replace: Cil_types.stmt -> data -> unit val add: Cil_types.stmt -> data -> unit val iter: (Cil_types.stmt -> data -> unit) -> unit val length: unit -> int end (** This module can be used to instantiate the [StmtStartData] components of the functors below. It is implemented through stmt-indexed hashtables. *) module StartData(X:sig type t val size: int end) : StmtStartData with type data = X.t (* ************************************************************************* *) (** {2 Forwards Dataflow Analysis} *) (* ************************************************************************* *) (** Interface to provide for a backward dataflow analysis. *) module type ForwardsTransfer = sig val name: string (** For debugging purposes, the name of the analysis *) val debug: bool ref (** Whether to turn on debugging *) type t (** The type of the data we compute for each block start. May be imperative. *) val copy: t -> t (** Make a deep copy of the data. *) val pretty: Format.formatter -> t -> unit (** Pretty-print the state. *) val computeFirstPredecessor: Cil_types.stmt -> t -> t (** Given the first value for a predecessors, compute the value to be set for the block. *) val combinePredecessors: Cil_types.stmt -> old:t -> t -> t option (** Take some old data for the start of a statement, and some new data for the same point. Return None if the combination is identical to the old data. Otherwise, compute the combination, and return it. *) val doInstr: Cil_types.stmt -> Cil_types.instr -> t -> t action (** The (forwards) transfer function for an instruction. The [(Cil.CurrentLoc.get ())] is set before calling this. The default action is to continue with the state unchanged. [stmt] is the statement englobing [instr]. *) val doGuard: Cil_types.stmt -> Cil_types.exp -> t -> t guardaction * t guardaction (** Generate the successors [th, el] to an If statement assuming the given expression is respectively nonzero and zero. Analyses that don't need guard information can return GDefault, GDefault; this is equivalent to returning GUse of the input. A return value of GUnreachable indicates that this half of the branch will not be taken and should not be explored. This will be called once per If. [stmt] is the corresponding [If] statement FYI only. *) val doStmt: Cil_types.stmt -> t -> t stmtaction (** The (forwards) transfer function for a statement. The [(Cil.CurrentLoc.get ())] * is set before calling this. The default action is to do the instructions * in this statement, if applicable, and continue with the successors. *) val filterStmt: Cil_types.stmt -> bool (** Whether to put this statement in the worklist. This is called when a block would normally be put in the worklist. *) val stmt_can_reach : Cil_types.stmt -> Cil_types.stmt -> bool (** Must return [true] if ther is a path in the control-flow graph of the function from the first statement to the second. Used to choose a "good" node in the worklist. Suggested use is [let stmt_can_reach = Stmts_graph.stmt_can_reach kf], where [kf] is the kernel_function being analyzed; [let stmt_can_reach _ _ = true] is also correct, albeit less efficient *) val doEdge: Cil_types.stmt -> Cil_types.stmt -> t -> t (** what to do when following the edge between the two given statements. Can default to identity if nothing special is required. *) module StmtStartData: StmtStartData with type data = t (** For each statement id, the data at the start. Not found in the hash table means nothing is known about the state at this point. At the end of the analysis this means that the block is not reachable. *) end module Forwards(T : ForwardsTransfer) : sig val reachedStatement : Cil_types.stmt -> Cil_types.stmt -> T.t -> unit val compute: Cil_types.stmt list -> unit (** Fill in the T.stmtStartData, given a number of initial statements to start from. All of the initial statements must have some entry in T.stmtStartData (i.e., the initial data should not be bottom) *) (**/**) (* Should not be used except for extremely special uses *) val worklist: Cil_types.stmt Queue.t end (* ************************************************************************* *) (** {2 Backwards Dataflow Analysis} *) (* ************************************************************************* *) (** Interface to provide for a backward dataflow analysis. *) module type BackwardsTransfer = sig val name: string (** For debugging purposes, the name of the analysis *) val debug: bool ref (** Whether to turn on debugging *) type t (** The type of the data we compute for each block start. In many presentations of backwards data flow analysis we maintain the data at the block end. This is not easy to do with JVML because a block has many exceptional ends. So we maintain the data for the statement start. *) val pretty: Format.formatter -> t -> unit (** Pretty-print the state *) val funcExitData: t (** The data at function exit. Used for statements with no successors. This is usually bottom, since we'll also use doStmt on Return statements. *) val combineStmtStartData: Cil_types.stmt -> old:t -> t -> t option (** When the analysis reaches the start of a block, combine the old data with the one we have just computed. Return None if the combination is the same as the old data, otherwise return the combination. In the latter case, the predecessors of the statement are put on the working list. *) val combineSuccessors: t -> t -> t (** Take the data from two successors and combine it *) val doStmt: Cil_types.stmt -> t action (** The (backwards) transfer function for a branch. The [(Cil.CurrentLoc.get ())] is set before calling this. If it returns None, then we have some default handling. Otherwise, the returned data is the data before the branch (not considering the exception handlers) *) val doInstr: Cil_types.stmt -> Cil_types.instr -> t -> t action (** The (backwards) transfer function for an instruction. The [(Cil.CurrentLoc.get ())] is set before calling this. If it returns None, then we have some default handling. Otherwise, the returned data is the data before the branch (not considering the exception handlers) *) val filterStmt: Cil_types.stmt -> Cil_types.stmt -> bool (** Whether to put this predecessor block in the worklist. We give the predecessor and the block whose predecessor we are (and whose data has changed) *) val stmt_can_reach : Cil_types.stmt -> Cil_types.stmt -> bool (** Must return [true] if ther is a path in the control-flow graph of the function from the first statement to the second. Used to choose a "good" node in the worklist. Suggested use is [let stmt_can_reach = Stmts_graph.stmt_can_reach kf], where [kf] is the kernel_function being analyzed; [let stmt_can_reach _ _ = true] is also correct, albeit less efficient @since Oxygen-20120901 *) module StmtStartData: StmtStartData with type data = t (** For each block id, the data at the start. This data structure must be initialized with the initial data for each block *) end module Backwards(T : BackwardsTransfer) : sig val compute: Cil_types.stmt list -> unit (** Fill in the T.stmtStartData, given a number of initial statements to start from (the sinks for the backwards data flow). All of the statements (not just the initial ones!) must have some entry in T.stmtStartData If you want to use bottom for the initial data, you should pass the complete list of statements to {!compute}, so that everything is visited. {!find_stmts} may be useful here. *) end val find_stmts: Cil_types.fundec -> (Cil_types.stmt list * Cil_types.stmt list) (** @return (all_stmts, sink_stmts), where all_stmts is a list of the statements in a function, and sink_stmts is a list of the return statments (including statements that fall through the end of a void function). Useful when you need an initial set of statements for BackwardsDataFlow.compute. *) (* Local Variables: compile-command: "LC_ALL=C make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/cil_datatype.ml0000644000175000017500000021461712155630367020352 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) open Cil_types let (=?=) = Extlib.compare_basic let compare_list = Extlib.list_compare let hash_list f = List.fold_left (fun acc d -> 65537 * acc + f d) 1 (* Functions that will clear internal, non-project compliant, caches *) let clear_caches = ref [] (**************************************************************************) (** {3 Generic builders for Cil datatypes} *) (**************************************************************************) module Make (X: sig type t val name: string val reprs: t list val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit val pretty: Format.formatter -> t -> unit val varname: t -> string end) = Datatype.Make (struct include Datatype.Undefined include X let name = "Cil_datatype." ^ name let structural_descr = Structural_descr.Abstract let rehash = Datatype.identity let mem_project = Datatype.never_any_project end) module Make_with_collections (X: sig type t val name: string val reprs: t list val compare: t -> t -> int val equal: t -> t -> bool val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit val pretty: Format.formatter -> t -> unit val varname: t -> string val hash: t -> int val copy: t -> t end) = Datatype.Make_with_collections (struct include X let name = "Cil_datatype." ^ name let structural_descr = Structural_descr.Abstract let rehash = Datatype.identity let mem_project = Datatype.never_any_project end) let compare_chain cmp x1 x2 next arg1 arg2 = let res = cmp x1 x2 in if res = 0 then next arg1 arg2 else res let rank_term = function | TConst _ -> 0 | TLval _ -> 1 | TSizeOf _ -> 2 | TSizeOfE _ -> 3 | TSizeOfStr _ -> 4 | TAlignOf _ -> 5 | TAlignOfE _ -> 6 | TUnOp _ -> 7 | TBinOp _ -> 8 | TCastE _ -> 9 | TAddrOf _ -> 10 | TStartOf _ -> 11 | Tapp _ -> 12 | Tlambda _ -> 13 | TDataCons _ -> 14 | Tif _ -> 15 | Tat _ -> 16 | Tbase_addr _ -> 17 | Tblock_length _ -> 18 | Tnull -> 19 | TCoerce _ -> 20 | TCoerceE _ -> 21 | TUpdate _ -> 22 | Ttypeof _ -> 23 | Ttype _ -> 24 | Tempty_set -> 25 | Tunion _ -> 26 | Tinter _ -> 27 | Trange _ -> 28 | Tlet _ -> 29 | Tcomprehension _ -> 30 | Toffset _ -> 31 | TLogic_coerce _ -> 32 (**************************************************************************) (** {3 Cabs types} *) (**************************************************************************) module Cabs_file = Make (struct type t = Cabs.file let name = "Cabs_file" let reprs = [ "", []; "", [ true, Cabs.GLOBANNOT [] ] ] let varname (s, _) = "cabs_" ^ s let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined end) (**************************************************************************) (** {3 C types} *) (**************************************************************************) module Position = Make_with_collections (struct type t = Lexing.position let name = "Position" let reprs = [ Lexing.dummy_pos ] let compare: t -> t -> int = (=?=) let hash = Hashtbl.hash let copy = Datatype.identity let equal: t -> t -> bool = ( = ) let internal_pretty_code = Datatype.undefined let pretty fmt pos = Format.fprintf fmt "%s:%d char %d" pos.Lexing.pos_fname pos.Lexing.pos_lnum (pos.Lexing.pos_cnum - pos.Lexing.pos_bol) let varname _ = "pos" end) module Location = struct let unknown = Lexing.dummy_pos, Lexing.dummy_pos include Make_with_collections (struct type t = location let name = "Location" let reprs = [ unknown ] let compare: location -> location -> int = (=?=) let hash (b, _e) = Hashtbl.hash (b.Lexing.pos_fname, b.Lexing.pos_lnum) let copy = Datatype.identity (* immutable strings *) let equal : t -> t -> bool = ( = ) let internal_pretty_code = Datatype.undefined let pretty fmt loc = let loc = (fst loc) in Format.fprintf fmt "%s:%d" loc.Lexing.pos_fname loc.Lexing.pos_lnum let varname _ = "loc" end) let pretty_long fmt loc = let file = Filename.basename (fst loc).Lexing.pos_fname in let line = (fst loc).Lexing.pos_lnum in if file <> "." && file <> "" && line > 0 then Format.fprintf fmt "file %s, line %d" file line else Format.fprintf fmt "generated" let pretty_line fmt loc = let line = (fst loc).Lexing.pos_lnum in if line > 0 then Format.fprintf fmt "line %d" line else Format.fprintf fmt "generated" end module Instr = struct let pretty_ref = ref (fun _ _ -> assert false) include Make (struct type t = instr let name = "Instr" let reprs = List.map (fun l -> Skip l) Location.reprs let internal_pretty_code = Datatype.undefined let pretty fmt x = !pretty_ref fmt x let varname = Datatype.undefined end) let loc = function | Skip l | Set (_,_,l) | Call (_,_,_,l) | Asm (_,_,_,_,_,l) | Code_annot (_,l) -> l end module File = Make (struct type t = file let name = "File" let reprs = [ { fileName = ""; globals = []; globinit = None; globinitcalled = false } ] include Datatype.Undefined let varname _ = "ast" end) module Stmt = struct let pretty_ref = ref (fun _ _ -> assert false) module Aux = Make_with_collections (struct type t = stmt let name = "Stmt" let reprs = [ { labels = []; skind = UnspecifiedSequence []; sid = -1; succs = []; preds = []; ghost = false } ] let compare t1 t2 = Datatype.Int.compare t1.sid t2.sid let hash t1 = t1.sid let equal t1 t2 = t1.sid = t2.sid let copy = Datatype.undefined let internal_pretty_code p_caller fmt s = let pp fmt = Format.fprintf fmt "@[fst@;@[(Kernel_function.find_from_sid@;%d)@]@]" s.sid in Type.par p_caller Type.Call fmt pp let pretty fmt s = !pretty_ref fmt s let varname _ = "stmt" end) include Aux let pretty_sid fmt s = Format.pp_print_int fmt s.sid module Hptset = struct include Hptset.Make (struct include Aux let id s = s.sid let pretty = pretty_sid end) (struct let v = [ [ ] ] end) (struct let l = [ ] (* This should be [Ast.self], but cannot be done here *) end) end let () = clear_caches := Hptset.clear_caches :: !clear_caches let rec loc_skind = function | Return(_, l) | Goto(_, l) | Break(l) | Continue l | If(_, _, _, l) | Switch (_, _, _, l) | Loop (_, _, l, _, _) | TryFinally (_, _, l) | TryExcept (_, _, _, l) -> l | Instr hd -> Instr.loc hd | Block b -> (match b.bstmts with [] -> Location.unknown | s :: _ -> loc s) | UnspecifiedSequence ((s,_,_,_,_) :: _) -> loc s | UnspecifiedSequence [] -> Location.unknown and loc s = loc_skind s.skind end module Kinstr = struct include Make_with_collections (struct type t = kinstr let name = "Kinstr" let reprs = Kglobal :: List.map (fun s -> Kstmt s) Stmt.reprs let compare i1 i2 = match i1, i2 with | Kglobal, Kglobal -> 0 | Kglobal, _ -> 1 | _, Kglobal -> -1 | Kstmt s1, Kstmt s2 -> Stmt.compare s1 s2 let equal t1 t2 = compare t1 t2 = 0 let hash = function | Kglobal -> 1 lsl 29 | Kstmt s -> s.sid let copy = Datatype.undefined let internal_pretty_code p fmt = function | Kglobal -> Format.fprintf fmt "Kglobal" | Kstmt s -> let pp fmt = Format.fprintf fmt "@[Kstmt@;%a@]" (Stmt.internal_pretty_code Type.Call) s in Type.par p Type.Call fmt pp let pretty = Datatype.from_pretty_code let varname _ = "ki" end) let loc = function | Kstmt st -> Stmt.loc st | Kglobal -> assert false let kinstr_of_opt_stmt = function | None -> Kglobal | Some s -> Kstmt s end let index_attrparam = function | AInt _ -> 0 | AStr _ -> 1 | ACons _ -> 2 | ASizeOf _ -> 3 | ASizeOfE _ -> 4 | AAlignOf _ -> 6 | AAlignOfE _ -> 7 | AUnOp _ -> 9 | ABinOp _ -> 10 | ADot _ -> 11 | AStar _ -> 12 | AAddrOf _ -> 13 | AIndex _ -> 14 | AQuestion _ -> 15 let index_typ = function | TVoid _ -> 0 | TInt _ -> 1 | TFloat _ -> 2 | TPtr _ -> 3 | TArray _ -> 4 | TFun _ -> 5 | TNamed _ -> 6 | TComp _ -> 7 | TEnum _ -> 8 | TBuiltin_va_list _ -> 9 let pbitsSizeOf = ref (fun _ -> failwith "pbitsSizeOf not yet defined") let punrollType = ref (fun _ -> failwith "punrollType not yet defined") let drop_non_logic_attributes = ref (fun a -> a) type type_compare_config = { by_name : bool; logic_type: bool; unroll: bool } let rec compare_attribute config a1 a2 = match a1, a2 with | Attr (s1, l1), Attr (s2, l2) -> compare_chain (=?=) s1 s2 (compare_attrparam_list config) l1 l2 | AttrAnnot s1, AttrAnnot s2 -> s1 =?= s2 | Attr _, AttrAnnot _ -> -1 | AttrAnnot _, Attr _ -> 1 and compare_attributes config l1 l2 = let l1, l2 = if config.logic_type then !drop_non_logic_attributes l1, !drop_non_logic_attributes l2 else l1,l2 in compare_list (compare_attribute config) l1 l2 and compare_attrparam_list config l1 l2 = compare_list (compare_attrparam config) l1 l2 and compare_attrparam config a1 a2 = match a1, a2 with | AInt i1, AInt i2 -> Integer.compare i1 i2 | AStr s1, AStr s2 -> s1 =?= s2 | ACons ((s1: string), l1), ACons (s2, l2) -> let r1 = (=?=) s1 s2 in if r1 <> 0 then r1 else compare_attrparam_list config l1 l2 | ASizeOf t1, ASizeOf t2 -> compare_type config t1 t2 | ASizeOfE p1, ASizeOfE p2 -> compare_attrparam config p1 p2 | AAlignOf t1, AAlignOf t2 -> compare_type config t1 t2 | AAlignOfE p1, AAlignOfE p2 -> compare_attrparam config p1 p2 | AUnOp (op1, a1), AUnOp (op2, a2) -> compare_chain (=?=) op1 op2 (compare_attrparam config) a1 a2 | ABinOp (op1, a1, a1'), ABinOp (op2, a2, a2') -> compare_chain (=?=) op1 op2 (compare_chain (compare_attrparam config) a1 a2 (compare_attrparam config)) a1' a2' | ADot (a1, s1), ADot (a2, s2) -> compare_chain (=?=) s1 s2 (compare_attrparam config) a1 a2 | AStar a1, AStar a2 | AAddrOf a1, AAddrOf a2 -> compare_attrparam config a1 a2 | AIndex (a1, a1'), AIndex (a2, a2') -> compare_chain (compare_attrparam config) a1 a2 (compare_attrparam config) a1' a2' | AQuestion (a1, a1', a1''), AQuestion (a2, a2', a2'') -> compare_chain (compare_attrparam config) a1 a2 (compare_chain (compare_attrparam config) a1' a2' (compare_attrparam config)) a1'' a2'' | (AInt _ | AStr _ | ACons _ | ASizeOf _ | ASizeOfE _ | AAlignOf _ | AAlignOfE _ | AUnOp _ | ABinOp _ | ADot _ | AStar _ | AAddrOf _ | AIndex _ | AQuestion _ as a1), a2 -> index_attrparam a1 - index_attrparam a2 and compare_type config t1 t2 = if t1 == t2 then 0 else let typs = if config.unroll then !punrollType t1, !punrollType t2 else t1,t2 in match typs with | TVoid l1, TVoid l2 -> compare_attributes config l1 l2 | TInt (i1, l1), TInt (i2, l2) -> compare_chain (=?=) i1 i2 (compare_attributes config) l1 l2 | TFloat (f1, l1), TFloat (f2, l2) -> compare_chain (=?=) f1 f2 (compare_attributes config) l1 l2 | TPtr (t1, l1), TPtr (t2, l2) -> compare_chain (compare_type config) t1 t2 (compare_attributes config) l1 l2 | TArray (t1', _, _, l1), TArray (t2', _, _, l2) -> (* bitsSizeOf is here to compare the size of the arrays *) compare_chain (=?=) (!pbitsSizeOf t1) (!pbitsSizeOf t2) (compare_chain (compare_type config) t1' t2' (compare_attributes config)) l1 l2 | TFun (r1, a1, v1, l1), TFun (r2, a2, v2, l2) -> compare_chain (compare_type config) r1 r2 (compare_chain (=?=) v1 v2 (compare_chain (compare_arg_list config) a1 a2 (compare_attributes config))) l1 l2 | TNamed (t1,a1), TNamed (t2,a2) -> assert (not config.unroll); compare_chain (=?=) t1.tname t2.tname (compare_attributes config) a1 a2 | TComp (c1, _, l1), TComp (c2, _, l2) -> let res = if config.by_name then (=?=) c1.cname c2.cname else (=?=) c1.ckey c2.ckey in if res <> 0 then res else compare_attributes config l1 l2 | TEnum (e1, l1), TEnum (e2, l2) -> compare_chain (=?=) e1.ename e2.ename (compare_attributes config) l1 l2 | TBuiltin_va_list l1, TBuiltin_va_list l2 -> compare_attributes config l1 l2 | (TVoid _ | TInt _ | TFloat _ | TPtr _ | TArray _ | TFun _ | TNamed _ | TComp _ | TEnum _ | TBuiltin_va_list _ as a1), a2 -> index_typ a1 - index_typ a2 and compare_arg_list config l1 l2 = Extlib.opt_compare (compare_list (fun (_n1, t1, l1) (_n2, t2, l2) -> (compare_chain (compare_type config) t1 t2 (compare_attributes config)) l1 l2 )) l1 l2 let hash_attribute _config = function | AttrAnnot s -> Hashtbl.hash s | Attr (s, _) -> (* We do not hash attrparams. There is a recursivity problem with typ, and the equal function will be complicated enough in itself *) 3 * Hashtbl.hash s + 117 let hash_attributes config l = let attrs = if config.logic_type then !drop_non_logic_attributes l else l in hash_list (hash_attribute config) attrs let rec hash_type config t = let t = if config.unroll then !punrollType t else t in match t with | TVoid l -> Hashtbl.hash (hash_attributes config l, 1) | TInt (i, l) -> Hashtbl.hash (i, 2, hash_attributes config l) | TFloat (f, l) -> Hashtbl.hash (f, 3, hash_attributes config l) | TPtr (t, l) -> Hashtbl.hash (hash_type config t, 4, hash_attributes config l) | TArray (t, _, _, l) -> Hashtbl.hash (hash_type config t, 5, hash_attributes config l) | TFun (r, a, v, l) -> Hashtbl.hash (hash_type config r, 6, hash_args config a, v, hash_attributes config l) | TNamed (ti, l) -> Hashtbl.hash (ti.tname, 7, hash_attributes config l) | TComp (c, _, l) -> Hashtbl.hash ((if config.by_name then Hashtbl.hash c.cname else c.ckey), 8, hash_attributes config l) | TEnum (e, l) -> Hashtbl.hash (e.ename, 9, hash_attributes config l) | TBuiltin_va_list l -> Hashtbl.hash (hash_attributes config l, 10) and hash_args config = function | None -> 11713 | Some l -> hash_list (fun (_, t, l) -> Hashtbl.hash (17, hash_type config t, hash_attributes config l)) l module Attribute=struct let pretty_ref = ref (fun _ _ -> assert false) include Make_with_collections (struct type t = attribute let config = { by_name = false; logic_type = false; unroll = true } let name = "Attribute" let reprs = [ AttrAnnot "" ] let compare = compare_attribute config let hash = hash_attribute config let equal = Datatype.from_compare let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty fmt t = !pretty_ref fmt t let varname = Datatype.undefined end) end let pretty_typ_ref = ref (fun _ _ -> assert false) module MakeTyp(M:sig val config: type_compare_config val name: string end) = struct include Make_with_collections (struct type t = typ let name = M.name let reprs = [ TVoid [] ] let compare = compare_type M.config let hash = hash_type M.config let equal = Datatype.from_compare let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty fmt t = !pretty_typ_ref fmt t let varname = Datatype.undefined end) end module Typ= MakeTyp (struct let config = { by_name = false; logic_type = false; unroll = true; } let name = "Typ" end) module TypByName = MakeTyp (struct let config = { by_name = true; logic_type = false; unroll = false; } let name = "TypByName" end) module TypNoUnroll = MakeTyp (struct let config = { by_name = false; logic_type = false; unroll = false; } let name = "TypNoUnroll" end) module Typeinfo = Make_with_collections (struct include Datatype.Undefined type t = typeinfo let name = "Type_info" let reprs = [ { torig_name = ""; tname = ""; ttype = TVoid []; treferenced = false } ] let compare v1 v2 = String.compare v1.tname v2.tname let hash v = Hashtbl.hash v.tname let equal v1 v2 = v1.tname = v2.tname end) module Exp = struct let pretty_ref = ref (fun _ _ -> assert false) let dummy = { eid = -1; enode = Const (CStr ""); eloc = Location.unknown } include Make_with_collections (struct include Datatype.Undefined type t = exp let name = "Exp" let reprs = [ dummy ] let compare e1 e2 = Datatype.Int.compare e1.eid e2.eid let hash e = Hashtbl.hash e.eid let equal e1 e2 = e1.eid = e2.eid let pretty fmt t = !pretty_ref fmt t end) end module Label = Make_with_collections (struct type t = label let name = "Label" let reprs = [ Label("", Location.unknown, false); Default Location.unknown ] let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname = Datatype.undefined let hash = function | Default _ -> 7 | Case (e, _) -> Exp.hash e | Label (s, _, b) -> Hashtbl.hash s + (if b then 13 else 59) let compare l1 l2 = match l1, l2 with | Default loc1, Default loc2 -> Location.compare loc1 loc2 | Case (e1, loc1), Case (e2, loc2) -> let c = Exp.compare e1 e2 in if c = 0 then Location.compare loc1 loc2 else c | Label (s1, loc1, b1), Label (s2, loc2, b2) -> let c = s1 =?= s2 in if c = 0 then let c = b1 =?= b2 in if c = 0 then Location.compare loc1 loc2 else c else c | Label _, (Case _ | Default _) | Case _, Default _ -> -1 | Case _, Label _ | Default _, (Label _ | Case _) -> 1 let equal = Datatype.from_compare let copy = Datatype.undefined end) module Varinfo = struct let pretty_ref = ref (fun _ _ -> assert false) let internal_pretty_code_ref = ref (fun _ _ _ -> assert false) let dummy = { vname = ""; vorig_name = ""; vtype = TVoid []; vattr = []; vstorage = NoStorage; vglob = false; vdefined = false; vformal = false; vinline = false; vdecl = Location.unknown; vid = -1; vaddrof = false; vreferenced = false; vgenerated = false; vdescr = None; vdescrpure = false; vghost = false; vlogic = false; vlogic_var_assoc = None } module Aux = Make_with_collections (struct type t = varinfo let name = "Varinfo" let reprs = [ dummy ] let compare v1 v2 = Datatype.Int.compare v1.vid v2.vid let hash v = v.vid let equal v1 v2 = v1.vid = v2.vid let copy = Datatype.undefined let internal_pretty_code p fmt v = !internal_pretty_code_ref p fmt v let pretty fmt v = !pretty_ref fmt v let varname v = "vi_" ^ v.vorig_name end) let pretty_vname fmt v = Format.pp_print_string fmt v.vname include Aux let pretty_vid fmt v = Format.pp_print_int fmt v.vid module Hptset = struct include Hptset.Make (struct include Aux let id v = v.vid let pretty = pretty_vid end) (struct let v = [ [ ] ] end) (struct let l = [ ] (* Should morally be [Ast.self] *) end) end let () = clear_caches := Hptset.clear_caches :: !clear_caches end module Compinfo = Make_with_collections (struct type t = compinfo let name = "compinfo" let reprs = [ { cstruct = false; corig_name = ""; cname = ""; ckey = -1; cfields = []; cattr = []; cdefined = false; creferenced = false } ] let compare v1 v2 = Datatype.Int.compare v1.ckey v2.ckey let hash v = Hashtbl.hash v.ckey let equal v1 v2 = v1.ckey = v2.ckey let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname = Datatype.undefined end) module Fieldinfo = Make_with_collections (struct type t = fieldinfo let name = "fieldinfo" let reprs = List.fold_left (fun acc ci -> List.fold_left (fun acc typ -> List.fold_left (fun acc loc -> { fcomp = ci; forig_name = ""; fname = ""; ftype = typ; fbitfield = None; fattr = []; floc = loc; faddrof = false; fsize_in_bits = None; foffset_in_bits = None; fpadding_in_bits = None } :: acc) acc Location.reprs) acc Typ.reprs) [] Compinfo.reprs let fid fi = fi.fcomp.ckey, fi.fname let compare f1 f2 = Extlib.compare_basic (fid f1) (fid f2) let hash f1 = Hashtbl.hash (fid f1) let equal f1 f2 = (fid f1) = (fid f2) let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname = Datatype.undefined end) module Enuminfo = Make_with_collections (struct include Datatype.Undefined type t = enuminfo let name = "Enuminfo" let reprs = [ { eorig_name = ""; ename = ""; eitems = []; eattr = []; ereferenced = false; ekind = IInt; } ] let compare v1 v2 = String.compare v1.ename v2.ename let hash v = Hashtbl.hash v.ename let equal v1 v2 = v1.ename = v2.ename end) module Enumitem = Make_with_collections (struct include Datatype.Undefined type t = enumitem let name = "Enumitem" let reprs = List.map (fun i -> { eiorig_name = ""; einame = ""; eival = { eloc = Location.unknown; eid = -1; enode = Const (CStr "") }; eihost = i; eiloc = Location.unknown }) Enuminfo.reprs let compare v1 v2 = String.compare v1.einame v2.einame let hash v = Hashtbl.hash v.einame let equal v1 v2 = v1.einame = v2.einame end) let compare_constant c1 c2 = match c1, c2 with | CInt64(v1,k1,_), CInt64(v2,k2,_) -> compare_chain Integer.compare v1 v2 Extlib.compare_basic k1 k2 | CStr s1, CStr s2 -> Datatype.String.compare s1 s2 | CWStr s1, CWStr s2 -> compare_list Datatype.Int64.compare s1 s2 | CChr c1, CChr c2 -> Datatype.Char.compare c1 c2 | CReal (f1,k1,_), CReal(f2,k2,_) -> compare_chain Datatype.Float.compare f1 f2 Extlib.compare_basic k1 k2 | CEnum e1, CEnum e2 -> Enumitem.compare e1 e2 | (CInt64 _, (CStr _ | CWStr _ | CChr _ | CReal _ | CEnum _)) -> 1 | (CStr _, (CWStr _ | CChr _ | CReal _ | CEnum _)) -> 1 | (CWStr _, (CChr _ | CReal _ | CEnum _)) -> 1 | (CChr _, (CReal _ | CEnum _)) -> 1 | (CReal _, CEnum _) -> 1 | (CStr _ | CWStr _ | CChr _ | CReal _ | CEnum _), (CInt64 _ | CStr _ | CWStr _ | CChr _ | CReal _) -> -1 let hash_const c = match c with CInt64 _ | CStr _ | CWStr _ | CChr _ | CReal _ -> Hashtbl.hash c | CEnum ei -> 95 + Enumitem.hash ei module StructEq = struct let rec compare_exp e1 e2 = match e1.enode, e2.enode with | Const c1, Const c2 -> compare_constant c1 c2 | Const _, _ -> 1 | _, Const _ -> -1 | Lval lv1, Lval lv2 -> compare_lval lv1 lv2 | Lval _, _ -> 1 | _, Lval _ -> -1 | SizeOf t1, SizeOf t2 -> Typ.compare t1 t2 | SizeOf _, _ -> 1 | _, SizeOf _ -> -1 | SizeOfE e1, SizeOfE e2 -> compare_exp e1 e2 | SizeOfE _, _ -> 1 | _, SizeOfE _ -> -1 | SizeOfStr s1, SizeOfStr s2 -> String.compare s1 s2 | SizeOfStr _, _ -> 1 | _, SizeOfStr _ -> -1 | AlignOf ty1, AlignOf ty2 -> Typ.compare ty1 ty2 | AlignOf _, _ -> 1 | _, AlignOf _ -> -1 | AlignOfE e1, AlignOfE e2 -> compare_exp e1 e2 | AlignOfE _, _ -> 1 | _, AlignOfE _ -> -1 | UnOp(op1,e1,ty1), UnOp(op2,e2,ty2) -> let res = Extlib.compare_basic op1 op2 in if res = 0 then let res = compare_exp e1 e2 in if res = 0 then Typ.compare ty1 ty2 else res else res | UnOp _, _ -> 1 | _, UnOp _ -> -1 | BinOp(op1,e11,e21, ty1), BinOp(op2,e12,e22, ty2) -> let res = Extlib.compare_basic op1 op2 in if res = 0 then let res = compare_exp e11 e12 in if res = 0 then let res = compare_exp e21 e22 in if res = 0 then Typ.compare ty1 ty2 else res else res else res | BinOp _, _ -> 1 | _, BinOp _ -> -1 | CastE(t1,e1), CastE(t2, e2) -> let res = Typ.compare t1 t2 in if res = 0 then compare_exp e1 e2 else res | CastE _, _ -> 1 | _, CastE _ -> -1 | AddrOf lv1, AddrOf lv2 -> compare_lval lv1 lv2 | AddrOf _, _ -> 1 | _, AddrOf _ -> -1 | StartOf lv1, StartOf lv2 -> compare_lval lv1 lv2 | StartOf _, _ -> 1 | _, StartOf _ -> -1 | Info _, Info _ -> Kernel.fatal "[exp_compare] Info node is obsolete. Do not use it" and compare_lval (h1,o1) (h2,o2) = let res = compare_lhost h1 h2 in if res = 0 then compare_offset o1 o2 else res and compare_lhost h1 h2 = match h1, h2 with | Var v1, Var v2 -> Varinfo.compare v1 v2 | Var _, Mem _ -> 1 | Mem e1, Mem e2 -> compare_exp e1 e2 | Mem _, Var _ -> -1 and compare_offset o1 o2 = match o1, o2 with | NoOffset, NoOffset -> 0 | NoOffset, _ -> 1 | _, NoOffset -> -1 | Field(f1,o1), Field(f2, o2) -> let res = Fieldinfo.compare f1 f2 in if res = 0 then compare_offset o1 o2 else res | Field _, _ -> 1 | _, Field _ -> -1 | Index(e1, o1), Index(e2, o2) -> let res = compare_exp e1 e2 in if res = 0 then compare_offset o1 o2 else res let prime = 83047 let rec hash_exp acc e = match e.enode with | Const c -> prime * acc lxor hash_const c | Lval lv -> hash_lval ((prime*acc) lxor 42) lv | SizeOf t -> (prime*acc) lxor Typ.hash t | SizeOfE e -> hash_exp ((prime*acc) lxor 75) e | SizeOfStr s -> (prime*acc) lxor Hashtbl.hash s | AlignOf t -> (prime*acc) lxor Typ.hash t | AlignOfE e -> hash_exp ((prime*acc) lxor 153) e | UnOp(op,e,ty) -> let res = hash_exp ((prime*acc) lxor Hashtbl.hash op) e in (prime*res) lxor Typ.hash ty | BinOp(op,e1,e2,ty) -> let res = hash_exp ((prime*acc) lxor Hashtbl.hash op) e1 in let res = hash_exp ((prime*res) lxor 257) e2 in (prime * res) lxor Typ.hash ty | CastE(ty,e) -> hash_exp ((prime*acc) lxor Typ.hash ty) e | AddrOf lv -> hash_lval (prime*acc lxor 329) lv | StartOf lv -> hash_lval (prime*acc lxor 431) lv | Info _ -> Kernel.fatal "Info node is deprecated and should not be used" and hash_lval acc (h,o) = hash_offset ((prime * acc) lxor hash_lhost 856 h) o and hash_lhost acc = function | Var v -> (prime * acc) lxor (Varinfo.hash v) | Mem e -> hash_exp ((prime * acc) lxor 967) e and hash_offset acc = function | NoOffset -> (prime * acc) lxor 1583 | Index(e,o) -> let res = hash_exp 1790 e in hash_offset ((prime * acc) lxor res) o | Field(f,o) -> hash_offset ((prime * acc) lxor Hashtbl.hash f.fname) o end module Wide_string = Datatype.List_with_collections(Datatype.Int64) (struct let module_name = "Cil_datatype.Wide_string" end) module Constant = struct let pretty_ref = Extlib.mk_fun "Cil_datatype.Constant.pretty_ref" include Make_with_collections (struct include Datatype.Undefined type t = constant let name = "Constant" let reprs = [ CInt64(Integer.zero, IInt, Some "0") ] let compare = compare_constant let hash = hash_const let equal = Datatype.from_compare let pretty fmt t = !pretty_ref fmt t end) end module ExpStructEq = Make_with_collections (struct include Datatype.Undefined type t = exp let name = "ExpStructEq" let reprs = [ Exp.dummy ] let compare = StructEq.compare_exp let hash = StructEq.hash_exp 7863 let equal = Datatype.from_compare let pretty fmt t = !Exp.pretty_ref fmt t end) module Block = struct let pretty_ref = Extlib.mk_fun "Cil_datatype.Block.pretty_ref" include Make (struct type t = block let name = "Block" let reprs = [ { battrs = []; blocals = Varinfo.reprs; bstmts = Stmt.reprs } ] let internal_pretty_code = Datatype.undefined let pretty fmt b = !pretty_ref fmt b let varname = Datatype.undefined end) let equal b1 b2 = (b1 == b2) end let rec equal_lval (h1, o1) (h2, o2) = equal_lhost h1 h2 && equal_offset o1 o2 and equal_lhost h1 h2 = match h1,h2 with | Var v1, Var v2 -> Datatype.Int.equal v1.vid v2.vid | Mem e1, Mem e2 -> Exp.equal e1 e2 | (Var _ | Mem _), _-> false and equal_offset o1 o2 = match o1,o2 with | NoOffset, NoOffset -> true | Field(f1,o1), Field(f2,o2) -> Fieldinfo.equal f1 f2 && equal_offset o1 o2 | Index(e1,o1), Index(e2,o2) -> Exp.equal e1 e2 && equal_offset o1 o2 | (NoOffset | Field _ | Index _), _ -> false let rec compare_lval (h1,o1) (h2,o2) = compare_chain compare_lhost h1 h2 compare_offset o1 o2 and compare_lhost h1 h2 = match h1,h2 with Var v1, Var v2 -> Datatype.Int.compare v1.vid v2.vid | Mem e1, Mem e2 -> Exp.compare e1 e2 | Var _, Mem _ -> 1 | Mem _, Var _ -> -1 and compare_offset o1 o2 = match o1,o2 with NoOffset, NoOffset -> 0 | Field(f1,o1), Field(f2,o2) -> compare_chain Fieldinfo.compare f1 f2 compare_offset o1 o2 | Index(e1,o1), Index(e2,o2) -> compare_chain Exp.compare e1 e2 compare_offset o1 o2 | (NoOffset, (Field _ | Index _)) -> 1 | (Field _, Index _) -> 1 | ((Field _ | Index _), (NoOffset | Field _ )) -> -1 let rec hash_lval (h,o) = Hashtbl.hash (hash_lhost h, hash_offset o) and hash_lhost = function | Var v -> 17 + v.vid | Mem e -> 13 + 5 * e.eid and hash_offset = function | NoOffset -> 19 | Field(f,o) -> Hashtbl.hash (Fieldinfo.hash f, hash_offset o) | Index (e, o) -> Hashtbl.hash (e.eid, hash_offset o) module Lval = struct let pretty_ref = ref (fun _ -> assert false) include Make_with_collections (struct type t = lval let name = "Lval" let reprs = List.map (fun v -> Var v, NoOffset) Varinfo.reprs let compare = compare_lval let equal = equal_lval let hash = hash_lval let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty fmt x = !pretty_ref fmt x let varname _ = "lv" end) end module LvalStructEq = Make_with_collections (struct type t = lval let name = "LvalStructEq" let reprs = List.map (fun v -> Var v, NoOffset) Varinfo.reprs let compare = StructEq.compare_lval let equal = Datatype.from_compare let hash = StructEq.hash_lval 13598 let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty fmt x = !Lval.pretty_ref fmt x let varname _ = "lv" end) module Offset = struct let pretty_ref = ref (fun _ -> assert false) include Make_with_collections (struct type t = offset let name = "Offset" let reprs = [NoOffset] let compare = compare_offset let equal = equal_offset let hash = hash_offset let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty fmt x = !pretty_ref fmt x let varname _ = "offs" end) end module OffsetStructEq = Make_with_collections (struct type t = offset let name = "OffsetStructEq" let reprs = [NoOffset] let compare = StructEq.compare_offset let equal = Datatype.from_compare let hash = StructEq.hash_offset 75489 let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty fmt x = !Offset.pretty_ref fmt x let varname _ = "offs" end) (**************************************************************************) (** {3 ACSL types} *) (**************************************************************************) module Logic_var = struct let pretty_ref = ref (fun _ _ -> assert false) include Make_with_collections (struct type t = logic_var let name = "Logic_var" let reprs = let dummy v = let kind = match v with None -> LVQuant | Some _ -> LVC in { lv_name = ""; lv_kind = kind; lv_id = -1; lv_type = Linteger; lv_origin = v } in dummy None :: List.map (fun v -> dummy (Some v)) Varinfo.reprs let compare v1 v2 = Datatype.Int.compare v1.lv_id v2.lv_id let hash v = v.lv_id let equal v1 v2 = v1.lv_id = v2.lv_id let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty fmt t = !pretty_ref fmt t let varname _ = "logic_var" end) end module Builtin_logic_info = Make_with_collections (struct type t = builtin_logic_info let name = "Builtin_logic_info" let reprs = [ { bl_name = ""; bl_labels = []; bl_params = []; bl_type = None; bl_profile = [] } ] let compare i1 i2 = String.compare i1.bl_name i2.bl_name let hash i = Hashtbl.hash i.bl_name let equal i1 i2 = i1.bl_name = i2.bl_name let copy = Datatype.identity (* works only if an AST is never modified *) let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname = Datatype.undefined end) module Logic_type_info = Make_with_collections (struct type t = logic_type_info let name = "Logic_type_info" let reprs = [ { lt_name = ""; lt_params = []; lt_def = None } ] let compare t1 t2 = String.compare t1.lt_name t2.lt_name let equal t1 t2 = t1.lt_name = t2.lt_name let hash t = Hashtbl.hash t.lt_name let copy = Datatype.identity (* works only if an AST is never modified *) let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname = Datatype.undefined end) module Logic_ctor_info = Make_with_collections (struct type t = logic_ctor_info let name = "Logic_ctor_info" let reprs = List.map (fun v -> { ctor_name = ""; ctor_type = v; ctor_params = [] }) Logic_type_info.reprs let compare t1 t2 = String.compare t1.ctor_name t2.ctor_name let equal t1 t2 = t1.ctor_name = t2.ctor_name let hash t = Hashtbl.hash t.ctor_name let copy = Datatype.identity (* works only if an AST is never modified *) let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname = Datatype.undefined end) module Initinfo = Make (struct type t = initinfo let name = "Initinfo" let reprs = { init = None } :: List.map (fun t -> { init = Some (CompoundInit(t, [])) }) Typ.reprs let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname = Datatype.undefined end) module Logic_info = Make_with_collections (struct type t = logic_info let name = "Logic_info" let reprs = List.map (fun v -> { l_var_info = v; l_labels = []; l_tparams = []; l_type = None; l_profile = []; l_body = LBnone }) Logic_var.reprs let compare i1 i2 = Logic_var.compare i1.l_var_info i2.l_var_info let equal i1 i2 = Logic_var.equal i1.l_var_info i2.l_var_info let hash i = Logic_var.hash i.l_var_info let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname _ = "logic_varinfo" end) let rec compare_logic_type config v1 v2 = let rank = function | Linteger -> 0 | Lreal -> 1 | Ctype _ -> 2 | Lvar _ -> 3 | Ltype _ -> 4 | Larrow _ -> 5 in let k1 = rank v1 in let k2 = rank v2 in if k1 <> k2 then k1-k2 else match v1,v2 with | Ctype t1 , Ctype t2 -> compare_type config t1 t2 | Ltype ({lt_def = Some (LTsyn t1)},ts1), Ltype ({lt_def = Some (LTsyn t2)},ts2) when config.unroll -> let c = compare_logic_type config t1 t2 in if c <> 0 then c else compare_list (compare_logic_type config) ts1 ts2 | Ltype(a,ts1), Ltype(b,ts2) -> let c = Logic_type_info.compare a b in if c <> 0 then c else compare_list (compare_logic_type config) ts1 ts2 | Lvar x1, Lvar x2 -> Datatype.String.compare x1 x2 | Linteger, Linteger -> 0 | Lreal, Lreal -> 0 | Larrow(l1, t1), Larrow(l2, t2) -> let c = compare_logic_type config t1 t2 in if c <> 0 then c else compare_list (compare_logic_type config) l1 l2 | _ -> assert false let rec hash_logic_type config = function | Linteger -> 0 | Lreal -> 1 | Ctype ty -> hash_type config ty | Ltype({ lt_def = Some (LTsyn t)},_) when config.unroll -> hash_logic_type config t | Ltype(t,_) -> Logic_type_info.hash t | Lvar x -> Datatype.String.hash x | Larrow (_,t) -> 41 * hash_logic_type config t let pretty_logic_type_ref = ref (fun _ _ -> assert false) module Make_Logic_type (M: sig val config: type_compare_config val name: string end) = Make_with_collections( struct include Datatype.Undefined type t = logic_type let name = M.name let reprs = List.map (fun t -> Ctype t) Typ.reprs let compare = compare_logic_type M.config let equal = Datatype.from_compare let hash = hash_logic_type M.config let pretty fmt t = !pretty_logic_type_ref fmt t end) module Logic_type = Make_Logic_type( struct let config = { by_name = false; logic_type = true; unroll = true } let name = "Logic_type" end) module Logic_type_ByName = Make_Logic_type( struct let name = "Logic_type_ByName" let config = { by_name = true; logic_type = true; unroll = false } end) module Logic_type_NoUnroll = Make_Logic_type( struct let name = "Logic_type_NoUnroll" let config = { by_name = false; logic_type = false; unroll = false } end) module Model_info = struct let pretty_ref = ref (fun _ _ -> assert false) include Make_with_collections( struct type t = model_info include Datatype.Undefined let name = "model_info" let reprs = Extlib.product (fun base field -> { mi_name = "dummy"; mi_base_type = base; mi_field_type = field; mi_decl = Location.unknown; }) Typ.reprs Logic_type.reprs let compare mi1 mi2 = let scmp = String.compare mi1.mi_name mi2.mi_name in if scmp <> 0 then scmp else Typ.compare mi1.mi_base_type mi2.mi_base_type let equal = Datatype.from_compare let hash mi = Hashtbl.hash mi.mi_name + 3 * Typ.hash mi.mi_base_type let copy mi = { mi_name = String.copy mi.mi_name; mi_base_type = Typ.copy mi.mi_base_type; mi_field_type = Logic_type.copy mi.mi_field_type; mi_decl = Location.copy mi.mi_decl; } let pretty fmt t = !pretty_ref fmt t end) end (* -------------------------------------------------------------------------- *) (* --- Comparison Over Terms --- *) (* -------------------------------------------------------------------------- *) let compare_logic_constant c1 c2 = match c1,c2 with | Integer (i1,_), Integer(i2,_) -> Integer.compare i1 i2 | LStr s1, LStr s2 -> Datatype.String.compare s1 s2 | LWStr s1, LWStr s2 -> compare_list Datatype.Int64.compare s1 s2 | LChr c1, LChr c2 -> Datatype.Char.compare c1 c2 | LReal r1, LReal r2 -> Datatype.String.compare r1.r_literal r2.r_literal | LEnum e1, LEnum e2 -> Enumitem.compare e1 e2 | Integer _,(LStr _|LWStr _ |LChr _|LReal _|LEnum _) -> 1 | LStr _ ,(LWStr _ |LChr _|LReal _|LEnum _) -> 1 | LWStr _ ,(LChr _|LReal _|LEnum _) -> 1 | LChr _,(LReal _|LEnum _) -> 1 | LReal _,LEnum _ -> 1 | (LStr _|LWStr _ |LChr _|LReal _|LEnum _), (Integer _|LStr _|LWStr _ |LChr _|LReal _) -> -1 let rec compare_term t1 t2 = let r1 = rank_term t1.term_node in let r2 = rank_term t2.term_node in if r1 <> r2 then r1 - r2 else match t1.term_node , t2.term_node with | TConst c1 , TConst c2 -> compare_logic_constant c1 c2 | TLval lv1 , TLval lv2 | TAddrOf lv1 , TAddrOf lv2 | TStartOf lv1 , TStartOf lv2 -> compare_tlval lv1 lv2 | TSizeOf ty1 , TSizeOf ty2 | TAlignOf ty1 , TAlignOf ty2 -> Typ.compare ty1 ty2 | TSizeOfE t1 , TSizeOfE t2 | TAlignOfE t1 , TAlignOfE t2 -> compare_term t1 t2 | TSizeOfStr s1 , TSizeOfStr s2 -> String.compare s1 s2 | TUnOp(op1,t1) , TUnOp(op2,t2) -> let c = Extlib.compare_basic op1 op2 in if c <> 0 then c else compare_term t1 t2 | TBinOp(op1,x1,y1) , TBinOp(op2,x2,y2) -> let c = Extlib.compare_basic op1 op2 in if c <> 0 then c else let cx = compare_term x1 x2 in if cx <> 0 then cx else compare_term y1 y2 | TCastE(ty1,t1) , TCastE(ty2,t2) -> let c = Typ.compare ty1 ty2 in if c <> 0 then c else compare_term t1 t2 | Tapp(f1,labs1,ts1) , Tapp(f2,labs2,ts2) -> let cf = Logic_info.compare f1 f2 in if cf <> 0 then cf else let cl = compare_list compare_logic_label_pair labs1 labs2 in if cl <> 0 then cl else compare_list compare_term ts1 ts2 | Tlambda(q1,t1) , Tlambda(q2,t2) -> let cq = compare_list Logic_var.compare q1 q2 in if cq <> 0 then cq else compare_term t1 t2 | TDataCons(f1,ts1) , TDataCons(f2,ts2) -> let cq = compare_ctor f1 f2 in if cq <> 0 then cq else compare_list compare_term ts1 ts2 | Tif(c1,a1,b1) , Tif(c2,a2,b2) -> compare_list compare_term [c1;a1;b1] [c2;a2;b2] | Tbase_addr (l1,t1) , Tbase_addr (l2,t2) | Tblock_length (l1,t1) , Tblock_length (l2,t2) | Toffset (l1,t1) , Toffset (l2,t2) | Tat(t1,l1) , Tat(t2,l2) -> let cl = compare_logic_label l1 l2 in if cl <> 0 then cl else compare_term t1 t2 | Tnull , Tnull -> 0 | TCoerce(t1,ty1) , TCoerce(t2,ty2) -> let ct = Typ.compare ty1 ty2 in if ct <> 0 then ct else compare_term t1 t2 | TCoerceE(t1,ty1) , TCoerceE(t2,ty2) -> let ct = compare_term ty1 ty2 in if ct <> 0 then ct else compare_term t1 t2 | TUpdate(x1,off1,y1) , TUpdate(x2,off2,y2) -> let cx = compare_term x1 x2 in if cx <> 0 then cx else let cf = compare_toffset off1 off2 in if cf <> 0 then cf else compare_term y1 y2 | Ttypeof t1 , Ttypeof t2 -> compare_term t1 t2 | Ttype ty1 , Ttype ty2 -> Typ.compare ty1 ty2 | Tempty_set , Tempty_set -> 0 | Tunion ts1 , Tunion ts2 | Tinter ts1 , Tinter ts2 -> compare_list compare_term ts1 ts2 | Trange(a1,b1) , Trange(a2,b2) -> let c = compare_bound a1 a2 in if c <> 0 then c else compare_bound b1 b2 | Tlet(x1,t1) , Tlet(x2,t2) -> let c = Logic_info.compare x1 x2 in if c <> 0 then c else compare_term t1 t2 | Tcomprehension (t1, q1, _p1), Tcomprehension (t2, q2, _p2) -> let c = compare_term t1 t2 in if c <> 0 then c else let cq = compare_list Logic_var.compare q1 q2 in if cq <> 0 then cq else assert false (* TODO !*) | TLogic_coerce(ty1,e1), TLogic_coerce(ty2,e2) -> let ct = Logic_type.compare ty1 ty2 in if ct <> 0 then ct else compare_term e1 e2 | (TConst _ | TLval _ | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ | TUnOp _ | TBinOp _ | TCastE _ | TAddrOf _ | TStartOf _ | Tapp _ | Tlambda _ | TDataCons _ | Tif _ | Tat _ | Tbase_addr _ | Tblock_length _ | Toffset _ | Tnull | TCoerce _ | TCoerceE _ | TUpdate _ | Ttypeof _ | Ttype _ | Tempty_set | Tunion _ | Tinter _ | Tcomprehension _ | Trange _ | Tlet _ | TLogic_coerce _), _ -> assert false and compare_tlval (h1,off1) (h2,off2) = let ch = compare_tlhost h1 h2 in if ch <> 0 then ch else compare_toffset off1 off2 and compare_tlhost h1 h2 = match h1 , h2 with | TVar x1 , TVar x2 -> Logic_var.compare x1 x2 | TMem m1 , TMem m2 -> compare_term m1 m2 | TResult ty1 , TResult ty2 -> Typ.compare ty1 ty2 | TVar _ , TMem _ | TVar _ , TResult _ | TMem _ , TResult _ -> (-1) | TMem _ , TVar _ | TResult _ , TVar _ | TResult _ , TMem _ -> 1 and compare_toffset off1 off2 = match off1 , off2 with | TNoOffset , TNoOffset -> 0 | TField(f1,next1) , TField(f2,next2) -> let cf = Fieldinfo.compare f1 f2 in if cf <> 0 then cf else compare_toffset next1 next2 | TIndex(t1,next1) , TIndex(t2,next2) -> let cf = compare_term t1 t2 in if cf <> 0 then cf else compare_toffset next1 next2 | TModel(f1,next1), TModel(f2,next2) -> let cf = Model_info.compare f1 f2 in if cf <> 0 then cf else compare_toffset next1 next2 | TNoOffset , (TField _ | TModel _ | TIndex _ ) | TField _, (TModel _ | TIndex _) | TModel _, TIndex _ -> (-1) | TField _, TNoOffset | TModel _, (TField _ | TNoOffset) | TIndex _, (TModel _ | TField _ | TNoOffset) -> 1 and compare_logic_label_pair (x1,p1) (x2,p2) = let c1 = compare_logic_label x1 x2 in if c1 <> 0 then c1 else compare_logic_label p1 p2 and compare_logic_label l1 l2 = match l1, l2 with | StmtLabel s1 , StmtLabel s2 -> Stmt.compare !s1 !s2 | LogicLabel (None,l1), LogicLabel (None,l2) -> String.compare l1 l2 | LogicLabel (Some s1,l1), LogicLabel (Some s2,l2) -> let cl = String.compare l1 l2 in if cl <> 0 then cl else Stmt.compare s1 s2 | (StmtLabel _ , LogicLabel _ | LogicLabel (None,_),LogicLabel (Some _,_)) -> (-1) | ( LogicLabel _ , StmtLabel _ | LogicLabel (Some _,_),LogicLabel (None,_)) -> 1 and compare_ctor c1 c2 = String.compare c1.ctor_name c2.ctor_name and compare_bound b1 b2 = match b1, b2 with | None , None -> 0 | Some _ , None -> 1 | None , Some _ -> (-1) | Some x , Some y -> compare_term x y exception StopRecursion of int let _hash_const c = match c with CInt64 _ | CStr _ | CWStr _ | CChr _ | CReal _ -> Hashtbl.hash c | CEnum ei -> 95 + Enumitem.hash ei let hash_logic_constant c = match c with Integer _ | LStr _ | LWStr _ | LChr _ | LReal _ -> Hashtbl.hash c | LEnum ei -> 95 + Enumitem.hash ei let hash_label x = match x with StmtLabel r -> 2*(Stmt.hash !r) | LogicLabel(_,l) -> 2*(Hashtbl.hash l) + 1 let rec hash_term (acc,depth,tot) t = if tot <= 0 || depth <= 0 then raise (StopRecursion acc) else begin match t.term_node with | TConst c -> (acc + hash_logic_constant c, tot - 1) | TLval lv -> hash_tlval (acc+19,depth - 1,tot -1) lv | TSizeOf t -> (acc + 38 + Typ.hash t, tot - 1) | TSizeOfE t -> hash_term (acc+57,depth -1, tot-1) t | TSizeOfStr s -> (acc + 76 + Hashtbl.hash s, tot - 1) | TAlignOf t -> (acc + 95 + Typ.hash t, tot - 1) | TAlignOfE t -> hash_term (acc+114,depth-1,tot-1) t | TUnOp(op,t) -> hash_term (acc+133+Hashtbl.hash op,depth-1,tot-2) t | TBinOp(bop,t1,t2) -> let hash1,tot1 = hash_term (acc+152+Hashtbl.hash bop,depth-1,tot-2) t1 in hash_term (hash1,depth-1,tot1) t2 | TCastE(ty,t) -> let hash1 = Typ.hash ty in hash_term (acc+171+hash1,depth-1,tot-2) t | TAddrOf lv -> hash_tlval (acc+190,depth-1,tot-1) lv | TStartOf lv -> hash_tlval (acc+209,depth-1,tot-1) lv | Tapp (li,labs,apps) -> let hash1 = acc + 228 + Logic_info.hash li in let hash_lb (acc,tot) (_,lb) = if tot = 0 then raise (StopRecursion acc) else (acc + hash_label lb,tot - 1) in let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in let res = List.fold_left hash_lb (hash1,tot-1) labs in List.fold_left hash_one_term res apps | Tlambda(quants,t) -> let hash_var (acc,tot) lv = if tot = 0 then raise (StopRecursion acc) else (acc + Logic_var.hash lv,tot-1) in let (acc,tot) = List.fold_left hash_var (acc+247,tot-1) quants in hash_term (acc,depth-1,tot-1) t | TDataCons(ctor,args) -> let hash = acc + 266 + Logic_ctor_info.hash ctor in let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in List.fold_left hash_one_term (hash,tot-1) args | Tif(t1,t2,t3) -> let hash1,tot1 = hash_term (acc+285,depth-1,tot) t1 in let hash2,tot2 = hash_term (hash1,depth-1,tot1) t2 in hash_term (hash2,depth-1,tot2) t3 | Tat(t,l) -> let hash = acc + 304 + hash_label l in hash_term (hash,depth-1,tot-2) t | Tbase_addr (l,t) -> let hash = acc + 323 + hash_label l in hash_term (hash,depth-1,tot-2) t | Tblock_length (l,t) -> let hash = acc + 342 + hash_label l in hash_term (hash,depth-1,tot-2) t | Toffset (l,t) -> let hash = acc + 351 + hash_label l in hash_term (hash,depth-1,tot-2) t | Tnull -> acc+361, tot - 1 | TCoerce(t,ty) -> let hash = Typ.hash ty in hash_term (acc+380+hash,depth-1,tot-2) t | TCoerceE(t1,t2) -> let hash1,tot1 = hash_term (acc+399,depth-1,tot-1) t1 in hash_term (hash1,depth-1,tot1) t2 | TUpdate(t1,off,t2) -> let hash1,tot1 = hash_term (acc+418,depth-1,tot-1) t1 in let hash2,tot2 = hash_toffset (hash1,depth-1,tot1) off in hash_term (hash2,depth-1,tot2) t2 | Ttypeof t -> hash_term (acc+437,depth-1,tot-1) t | Ttype t -> acc + 456 + Typ.hash t, tot - 1 | Tempty_set -> acc + 475, tot - 1 | Tunion tl -> let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in List.fold_left hash_one_term (acc+494,tot-1) tl | Tinter tl -> let hash_one_term (acc,tot) t = hash_term (acc,depth-1,tot) t in List.fold_left hash_one_term (acc+513,tot-1) tl | Tcomprehension (t,quants,_) -> (* TODO: hash predicates *) let hash_var (acc,tot) lv = if tot = 0 then raise (StopRecursion acc) else (acc + Logic_var.hash lv,tot-1) in let (acc,tot) = List.fold_left hash_var (acc+532,tot-1) quants in hash_term (acc,depth-1,tot-1) t | Trange(t1,t2) -> let acc = acc + 551 in let acc,tot = match t1 with None -> acc,tot - 1 | Some t -> hash_term (acc,depth-1,tot-2) t in if tot <= 0 then raise (StopRecursion acc) else (match t2 with None -> acc, tot - 1 | Some t -> hash_term (acc,depth-1,tot-1) t) | Tlet(li,t) -> hash_term (acc + 570 + Hashtbl.hash li.l_var_info.lv_name, depth-1, tot-1) t | TLogic_coerce(_,e) -> hash_term (acc + 587, depth - 1, tot - 1) e end and hash_tlval (acc,depth,tot) (h,o) = if tot <= 0 || depth <= 0 then raise (StopRecursion acc) else begin let hash, tot = hash_tlhost (acc, depth - 1, tot - 1) h in hash_toffset (hash,depth-1,tot) o end and hash_tlhost (acc,depth,tot) t = if tot <=0 || depth <= 0 then raise (StopRecursion acc) else begin match t with | TVar v -> acc + 17 + Logic_var.hash v, tot - 1 | TResult typ -> 31 + 7 * Typ.hash typ, tot - 2 | TMem t -> hash_term (acc + 71, depth - 1, tot - 1) t end and hash_toffset (acc, depth, tot) t = if depth <= 0 || tot <= 0 then raise (StopRecursion acc) else begin match t with | TNoOffset -> acc, tot - 1 | TField(f,o) -> hash_toffset (acc+13+Fieldinfo.hash f, depth -1, tot - 1) o | TModel (mi, o) -> hash_toffset (acc+41+Model_info.hash mi, depth - 1, tot - 1) o | TIndex (t, o) -> let hash, tot = hash_term (acc+73, depth - 1, tot - 1) t in hash_toffset (hash, depth - 1, tot) o end let hash_fct f t = try fst (f (0,10,100) t) with StopRecursion n -> n module Logic_constant = Make_with_collections (struct type t = logic_constant let name = "Logic_constant" let reprs = [LStr "Foo"] let compare = compare_logic_constant let equal = Datatype.from_compare let hash = hash_logic_constant let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname _ = "lconst" end) module Term = struct let pretty_ref = ref (fun _ _ -> assert false) include Make_with_collections (struct type t = term let name = "Term" let reprs = List.map (fun t -> { term_node = TConst (LStr ""); term_loc = Location.unknown; term_type = t; term_name = [] }) Logic_type.reprs let compare = compare_term let equal = Datatype.from_compare let copy = Datatype.undefined let hash = hash_fct hash_term let internal_pretty_code = Datatype.undefined let pretty fmt t = !pretty_ref fmt t let varname _ = "term" end) end module Identified_term = Make_with_collections (struct type t = identified_term let name = "Identified_term" let reprs = List.map (fun t -> { it_id = -1; it_content = t}) Term.reprs let compare x y = Extlib.compare_basic x.it_id y.it_id let equal x y = x.it_id = y.it_id let copy x = (* NB: Term.copy itself is undefined. *) { it_id = x.it_id; it_content = Term.copy x.it_content } let hash x = x.it_id let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname _ = "id_term" end) module Term_lhost = Make_with_collections (struct type t = term_lhost let name = "Term_lhost" let reprs = List.fold_left (fun acc ty -> List.fold_left (fun acc t -> TMem t :: acc) (TResult ty :: acc) Term.reprs) (List.map (fun lv -> TVar lv) Logic_var.reprs) Typ.reprs let compare = compare_tlhost let equal = Datatype.from_compare let hash = hash_fct hash_tlhost let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname = Datatype.undefined end) module Term_offset = Make_with_collections (struct type t = term_offset let name = "Term_offset" let reprs = [ TNoOffset ] let compare = compare_toffset let equal = Datatype.from_compare let hash = hash_fct hash_toffset let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname = Datatype.undefined end) module Term_lval = Datatype.Pair_with_collections (Term_lhost) (Term_offset) (struct let module_name = "Cil_datatype.Term_lval" end) module Logic_label = Make_with_collections (struct type t = logic_label let name = "Logic_label" let reprs = (LogicLabel (None,"Pre")) :: List.map (fun x -> StmtLabel (ref x)) Stmt.reprs let compare = compare_logic_label let equal = Datatype.from_compare let copy = Datatype.undefined let hash = hash_label let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname _ = "logic_label" end) module Global_annotation = struct include Make_with_collections (struct type t = global_annotation let name = "Global_annotation" let reprs = List.map (fun l -> Daxiomatic ("", [], l)) Location.reprs let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname = Datatype.undefined let rec compare g1 g2 = match g1,g2 with | Dfun_or_pred (l1,_), Dfun_or_pred(l2,_) -> Logic_info.compare l1 l2 | Dfun_or_pred _,_ -> -1 | _, Dfun_or_pred _ -> 1 | Dvolatile (it1,_,_,_), Dvolatile(it2,_,_,_) -> compare_list Identified_term.compare it1 it2 | Dvolatile _,_ -> -1 | _,Dvolatile _ -> 1 | Daxiomatic (_,g1,_), Daxiomatic (_,g2,_) -> (* ACSL does not require the name to be unique. *) compare_list compare g1 g2 | Daxiomatic _, _ -> -1 | _, Daxiomatic _ -> 1 | Dtype(t1,_), Dtype(t2,_) -> Logic_type_info.compare t1 t2 | Dtype _, _ -> -1 | _, Dtype _ -> 1 | Dlemma (l1,_,_,_,_,_), Dlemma(l2,_,_,_,_,_) -> Datatype.String.compare l1 l2 | Dlemma _, _ -> -1 | _, Dlemma _ -> 1 | Dinvariant (l1,_), Dinvariant (l2,_) -> Logic_info.compare l1 l2 | Dinvariant _, _ -> -1 | _, Dinvariant _ -> 1 | Dtype_annot(l1, _), Dtype_annot (l2, _) -> Logic_info.compare l1 l2 | Dtype_annot _, _ -> -1 | _, Dtype_annot _ -> 1 | Dmodel_annot(l1,_), Dmodel_annot(l2,_) -> Model_info.compare l1 l2 | Dmodel_annot _, _ -> -1 | _, Dmodel_annot _ -> 1 | Dcustom_annot(_, n1, _), Dcustom_annot(_, n2, _) -> Datatype.String.compare n1 n2 let equal = Datatype.from_compare let rec hash g = match g with | Dfun_or_pred (l,_) -> 2 * Logic_info.hash l | Dvolatile ([],_,_,(source,_)) -> Kernel.fatal ~source "Empty location list for volatile annotation" | Dvolatile (t::_,_,_,_) -> 3 * Identified_term.hash t | Daxiomatic (_,[],_) -> 5 (* Empty axiomatic is weird but authorized. *) | Daxiomatic (_,g::_,_) -> 5 * hash g | Dtype (t,_) -> 7 * Logic_type_info.hash t | Dlemma(n,_,_,_,_,_) -> 11 * Datatype.String.hash n | Dinvariant(l,_) -> 13 * Logic_info.hash l | Dtype_annot(l,_) -> 17 * Logic_info.hash l | Dmodel_annot(l,_) -> 19 * Model_info.hash l | Dcustom_annot(_,n,_) -> 23 * Datatype.String.hash n let copy = Datatype.undefined end) let loc = function | Dfun_or_pred(_, loc) | Daxiomatic(_, _, loc) | Dtype (_, loc) | Dlemma(_, _, _, _, _, loc) | Dinvariant(_, loc) | Dtype_annot(_, loc) -> loc | Dmodel_annot(_, loc) -> loc | Dvolatile(_, _, _, loc) -> loc | Dcustom_annot(_,_,loc) -> loc end module Global = struct include Make_with_collections (struct type t = global let name = "Global" let reprs = [ GText "" ] let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname = Datatype.undefined let compare g1 g2 = match g1, g2 with | GType (t1,_), GType (t2,_) -> Typeinfo.compare t1 t2 | GType _,_ -> -1 | _, GType _ -> 1 | GCompTag (t1,_), GCompTag(t2,_) -> Compinfo.compare t1 t2 | GCompTag _,_ -> -1 | _, GCompTag _ -> 1 | GCompTagDecl (t1,_), GCompTagDecl(t2,_) -> Compinfo.compare t1 t2 | GCompTagDecl _,_ -> -1 | _,GCompTagDecl _ -> 1 | GEnumTag(t1,_), GEnumTag(t2,_) -> Enuminfo.compare t1 t2 | GEnumTag _,_ -> -1 | _, GEnumTag _ -> 1 | GEnumTagDecl(t1,_), GEnumTagDecl(t2,_) -> Enuminfo.compare t1 t2 | GEnumTagDecl _, _ -> -1 | _, GEnumTagDecl _ -> 1 | GVarDecl (_,v1,_), GVarDecl(_,v2,_) -> Varinfo.compare v1 v2 | GVarDecl _,_ -> -1 | _,GVarDecl _ -> 1 | GVar (v1,_,_), GVar (v2,_,_) -> Varinfo.compare v1 v2 | GVar _,_ -> -1 | _, GVar _ -> 1 | GFun(f1,_), GFun(f2,_) -> Varinfo.compare f1.svar f2.svar | GFun _, _ -> -1 | _, GFun _ -> 1 | GAsm (_,l1), GAsm(_,l2) -> Location.compare l1 l2 | GAsm _, _ -> -1 | _, GAsm _ -> 1 | GPragma(_,l1), GPragma(_,l2) -> Location.compare l1 l2 | GPragma _, _ -> -1 | _, GPragma _ -> 1 | GText s1, GText s2 -> Datatype.String.compare s1 s2 | GText _, _ -> -1 | _, GText _ -> 1 | GAnnot (g1,_), GAnnot(g2,_) -> Global_annotation.compare g1 g2 let equal = Datatype.from_compare let hash g = match g with GType (t,_) -> 2 * Typeinfo.hash t | GCompTag (t,_) -> 3 * Compinfo.hash t | GCompTagDecl (t,_) -> 5 * Compinfo.hash t | GEnumTag (t,_) -> 7 * Enuminfo.hash t | GEnumTagDecl(t,_) -> 11 * Enuminfo.hash t | GVarDecl (_,v,_) -> 13 * Varinfo.hash v | GVar (v,_,_) -> 17 * Varinfo.hash v | GFun (f,_) -> 19 * Varinfo.hash f.svar | GAsm (_,l) -> 23 * Location.hash l | GText t -> 29 * Datatype.String.hash t | GAnnot (g,_) -> 31 * Global_annotation.hash g | GPragma(_,l) -> 37 * Location.hash l let copy = Datatype.undefined end) let loc = function | GFun(_, l) | GType(_, l) | GEnumTag(_, l) | GEnumTagDecl(_, l) | GCompTag(_, l) | GCompTagDecl(_, l) | GVarDecl(_, _, l) | GVar(_, _, l) | GAsm(_, l) | GPragma(_, l) | GAnnot (_, l) -> l | GText _ -> Location.unknown end module Kf = struct let vi kf = match kf.fundec with | Definition (d, _) -> d.svar | Declaration (_,vi,_, _) -> vi let id kf = (vi kf).vid let set_formal_decls = ref (fun _ _ -> assert false) include Datatype.Make_with_collections (struct type t = kernel_function let name = "Cil_datatype.Kf" let structural_descr = Structural_descr.Abstract let reprs = let empty_spec = { spec_behavior = []; spec_variant = None; spec_terminates = None; spec_complete_behaviors = []; spec_disjoint_behaviors = [] } in List.fold_left (fun acc loc -> List.fold_left (fun acc b -> List.fold_left (fun acc vi -> { fundec = Definition ({ svar = vi; smaxid = 0; slocals = []; sformals = []; sbody = b; smaxstmtid = None; sallstmts = []; sspec = empty_spec }, loc); return_stmt = None; spec = empty_spec } :: acc) acc Varinfo.reprs) acc Block.reprs) [] Location.reprs let compare k1 k2 = Datatype.Int.compare (id k1) (id k2) let equal k1 k2 = if k1 != k2 then (assert (Kernel.verify ((id k1) <> (id k2)) "Two kf for %a and %a (%d)" Varinfo.pretty (vi k1) Varinfo.pretty (vi k2) (id k1)); false) else true let hash = id let copy = Datatype.undefined let rehash x = match x.fundec with | Definition _ | Declaration (_, _, None, _)-> x | Declaration (_, v, Some args, _) -> !set_formal_decls v args; x let get_name_kf kf = (vi kf).Cil_types.vname let internal_pretty_code p_caller fmt kf = Type.par p_caller Type.Call fmt (fun fmt -> Format.fprintf fmt "@[Globals.Functions.find_by_name@;%S@]" (get_name_kf kf)) let pretty fmt kf = Varinfo.pretty fmt (vi kf) let mem_project = Datatype.never_any_project let varname kf = "kf_" ^ (get_name_kf kf) end) let () = Type.set_ml_name ty (Some "Kernel_function.ty") end module Code_annotation = struct let pretty_ref = ref (fun _ _ -> assert false) include Make_with_collections (struct type t = code_annotation let name = "Code_annotation" let reprs = [ { annot_content = AAssigns([],WritesAny); annot_id = -1 } ] let hash x = x.annot_id let equal x y = x.annot_id = y.annot_id let compare x y = Datatype.Int.compare x.annot_id y.annot_id let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty fmt ca = !pretty_ref fmt ca let varname _ = "code_annot" end) let loc ca = match ca.annot_content with | AAssert(_,{loc=loc}) | AInvariant(_,_,{loc=loc}) | AVariant({term_loc=loc},_) -> Some loc | AAssigns _ | AAllocation _ | APragma _ | AStmtSpec _ -> None end module Funspec = Datatype.Make (struct include Datatype.Serializable_undefined type t = funspec let name = "funspec" let reprs = [ { spec_behavior = []; spec_variant = None; spec_terminates = None; spec_complete_behaviors = []; spec_disjoint_behaviors = [] } ] let mem_project = Datatype.never_any_project end) module Fundec = struct let make_dummy vi fs = { svar = vi; sformals = []; slocals = []; smaxid = 0; sbody = { battrs = [] ; blocals = []; bstmts = [] }; smaxstmtid = None; sallstmts = []; sspec = fs ; } let reprs = List.fold_left (fun list vi -> List.fold_left (fun list fs -> ((make_dummy vi fs)::list)) list Funspec.reprs) [] Varinfo.reprs;; include Datatype.Make_with_collections (struct type t = fundec let name = "fundec" let varname v = "fd_" ^ v.svar.vorig_name let reprs = reprs let structural_descr = Structural_descr.Abstract let compare v1 v2 = Datatype.Int.compare v1.svar.vid v2.svar.vid let hash v = v.svar.vid let equal v1 v2 = v1.svar.vid = v2.svar.vid let rehash = Datatype.identity let copy = Datatype.undefined let pretty = Datatype.undefined let internal_pretty_code = Datatype.undefined let mem_project = Datatype.never_any_project end) end module Predicate_named = Make (struct type t = predicate named let name = "predicate_named" let reprs = [ { name = [ "" ]; loc = Location.unknown; content = Pfalse } ] let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname _ = "p" end) (**************************************************************************) (** {3 Logic_ptree} Sorted by alphabetic order. *) (**************************************************************************) module Lexpr = Make (struct open Logic_ptree type t = lexpr let name = "Lexpr" let reprs = [ { lexpr_node = PLvar ""; lexpr_loc = Location.unknown } ] let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname = Datatype.undefined end) (**************************************************************************) (** {3 Other types} *) (**************************************************************************) module Localisation = Datatype.Make (struct include Datatype.Serializable_undefined type t = localisation let name = "Localisation" let reprs = [ VGlobal ] let internal_pretty_code p_caller fmt loc = let pp s kf = Type.par p_caller Type.Call fmt (fun fmt -> Format.fprintf fmt "@[%s@;%a@]" s (Kf.internal_pretty_code Type.Call) kf) in match loc with | VGlobal -> Format.fprintf fmt "Cil_types.VGlobal" | VLocal kf -> pp "Cil_types.VLocal" kf | VFormal kf -> pp "Cil_types.VFormal" kf let mem_project = Datatype.never_any_project end) (* -------------------------------------------------------------------------- *) (* --- Internal --- *) (* -------------------------------------------------------------------------- *) let clear_caches () = List.iter (fun f -> f ()) !clear_caches (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/cil/src/rmtmps.mli0000644000175000017500000001306512155630367017375 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* rmtmps.mli *) (* remove unused things from cil files: *) (* - local temporaries introduced but not used *) (* - global declarations that are not used *) (* - types that are not used *) (* - labels that are not used (gn) *) (* Some clients may wish to augment or replace the standard strategy * for finding the initially reachable roots. The optional * "isRoot" argument to Rmtmps.removeUnusedTemps grants this * flexibility. If given, it should name a function which will return * true if a given global should be treated as a retained root. * * Function Rmtmps.isDefaultRoot encapsulates the default root * collection, which consists of those global variables and functions * which are visible to the linker and runtime loader. A client's * root filter can use this if the goal is to augment rather than * replace the standard logic. Function Rmtmps.isExportedRoot is an * alternate name for this same function. * * Function Rmtmps.isCompleteProgramRoot is an example of an alternate * root collection. This function assumes that it is operating on a * complete program rather than just one object file. It treats * "main()" as a root, as well as any function carrying the * "constructor" or "destructor" attribute. All other globals are * candidates for removal, regardless of their linkage. * * Note that certain CIL- and CCured-specific pragmas induce * additional global roots. This functionality is always present, and * is not subject to replacement by "filterRoots". *) type rootsFilter = Cil_types.global -> bool val isDefaultRoot : rootsFilter val isExportedRoot : rootsFilter val isCompleteProgramRoot : rootsFilter (* process a complete Cil file *) val removeUnusedTemps: ?isRoot:rootsFilter -> Cil_types.file -> unit (** removes unused labels for which [is_removable] is true. [is_removable] defaults to the negation of boolean flag of [Label] {i i.e.} only labels generated by CIL may be removed. @since Carbon-20101201 *) val remove_unused_labels: ?is_removable:(Cil_types.label -> bool) -> Cil_types.fundec -> unit val keepUnused: bool ref (* Set this to true to turn off this module *) val rmUnusedInlines: bool ref (* Delete unused inline funcs in gcc mode? *) val rmUnusedStatic: bool ref (* Delete unused static functions? *) frama-c-Fluorine-20130601/cil/src/frontc/0000755000175000017500000000000012155634040016626 5ustar mehdimehdiframa-c-Fluorine-20130601/cil/src/frontc/clexer.mll0000644000175000017500000007106212155630365020632 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* FrontC -- lexical analyzer ** ** 1.0 3.22.99 Hugues Cass First version. ** 2.0 George Necula 12/12/00: Many extensions *) { open Cparser exception InternalError of string module H = Hashtbl module E = Errorloc let matchingParsOpen = ref 0 let currentLoc () = Cabshelper.currentLoc () let one_line_ghost = ref false let is_oneline_ghost () = !one_line_ghost let enter_oneline_ghost () = one_line_ghost := true let exit_oneline_ghost () = one_line_ghost := false let ghost_code = ref false let is_ghost_code () = !ghost_code let enter_ghost_code () = ghost_code := true let exit_ghost_code () = ghost_code := false let addComment c = Cabshelper.Comments.add (currentLoc()) c (* Some debugging support for line numbers *) let dbgToken (t: token) = if false then begin let dprintf fmt = Kernel.debug fmt in (match t with IDENT n -> dprintf "IDENT(%s)\n" n | LBRACE l -> dprintf "LBRACE(%d)\n" (fst l).Lexing.pos_lnum | RBRACE l -> dprintf "RBRACE(%d)\n" (fst l).Lexing.pos_lnum | IF l -> dprintf "IF(%d)\n" (fst l).Lexing.pos_lnum | SWITCH l -> dprintf "SWITCH(%d)\n" (fst l).Lexing.pos_lnum | RETURN l -> dprintf "RETURN(%d)\n" (fst l).Lexing.pos_lnum | _ -> ()) ; t end else t (* ** Keyword hashtable *) let lexicon = H.create 211 let init_lexicon _ = H.clear lexicon; Logic_env.reset_typenames (); Logic_env.builtin_types_as_typenames (); List.iter (fun (key, builder) -> H.add lexicon key builder) [ ("auto", fun loc -> AUTO loc); ("const", fun loc -> CONST loc); ("__const", fun loc -> CONST loc); ("__const__", fun loc -> CONST loc); ("static", fun loc -> STATIC loc); ("extern", fun loc -> EXTERN loc); ("long", fun loc -> LONG loc); ("short", fun loc -> SHORT loc); ("register", fun loc -> REGISTER loc); ("signed", fun loc -> SIGNED loc); ("__signed", fun loc -> SIGNED loc); ("unsigned", fun loc -> UNSIGNED loc); ("volatile", fun loc -> VOLATILE loc); ("__volatile", fun loc -> VOLATILE loc); (* WW: see /usr/include/sys/cdefs.h for why __signed and __volatile * are accepted GCC-isms *) ("char", fun loc -> CHAR loc); ("_Bool", fun loc -> BOOL loc); ("int", fun loc -> INT loc); ("float", fun loc -> FLOAT loc); ("double", fun loc -> DOUBLE loc); ("void", fun loc -> VOID loc); ("enum", fun loc -> ENUM loc); ("struct", fun loc -> STRUCT loc); ("typedef", fun loc -> TYPEDEF loc); ("union", fun loc -> UNION loc); ("break", fun loc -> BREAK loc); ("continue", fun loc -> CONTINUE loc); ("goto", fun loc -> GOTO loc); ("return", fun loc -> dbgToken (RETURN loc)); ("switch", fun loc -> dbgToken (SWITCH loc)); ("case", fun loc -> CASE loc); ("default", fun loc -> DEFAULT loc); ("while", fun loc -> WHILE loc); ("do", fun loc -> DO loc); ("for", fun loc -> FOR loc); ("if", fun loc -> dbgToken (IF loc)); ("else", fun _ -> ELSE); (*** Implementation specific keywords ***) ("__signed__", fun loc -> SIGNED loc); ("__inline__", fun loc -> INLINE loc); ("inline", fun loc -> INLINE loc); ("__inline", fun loc -> INLINE loc); ("_inline", fun loc -> if !Cprint.msvcMode then INLINE loc else IDENT ("_inline")); ("__attribute__", fun loc -> ATTRIBUTE loc); ("__attribute", fun loc -> ATTRIBUTE loc); (* ("__attribute_used__", fun loc -> ATTRIBUTE_USED loc); *) ("__blockattribute__", fun _ -> BLOCKATTRIBUTE); ("__blockattribute", fun _ -> BLOCKATTRIBUTE); ("__asm__", fun loc -> ASM loc); ("asm", fun loc -> ASM loc); ("__typeof__", fun loc -> TYPEOF loc); ("__typeof", fun loc -> TYPEOF loc); ("typeof", fun loc -> TYPEOF loc); ("__alignof", fun loc -> ALIGNOF loc); ("__alignof__", fun loc -> ALIGNOF loc); ("__volatile__", fun loc -> VOLATILE loc); ("__volatile", fun loc -> VOLATILE loc); ("__FUNCTION__", fun loc -> FUNCTION__ loc); ("__func__", fun loc -> FUNCTION__ loc); (* ISO 6.4.2.2 *) ("__PRETTY_FUNCTION__", fun loc -> PRETTY_FUNCTION__ loc); ("__label__", fun _ -> LABEL__); (*** weimer: GCC arcana ***) ("__restrict", fun loc -> RESTRICT loc); ("restrict", fun loc -> RESTRICT loc); (* ("__extension__", EXTENSION); *) (**** MS VC ***) ("__int64", fun _ -> INT64 (currentLoc ())); ("__int32", fun loc -> INT loc); ("_cdecl", fun _ -> MSATTR ("_cdecl", currentLoc ())); ("__cdecl", fun _ -> MSATTR ("__cdecl", currentLoc ())); ("_stdcall", fun _ -> MSATTR ("_stdcall", currentLoc ())); ("__stdcall", fun _ -> MSATTR ("__stdcall", currentLoc ())); ("_fastcall", fun _ -> MSATTR ("_fastcall", currentLoc ())); ("__fastcall", fun _ -> MSATTR ("__fastcall", currentLoc ())); ("__w64", fun _ -> MSATTR("__w64", currentLoc ())); ("__declspec", fun loc -> DECLSPEC loc); ("__forceinline", fun loc -> INLINE loc); (* !! we turn forceinline * into inline *) ("__try", fun loc -> TRY loc); ("__except", fun loc -> EXCEPT loc); ("__finally", fun loc -> FINALLY loc); (* weimer: some files produced by 'GCC -E' expect this type to be * defined *) ("__builtin_va_list", fun _ -> NAMED_TYPE "__builtin_va_list"); ("__builtin_va_arg", fun loc -> BUILTIN_VA_ARG loc); ("__builtin_types_compatible_p", fun loc -> BUILTIN_TYPES_COMPAT loc); ("__builtin_offsetof", fun loc -> BUILTIN_OFFSETOF loc); (* On some versions of GCC __thread is a regular identifier *) ("__thread", (fun loc -> if Cil.theMachine.Cil.theMachine.Cil_types.__thread_is_keyword then THREAD loc else IDENT "__thread")); ] let is_c_keyword s = Hashtbl.mem lexicon s (* Mark an identifier as a type name. The old mapping is preserved and will * be reinstated when we exit this context *) let add_type name = (* ignore (print_string ("adding type name " ^ name ^ "\n")); *) H.add lexicon name (fun _ -> NAMED_TYPE name); Logic_env.add_typename name let context : string list list ref = ref [ [] ] let push_context _ = context := []::!context let pop_context _ = match !context with [] -> Kernel.fatal "Empty context stack" | con::sub -> (context := sub; List.iter (fun name -> (* Format.eprintf "removing lexicon for %s@." name; *) H.remove lexicon name; Logic_env.remove_typename name ) con) (* Mark an identifier as a variable name. The old mapping is preserved and * will be reinstated when we exit this context *) let add_identifier name = match !context with [] -> Kernel.fatal "Empty context stack" | con::sub -> (context := (name::con)::sub; (*Format.eprintf "adding IDENT for %s@." name;*) H.add lexicon name (fun _ -> dbgToken (IDENT name)); Logic_env.hide_typename name ) (* ** Useful primitives *) let scan_ident id = let here = currentLoc () in try (H.find lexicon id) here (* default to variable name, as opposed to type *) with Not_found -> dbgToken (IDENT id) (* ** Buffer processor *) let init ~(filename: string) : Lexing.lexbuf = init_lexicon (); (* Inititialize the pointer in Errormsg *) Lexerhack.add_type := add_type; Lexerhack.push_context := push_context; Lexerhack.pop_context := pop_context; Lexerhack.add_identifier := add_identifier; E.startParsing ~useBasename:false filename let finish () = E.finishParsing () (*** Error handling ***) let error msg = E.parse_error msg (*** escape character management ***) let scan_escape (char: char) : int64 = let result = match char with 'n' -> '\n' | 'r' -> '\r' | 't' -> '\t' | 'b' -> '\b' | 'f' -> '\012' (* ASCII code 12 *) | 'v' -> '\011' (* ASCII code 11 *) | 'a' -> '\007' (* ASCII code 7 *) | 'e' | 'E' -> '\027' (* ASCII code 27. This is a GCC extension *) | '\'' -> '\'' | '"'-> '"' (* '"' *) | '?' -> '?' | '(' when not !Cprint.msvcMode -> '(' | '{' when not !Cprint.msvcMode -> '{' | '[' when not !Cprint.msvcMode -> '[' | '%' when not !Cprint.msvcMode -> '%' | '\\' -> '\\' | other -> error ("Unrecognized escape sequence: \\" ^ (String.make 1 other)) in Int64.of_int (Char.code result) let scan_hex_escape str = let radix = Int64.of_int 16 in let the_value = ref Int64.zero in (* start at character 2 to skip the \x *) for i = 2 to (String.length str) - 1 do let thisDigit = Cabshelper.valueOfDigit (String.get str i) in (* the_value := !the_value * 16 + thisDigit *) the_value := Int64.add (Int64.mul !the_value radix) thisDigit done; !the_value let scan_oct_escape str = let radix = Int64.of_int 8 in let the_value = ref Int64.zero in (* start at character 1 to skip the \x *) for i = 1 to (String.length str) - 1 do let thisDigit = Cabshelper.valueOfDigit (String.get str i) in (* the_value := !the_value * 8 + thisDigit *) the_value := Int64.add (Int64.mul !the_value radix) thisDigit done; !the_value let lex_hex_escape remainder lexbuf = let prefix = scan_hex_escape (Lexing.lexeme lexbuf) in prefix :: remainder lexbuf let lex_oct_escape remainder lexbuf = let prefix = scan_oct_escape (Lexing.lexeme lexbuf) in prefix :: remainder lexbuf let lex_simple_escape remainder lexbuf = let lexchar = Lexing.lexeme_char lexbuf 1 in let prefix = scan_escape lexchar in prefix :: remainder lexbuf let lex_unescaped remainder lexbuf = let prefix = Int64.of_int (Char.code (Lexing.lexeme_char lexbuf 0)) in prefix :: remainder lexbuf let lex_comment remainder buffer lexbuf = let ch = Lexing.lexeme_char lexbuf 0 in if ch = '\n' then E.newline() ; (match buffer with None -> () | Some b -> Buffer.add_char b ch) ; remainder buffer lexbuf let do_lex_comment ?first_char remainder lexbuf = let buffer = if Kernel.PrintComments.get () then Some(let b = Buffer.create 80 in (match first_char with Some c -> Buffer.add_char b c | None -> ()); b) else None in remainder buffer lexbuf ; match buffer with | Some b -> addComment (Buffer.contents b) | None -> () (* ISO standard locale-specific function to convert a wide character * into a sequence of normal characters. Here we work on strings. * We convert L"Hi" to "H\000i\000" matth: this seems unused. let wbtowc wstr = let len = String.length wstr in let dest = String.make (len * 2) '\000' in for i = 0 to len-1 do dest.[i*2] <- wstr.[i] ; done ; dest *) (* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' } matth: this seems unused. let wstr_to_warray wstr = let len = String.length wstr in let res = ref "{ " in for i = 0 to len-1 do res := !res ^ (Printf.sprintf "L'%c', " wstr.[i]) done ; res := !res ^ "}" ; !res *) (* Pragmas get explicit end-of-line tokens. * Elsewhere they are silently discarded as whitespace. *) let pragmaLine = ref false let annot_char = ref '@' let () = Kernel.ReadAnnot.add_set_hook (fun _ x -> (* prevent the C lexer interpretation of comments *) annot_char := if x then '@' else '\000') let annot_start_pos = ref Cabshelper.cabslu let buf = Buffer.create 1024 let save_current_pos () = annot_start_pos := currentLoc () let make_annot ~one_line lexbuf s = let start = snd !annot_start_pos in let stop, token = Logic_lexer.annot (start, s) in lexbuf.Lexing.lex_curr_p <- stop; (* The filename has already been normalized, so we must reuse it "as is". *) E.setCurrentFile ~normalize:false stop.Lexing.pos_fname; E.setCurrentLine stop.Lexing.pos_lnum; if one_line then E.newline (); match token with | Logic_ptree.Adecl d -> DECL d | Logic_ptree.Aspec -> SPEC (start,s) (* At this point, we only have identified a function spec. Complete parsing of the annotation will only occur in the cparser.mly rule. *) | Logic_ptree.Acode_annot (loc,a) -> CODE_ANNOT (a, loc) | Logic_ptree.Aloop_annot (loc,a) -> LOOP_ANNOT (a,loc) | Logic_ptree.Aattribute_annot (loc,a) -> ATTRIBUTE_ANNOT (a, loc) | Logic_ptree.Acustom(loc,id, a) -> CUSTOM_ANNOT(a, id, loc) } let decdigit = ['0'-'9'] let octdigit = ['0'-'7'] let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F'] let letter = ['a'- 'z' 'A'-'Z'] let usuffix = ['u' 'U'] let lsuffix = "l"|"L"|"ll"|"LL" let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix | usuffix ? "i64" let hexprefix = '0' ['x' 'X'] let intnum = decdigit+ intsuffix? let octnum = '0' octdigit+ intsuffix? let hexnum = hexprefix hexdigit+ intsuffix? let exponent = ['e' 'E']['+' '-']? decdigit+ let fraction = '.' decdigit+ let decfloat = (intnum? fraction) |(intnum exponent) |(intnum? fraction exponent) | (intnum '.') | (intnum '.' exponent) let hexfraction = hexdigit* '.' hexdigit+ | hexdigit+ '.' let binexponent = ['p' 'P'] ['+' '-']? decdigit+ let hexfloat = hexprefix hexfraction binexponent | hexprefix hexdigit+ binexponent let floatsuffix = ['f' 'F' 'l' 'L'] let floatnum = (decfloat | hexfloat) floatsuffix? let ident = (letter|'_')(letter|decdigit|'_'|'$')* let blank = [' ' '\t' '\012' '\r' '\026'(*this is the plain old DOS eof char*)]+ let escape = '\\' _ let hex_escape = '\\' ['x' 'X'] hexdigit+ let oct_escape = '\\' octdigit octdigit? octdigit? (* Pragmas that are not parsed by CIL. We lex them as PRAGMA_LINE tokens *) let no_parse_pragma = "warning" | "GCC" (* Solaris-style pragmas: *) | "ident" | "section" | "option" | "asm" | "use_section" | "weak" | "redefine_extname" | "TCS_align" (* Embedded world *) | "global_register" | "location" rule initial = parse "/*" { do_lex_comment comment lexbuf ; initial lexbuf } | "/*" ([^ '*' '\n'] as c) { if c = !annot_char then begin Cabshelper.continue_annot (currentLoc ()) (fun () -> save_current_pos (); Buffer.clear buf; annot_first_token lexbuf) (fun () -> initial lexbuf) "Skipping annotation" end else begin do_lex_comment ~first_char:c comment lexbuf ; initial lexbuf end } | "//" { do_lex_comment onelinecomment lexbuf ; E.newline(); if is_oneline_ghost () then begin exit_oneline_ghost (); RGHOST end else begin initial lexbuf end } | "//" ([^ '\n'] as c) { if c = !annot_char then begin Cabshelper.continue_annot (currentLoc()) (fun () -> save_current_pos (); Buffer.clear buf; annot_one_line lexbuf) (fun () -> initial lexbuf) "Skipping annotation" end else begin do_lex_comment ~first_char:c onelinecomment lexbuf ; E.newline(); if is_oneline_ghost () then begin exit_oneline_ghost (); RGHOST end else begin initial lexbuf end end } | blank {initial lexbuf} | '\n' { E.newline (); if !pragmaLine then begin pragmaLine := false; PRAGMA_EOL end else if is_oneline_ghost () then begin exit_oneline_ghost (); RGHOST end else begin initial lexbuf end } | '\\' '\r' * '\n' { E.newline (); initial lexbuf } | '#' { hash lexbuf} | "_Pragma" { PRAGMA (currentLoc ()) } | '\'' { CST_CHAR (chr lexbuf, currentLoc ())} | "L'" { CST_WCHAR (chr lexbuf, currentLoc ()) } | '"' { (* matth: BUG: this could be either a regular string or a wide string. * e.g. if it's the "world" in * L"Hello, " "world" * then it should be treated as wide even though there's no L immediately * preceding it. See test/small1/wchar5.c for a failure case. *) try CST_STRING (str lexbuf, currentLoc ()) with e -> raise (InternalError ("str: " ^ Printexc.to_string e))} | "L\"" { (* weimer: wchar_t string literal *) try CST_WSTRING(str lexbuf, currentLoc ()) with e -> raise (InternalError ("wide string: " ^ Printexc.to_string e))} | floatnum {CST_FLOAT (Lexing.lexeme lexbuf, currentLoc ())} | hexnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} | octnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} | intnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} | "!quit!" {EOF} | "..." {ELLIPSIS} | "+=" {PLUS_EQ} | "-=" {MINUS_EQ} | "*=" {STAR_EQ} | "/=" {SLASH_EQ} | "%=" {PERCENT_EQ} | "|=" {PIPE_EQ} | "&=" {AND_EQ} | "^=" {CIRC_EQ} | "<<=" {INF_INF_EQ} | ">>=" {SUP_SUP_EQ} | "<<" {INF_INF} | ">>" {SUP_SUP} | "==" {EQ_EQ} | "!=" {EXCLAM_EQ} | "<=" {INF_EQ} | ">=" {SUP_EQ} | "=" {EQ} | "<" {INF} | ">" {SUP} | "++" {PLUS_PLUS (currentLoc ())} | "--" {MINUS_MINUS (currentLoc ())} | "->" {ARROW} | '+' {PLUS (currentLoc ())} | '-' {MINUS (currentLoc ())} | '*' { if is_ghost_code () then might_end_ghost lexbuf else STAR (currentLoc ())} | '/' {SLASH} | '%' {PERCENT} | '!' {EXCLAM (currentLoc ())} | "&&" {AND_AND (currentLoc ())} | "||" {PIPE_PIPE} | '&' {AND (currentLoc ())} | '|' {PIPE} | '^' {CIRC} | '?' {QUEST} | ':' {COLON} | '~' {TILDE (currentLoc ())} | '{' {dbgToken (LBRACE (currentLoc ()))} | '}' {dbgToken (RBRACE (currentLoc ()))} | '[' {LBRACKET} | ']' {RBRACKET} | '(' {dbgToken (LPAREN (currentLoc ())) } | ')' {RPAREN} | ';' {dbgToken (SEMICOLON (currentLoc ())) } | ',' {COMMA} | '.' {DOT} | "sizeof" {SIZEOF (currentLoc ())} | "__asm" { if !Cprint.msvcMode then MSASM (msasm lexbuf, currentLoc ()) else (ASM (currentLoc ())) } (* If we see __pragma we eat it and the matching parentheses as well *) | "__pragma" { matchingParsOpen := 0; let _ = matchingpars lexbuf in initial lexbuf } (* __extension__ is a black. The parser runs into some conflicts if we let it * pass *) | "__extension__" {initial lexbuf } | ident {scan_ident (Lexing.lexeme lexbuf)} | eof { if is_oneline_ghost() then begin exit_oneline_ghost (); RGHOST end else EOF } | _ {E.parse_error "Invalid symbol"} and might_end_ghost = parse | '/' { exit_ghost_code(); RGHOST } | "" { STAR (currentLoc()) } and comment buffer = parse | "*/" { } | eof { E.parse_error "Unterminated C comment" } | _ { lex_comment comment buffer lexbuf } and onelinecomment buffer = parse | '\n'|eof { } | _ { lex_comment onelinecomment buffer lexbuf } and matchingpars = parse '\n' { E.newline (); matchingpars lexbuf } | blank { matchingpars lexbuf } | '(' { incr matchingParsOpen; matchingpars lexbuf } | ')' { decr matchingParsOpen; if !matchingParsOpen = 0 then () else matchingpars lexbuf } | "/*" { do_lex_comment comment lexbuf ; matchingpars lexbuf } | '"' { let _ = str lexbuf in matchingpars lexbuf } | _ { matchingpars lexbuf } (* # ... *) and hash = parse '\n' { E.newline (); initial lexbuf} | blank { hash lexbuf} | intnum { (* We are seeing a line number. This is the number for the * next line *) let s = Lexing.lexeme lexbuf in let lineno = try int_of_string s with Failure ("int_of_string") -> (* the int is too big. *) Kernel.warning "Bad line number in preprocessed file: %s" s; (-1) in E.setCurrentLine (lineno - 1); (* A file name may follow *) file lexbuf } | "line" { hash lexbuf } (* MSVC line number info *) (* For pragmas with irregular syntax, like #pragma warning, * we parse them as a whole line. *) | "pragma" blank (no_parse_pragma as pragmaName) { let here = currentLoc () in PRAGMA_LINE (pragmaName ^ pragma lexbuf, here) } | "pragma" { pragmaLine := true; PRAGMA (currentLoc ()) } | _ { endline lexbuf} and file = parse '\n' {E.newline (); initial lexbuf} | blank {file lexbuf} (* The //-ending file directive is a GCC extension that provides the CWD of the preprocessor when the file was preprocessed. *) | '"' [^ '\012' '\t' '"']* '/' '/' '"' { let n = Lexing.lexeme lexbuf in let n1 = String.sub n 1 ((String.length n) - 4) in E.setCurrentWorkingDirectory n1; endline lexbuf } | '"' [^ '\012' '\t' '"']* '"' { (* '"' *) let n = Lexing.lexeme lexbuf in let n1 = String.sub n 1 ((String.length n) - 2) in E.setCurrentFile n1; endline lexbuf} | _ {endline lexbuf} and endline = parse '\n' { E.newline (); initial lexbuf} | eof { EOF } | _ { endline lexbuf} and pragma = parse '\n' { E.newline (); "" } | _ { let cur = Lexing.lexeme lexbuf in cur ^ (pragma lexbuf) } and str = parse '"' {[]} (* no nul terminiation in CST_STRING '"' *) | hex_escape {lex_hex_escape str lexbuf} | oct_escape {lex_oct_escape str lexbuf} | escape {lex_simple_escape str lexbuf} | eof {E.parse_error "unterminated string" } | _ {lex_unescaped str lexbuf} and chr = parse '\'' {[]} | hex_escape {lex_hex_escape chr lexbuf} | oct_escape {lex_oct_escape chr lexbuf} | escape {lex_simple_escape chr lexbuf} | eof { E.parse_error "unterminated char" } | _ {lex_unescaped chr lexbuf} and msasm = parse blank { msasm lexbuf } | '{' { msasminbrace lexbuf } | _ { let cur = Lexing.lexeme lexbuf in cur ^ (msasmnobrace lexbuf) } and msasminbrace = parse '}' { "" } | _ { let cur = Lexing.lexeme lexbuf in cur ^ (msasminbrace lexbuf) } and msasmnobrace = parse ['}' ';' '\n'] { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; "" } | "__asm" { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 5; "" } | _ { let cur = Lexing.lexeme lexbuf in cur ^ (msasmnobrace lexbuf) } and annot_first_token = parse | "ghost" { if is_oneline_ghost () then E.parse_error "nested ghost code"; Buffer.clear buf; enter_ghost_code (); LGHOST } | ' '|'@'|'\t'|'\r' as c { Buffer.add_char buf c; annot_first_token lexbuf } | '\n' { E.newline(); Buffer.add_char buf '\n'; annot_first_token lexbuf } | "" { annot_token lexbuf } and annot_token = parse | "*/" { let s = Buffer.contents buf in make_annot ~one_line:false lexbuf s } | eof { E.parse_error "Unterminated annotation" } | '\n' {E.newline(); Buffer.add_char buf '\n'; annot_token lexbuf } | _ as c { Buffer.add_char buf c; annot_token lexbuf } and annot_one_line = parse | "ghost" { if is_oneline_ghost () then E.parse_error "nested ghost code"; enter_oneline_ghost (); LGHOST } | ' '|'@'|'\t'|'\r' as c { Buffer.add_char buf c; annot_one_line lexbuf } | "" { annot_one_line_logic lexbuf } and annot_one_line_logic = parse | '\n' { make_annot ~one_line:true lexbuf (Buffer.contents buf) } | _ as c { Buffer.add_char buf c; annot_one_line_logic lexbuf } { } (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/frontc/cabs.ml0000644000175000017500000003243112155630365020101 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** This file was originally part of Hugues Casee's frontc 2.0, and has been * extensively changed since. ** ** 1.0 3.22.99 Hugues Cass First version. ** 2.0 George Necula 12/12/00: Many extensions **) (* ** Types *) type cabsloc = Lexing.position * Lexing.position type typeSpecifier = (* Merge all specifiers into one type *) Tvoid (* Type specifier ISO 6.7.2 *) | Tchar | Tbool | Tshort | Tint | Tlong | Tint64 | Tfloat | Tdouble | Tsigned | Tunsigned | Tnamed of string (* each of the following three kinds of specifiers contains a field * or item list iff it corresponds to a definition (as opposed to * a forward declaration or simple reference to the type); they * also have a list of __attribute__s that appeared between the * keyword and the type name (definitions only) *) | Tstruct of string * field_group list option * attribute list | Tunion of string * field_group list option * attribute list | Tenum of string * enum_item list option * attribute list | TtypeofE of expression (* GCC __typeof__ *) | TtypeofT of specifier * decl_type (* GCC __typeof__ *) and storage = NO_STORAGE | AUTO | STATIC | EXTERN | REGISTER and funspec = INLINE | VIRTUAL | EXPLICIT and cvspec = | CV_CONST | CV_VOLATILE | CV_RESTRICT | CV_ATTRIBUTE_ANNOT of string (* Type specifier elements. These appear at the start of a declaration *) (* Everywhere they appear in this file, they appear as a 'spec_elem list', *) (* which is not interpreted by cabs -- rather, this "word soup" is passed *) (* on to the compiler. Thus, we can represent e.g. 'int long float x' even *) (* though the compiler will of course choke. *) and spec_elem = SpecTypedef | SpecCV of cvspec (* const/volatile *) | SpecAttr of attribute (* __attribute__ *) | SpecStorage of storage | SpecInline | SpecType of typeSpecifier | SpecPattern of string (* specifier pattern variable *) (* decided to go ahead and replace 'spec_elem list' with specifier *) and specifier = spec_elem list (* Declarator type. They modify the base type given in the specifier. Keep * them in the order as they are printed (this means that the top level * constructor for ARRAY and PTR is the inner-level in the meaning of the * declared type) *) and decl_type = | JUSTBASE (* Prints the declared name *) | PARENTYPE of attribute list * decl_type * attribute list (* Prints "(attrs1 decl attrs2)". * attrs2 are attributes of the * declared identifier and it is as * if they appeared at the very end * of the declarator. attrs1 can * contain attributes for the * identifier or attributes for the * enclosing type. *) | ARRAY of decl_type * attribute list * expression (* Prints "decl [ attrs exp ]". * decl is never a PTR. *) | PTR of attribute list * decl_type (* Prints "* attrs decl" *) | PROTO of decl_type * single_name list * bool (* Prints "decl (args[, ...])". * decl is never a PTR.*) (* The base type and the storage are common to all names. Each name might * contain type or storage modifiers *) (* e.g.: int x, y; *) and name_group = specifier * name list (* The optional expression is the bitfield *) and field_group = | FIELD of specifier * (name * expression option) list | TYPE_ANNOT of Logic_ptree.type_annot (* like name_group, except the declared variables are allowed to have initializers *) (* e.g.: int x=1, y=2; *) and init_name_group = specifier * init_name list (* The decl_type is in the order in which they are printed. Only the name of * the declared identifier is pulled out. The attributes are those that are * printed after the declarator *) (* e.g: in "int *x", "*x" is the declarator; "x" will be pulled out as *) (* the string, and decl_type will be PTR([], JUSTBASE) *) and name = string * decl_type * attribute list * cabsloc (* A variable declarator ("name") with an initializer *) and init_name = name * init_expression (* Single names are for declarations that cannot come in groups, like * function parameters and functions *) and single_name = specifier * name and enum_item = string * expression * cabsloc (* ** Declaration definition (at toplevel) *) and definition = FUNDEF of (Logic_ptree.spec*cabsloc) option * single_name * block * cabsloc * cabsloc | DECDEF of (Logic_ptree.spec*cabsloc) option * init_name_group * cabsloc (* global variable(s), or function prototype *) | TYPEDEF of name_group * cabsloc | ONLYTYPEDEF of specifier * cabsloc | GLOBASM of string * cabsloc | PRAGMA of expression * cabsloc | LINKAGE of string * cabsloc * definition list (* extern "C" { ... } *) | GLOBANNOT of Logic_ptree.decl list (** Logical declaration (axiom, logic, etc.)*) | CUSTOM of Logic_ptree.custom_tree * string * cabsloc (* the string is a file name, and then the list of toplevel forms *) and file = string * (bool * definition) list (* ** statements *) (* A block contains a list of local label declarations ( GCC's ({ __label__ * l1, l2; ... }) ) , a list of definitions and a list of statements *) and block = { blabels: string list; battrs: attribute list; bstmts: statement list } (* GCC asm directives have lots of extra information to guide the optimizer *) and asm_details = { aoutputs: (string option * string * expression) list; (* optional name, constraints and expressions for outputs *) ainputs: (string option * string * expression) list; (* optional name, constraints and expressions for inputs *) aclobbers: string list (* clobbered registers *) } and raw_statement = NOP of cabsloc | COMPUTATION of expression * cabsloc | BLOCK of block * cabsloc * cabsloc | SEQUENCE of statement * statement * cabsloc | IF of expression * statement * statement * cabsloc | WHILE of loop_invariant * expression * statement * cabsloc | DOWHILE of loop_invariant * expression * statement * cabsloc | FOR of loop_invariant * for_clause * expression * expression * statement * cabsloc | BREAK of cabsloc | CONTINUE of cabsloc | RETURN of expression * cabsloc | SWITCH of expression * statement * cabsloc | CASE of expression * statement * cabsloc | CASERANGE of expression * expression * statement * cabsloc | DEFAULT of statement * cabsloc | LABEL of string * statement * cabsloc | GOTO of string * cabsloc | COMPGOTO of expression * cabsloc (* GCC's "goto *exp" *) | DEFINITION of definition (*definition or declaration of a variable or type*) | ASM of attribute list * (* typically only volatile and const *) string list * (* template *) asm_details option * (* extra details to guide GCC's optimizer *) cabsloc (** MS SEH *) | TRY_EXCEPT of block * expression * block * cabsloc | TRY_FINALLY of block * block * cabsloc (* annotations *) | CODE_ANNOT of (Logic_ptree.code_annot * cabsloc) | CODE_SPEC of (Logic_ptree.spec * cabsloc) and statement = { mutable stmt_ghost: bool; stmt_node:raw_statement } and loop_invariant = Logic_ptree.code_annot list and for_clause = FC_EXP of expression | FC_DECL of definition (* ** Expressions *) and binary_operator = ADD | SUB | MUL | DIV | MOD | AND | OR | BAND | BOR | XOR | SHL | SHR | EQ | NE | LT | GT | LE | GE | ASSIGN | ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN | DIV_ASSIGN | MOD_ASSIGN | BAND_ASSIGN | BOR_ASSIGN | XOR_ASSIGN | SHL_ASSIGN | SHR_ASSIGN and unary_operator = MINUS | PLUS | NOT | BNOT | MEMOF | ADDROF | PREINCR | PREDECR | POSINCR | POSDECR and expression = { expr_loc : cabsloc; expr_node: cabsexp } and cabsexp = NOTHING | UNARY of unary_operator * expression | LABELADDR of string (* GCC's && Label *) | BINARY of binary_operator * expression * expression | QUESTION of expression * expression * expression (* A CAST can actually be a constructor expression *) | CAST of (specifier * decl_type) * init_expression (* There is a special form of CALL in which the function called is __builtin_va_arg and the second argument is sizeof(T). This should be printed as just T *) | CALL of expression * expression list | COMMA of expression list | CONSTANT of constant | PAREN of expression | VARIABLE of string | EXPR_SIZEOF of expression | TYPE_SIZEOF of specifier * decl_type | EXPR_ALIGNOF of expression | TYPE_ALIGNOF of specifier * decl_type | INDEX of expression * expression | MEMBEROF of expression * string | MEMBEROFPTR of expression * string | GNU_BODY of block | EXPR_PATTERN of string (* pattern variable, and name *) and constant = | CONST_INT of string (* the textual representation *) | CONST_FLOAT of string (* the textual representaton *) | CONST_CHAR of int64 list | CONST_WCHAR of int64 list | CONST_STRING of string | CONST_WSTRING of int64 list (* ww: wstrings are stored as an int64 list at this point because * we might need to feed the wide characters piece-wise into an * array initializer (e.g., wchar_t foo[] = L"E\xabcd";). If that * doesn't happen we will convert it to an (escaped) string before * passing it to Cil. *) and init_expression = | NO_INIT | SINGLE_INIT of expression | COMPOUND_INIT of (initwhat * init_expression) list and initwhat = NEXT_INIT | INFIELD_INIT of string * initwhat | ATINDEX_INIT of expression * initwhat | ATINDEXRANGE_INIT of expression * expression (* Each attribute has a name and some * optional arguments *) and attribute = string * expression list (* Local Variables: compile-command: "LC_ALL=C make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/frontc/cabs2cil.mli0000644000175000017500000002653412155630365021033 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Registers a new hook that will be applied each time a side-effect free expression whose result is unused is dropped. The string is the name of the current function. *) val register_ignore_pure_exp_hook: (string -> Cil_types.exp -> unit) -> unit (** new hook called when an implicit prototype is generated. @since Carbon-20101201 *) val register_implicit_prototype_hook: (Cil_types.varinfo -> unit) -> unit (** new hook called when two conflicting declarations are found. The hook takes as argument the old and new varinfo, and a description of the issue. @since Carbon-20101201 *) val register_incompatible_decl_hook: (Cil_types.varinfo -> Cil_types.varinfo -> string -> unit) -> unit (** new hook called when a definition has a compatible but not strictly identical prototype than its declaration The hook takes as argument the old and new varinfo. Note that only the old varinfo is kept in the AST, and that its type will be modified in place just after to reflect the merge of the prototypes. @since Carbon-20101201 *) val register_different_decl_hook: (Cil_types.varinfo -> Cil_types.varinfo -> unit) -> unit (** new hook called when encountering a definition of a local function. The hook take as argument the varinfo of the local function. @since Carbon-20101201 *) val register_local_func_hook: (Cil_types.varinfo -> unit) -> unit (** new hook called when side-effects are dropped. The first argument is the original expression, the second one the (side-effect free) normalized expression. *) val register_ignore_side_effect_hook: (Cabs.expression -> Cil_types.exp -> unit) -> unit (** new hook called when an expression with side-effect is evaluated conditionally (RHS of && or ||, 2nd and 3rd term of ?:). Note that in case of nested conditionals, only the innermost expression with side-effects will trigger the hook (for instance, in [(x && (y||z++))], we have a warning on [z++], not on [y||z++], and similarly, on [(x && (y++||z))], we only have a warning on [y++]). - First expression is the englobing expression - Second expression is the expression with side effects. *) val register_conditional_side_effect_hook: (Cabs.expression -> Cabs.expression -> unit) -> unit (** new hook that will be called when processing a for loop. Arguments are the four elements of the for clause (init, test, increment, body) @since Oxygen-20120901 *) val register_for_loop_all_hook: (Cabs.for_clause -> Cabs.expression -> Cabs.expression -> Cabs.statement -> unit) -> unit (** new hook that will be called when processing a for loop. Argument is the initializer of the for loop. @since Oxygen-20120901 *) val register_for_loop_init_hook: (Cabs.for_clause -> unit) -> unit (** new hook that will be called when processing a for loop. Argument is the test of the loop. @since Oxygen-20120901 *) val register_for_loop_test_hook: (Cabs.expression -> unit) -> unit (** new hook that will called when processing a for loop. Argument is the body of the loop. @since Oxygen-20120901 *) val register_for_loop_body_hook: (Cabs.statement -> unit) -> unit (** new hook that will be called when processing a for loop. Argument is the increment part of the loop. @since Oxygen-20120901 *) val register_for_loop_incr_hook: (Cabs.expression -> unit) -> unit val convFile: Cabs.file -> Cil_types.file (** Name of the attribute inserted by the elaboration to prevent user blocks from disappearing. It can be removed whenever block contracts have been processed. *) val frama_c_keep_block: string (** A hook into the code that creates temporary local vars. By default this is the identity function, but you can overwrite it if you need to change the types of cabs2cil-introduced temp variables. *) val typeForInsertedVar: (Cil_types.typ -> Cil_types.typ) ref (** Like [typeForInsertedVar], but for casts. [typeForInsertedCast expr original_type destination_type] returns the type into which [expr], which has type [original_type] and whose type must be converted into [destination_type], must be casted. By default, returns [destination_type]. This applies only to implicit casts. Casts already present in the source code are exempt from this hook. *) val typeForInsertedCast: (Cil_types.exp -> Cil_types.typ -> Cil_types.typ -> Cil_types.typ) ref (** [fresh_global prefix] creates a variable name not clashing with any other globals and starting with [prefix] *) val fresh_global : string -> string (** Check that [s] starts with the prefix [p]. *) val prefix : string -> string -> bool val anonCompFieldName : string val find_field_offset: (Cil_types.fieldinfo -> bool) -> Cil_types.fieldinfo list -> Cil_types.offset (** returns the offset (can be more than one field in case of unnamed members) corresponding to the first field matching the condition. @raise Not_found if no such field exists. *) (** returns the type of the result of a logic operator applied to values of the corresponding input types. *) val logicConditionalConversion: Cil_types.typ -> Cil_types.typ -> Cil_types.typ (** returns the type of the result of an arithmetic operator applied to values of the corresponding input types. @deprecated Nitrogen-20111001 moved to Cil module *) val arithmeticConversion : Cil_types.typ -> Cil_types.typ -> Cil_types.typ (** performs the usual integral promotions mentioned in C reference manual. @deprecated Nitrogen-20111001 moved to Cil module. *) val integralPromotion : Cil_types.typ -> Cil_types.typ (** local information needed to typecheck expressions and statements *) type local_env = private { authorized_reads: Cil_datatype.Lval.Set.t; (** sets of lvalues that can be read regardless of a potential write access between sequence points. Mainly for tmp variables introduced by the normalization. *) known_behaviors: string list; (** list of known behaviors at current point. *) is_ghost: bool; (** whether we're analyzing ghost code or not *) } (** an empty local environment. *) val empty_local_env: local_env (** same as [empty_local_env], but sets the ghost status to the value of its argument *) val ghost_local_env: bool -> local_env (* [VP] Jessie plug-in needs this function to be exported for semi-good reasons. *) val blockInitializer : local_env -> Cil_types.varinfo -> Cabs.init_expression -> Cil_types.block * Cil_types.init * Cil_types.typ (** Returns a block of statements equivalent to the initialization [init] applied to lvalue [lval] of type [typ]. *) val blockInit: ghost:bool -> Cil_types.lval -> Cil_types.init -> Cil_types.typ -> Cil_types.block (** Applies [mkAddrOf] after marking variable whose address is taken. *) val mkAddrOfAndMark : Cil_types.location -> Cil_types.lval -> Cil_types.exp (** If called, sets a flag so that [continue] in while loops get transformed into forward gotos, like it is already done in do-while and for loops. *) val setDoTransformWhile : unit -> unit (** If called, sets a flag so that translation of conditionals does not result in forward ingoing gotos (from the if-branch to the else-branch). *) val setDoAlternateConditional : unit -> unit (** Raise Failure *) val integral_cast: Cil_types.typ -> Cil_types.term -> Cil_types.term (** Given a call [lv = f()], if [tf] is the return type of [f] and [tlv] the type of [lv], [allow_return_collapse ~tlv ~tf] returns false if a temporary must be introduced to hold the result of [f], and true otherwise. Currently, implicit cast between pointers or cast from an scalar type or a strictly bigger one are accepted without cast. This is subject to change without notice. @since Oxygen-20120901 *) val allow_return_collapse: tlv:Cil_types.typ -> tf:Cil_types.typ -> bool val compatibleTypes: Cil_types.typ -> Cil_types.typ -> Cil_types.typ (** Check that the two given types are compatible (C99, 6.2.7), and return their composite type. Raise [Failure] with an explantion if the two types are not compatible @since Oxygen-20120901 *) (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/frontc/cabsbranches.ml0000644000175000017500000002017312155630365021607 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) open Cil_types open Cil_datatype open Cabscond (* -------------------------------------------------------------------------- *) (* --- Branching --- *) (* -------------------------------------------------------------------------- *) type branches = { s_info : info ; s_leftmost : int ; (* eid of the left-most atom *) mutable s_then : block list ; mutable s_else : block list ; } let branches : (int,branches) Hashtbl.t = Hashtbl.create 371 (* indexed by info.id *) type target = Cond | Then | Else let link_target cbs tgt block = match tgt with | Cond -> () | Then -> cbs.s_then <- block :: cbs.s_then | Else -> cbs.s_else <- block :: cbs.s_else let rec link_branches cbs cond atom tt tf st sf = match cond with | And(a,b) -> link_branches cbs a atom Cond tf st sf ; link_branches cbs b atom tt tf st sf | Or(a,b) -> link_branches cbs a atom tt Cond st sf ; link_branches cbs b atom tt tf st sf | Not a -> link_branches cbs a atom tf tt st sf | Atom leaf -> if leaf.eid = atom.eid then ( link_target cbs tt st ; link_target cbs tf sf ) | Blob -> () let rec leftmost = function | And(cond,_) | Or(cond,_) | Not cond -> leftmost cond | Atom e -> e.eid | Blob -> 0 let link_stmt stmt = match stmt.skind with | If(e,b_then,b_else,_) -> begin match lookup e with | Some info -> let cbs = try Hashtbl.find branches info.id with Not_found -> let eid = leftmost info.cond in let cbs = { s_info=info ; s_leftmost=eid ; s_then=[] ; s_else=[] ; } in Hashtbl.add branches info.id cbs ; cbs in link_branches cbs info.cond e Then Else b_then b_else | None -> () end | _ -> () let rec adherence adh = function | [] -> adh | { bstmts = stmt::_ }::bs -> adherence (Stmt.Set.add stmt adh) bs | { bstmts = [] }::bs -> adherence adh bs let filter_block adh = function | { bstmts = {skind=Goto _;succs=succs}::_ } -> List.for_all (fun s -> not (Stmt.Set.mem s adh)) succs | _ -> true type branch_info = { mutable b_then : info list ; mutable b_else : info list ; } let branches_info : branch_info Stmt.Hashtbl.t = Stmt.Hashtbl.create 371 let get_branch_info s = try Stmt.Hashtbl.find branches_info s with Not_found -> let binfo = { b_then=[] ; b_else=[] } in Stmt.Hashtbl.add branches_info s binfo ; binfo let add_branch_then info block = match block.bstmts with [] -> () | s::_ -> let binfo = get_branch_info s in binfo.b_then <- info :: binfo.b_then let add_branch_else info block = match block.bstmts with [] -> () | s::_ -> let binfo = get_branch_info s in binfo.b_else <- info :: binfo.b_else let non_empty cbs = cbs.s_then <> [] && cbs.s_else <> [] let filter_internal cbs = let adh = adherence (adherence Stmt.Set.empty cbs.s_then) cbs.s_else in begin cbs.s_then <- List.filter (filter_block adh) cbs.s_then ; cbs.s_else <- List.filter (filter_block adh) cbs.s_else ; if non_empty cbs then begin List.iter (add_branch_then cbs.s_info) cbs.s_then ; List.iter (add_branch_else cbs.s_info) cbs.s_else ; end end class link_branches = object inherit Visitor.frama_c_inplace method vinit _ _ _ = Cil.SkipChildren method vtype _ = Cil.SkipChildren method vattr _ = Cil.SkipChildren method vinst _ = Cil.SkipChildren method vexpr _ = Cil.SkipChildren method vlval _ = Cil.SkipChildren method vlogic_type _ = Cil.SkipChildren method vterm _ = Cil.SkipChildren method vpredicate _ = Cil.SkipChildren method vpredicate_named _ = Cil.SkipChildren method vbehavior _ = Cil.SkipChildren method vspec _ = Cil.SkipChildren method vcode_annot _ = Cil.SkipChildren method vannotation _ = Cil.SkipChildren method vstmt_aux stmt = link_stmt stmt ; Cil.DoChildren end let computed = ref false let compute () = if !active && not !computed then begin Kernel.feedback "Computing Branches" ; Visitor.visitFramacFile (new link_branches) (Ast.get()) ; Hashtbl.iter (fun _ -> filter_internal) branches ; computed := true ; end let branches stmt = compute () ; match stmt.skind with | If(e,_,_,_) -> begin match lookup e with | None -> None | Some info -> try let cbs = Hashtbl.find branches info.id in if non_empty cbs && cbs.s_leftmost = e.eid then Some ( cbs.s_then , cbs.s_else ) else None with Not_found -> None end | _ -> None let pp_comment fmt stmt = if !active then try let binfo = Stmt.Hashtbl.find branches_info stmt in Format.fprintf fmt "@[/*" ; List.iter (fun info -> Format.fprintf fmt "[THEN:%d]@," info.id) binfo.b_then ; List.iter (fun info -> Format.fprintf fmt "[ELSE:%d]@," info.id) binfo.b_else ; Format.fprintf fmt "*/@]@ " ; with Not_found -> () let () = Printer.cabsbranches_pp_comment := pp_comment frama-c-Fluorine-20130601/cil/src/frontc/cprint.mli0000644000175000017500000001231312155630365020636 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Printers for the Cabs AST *) val version : string val msvcMode : bool ref val printLn : bool ref val printLnComment : bool ref val printCounters : bool ref val printComments : bool ref val get_operator : Cabs.expression -> (string * int) val print_specifiers : Format.formatter -> Cabs.specifier -> unit val print_type_spec : Format.formatter -> Cabs.typeSpecifier -> unit val print_struct_name_attr : string -> Format.formatter -> (string * Cabs.attribute list) -> unit val print_decl : string -> Format.formatter -> Cabs.decl_type -> unit val print_fields : Format.formatter -> Cabs.field_group list -> unit val print_enum_items : Format.formatter -> Cabs.enum_item list -> unit val print_onlytype : Format.formatter -> Cabs.specifier * Cabs.decl_type -> unit val print_name : Format.formatter -> Cabs.name -> unit val print_init_name : Format.formatter -> Cabs.init_name -> unit val print_name_group : Format.formatter -> Cabs.name_group -> unit val print_field_group : Format.formatter -> Cabs.field_group -> unit val print_field : Format.formatter -> Cabs.name * Cabs.expression option -> unit val print_init_name_group : Format.formatter -> Cabs.init_name_group -> unit val print_single_name : Format.formatter -> Cabs.single_name -> unit val print_params : Format.formatter -> (Cabs.single_name list * bool) -> unit val print_init_expression : Format.formatter -> Cabs.init_expression -> unit val print_expression : Format.formatter -> Cabs.expression -> unit val print_expression_level : int -> Format.formatter -> Cabs.expression -> unit val print_statement : Format.formatter -> Cabs.statement -> unit val print_block : Format.formatter -> Cabs.block -> unit val print_attribute : Format.formatter -> Cabs.attribute -> unit val print_attributes : Format.formatter -> Cabs.attribute list -> unit val print_defs : Format.formatter -> (bool*Cabs.definition) list -> unit val print_def : Format.formatter -> Cabs.definition -> unit val printFile : Format.formatter -> Cabs.file -> unit frama-c-Fluorine-20130601/cil/src/frontc/cabshelper.ml0000644000175000017500000002003312155630365021274 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) open Cabs let nextident = ref 0 let getident () = nextident := !nextident + 1; !nextident let currentLoc () = Errorloc.getPosition () let cabslu = Lexing.dummy_pos,Lexing.dummy_pos let continue_annot _ job default msg = try Cilmsg.push_errors () ; let result = job () in if Cilmsg.had_errors () then failwith "Annotation has errors" ; Cilmsg.pop_errors () ; Log.with_null (fun _ -> result) msg ; with exn when Kernel.ContinueOnAnnotError.get () -> Kernel.debug "Continue on annotation error (%s)" (Printexc.to_string exn) ; Cilmsg.pop_errors (); Log.with_null (fun _ -> default ()) msg module Comments = struct module MapDest = struct include Datatype.List(Datatype.Pair(Cil_datatype.Position)(Datatype.String)) let fast_equal (_:t) (_:t) = false end module MyTable = Rangemap.Make (Cil_datatype.Position) (MapDest) module MyState = State_builder.Ref (MyTable) (struct let name = "Cabshelper.Comments" let dependencies = [ ] (* depends from File.self and Ast.self which add the dependency themselves. *) let default () = MyTable.empty end) let self = MyState.self (* What matters is the beginning of the comment. *) let add (first,last) comment = let state = MyState.get () in let acc = try MyTable.find first state with Not_found -> [] in MyState.set ((MyTable.add first ((last,comment)::acc)) state) let get (first,last) = Kernel.debug "Searching for comments between positions %a and %a@." Cil_datatype.Position.pretty first Cil_datatype.Position.pretty last; MyTable.fold_range (fun pos -> match Cil_datatype.Position.compare first pos with | n when n > 0 -> Rangemap.Below | 0 -> Rangemap.Match | _ -> if Cil_datatype.Position.compare pos last <= 0 then Rangemap.Match else Rangemap.Above) (fun _ comments acc -> acc @ List.rev_map snd comments) (MyState.get ()) [] let iter f = MyTable.iter (fun first comments -> List.iter (fun (last,comment) -> f (first,last) comment) comments) (MyState.get()) let fold f acc = MyTable.fold (fun first comments acc -> List.fold_left (fun acc (last,comment) -> f (first,last) comment acc) acc comments) (MyState.get()) acc end (*********** HELPER FUNCTIONS **********) let missingFieldDecl = (Cil.missingFieldName, JUSTBASE, [], cabslu) let rec isStatic = function [] -> false | (SpecStorage STATIC) :: _ -> true | _ :: rest -> isStatic rest let rec isExtern = function [] -> false | (SpecStorage EXTERN) :: _ -> true | _ :: rest -> isExtern rest let rec isInline = function [] -> false | SpecInline :: _ -> true | _ :: rest -> isInline rest let rec isTypedef = function [] -> false | SpecTypedef :: _ -> true | _ :: rest -> isTypedef rest let get_definitionloc (d : definition) : cabsloc = match d with | FUNDEF(_,_, _, l, _) -> l | DECDEF(_,_, l) -> l | TYPEDEF(_, l) -> l | ONLYTYPEDEF(_, l) -> l | GLOBASM(_, l) -> l | PRAGMA(_, l) -> l | LINKAGE (_, l, _) -> l | GLOBANNOT({Logic_ptree.decl_loc = l }::_) -> l | GLOBANNOT [] -> assert false | CUSTOM (_,_,l) -> l let get_statementloc (s : statement) : cabsloc = begin match s.stmt_node with | NOP(loc) -> loc | COMPUTATION(_,loc) -> loc | BLOCK(_,loc,_) -> loc | SEQUENCE(_,_,loc) -> loc | IF(_,_,_,loc) -> loc | WHILE(_,_,_,loc) -> loc | DOWHILE(_,_,_,loc) -> loc | FOR(_,_,_,_,_,loc) -> loc | BREAK(loc) -> loc | CONTINUE(loc) -> loc | RETURN(_,loc) -> loc | SWITCH(_,_,loc) -> loc | CASE(_,_,loc) -> loc | CASERANGE(_,_,_,loc) -> loc | DEFAULT(_,loc) -> loc | LABEL(_,_,loc) -> loc | GOTO(_,loc) -> loc | COMPGOTO (_, loc) -> loc | DEFINITION d -> get_definitionloc d | ASM(_,_,_,loc) -> loc | TRY_EXCEPT(_, _, _, loc) -> loc | TRY_FINALLY(_, _, loc) -> loc | (CODE_SPEC (_,l) |CODE_ANNOT (_,l)) -> l end let explodeStringToInts (s: string) : int64 list = let rec allChars i acc = if i < 0 then acc else allChars (i - 1) (Int64.of_int (Char.code (String.get s i)) :: acc) in allChars (-1 + String.length s) [] let valueOfDigit chr = let int_value = match chr with '0'..'9' -> (Char.code chr) - (Char.code '0') | 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10 | 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10 | _ -> Kernel.fatal "not a digit" in Int64.of_int int_value let d_cabsloc fmt cl = Format.fprintf fmt "%s:%d" (fst cl).Lexing.pos_fname (fst cl).Lexing.pos_lnum (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/frontc/errorloc.ml0000644000175000017500000002240212155630365021015 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* * * Copyright (c) 2001-2002, * George C. Necula * Scott McPeak * Wes Weimer * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * 3. The names of the contributors may not be used to endorse or promote * products derived from this software without specific prior written * permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * *) (* Copied and modified from [cil/src/errormsg.ml] *) (***** Handling parsing errors ********) type parseinfo = { mutable linenum: int ; (* Current line *) mutable linestart: int ; (* The position in the buffer where the * current line starts *) mutable fileName : string ; (* Current file *) lexbuf : Lexing.lexbuf; inchan : in_channel option; (* None, if from a string *) mutable num_errors : int; (* Errors so far *) } let dummyinfo = { linenum = 1; linestart = 0; fileName = "" ; lexbuf = Lexing.from_string ""; inchan = None; num_errors = 0; } let current = ref dummyinfo let current_working_directory = ref None let readingFromStdin = ref false let startParsing ?(useBasename=true) fname = (* We only support one open file at a time *) if !current != dummyinfo then begin Kernel.fatal "[Errorloc.startParsing] supports only one open file: \ You want to open %S and %S is still open" fname !current.fileName; end; let inchan = try if fname = "-" then begin readingFromStdin := true; stdin end else begin readingFromStdin := false; open_in_bin fname end with Sys_error s -> Kernel.abort "Cannot find input file %S: %s" fname s in let lexbuf = Lexing.from_channel inchan in let i = { linenum = 1; linestart = 0; fileName = (if useBasename then Filename.basename fname else Filepath.normalize fname); lexbuf = lexbuf; inchan = Some inchan; num_errors = 0 } in (* Initialize lexer buffer. *) lexbuf.Lexing.lex_curr_p <- { Lexing.pos_fname = i.fileName; Lexing.pos_lnum = 1; Lexing.pos_bol = 0; Lexing.pos_cnum = 0 }; current := i; current_working_directory := None; lexbuf let finishParsing () = let i = !current in (match i.inchan with Some c -> close_in c | _ -> ()); current := dummyinfo (* Call this function to announce a new line *) let newline () = (* Update lexer buffer. *) let update_newline_loc lexbuf = let pos = lexbuf.Lexing.lex_curr_p in lexbuf.Lexing.lex_curr_p <- { pos with Lexing.pos_lnum = pos.Lexing.pos_lnum + 1; Lexing.pos_bol = pos.Lexing.pos_cnum; } in update_newline_loc !current.lexbuf; (* Default CIL location update. *) let i = !current in i.linenum <- 1 + i.linenum; i.linestart <- Lexing.lexeme_start i.lexbuf let setCurrentLine (i: int) = (* Update lexer buffer. *) let update_line_loc lexbuf line absolute chars = let pos = lexbuf.Lexing.lex_curr_p in lexbuf.Lexing.lex_curr_p <- { pos with Lexing.pos_lnum = if absolute then line else pos.Lexing.pos_lnum + line; Lexing.pos_bol = pos.Lexing.pos_cnum - chars; } in update_line_loc !current.lexbuf i true 0; (* Default CIL location update. *) !current.linenum <- i let setCurrentWorkingDirectory s = current_working_directory := Some(s);; let setCurrentFile ?(normalize=true) (n: string) = let n = if not normalize then n else Filepath.normalize (match !current_working_directory with | None -> n | Some(s) -> if Filename.is_relative n then Filename.concat s n else n) in (* Update lexer buffer. *) let update_file_loc lexbuf file = let pos = lexbuf.Lexing.lex_curr_p in lexbuf.Lexing.lex_curr_p <- { pos with Lexing.pos_fname = file; } in update_file_loc !current.lexbuf n; (* Default CIL location update. *) !current.fileName <- n let max_errors = 20 (* Stop after 20 errors *) let parse_error (msg: string) : 'a = let i = !current in i.num_errors <- i.num_errors + 1; if i.num_errors > max_errors then Kernel.abort "Too many errors." else Kernel.with_error (fun _ -> raise Parsing.Parse_error) ~source:{Lexing.pos_fname= i.fileName ; pos_lnum = i.linenum; pos_bol = i.linestart; pos_cnum = 0;} "%s" msg (* More parsing support functions: line, file, char count *) let getPosition () : Lexing.position * Lexing.position = let i = !current in Lexing.lexeme_start_p i.lexbuf, Lexing.lexeme_end_p i.lexbuf (** Type for source-file locations *) type location = { file: string; (** The file name *) line: int; (** The line number *) } let d_loc fmt l = Format.fprintf fmt "%s:%d" l.file l.line let locUnknown = { file = ""; line = -1 } frama-c-Fluorine-20130601/cil/src/frontc/frontc.ml0000644000175000017500000001476212155630365020473 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* Output management *) let out : out_channel option ref = ref None let close_me = ref false let close_output _ = match !out with None -> () | Some o -> begin flush o; if !close_me then close_out o else (); close_me := false end (* Signal that we are in MS VC mode *) let setMSVCMode () = Cprint.msvcMode := true let printNotice = ref false (* ** Argument definition let args : (string * Arg.spec * string) list = [ "--cabsonly", Arg.String set_output, ": CABS output file name"; "--printComments", Arg.Unit (fun _ -> Cprint.printComments := true), ": print cabs tree structure in comments in cabs output"; "--patchFile", Arg.String (fun pf -> patchFileName := pf), ": name the file containing patching transformations"; "--printPatched", Arg.Unit (fun _ -> printPatchedFiles := true), ": print patched CABS files after patching, to *.patched"; "--printProtos", Arg.Unit (fun _ -> doPrintProtos := true), ": print prototypes to safec.proto.h after parsing"; "--printNotice", Arg.Set printNotice, ": include a comment saying printed by FrontC"; ] *) exception CabsOnly (* parse *) let rec parse_to_cabs fname = (* now parse the file we came here to parse *) let cabs = parse_to_cabs_inner fname in if Cilmsg.had_errors () then begin Kernel.debug "There were parsing errors in %s" fname ; raise Parsing.Parse_error end; (* print it ... *) (match !out with | None -> (); | Some o -> begin if !printNotice then output_string o ("/* Generated by Frontc */\n"); Cprint.printFile (Format.formatter_of_out_channel o) cabs; close_output (); raise CabsOnly end); if Cilmsg.had_errors () then raise Parsing.Parse_error; (* and return the patched source *) cabs (* just parse *) and parse_to_cabs_inner (fname : string) = try Kernel.feedback ~level:2 "Parsing %s" fname ; Cilmsg.clear_errors () ; let lexbuf = Clexer.init fname in let cabs = Cparser.file Clexer.initial lexbuf in (* Cprint.print_defs cabs;*) Clexer.finish (); (*TODO: explore deeper why to overwrite fname ?! let fname = match !E.first_filename_encountered with | None -> fname | Some f -> f in*) (fname, cabs) with | Sys_error msg -> Clexer.finish () ; close_output () ; Kernel.abort "Cannot open %s : %s" fname msg ; | Parsing.Parse_error -> Clexer.finish (); close_output (); raise Parsing.Parse_error ; (*| e -> begin ignore (E.log "Caught %s while parsing\n" (Printexc.to_string e)); Clexer.finish (); raise e end *) module Syntactic_transformations = Hook.Fold(struct type t = Cabs.file end) let add_syntactic_transformation = Syntactic_transformations.extend let parse fname = Kernel.feedback ~level:2 "Parsing %s to Cabs" fname ; let cabs = parse_to_cabs fname in let cabs = Syntactic_transformations.apply cabs in (*Cprint.printFile stdout cabs;*) (* Now (return a function that will) convert to CIL *) fun _ -> Kernel.feedback ~level:2 "Converting %s from Cabs to CIL" fname ; let cil = Cabs2cil.convFile cabs in (*if !doPrintProtos then (printPrototypes cabs);*) (*Cil.dumpFile Cil.defaultCilPrinter stdout "behue" cil;*) cil,cabs frama-c-Fluorine-20130601/cil/src/frontc/cabs2cil.ml0000644000175000017500000123014312155630365020654 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* Type check and elaborate ABS to CIL *) (* The references to ISO means ANSI/ISO 9899-1999 *) module A = Cabs module C = Cabshelper module V = Cabsvisit module H = Hashtbl module IH = Datatype.Int.Hashtbl module AL = Alpha open Pretty_utils open Cabs open Cabshelper open Cil open Cil_types open Cil_datatype open Lexing let debugGlobal = true let continueOnError = false let frama_c_keep_block = "FRAMA_C_KEEP_BLOCK" let () = Cil.register_shallow_attribute frama_c_keep_block (** A hook into the code that creates temporary local vars. By default this is the identity function, but you can overwrite it if you need to change the types of cabs2cil-introduced temp variables. *) let typeForInsertedVar: (Cil_types.typ -> Cil_types.typ) ref = ref (fun t -> t) (** Like [typeForInsertedVar], but for casts. * Casts in the source code are exempt from this hook. *) let typeForInsertedCast: (Cil_types.exp -> Cil_types.typ -> Cil_types.typ -> Cil_types.typ) ref = ref (fun _ _ t -> t) let cabs_exp loc node = { expr_loc = loc; expr_node = node } module IgnorePureExpHook = Hook.Build (struct type t = string * Cil_types.exp end) let register_ignore_pure_exp_hook f = IgnorePureExpHook.extend (fun (x,z) -> f x z) module ImplicitPrototypeHook = Hook.Build (struct type t = varinfo end) let register_implicit_prototype_hook f = ImplicitPrototypeHook.extend f module IncompatibleDeclHook = Hook.Build(struct type t = varinfo * varinfo * string end) let register_incompatible_decl_hook f = IncompatibleDeclHook.extend (fun (x,y,z) -> f x y z) module DifferentDeclHook = Hook.Build(struct type t = varinfo * varinfo end) let register_different_decl_hook f = DifferentDeclHook.extend (fun (x,y) -> f x y) module LocalFuncHook = Hook.Build(struct type t = varinfo end) let register_local_func_hook = LocalFuncHook.extend module IgnoreSideEffectHook = Hook.Build(struct type t = Cabs.expression * Cil_types.exp end) let register_ignore_side_effect_hook f = IgnoreSideEffectHook.extend (fun (y,z) -> f y z) module ConditionalSideEffectHook = Hook.Build(struct type t = Cabs.expression * Cabs.expression end) module ForLoopHook = Hook.Build(struct type t = Cabs.for_clause * Cabs.expression * Cabs.expression * Cabs.statement end) let register_for_loop_all_hook f = ForLoopHook.extend (fun (x,y,z,t) -> f x y z t) let register_for_loop_init_hook f = ForLoopHook.extend (fun (x,_,_,_) -> f x) let register_for_loop_test_hook f = ForLoopHook.extend (fun (_,x,_,_) -> f x) let register_for_loop_incr_hook f = ForLoopHook.extend (fun (_,_,x,_) -> f x) let register_for_loop_body_hook f = ForLoopHook.extend (fun (_,_,_,x) -> f x) let register_conditional_side_effect_hook f = ConditionalSideEffectHook.extend (fun (y,z) -> f y z) let rec is_dangerous_offset = function NoOffset -> false | Field (_,o) -> is_dangerous_offset o | Index _ -> true let rec is_dangerous e = match e.enode with | Lval lv | AddrOf lv | StartOf lv -> is_dangerous_lval lv | UnOp (_,e,_) | CastE(_,e) | Info(e,_) -> is_dangerous e | BinOp(_,e1,e2,_) -> is_dangerous e1 || is_dangerous e2 | Const _ | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> false and is_dangerous_lval = function | Var v,_ when not v.vglob && not v.vformal && not v.vgenerated -> true (* Local might be uninitialized, which will trigger UB, but we assume that the variables we generate are correctly initialized. *) | Var _, o -> is_dangerous_offset o | Mem _,_ -> true class check_no_locals = object inherit nopCilVisitor method vlval (h,_) = (match h with | Var v -> if not v.vglob then Kernel.error ~once:true ~current:true "Forbidden access to local variable %a in static initializer" Cil_printer.pp_varinfo v | _ -> ()); DoChildren end let rec check_no_locals_in_initializer i = match i with | SingleInit e -> ignore (visitCilExpr (new check_no_locals) e) | CompoundInit (ct, initl) -> foldLeftCompound ~implicit:false ~doinit:(fun _off' i' _ () -> check_no_locals_in_initializer i') ~ct:ct ~initl:initl ~acc:() (* ---------- source error message handling ------------- *) let cabslu s = {Lexing.dummy_pos with pos_fname="Cabs2cil_start"^s}, {Lexing.dummy_pos with pos_fname="Cabs2cil_end"^s} (** Keep a list of the variable ID for the variables that were created to * hold the result of function calls *) let callTempVars: unit IH.t = IH.create 13 (* Keep a list of functions that were called without a prototype. *) let noProtoFunctions : bool IH.t = IH.create 13 (* Check that s starts with the prefix p *) let prefix p s = let lp = String.length p in let ls = String.length s in lp <= ls && String.sub s 0 lp = p (***** PROCESS PRAGMAS **********) (* ICC align/noalign pragmas (not supported by GCC/MSVC with this syntax). Implemented by translating them to 'aligned' attributes. Currently, only default and noalign are supported, not explicit alignment values. Cf. www.slac.stanford.edu/grp/cd/soft/rmx/manuals/IC_386.PDF *) let current_pragma_align = ref (None : bool option) let pragma_align_by_struct = H.create 17 let process_align_pragma name args = let aux pname v = (if theMachine.msvcMode then Kernel.warning else Kernel.debug ~level:1 ?dkey:None) ~current:true "Parsing ICC '%s' pragma." pname; match args with | [] -> current_pragma_align := Some v | l -> List.iter (function | AStr s | ACons (s, _) -> H.replace pragma_align_by_struct s v | _ -> Kernel.warning ~current:true "Unsupported '%s' pragma not honored by Frama-C." pname ) l in match name with | "align" -> aux "align" true | "noalign" -> aux "noalign" false | _ -> () let align_pragma_for_struct sname = try Some (H.find pragma_align_by_struct sname) with Not_found -> !current_pragma_align (* The syntax and semantics for the pack pragmas are GCC's. The MSVC ones seems quite different and specific code should be written so support it. *) (* The pack pragma stack *) let packing_pragma_stack = Stack.create () (* The current pack pragma *) let current_packing_pragma = ref None let process_pack_pragma name args = begin match name with | "pack" -> begin if theMachine.msvcMode then Kernel.warning ~current:true "'pack' pragmas are probably incorrect in MSVC mode. \ Using GCC like pragmas."; match args with | [] (* #pragma pack() *) -> current_packing_pragma := None; None | [AInt n] (* #pragma pack(n) *) -> current_packing_pragma := Some n; None | [ACons ("push",[])] (* #pragma pack(push) *) -> Stack.push !current_packing_pragma packing_pragma_stack; None | [ACons ("push",[AInt n])] (* #pragma pack(push,n) *) -> Stack.push !current_packing_pragma packing_pragma_stack; current_packing_pragma:= Some n; None | [ACons ("pop",[])] (* #pragma pack(pop) *) -> begin try current_packing_pragma := Stack.pop packing_pragma_stack; None with Stack.Empty -> Kernel.warning ~current:true "Inconsistent #pragma pack(pop). Using default packing."; current_packing_pragma := None; None end | [ACons ("show",[])] (* #pragma pack(show) *) -> Some (Attr (name, args)) | _ -> Kernel.warning ~current:true "Unsupported packing pragma not honored by Frama-C."; Some (Attr (name, args)) end | _ -> Some (Attr (name, args)) end let force_packed_attribute a = if hasAttribute "packed" a then a else addAttribute (Attr("packed",[])) a let add_packing_attributes s a = match !current_packing_pragma, align_pragma_for_struct s.corig_name with | None, None -> a | Some n, _ -> (* ignore 'align' pragma if some 'pack' pragmas are present (no known compiler support both syntaxes) *) let with_aligned_attributes = match filterAttributes "aligned" a with | [] (* no aligned attributes yet. Add the global one. *) -> addAttribute (Attr("aligned",[AInt n])) a | [Attr("aligned",[AInt local])] (* The largest aligned wins with GCC. Don't know with other compilers. *) -> addAttribute (Attr("aligned",[AInt (Integer.max local n)])) (dropAttribute "aligned" a) | [Attr("aligned",[])] -> (* This one always wins as it is the biggest available on the plateform. *) a | _ -> Kernel.warning ~current:true "Unknown aligned attribute syntax: keeping it as is and \ adding new one."; addAttribute (Attr("aligned",[AInt n])) a in force_packed_attribute with_aligned_attributes | None, Some true -> dropAttribute "aligned" a | None, Some false -> force_packed_attribute (addAttribute (Attr("aligned",[AInt Integer.one])) (dropAttribute "aligned" a)) (***** COMPUTED GOTO ************) (* The address of labels are small integers (starting from 0). A computed * goto is replaced with a switch on the address of the label. We generate * only one such switch and we'll jump to it from all computed gotos. To * accomplish this we'll add a local variable to store the target of the * goto. *) (* The local variable in which to put the detination of the goto and the * statement where to jump *) let gotoTargetData: (varinfo * stmt) option ref = ref None (* The "addresses" of labels *) let gotoTargetHash: (string, int) H.t = H.create 13 let gotoTargetNextAddr: int ref = ref 0 (********** TRANSPARENT UNION ******) (* Check if a type is a transparent union, and return the first field if it * is *) let isTransparentUnion (t: typ) : fieldinfo option = match unrollType t with | TComp (comp, _, _) when not comp.cstruct -> (* Turn transparent unions into the type of their first field *) if hasAttribute "transparent_union" (typeAttrs t) then begin match comp.cfields with | [] -> Kernel.abort ~current:true "Empty transparent union: %s" (compFullName comp) | f :: _ -> Some f end else None | _ -> None (* When we process an argument list, remember the argument index which has a * transparent union type, along with the original type. We need this to * process function definitions *) let transparentUnionArgs : (int * typ) list ref = ref [] let debugLoc = false let convLoc (l : cabsloc) = if debugLoc then Kernel.debug "convLoc at %s: line %d, btye %d\n" (fst l).Lexing.pos_fname (fst l).Lexing.pos_lnum (fst l).Lexing.pos_bol; l let isOldStyleVarArgName n = if theMachine.msvcMode then n = "va_alist" else n = "__builtin_va_alist" let isOldStyleVarArgTypeName n = if theMachine.msvcMode then n = "va_list" || n = "__ccured_va_list" else n = "__builtin_va_alist_t" (*** EXPRESSIONS *************) (* We collect here the program *) let theFile : global list ref = ref [] let theFileTypes : global list ref = ref [] (* This hashtbl contains the varinfo-indexed globals of theFile. They are duplicated here for faster lookup *) let theFileVars : global Cil_datatype.Varinfo.Hashtbl.t = Cil_datatype.Varinfo.Hashtbl.create 13 let findVarInTheFile vi = try List.rev (Cil_datatype.Varinfo.Hashtbl.find_all theFileVars vi) with Not_found -> [] let update_fundec_in_theFile vi (f:global -> unit) = let rec aux = function | [] -> assert false | (GVarDecl _ as g) :: _ -> f g | _ :: tl -> aux tl in aux (findVarInTheFile vi) let update_funspec_in_theFile vi spec = let rec aux = function | [] -> assert false | GFun (f,_) :: _ -> Cil.CurrentLoc.set vi.vdecl; Logic_utils.merge_funspec f.sspec spec | _ :: tl -> aux tl in aux (findVarInTheFile vi) let find_existing_behaviors vi = let behaviors spec = List.map (fun x -> x.b_name) spec.spec_behavior in let aux acc = function | GFun(f,_) -> (behaviors f.sspec) @ acc | GVarDecl (spec,_,_) -> behaviors spec @ acc | _ -> acc in List.fold_left aux [] (findVarInTheFile vi) let get_formals vi = let rec aux = function | [] -> assert false | GFun(f,_)::_ -> f.sformals | _ :: tl -> aux tl in aux (findVarInTheFile vi) let initGlobals () = theFile := []; theFileTypes := []; Cil_datatype.Varinfo.Hashtbl.clear theFileVars; ;; let required_builtins = [ "Frama_C_bzero"; "Frama_C_copy_block" ] let cabsPushGlobal (g: global) = (match g with | GFun({ svar = v},_) | GVarDecl(_,v,_) when List.mem v.vname required_builtins -> ignore (Cil.Frama_c_builtins.memo (fun _ -> v) v.vname) | _ -> ()); pushGlobal g ~types:theFileTypes ~variables:theFile; (match g with | GVar (vi, _, _) | GVarDecl (_, vi, _) | GFun ({svar = vi}, _) -> (* Do 'add' and not 'replace' here, as we may store both declarations and definitions for the same varinfo *) Cil_datatype.Varinfo.Hashtbl.add theFileVars vi g | _ -> () ); ;; (* Keep track of some variable ids that must be turned into definitions. We * do this when we encounter what appears a definition of a global but * without initializer. We leave it a declaration because maybe down the road * we see another definition with an initializer. But if we don't see any * then we turn the last such declaration into a definition without * initializer *) let mustTurnIntoDef: bool IH.t = IH.create 117 (* Globals that have already been defined. Indexed by the variable name. *) let alreadyDefined: (string, location) H.t = H.create 117 (* Globals that were created due to static local variables. We chose their * names to be distinct from any global encountered at the time. But we might * see a global with conflicting name later in the file. *) let staticLocals: (string, varinfo) H.t = H.create 13 (* Typedefs. We chose their names to be distinct from any global encounterd * at the time. But we might see a global with conflicting name later in the * file *) let typedefs: (string, typeinfo) H.t = H.create 13 let fileGlobals () = let rec revonto (tail: global list) = function [] -> tail | GVarDecl (_,vi, l) :: rest when vi.vstorage != Extern && IH.mem mustTurnIntoDef vi.vid -> IH.remove mustTurnIntoDef vi.vid; revonto (GVar (vi, {init = None}, l) :: tail) rest | x :: rest -> revonto (x :: tail) rest in revonto (revonto [] !theFile) !theFileTypes (********* ENVIRONMENTS ***************) (* The environment is kept in two distinct data structures. A hash table maps * each original variable name into a varinfo (for variables, or an * enumeration tag, or a type). (Note that the varinfo might contain an * alpha-converted name different from that of the lookup name.) The Ocaml * hash tables can keep multiple mappings for a single key. Each time the * last mapping is returned and upon deletion the old mapping is restored. To * keep track of local scopes we also maintain a list of scopes (represented * as lists). *) type envdata = EnvVar of varinfo (* The name refers to a variable * (which could also be a function) *) | EnvEnum of enumitem (* the name refers to an enum item *) | EnvTyp of typ (* The name is of the form "struct * foo", or "union foo" or "enum foo" * and refers to a type. Note that * the name of the actual type might * be different from foo due to alpha * conversion *) | EnvLabel of string (* The name refers to a label. This * is useful for GCC's locally * declared labels. The lookup name * for this category is "label foo" *) let env : (string, envdata * location) H.t = H.create 307 (* We also keep a global environment. This is always a subset of the env *) let genv : (string, envdata * location) H.t = H.create 307 (* In the scope we keep the original name, so we can remove them from the * hash table easily *) type undoScope = UndoRemoveFromEnv of string | UndoResetAlphaCounter of location AL.alphaTableData ref * location AL.alphaTableData | UndoRemoveFromAlphaTable of string let scopes : undoScope list ref list ref = ref [] (* When you add to env, you also add it to the current scope *) let addLocalToEnv (n: string) (d: envdata) = (*log "%a: adding local %s to env\n" d_loc !currentLoc n; *) H.add env n (d, CurrentLoc.get ()); (* If we are in a scope, then it means we are not at top level. Add the * name to the scope *) (match !scopes with [] -> begin match d with | EnvVar _ -> Kernel.fatal ~current:true "addLocalToEnv: not in a scope when adding %s!" n | _ -> () (* We might add types *) end | s :: _ -> s := (UndoRemoveFromEnv n) :: !s) let addGlobalToEnv (k: string) (d: envdata) : unit = (* ignore (E.log "%a: adding global %s to env\n" d_loc !currentLoc k); *) H.add env k (d, CurrentLoc.get ()); (* Also add it to the global environment *) H.add genv k (d, CurrentLoc.get ()) (* Create a new name based on a given name. The new name is formed from a * prefix (obtained from the given name as the longest prefix that ends with * a non-digit), followed by a '_' and then by a positive integer suffix. The * first argument is a table mapping name prefixes with the largest suffix * used so far for that prefix. The largest suffix is one when only the * version without suffix has been used. *) let alphaTable : (string, location AL.alphaTableData ref) H.t = H.create 307 (* vars and enum tags. For composite types we have names like "struct * foo" or "union bar" *) let fresh_global lookupname = fst (AL.newAlphaName alphaTable None lookupname (CurrentLoc.get ())) (* To keep different name scopes different, we add prefixes to names * specifying the kind of name: the kind can be one of "" for variables or * enum tags, "struct" for structures and unions (they share the name space), * "enum" for enumerations, or "type" for types *) let kindPlusName (kind: string) (origname: string) : string = if kind = "" then origname else kind ^ " " ^ origname let stripKind (kind: string) (kindplusname: string) : string = let l = 1 + String.length kind in if l > 1 then String.sub kindplusname l (String.length kindplusname - l) else kindplusname let newAlphaName (globalscope: bool) (* The name should have global scope *) (kind: string) (origname: string) : string * location = let lookupname = kindPlusName kind origname in (* If we are in a scope then it means that we are alpha-converting a local * name. Go and add stuff to reset the state of the alpha table but only to * the top-most scope (that of the enclosing function) *) let rec findEnclosingFun = function [] -> (* At global scope *)() | [s] -> begin let prefix = AL.getAlphaPrefix lookupname in try let countref = H.find alphaTable prefix in s := (UndoResetAlphaCounter (countref, !countref)) :: !s with Not_found -> s := (UndoRemoveFromAlphaTable prefix) :: !s end | _ :: rest -> findEnclosingFun rest in if not globalscope then findEnclosingFun !scopes; let newname, oldloc = AL.newAlphaName alphaTable None lookupname (CurrentLoc.get ()) in stripKind kind newname, oldloc (*** In order to process GNU_BODY expressions we must record that a given *** COMPUTATION is interesting *) let gnu_body_result : (A.statement * ((exp * typ) option ref)) ref = ref ({stmt_ghost = false; stmt_node = A.NOP (cabslu "_NOP")}, ref None) (*** When we do statements we need to know the current return type *) let dummy_function = emptyFunction "@dummy@" let currentReturnType : typ ref = ref (TVoid([])) let currentFunctionFDEC: fundec ref = ref dummy_function let lastStructId = ref 0 let anonStructName (k: string) (suggested: string) = incr lastStructId; "__anon" ^ k ^ (if suggested <> "" then "_" ^ suggested else "") ^ "_" ^ (string_of_int (!lastStructId)) let constrExprId = ref 0 let startFile () = H.clear env; H.clear genv; H.clear alphaTable; lastStructId := 0; ;; (* Lookup a variable name. Return also the location of the definition. Might * raise Not_found *) let lookupVar (n: string) : varinfo * location = match H.find env n with (EnvVar vi), loc -> vi, loc | _ -> raise Not_found let lookupGlobalVar (n: string) : varinfo * location = match H.find genv n with (EnvVar vi), loc -> vi, loc | _ -> raise Not_found let _docEnv () = let acc : (string * (envdata * location)) list ref = ref [] in let doone fmt = function EnvVar vi, l -> Format.fprintf fmt "Var(%s,global=%b) (at %a)" vi.vname vi.vglob Cil_printer.pp_location l | EnvEnum (_item), l -> Format.fprintf fmt "Enum (at %a)" Cil_printer.pp_location l | EnvTyp _t, _l -> Format.fprintf fmt "typ" | EnvLabel l, _ -> Format.fprintf fmt "label %s" l in H.iter (fun k d -> acc := (k, d) :: !acc) env; Pretty_utils.pp_list ~sep:"@\n" (fun fmt (k, d) -> Format.fprintf fmt " %s -> %a" k doone d) Format.std_formatter !acc (* Add a new variable. Do alpha-conversion if necessary *) let alphaConvertVarAndAddToEnv (addtoenv: bool) (vi: varinfo) : varinfo = (* ignore (E.log "%t: alphaConvert(addtoenv=%b) %s" d_thisloc addtoenv vi.vname); *) (* Announce the name to the alpha conversion table *) let newname, oldloc = newAlphaName (addtoenv && vi.vglob) "" vi.vname in (* Make a copy of the vi if the name has changed. Never change the name for * global variables *) let newvi = if vi.vname = newname then vi else begin if vi.vglob then begin (* Perhaps this is because we have seen a static local which happened * to get the name that we later want to use for a global. *) try let static_local_vi = H.find staticLocals vi.vname in H.remove staticLocals vi.vname; (* Use the new name for the static local *) static_local_vi.vname <- newname; (* And continue using the last one *) vi with Not_found -> begin (* Or perhaps we have seen a typedef which stole our name. This is possible because typedefs use the same name space *) try let typedef_ti = H.find typedefs vi.vname in H.remove typedefs vi.vname; (* Use the new name for the typedef instead *) typedef_ti.tname <- newname; (* And continue using the last name *) vi with Not_found -> Kernel.abort ~current:true "It seems that we would need to rename global %s (to %s) \ because of previous occurrence at %a" vi.vname newname Cil_printer.pp_location oldloc; end end else begin (* We have changed the name of a local variable. Can we try to detect * if the other variable was also local in the same scope? Not for * now. *) copyVarinfo vi newname end end in (* Store all locals in the slocals (in reversed order). We'll reverse them * and take out the formals at the end of the function *) if not vi.vglob then !currentFunctionFDEC.slocals <- newvi :: !currentFunctionFDEC.slocals; (if addtoenv then if vi.vglob then addGlobalToEnv vi.vname (EnvVar newvi) else addLocalToEnv vi.vname (EnvVar newvi)); (* ignore (E.log " new=%s\n" newvi.vname); *) (* ignore (E.log "After adding %s alpha table is: %a\n" newvi.vname docAlphaTable alphaTable); *) newvi let constFoldTypeVisitor = object inherit nopCilVisitor method vtype t: typ visitAction = match t with TArray(bt, Some len, _, a) -> let len' = constFold true len in ChangeDoChildrenPost ( TArray(bt, Some len', empty_size_cache (), a), (fun x -> x) ) | _ -> DoChildren end (* Const-fold any expressions that appear as array lengths in this type *) let constFoldType (t:typ) : typ = visitCilType constFoldTypeVisitor t (* Create a new temporary variable *) let newTempVar descr (descrpure:bool) typ = (* physical equality used on purpose here *) if !currentFunctionFDEC == dummy_function then Kernel.fatal ~current:true "newTempVar called outside a function" ; (* ignore (E.log "stripConstLocalType(%a) for temporary\n" d_type typ); *) let t' = (!typeForInsertedVar) (Cil.stripConstLocalType typ) in (* Start with the name "tmp". The alpha converter will fix it *) let vi = makeVarinfo false false "tmp" t' in vi.vdescr <- descr; vi.vdescrpure <- descrpure; (* Rename if clash, but do not add to the environment *) let vi = alphaConvertVarAndAddToEnv false vi in (* (* the temporary is local to the function: the normalization can use it wherever it wants. *) !currentFunctionFDEC.sbody.blocals <- vi :: !currentFunctionFDEC.sbody.blocals; *) vi let mkAddrOfAndMark loc ((b, off) as lval) : exp = (* Mark the vaddrof flag if b is a variable *) begin match lastOffset off with | NoOffset -> (match b with Var vi -> (* Do not mark arrays as having their address taken. *) if not (isArrayType vi.vtype) then vi.vaddrof <- true | _ -> ()) | Index _ -> () | Field(fi,_) -> fi.faddrof <- true end; mkAddrOf ~loc lval (* Call only on arrays *) let mkStartOfAndMark loc ((_b, _off) as lval) : exp = (* Mark the vaddrof flag if b is a variable *) (* Do not mark arrays as having their address taken. (match b with Var vi -> vi.vaddrof <- true | _ -> ()); *) let res = new_exp ~loc (StartOf lval) in res (* Keep a set of self compinfo for composite types *) let compInfoNameEnv : (string, compinfo) H.t = H.create 113 let enumInfoNameEnv : (string, enuminfo) H.t = H.create 113 let lookupTypeNoError (kind: string) (n: string) : typ * location = let kn = kindPlusName kind n in match H.find env kn with EnvTyp t, l -> t, l | _ -> raise Not_found let lookupType (kind: string) (n: string) : typ * location = try lookupTypeNoError kind n with Not_found -> Kernel.fatal ~current:true "Cannot find type %s (kind:%s)" n kind (* Create the self ref cell and add it to the map. Return also an indication * if this is a new one. *) let createCompInfo (iss: bool) (n: string) ~(norig: string) : compinfo * bool = (* Add to the self cell set *) let key = (if iss then "struct " else "union ") ^ n in try H.find compInfoNameEnv key, false (* Only if not already in *) with Not_found -> begin (* Create a compinfo. This will have "cdefined" false. *) let res = mkCompInfo iss n ~norig (fun _ -> []) [] in H.add compInfoNameEnv key res; res, true end (* Create the self ref cell and add it to the map. Return an indication * whether this is a new one. *) let createEnumInfo (n: string) ~(norig:string) : enuminfo * bool = (* Add to the self cell set *) try H.find enumInfoNameEnv n, false (* Only if not already in *) with Not_found -> begin (* Create a enuminfo *) let enum = { eorig_name = norig; ename = n; eitems = []; eattr = []; ereferenced = false; ekind = IInt ; } in H.add enumInfoNameEnv n enum; enum, true end (* kind is either "struct" or "union" or "enum" and n is a name *) let findCompType (kind: string) (n: string) (a: attributes) = let makeForward () = (* This is a forward reference, either because we have not seen this * struct already or because we want to create a version with different * attributes *) if kind = "enum" then let enum, isnew = createEnumInfo n n in if isnew then cabsPushGlobal (GEnumTagDecl (enum, CurrentLoc.get ())); TEnum (enum, a) else let iss = if kind = "struct" then true else false in let self, isnew = createCompInfo iss n ~norig:n in if isnew then cabsPushGlobal (GCompTagDecl (self, CurrentLoc.get ())); TComp (self, empty_size_cache (), a) in try let old, _ = lookupTypeNoError kind n in (* already defined *) let olda = typeAttrs old in let equal = try List.for_all2 Cil_datatype.Attribute.equal olda a with Invalid_argument _ -> false in if equal then old else makeForward () with Not_found -> makeForward () (* A simple visitor that searchs a statement for labels *) class canDropStmtClass pRes = object inherit nopCilVisitor method vstmt s = if s.labels != [] then (pRes := false; SkipChildren) else if !pRes then DoChildren else SkipChildren method vinst _ = SkipChildren method vexpr _ = SkipChildren end let canDropStatement (s: stmt) : bool = let pRes = ref true in let vis = new canDropStmtClass pRes in ignore (visitCilStmt vis s); !pRes (******** CASTS *********) let arithmeticConversion = Cil.arithmeticConversion let integralPromotion = Cil.integralPromotion (* true if the expression is known to be a boolean result, i.e. 0 or 1. *) let rec is_boolean_result e = match e.enode with | Const _ -> (match Cil.isInteger e with | Some i -> Integer.equal i Integer.zero || Integer.equal i Integer.one | None -> false) | CastE (_,e) -> is_boolean_result e | BinOp((Lt | Gt | Le | Ge | Eq | Ne | LAnd | LOr),_,_,_) -> true | BinOp((PlusA | PlusPI | IndexPI | MinusA | MinusPI | MinusPP | Mult | Div | Mod | Shiftlt | Shiftrt | BAnd | BXor | BOr),_,_,_) -> false | UnOp(LNot,_,_) -> true | UnOp ((Neg | BNot),_,_) -> false | Lval _ | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ | AddrOf _ | StartOf _ | Info _ -> false (* Specify whether the cast is from the source code *) let rec castTo ?(fromsource=false) (ot : typ) (nt : typ) (e : exp) : (typ * exp ) = let dkey = Kernel.register_category "typecheck:cast" in Kernel.debug ~dkey "@[%t: castTo:%s %a->%a@\n@]" Cil.pp_thisloc (if fromsource then "(source)" else "") Cil_printer.pp_typ ot Cil_printer.pp_typ nt; let ot' = unrollType ot in let nt' = unrollType nt in if not fromsource && not (need_cast ot' nt') then begin (* Do not put the cast if it is not necessary, unless it is from the * source. *) Kernel.debug ~dkey "no cast to perform"; (ot, e) end else begin let nt' = if fromsource then nt' else !typeForInsertedCast e ot' nt' in let result = (nt', if theMachine.insertImplicitCasts || fromsource then Cil.mkCastT ~force:true ~e ~oldt:ot ~newt:nt' else e) in let error s = (if fromsource then Kernel.abort else Kernel.fatal) ~current:true s in (* [BM] uncomment the following line to enable attributes static typing ignore (check_strict_attributes true ot nt && check_strict_attributes false nt ot);*) Kernel.debug ~dkey "@[castTo: ot=%a nt=%a\n result is %a@\n@]" Cil_printer.pp_typ ot Cil_printer.pp_typ nt' Cil_printer.pp_exp (snd result); (* Now see if we can have a cast here *) match ot', nt' with TNamed _, _ | _, TNamed _ -> Kernel.fatal ~current:true "unrollType failed in castTo" | _, TInt(IBool,_) -> if is_boolean_result e then result else nt, Cil.mkCastT (constFold true (new_exp ~loc:e.eloc (BinOp(Ne,e,Cil.integer ~loc:e.eloc 0,intType)))) ot nt' | TInt(_,_), TInt(_,_) -> (* We used to ignore attributes on integer-integer casts. Not anymore *) (* if ikindo = ikindn then (nt, e) else *) result | TPtr (_, _), TPtr(_, _) -> result | TInt _, TPtr _ -> result | TPtr _, TInt _ -> result | TArray _, TPtr _ -> result | TArray(t1,_,_,_), TArray(t2,None,_,_) when Cil_datatype.Typ.equal t1 t2 -> (nt', e) | TPtr _, TArray(_,_,_,_) -> error "Cast over a non-scalar type %a" Cil_printer.pp_typ nt'; | TEnum _, TInt _ -> result | TFloat _, (TInt _|TEnum _) -> result | (TInt _|TEnum _), TFloat _ -> result | TFloat _, TFloat _ -> result | TInt (ik,_), TEnum (ei,_) -> (match e.enode with | Const (CEnum { eihost = ei'}) when ei.ename = ei'.ename && not fromsource && Cil.bytesSizeOfInt ik = Cil.bytesSizeOfInt ei'.ekind -> (nt',e) | _ -> result) | TEnum _, TEnum _ -> result | TEnum _, TPtr _ -> result | TBuiltin_va_list _, (TInt _ | TPtr _) -> result | (TInt _ | TPtr _), TBuiltin_va_list _ -> Kernel.debug ~dkey "Casting %a to __builtin_va_list" Cil_printer.pp_typ ot ; result | TPtr _, TEnum _ -> Kernel.debug ~dkey "Casting a pointer into an enumeration type" ; result (* The expression is evaluated for its effects *) | (TInt _ | TEnum _ | TPtr _ ), TVoid _ -> Kernel.debug ~level:3 "Casting a value into void: expr is evaluated for side effects"; result (* Even casts between structs are allowed when we are only * modifying some attributes *) | TComp (comp1, _, _), TComp (comp2, _, _) when comp1.ckey = comp2.ckey -> result (** If we try to pass a transparent union value to a function * expecting a transparent union argument, the argument type would * have been changed to the type of the first argument, and we'll * see a cast from a union to the type of the first argument. Turn * that into a field access *) | TComp(_, _, _), _ -> begin match isTransparentUnion ot with | None -> Kernel.fatal ~current:true "castTo %a -> %a" Cil_printer.pp_typ ot Cil_printer.pp_typ nt' | Some fstfield -> begin (* We do it now only if the expression is an lval *) let e' = match e.enode with | Lval lv -> new_exp ~loc:e.eloc (Lval (addOffsetLval (Field(fstfield, NoOffset)) lv)) | _ -> Kernel.fatal ~current:true "castTo: transparent union expression is not an lval: %a\n" Cil_printer.pp_exp e in (* Continue casting *) castTo ~fromsource:fromsource fstfield.ftype nt' e' end end | _ -> error "cannot cast from %a to %a@\n" Cil_printer.pp_typ ot Cil_printer.pp_typ nt' end (* Like Cil.mkCastT, but it calls typeForInsertedCast *) let makeCastT ~(e: exp) ~(oldt: typ) ~(newt: typ) = if need_cast oldt newt then Cil.mkCastT e oldt (!typeForInsertedCast e oldt newt) else e let makeCast ~(e: exp) ~(newt: typ) = makeCastT e (typeOf e) newt (* A cast that is used for conditional expressions. Pointers are Ok. Abort if invalid *) let checkBool (ot : typ) (_ : exp) = match unrollType ot with | TInt _ | TPtr _ | TEnum _ | TFloat _ -> () | _ -> Kernel.fatal ~current:true "castToBool %a" Cil_printer.pp_typ ot (* Given an expression that is being coerced to bool, is it a nonzero constant? *) let rec isConstTrue (e:exp): bool = match e.enode with | Const(CInt64 (n,_,_)) -> not (Integer.equal n Integer.zero) | Const(CChr c) -> 0 <> Char.code c | Const(CStr _ | CWStr _) -> true | Const(CReal(f, _, _)) -> f <> 0.0; | CastE(_, e) -> isConstTrue e | _ -> false (* Given an expression that is being coerced to bool, is it zero? This is a more general version of Cil.isZero, which only handles integers. On constant expressions, either isConstTrue or isConstFalse will hold. *) let rec isConstFalse (e:exp): bool = match e.enode with | Const(CInt64 (n,_,_)) -> Integer.equal n Integer.zero | Const(CChr c) -> 0 = Char.code c | Const(CReal(f, _, _)) -> f = 0.0; | CastE(_, e) -> isConstFalse e | _ -> false let rec isCabsZeroExp e = match e.expr_node with | CAST (_, ie) -> (match ie with | SINGLE_INIT e -> isCabsZeroExp e | NO_INIT | COMPOUND_INIT _ -> false) | CONSTANT (CONST_INT i) -> Integer.is_zero (Cil.parseInt i) | _ -> false module BlockChunk = struct type chunk = { stmts: (stmt * lval list * lval list * lval list * stmt ref list) list; (* statements of the chunk. This list is built on reverse order. Each statements comes with the list of pending modified, written and read values. The first category represents values which are to be modified during the execution of the chunk and whose new value depends on the statement (hence, it is legal to read them). They are removed syntactically from the list of reads, but we keep them to avoid spurious warnings in presence of aliases. The order of the write is supposed to be fixed at this level. We also maintain a list of function calls inside the chunk. E.g. for G[i] = j, the written lval is G[i], and the read lval are G, i, and j. *) unspecified_order:bool; (* order of evaluation of statements in the chunk is unspecified. *) locals: varinfo list; (* variables that are local to the chunk. *) cases: stmt list; (* A list of case statements * (statements with Case labels) * visible at the outer level *) } let d_stmt_chunk fmt (s,modified,write,reads,calls) = Format.fprintf fmt "@[/*@[(%a) %a@ <-@ %a@]@;Calls:@;%a@;*/@;%a@]" (Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_lval) modified (Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_lval) write (Pretty_utils.pp_list ~sep:",@ " Cil_printer.pp_lval) reads (Pretty_utils.pp_list ~sep:",@ " (fun fmt x -> Cil_printer.pp_stmt fmt !x)) calls Cil_printer.pp_stmt s let d_chunk fmt (c: chunk) = Format.fprintf fmt "@[@[%a%a@]@;@[{%a@]}@]" (fun fmt b -> if b then Format.fprintf fmt "/* UNDEFINED ORDER */@\n") c.unspecified_order (Pretty_utils.pp_list ~sep:";" Cil_printer.pp_varinfo) c.locals (Pretty_utils.pp_list ~sep:";@\n" d_stmt_chunk) (List.rev c.stmts) let empty = { stmts = []; cases = []; locals = []; unspecified_order = false; } let empty_stmts l = let rec is_empty_stmt s = match s.skind with Instr (Skip _) -> true | Block b -> b.battrs = [] && List.for_all is_empty_stmt b.bstmts | UnspecifiedSequence seq -> List.for_all is_empty_stmt (List.map (fun (x,_,_,_,_) -> x) seq) | _ -> false in List.for_all is_empty_stmt (List.map (fun (x,_,_,_,_) -> x) l) let isEmpty c = empty_stmts c.stmts let isNotEmpty c = not (isEmpty c) let i2c (i,m,w,r) = let c = match i.skind with Instr(Call _) -> [ref i] | _ -> [] in { empty with stmts = [i,m,w,r,c]; } (* Keep track of the gotos *) let backPatchGotos : (string, stmt ref list ref) H.t = H.create 17 let addGoto (lname: string) (bref: stmt ref) : unit = let gotos = try H.find backPatchGotos lname with Not_found -> begin let gotos = ref [] in H.add backPatchGotos lname gotos; gotos end in gotos := bref :: !gotos (* Keep track of the labels *) let labelStmt : (string, stmt) H.t = H.create 17 let initLabels () = H.clear backPatchGotos; H.clear labelStmt let resolveGotos () = H.iter (fun lname gotos -> try let dest = H.find labelStmt lname in List.iter (fun gref -> gref := dest) !gotos; (* Format.eprintf "Label %s associated to %a@." lname d_stmt dest*) with Not_found -> begin Kernel.error ~once:true ~current:true "Label %s not found" lname end) backPatchGotos module Logic_labels = struct (* On the contrary to C, use of labels in the logic obeys block scope rules. We keep track of these scopes here. *) let labels: (string, stmt) H.t = H.create 7 (* label held by the current statement*) let label_current = ref [] let add_current_label s = label_current:= s :: !label_current let reset_current_label () = label_current := [] let scope = Stack.create () let enter_scope () = Stack.push (ref []) scope let exit_scope () = let scope_labels = Stack.pop scope in List.iter (H.remove labels) !scope_labels let add_label l stmt = let scope = Stack.top scope in scope := l::!scope; H.add labels l stmt let find_label s = try ref (H.find labels s) with Not_found when List.mem s !label_current -> let my_ref = ref (mkEmptyStmt ~loc:(cabslu "_find_label") ()) in addGoto s my_ref; my_ref end let add_label l labstmt = Logic_labels.add_label l labstmt; H.add labelStmt l labstmt (* transforms a chunk into a block. Note that if the chunk has its unspecified_order flag set, the resulting block contains a single UnspecifiedSequence statement. If the chunk consists in a single block, this block will get returned directly, unless collapse_block is set to false. *) let c2block ~ghost ?(collapse_block=true) (c: chunk) : block = if c.unspecified_order then { battrs = []; blocals = c.locals; bstmts = [mkStmt ~ghost (UnspecifiedSequence (List.rev c.stmts))]; } else match c.stmts with | [{ skind = Block b } as s,_,_,_,_] when collapse_block && s.labels = [] -> b.blocals <- c.locals @ b.blocals; b | stmts -> (* block has no locals by itself. We must add them now *) { blocals = c.locals; battrs = []; bstmts = List.rev_map (fun (s,_,_,_,_) -> s) stmts; } (* converts a chunk into a statement. *) let c2stmt ~ghost c = let kind = if c.unspecified_order then let kind = UnspecifiedSequence (List.rev c.stmts) in if c.locals <> [] then Block { battrs = []; blocals = c.locals; bstmts = [mkStmt ~ghost kind] } else kind else let block = c2block ~ghost c in Block block in mkStmt ~ghost kind let merge_effects (m1,w1,r1,c1) (m2,w2,r2,c2) = let add_uniq l x = if List.exists (Lval.equal x) l then l else x::l in List.fold_left add_uniq m1 m2, List.fold_left add_uniq w1 w2, List.fold_left add_uniq r1 r2, c1 @ c2 let get_chunk_effects c = List.fold_left (fun c (_,x,y,z,t) -> merge_effects c (x,y,z,t)) ([],[],[],[]) c.stmts let c2stmt_effect ~ghost c = let modified, writes, reads, calls = get_chunk_effects c in (c2stmt ~ghost c, modified, writes, reads, calls) let unspecified_chunk c = (* c *) (* to restore previous behavior (where unspecified evaluation order was not explicitly marked), comment out the line below and make unspecified_chunk the identity function. *) { c with unspecified_order = true } let local_var_chunk c v = { c with locals = v::c.locals } (* Add a statement at the end. Never refer to this statement again * after you call this *) let (+++) (c: chunk) (i,m,w,r) = let call = match i.skind with Instr (Call _) -> [ref i] | _ -> [] in {c with stmts = (i,m,w,r,call) :: c.stmts; } (* Append two chunks. Never refer to the original chunks after you call * this. And especially never share c2 with somebody else *) let (@@) (c1: chunk) (c2, ghost) = let r = if (c1.unspecified_order && c2.unspecified_order) || (not c1.unspecified_order && not c2.unspecified_order) then { stmts = c2.stmts @ c1.stmts; cases = c1.cases @ c2.cases; locals = c1.locals @ c2.locals; unspecified_order = c1.unspecified_order; } else match c2.stmts with [] -> c1 | [s] -> { stmts = s :: c1.stmts; cases = c1.cases @ c2.cases; locals = c1.locals @ c2.locals; unspecified_order = c1.unspecified_order; } | _ -> let locals = c1.locals @ c2.locals in (* the lifespan of the locals is the whole chunk, not just c2, which may be transformed artificially in a block at this point. *) let c2 = { c2 with locals = [] } in { stmts = c2stmt_effect ~ghost c2 :: c1.stmts; cases = c1.cases @ c2.cases; locals = locals; unspecified_order = c1.unspecified_order; } in (* Format.eprintf "Concat:@\n%a@\nWITH@\n%a@\nLEADS TO@\n%a@." d_chunk c1 d_chunk c2 d_chunk r; *) r let remove_reads lv c = (* Format.eprintf "Removing %a from chunk@\n%a@." d_lval lv d_chunk c; *) let remove_list = List.filter (fun x -> not (Cil.compareLval lv x)) in let remove_from_reads = List.map (fun (s,m,w,r,c) -> (s,lv::m,w,remove_list r,c)) in let res = { c with stmts = remove_from_reads c.stmts; } in (* Format.eprintf "Result is@\n%a@." d_chunk res; *) res let remove_effects_stmt (s,_,_,_,_) = (s,[],[],[],[]) let remove_effects c = { c with stmts = List.map remove_effects_stmt c.stmts } (* the chunks below are used in statements translation. Hence, their order of evaluation is always specified, and we can forget their effects. *) let skipChunk = empty (* return can be ghost but only in ghost functions *) let returnChunk ~ghost e (l: location) : chunk = { stmts = [ mkStmt ~ghost (Return(e, l)),[],[],[],[] ]; cases = []; locals = []; unspecified_order = false; } let ifChunk ~ghost be (l: location) (t: chunk) (e: chunk) : chunk = let effects_t = get_chunk_effects t in let effects_e = get_chunk_effects e in let (m,r,w,c) = merge_effects effects_t effects_e in let stmt = mkStmt ~ghost (If(be, c2block ~ghost t, c2block ~ghost e, l)) in { stmts = [ stmt ,m,r,w,c ]; cases = t.cases @ e.cases; locals = []; unspecified_order = false; } let keepPureExpr ~ghost e l = ifChunk ~ghost e l skipChunk skipChunk (* We can duplicate a chunk if it has a few simple statements, and if * it does not have cases *) let duplicateChunk (c: chunk) = (* raises Failure if you should not * duplicate this chunk *) if not (Kernel.AllowDuplication.get ()) then raise (Failure "cannot duplicate: disallowed by user"); if c.locals !=[] then raise (Failure "cannot duplicate: has locals"); if c.cases != [] then raise (Failure "cannot duplicate: has cases") else let pCount = ref 0 in let duplicate_stmt (s,m,w,r,c) = if s.labels != [] then raise (Failure "cannot duplicate: has labels"); (match s.skind with If _ | Switch _ | Loop _ | Block _ | UnspecifiedSequence _ | TryFinally _ | TryExcept _ -> raise (Failure "cannot duplicate: complex stmt") | Instr _ | Goto _ | Return _ | Break _ | Continue _ -> incr pCount); if !pCount > 5 then raise (Failure ("cannot duplicate: too many instr")); (* We can just copy it because there is nothing to share here. * Except maybe for the ref cell in Goto but it is Ok to share * that, I think *) let s' = { s with sid = s.sid} in let c = match s.skind with | Instr (Call _) -> [ref s'] | Instr _ | TryExcept (_, _, _, _)| TryFinally (_, _, _) | UnspecifiedSequence _| Block _| Loop (_, _, _, _, _) | Switch (_, _, _, _)| If (_, _, _, _)| Continue _| Break _ | Goto (_, _)| Return (_, _) -> assert (c = []); [] in (s',m,w,r,c) in { stmts = List.map duplicate_stmt c.stmts; cases = []; unspecified_order = c.unspecified_order; locals = c.locals; (* varinfos must be shared anyway. *) } (* We can drop a chunk if it does not have labels inside *) let canDrop (c: chunk) = List.for_all (fun (s,_,_,_,_) -> canDropStatement s) c.stmts let loopChunk ~ghost a (body: chunk) : chunk = (* Make the statement *) let loop = mkStmt ~ghost (Loop (a,c2block ~ghost body, CurrentLoc.get (), None, None)) in { stmts = [ loop,[],[],[],[] ]; cases = body.cases; unspecified_order = false; locals = []; } (* can be ghost inside a ghost loop *) let breakChunk ~ghost (l: location) : chunk = { stmts = [ mkStmt ~ghost (Break l),[],[],[],[] ]; cases = []; unspecified_order = false; locals = []; } (* can be ghost inside a ghost loop *) let continueChunk ~ghost (l: location) : chunk = { stmts = [ mkStmt ~ghost (Continue l),[],[],[],[] ]; cases = []; unspecified_order = false; locals = []; } (* Get the first statement in a chunk. Might need to change the * statements in the chunk *) let getFirstInChunk ~ghost ~loc c = (* Get the first statement and add the label to it *) match c.stmts with | [] -> (* Add a statement *) let n = mkEmptyStmt ~ghost ~loc () in n, [n,[],[],[],[]] | s -> let (st,_,_,_,_) = Extlib.last s in st,s (* s2c must not be used during expression translation, as it does not take care of the effects of the statement. Use i2c instead. *) let s2c (s:stmt) : chunk = { stmts = [ s,[],[],[],[] ]; cases = []; unspecified_order = false; locals = []; } let gotoChunk ~ghost (ln: string) (l: location) : chunk = let gref = ref dummyStmt in addGoto ln gref; { stmts = [ mkStmt ~ghost (Goto (gref, l)),[],[],[],[] ]; cases = []; locals = []; unspecified_order = false; } let caseRangeChunk ~ghost el loc (next: chunk) = let fst, stmts' = getFirstInChunk ~ghost ~loc next in let labels = List.map (fun e -> Case (e, loc)) el in fst.labels <- labels @ fst.labels; { next with stmts = stmts'; cases = fst :: next.cases; unspecified_order = false } let defaultChunk ~ghost loc (next: chunk) = let fst, stmts' = getFirstInChunk ~ghost ~loc next in let lb = Default loc in fst.labels <- lb :: fst.labels; { next with stmts = stmts'; cases = fst :: next.cases; unspecified_order = false } let switchChunk ~ghost (e: exp) (body: chunk) (l: location) = (* Make the statement *) let defaultSeen = ref false in let t = typeOf e in let checkForDefaultAndCast lb = match lb with | Default _ as d -> if !defaultSeen then Kernel.error ~once:true ~current:true "Switch statement at %a has duplicate default entries." Cil_printer.pp_location l; defaultSeen := true; d | Label _ as l -> l | Case (e, loc) -> (* If needed, convert e to type t, and check in case the label was too big *) let e' = makeCast ~e ~newt:t in let constFold = constFold false in let e'' = if theMachine.lowerConstants then constFold e' else e' in (match (constFold e).enode, (constFold e'').enode with | Const(CInt64(i1, _, _)), Const(CInt64(i2, _, _)) when not (Integer.equal i1 i2) -> Kernel.warning ~source:(fst e.eloc) "Case label %a exceeds range for switch expression" Cil_printer.pp_exp e; | _ -> () ); Case (e'', loc) in let block = c2block ~ghost body in let cases = (* eliminate duplicate entries from body.cases. A statement is added to body.cases for each case label it has. *) List.fold_right (fun s acc -> if List.memq s acc then acc else begin s.labels <- List.map checkForDefaultAndCast s.labels; s::acc end) body.cases [] in let switch = mkStmt ~ghost (Switch (e, block, cases, l)) in { stmts = [ switch,[],[],[],[] ]; cases = []; locals = []; unspecified_order = false; } exception Found let find_stmt b l s = let find = object inherit Cil.nopCilVisitor method vstmt s' = if s == s' then begin (*Format.eprintf "Label %s is in the AST@." l;*) raise Found end else DoChildren end in try ignore (visitCilBlock find b); Kernel.warning ~current:true "Inconsistent AST: Statement %a,@ with label %s is not in the AST" Cil_printer.pp_stmt s l; with Found -> () class cleanUnspecified = object(self) inherit nopCilVisitor val unspecified_stack = Stack.create () val mutable replace_table = [] (* we start in a deterministic block. *) initializer Stack.push false unspecified_stack method private push: 'a.bool->'a->'a visitAction = fun flag x -> Stack.push flag unspecified_stack; ChangeDoChildrenPost (x,fun x -> ignore(Stack.pop unspecified_stack); x) method vblock b = b.bstmts <- List.rev (List.fold_left( fun res s -> match s.skind with Block b when (not (Stack.top unspecified_stack)) && b.battrs = [] && b.blocals = [] && s.labels = [] -> List.rev_append b.bstmts res | _ -> s ::res) [] b.bstmts); DoChildren method vstmt s = let change_label_stmt s s' = List.iter (function | Label (x,_,_) -> H.replace labelStmt x s' | Case _ | Default _ -> replace_table <- (s, s') :: replace_table ) s.labels; s'.labels <- s.labels @ s'.labels in match s.skind with UnspecifiedSequence [s',_,_,_,_] -> change_label_stmt s s'; ChangeDoChildrenPost(s', fun x -> x) | UnspecifiedSequence [] -> let s' = mkEmptyStmt ~loc:(cabslu "_useq") () in change_label_stmt s s'; ChangeTo s'; | UnspecifiedSequence _ -> self#push true s | Block { battrs = []; blocals = []; bstmts = [s']} -> change_label_stmt s s'; ChangeDoChildrenPost (s', fun x -> x) | Block _ | If _ | Loop _ | TryFinally _ | TryExcept _ -> self#push false s | Switch _ -> let change_cases stmt = match stmt.skind with | Switch(e,body,cases,loc) -> let newcases = List.map (fun s -> try List.assq s replace_table with Not_found -> s) cases in stmt.skind <- Switch(e,body,newcases,loc); ignore (Stack.pop unspecified_stack); stmt | _ -> assert false in Stack.push false unspecified_stack; ChangeDoChildrenPost(s,change_cases) | Instr _ | Return _ | Goto _ | Break _ | Continue _ -> DoChildren end let mkFunctionBody ~ghost (c: chunk) : block = if c.cases <> [] then Kernel.error ~once:true ~current:true "Switch cases not inside a switch statement\n"; (* cleanup empty blocks and unspecified sequences. This can change some labels (the one attached to removed blocks), so it has to be done before resolveGotos. *) let res = visitCilBlock (new cleanUnspecified) (c2block ~ghost c) in H.iter (find_stmt res) labelStmt; resolveGotos (); initLabels (); res let add_reads loc r c = match r with | [] -> c | _ :: _ -> c +++ (mkEmptyStmt ~loc (), [],[], r) end open BlockChunk (* To avoid generating backward gotos, we treat while loops as non-while ones, * adding a marker for continue. (useful for Jessie) *) let doTransformWhile = ref false let setDoTransformWhile () = doTransformWhile := true (* To avoid generating forward ingoing gotos, we translate conditionals in * an alternate way. (useful for Jessie) *) let doAlternateConditional = ref false let setDoAlternateConditional () = doAlternateConditional := true (************ Labels ***********) (* Since we turn dowhile and for loops into while we need to take care in * processing the continue statement. For each loop that we enter we place a * marker in a list saying what kinds of loop it is. When we see a continue * for a Non-while loop we must generate a label for the continue *) type loopstate = While of string ref | NotWhile of string ref let continues : loopstate list ref = ref [] (* Sometimes we need to create new label names *) let newLabelName (base: string) = fst (newAlphaName false "label" base) let continueOrLabelChunk ~ghost (l: location) : chunk = match !continues with | [] -> Kernel.abort ~current:true "continue not in a loop" | While lr :: _ -> if !doTransformWhile then begin if !lr = "" then begin lr := newLabelName "__Cont" end; gotoChunk ~ghost !lr l end else continueChunk ~ghost l | NotWhile lr :: _ -> if !lr = "" then begin lr := newLabelName "__Cont" end; gotoChunk ~ghost !lr l (* stack of statements inside which break instruction can be found. *) let break_env = Stack.create () let enter_break_env () = Stack.push () break_env let breakChunk ~ghost l = if Stack.is_empty break_env then Kernel.abort ~current:true "break outside of a loop or switch"; breakChunk ~ghost l let exit_break_env () = if Stack.is_empty break_env then Kernel.fatal ~current:true "trying to exit a breakable env without having entered it"; ignore (Stack.pop break_env) (* In GCC we can have locally declared labels. *) let genNewLocalLabel (l: string) = (* Call the newLabelName to register the label name in the alpha conversion * table. *) let l' = newLabelName l in (* Add it to the environment *) addLocalToEnv (kindPlusName "label" l) (EnvLabel l'); l' let lookupLabel (l: string) = try match H.find env (kindPlusName "label" l) with EnvLabel l', _ -> l' | _ -> raise Not_found with Not_found -> l class gatherLabelsClass : V.cabsVisitor = object (self) inherit V.nopCabsVisitor (* We have to know if a label is local to know if it is an error if * another label with the same name exists. But a local label can be * declared multiple times at different nesting depths. Since a * Hashtbl can maintain multiple mappings, we add and remove local * labels as we visit their blocks. We map each local label to a * location option indicating where it was defined (if it has been). * This enables us to raise an error if a local label is defined * twice, and we can issue warnings if local labels are declared but * never defined. *) val localLabels : (string, location option) H.t = H.create 5 method private addLocalLabels blk = List.iter (fun lbl -> H.add localLabels lbl None) blk.blabels method private removeLocalLabels blk = List.iter (fun lbl -> if H.find localLabels lbl = None then Kernel.warning ~current:true "Local label %s declared but not defined" lbl; H.remove localLabels lbl) blk.blabels method vblock blk = (* Add the local labels, process the block, then remove the local labels *) self#addLocalLabels blk; ChangeDoChildrenPost (blk, fun _ -> (self#removeLocalLabels blk; blk)) method vstmt s = CurrentLoc.set (get_statementloc s); (match s.stmt_node with | LABEL (lbl,_,_) -> (try (match H.find localLabels lbl with | Some oldloc -> Kernel.error ~once:true ~current:true "Duplicate local label '%s' (previous definition was at %a)" lbl Cil_printer.pp_location oldloc | None -> (* Mark this label as defined *) H.replace localLabels lbl (Some (CurrentLoc.get()))) with Not_found -> (* lbl is not a local label *) let newname, oldloc = newAlphaName false "label" lbl in if newname <> lbl then Kernel.error ~once:true ~current:true "Duplicate label '%s' (previous definition was at %a)" lbl Cil_printer.pp_location oldloc) | _ -> ()); DoChildren end (* Enter all the labels into the alpha renaming table to prevent duplicate labels when unfolding short-circuiting logical operators and when creating labels for (some) continue statements. *) class registerLabelsVisitor = object inherit V.nopCabsVisitor method vstmt s = let currentLoc = convLoc (C.get_statementloc s) in (match s.stmt_node with | A.LABEL (lbl,_,_) -> AL.registerAlphaName alphaTable None (kindPlusName "label" lbl) currentLoc | _ -> ()); DoChildren end (** ALLOCA ***) let allocaFun () = if theMachine.msvcMode then begin let name = "alloca" in let fdec = emptyFunction name in fdec.svar.vtype <- TFun(voidPtrType, Some [ ("len", theMachine.typeOfSizeOf, []) ], false, []); fdec.svar end else (* Use __builtin_alloca where possible, because this can be used even when gcc is invoked with -fno-builtin *) let alloca, _ = lookupGlobalVar "__builtin_alloca" in alloca (* Maps local variables that are variable sized arrays to the expression that * denotes their length *) let varSizeArrays : exp IH.t = IH.create 17 (**** EXP actions ***) type expAction = ADrop (* Drop the result. Only the * side-effect is interesting *) | AType (* Only the type of the result is interesting. *) | ASet of bool * lval * lval list * typ (* Put the result in a given lval, * provided it matches the type. The * type is the type of the lval. * the flag indicates whether this * should be considered in the * effects of current * chunk. * The lval list is the list of location that are read to evaluate * the location of the lval. * The location of lval is guaranteed * not to depend on its own value, * e.g. p[p[0]] when p[0] is initially * 0, so the location won't change * after assignment. *) | AExp of typ option (* Return the exp as usual. * Optionally we can specify an * expected type. This is useful for * constants. The expected type is * informational only, we do not * guarantee that the converted * expression has that type.You must * use a doCast afterwards to make * sure. *) | AExpLeaveArrayFun (* Do it like an expression, but do * not convert arrays of functions * into pointers *) (*** Result of compiling conditional expressions *) type condExpRes = CEExp of chunk * exp (* Do a chunk and then an expression *) | CEAnd of condExpRes * condExpRes | CEOr of condExpRes * condExpRes | CENot of condExpRes (* We have our own version of addAttributes that does not allow duplicates *) let cabsAddAttributes al0 (al: attributes) : attributes = if al0 == [] then al else List.fold_left (fun acc (Attr(an, _) | AttrAnnot an as a) -> (* See if the attribute is already in there *) match filterAttributes an acc with [] -> addAttribute a acc (* Nothing with that name *) | a' :: _ -> if Cil_datatype.Attribute.equal a a' then acc (* Already in *) else begin Kernel.debug ~level:3 "Duplicate attribute %a along with %a" Cil_printer.pp_attribute a Cil_printer.pp_attribute a' ; (* let acc' = dropAttribute an acc in *) (** Keep both attributes *) addAttribute a acc end) al al0 (* BY: nothing cabs here, plus seems to duplicate most of Cil.typeAddAttributes *) let rec cabsTypeAddAttributes a0 t = begin match a0 with | [] -> (* no attributes, keep same type *) t | _ -> (* anything else: add a0 to existing attributes *) let add (a: attributes) = cabsAddAttributes a0 a in match t with TVoid a -> TVoid (add a) | TInt (ik, a) -> (* Here we have to watch for the mode attribute *) (* sm: This stuff is to handle a GCC extension where you can request integers*) (* of specific widths using the "mode" attribute syntax; for example: *) (* typedef int int8_t __attribute__ ((__mode__ ( __QI__ ))) ; *) (* The cryptic "__QI__" defines int8_t to be 8 bits wide, instead of the *) (* 32 bits you'd guess if you didn't know about "mode". The relevant *) (* testcase is test/small2/mode_sizes.c, and it was inspired by my *) (* /usr/include/sys/types.h. *) (* *) (* A consequence of this handling is that we throw away the mode *) (* attribute, which we used to go out of our way to avoid printing anyway.*) let ik', a0' = (* Go over the list of new attributes and come back with a * filtered list and a new integer kind *) List.fold_left (fun (ik', a0') a0one -> match a0one with Attr("mode", [ACons(mode,[])]) -> begin (* (trace "gccwidth" (dprintf "I see mode %s applied to an int type\n" mode )); *) (* the cases below encode the 32-bit assumption.. *) match (ik', mode) with | (IInt, "__QI__") -> (IChar, a0') | (IInt, "__byte__") -> (IChar, a0') | (IInt, "__HI__") -> (IShort, a0') | (IInt, "__SI__") -> (IInt, a0') (* same as t *) | (IInt, "__word__") -> (IInt, a0') | (IInt, "__pointer__") -> (IInt, a0') | (IInt, "__DI__") -> (ILongLong, a0') | (IUInt, "__QI__") -> (IUChar, a0') | (IUInt, "__byte__") -> (IUChar, a0') | (IUInt, "__HI__") -> (IUShort, a0') | (IUInt, "__SI__") -> (IUInt, a0') | (IUInt, "__word__") -> (IUInt, a0') | (IUInt, "__pointer__")-> (IUInt, a0') | (IUInt, "__DI__") -> (IULongLong, a0') | _ -> Kernel.error ~once:true ~current:true "GCC width mode %s applied to unexpected type, \ or unexpected mode" mode; (ik', a0one :: a0') end | _ -> (ik', a0one :: a0')) (ik, []) a0 in TInt (ik', cabsAddAttributes a0' a) | TFloat (fk, a) -> TFloat (fk, add a) | TEnum (enum, a) -> TEnum (enum, add a) | TPtr (t, a) -> TPtr (t, add a) | TFun (t, args, isva, a) -> TFun(t, args, isva, add a) | TComp (comp, s, a) -> TComp (comp, s, add a) | TNamed (t, a) -> TNamed (t, add a) | TBuiltin_va_list a -> TBuiltin_va_list (add a) | TArray (t, l, s, a) -> let att_elt, att_typ = Cil.splitArrayAttributes a0 in TArray (cabsArrayPushAttributes att_elt t, l, s, cabsAddAttributes att_typ a) end and cabsArrayPushAttributes al = function | TArray (bt, l, s, a) -> TArray (cabsArrayPushAttributes al bt, l, s, a) | t -> cabsTypeAddAttributes al t (* Do types *) (* Combine the types. Raises the Failure exception with an error message. * isdef says whether the new type is for a definition *) type combineWhat = CombineFundef of bool (* The new definition is for a function definition. The old * is for a prototype. arg is [true] for an old-style declaration *) | CombineFunarg of bool (* Comparing a function argument type with an old prototype argument. arg is [true] for an old-style declaration, which triggers some ad'hoc treatment in GCC mode. *) | CombineFunret (* Comparing the return of a function with that from an old * prototype *) | CombineOther (* We sometimes want to succeed in combining two structure types that are * identical except for the names of the structs. We keep a list of types * that are known to be equal *) let isomorphicStructs : (string * string, bool) H.t = H.create 15 let rec combineTypes (what: combineWhat) (oldt: typ) (t: typ) : typ = match oldt, t with | TVoid olda, TVoid a -> TVoid (cabsAddAttributes olda a) | TInt (oldik, olda), TInt (ik, a) -> let combineIK oldk k = if oldk = k then oldk else (match what with | CombineFunarg b when not theMachine.msvcMode && oldk = IInt && sizeOf_int t <= (bytesSizeOfInt IInt) && b -> (* GCC allows a function definition to have a more precise integer * type than a prototype that says "int" *) k | _ -> raise (Failure "different integer types")) in TInt (combineIK oldik ik, cabsAddAttributes olda a) | TFloat (oldfk, olda), TFloat (fk, a) -> let combineFK oldk k = if oldk = k then oldk else ( match what with | CombineFunarg b when not theMachine.msvcMode && oldk = FDouble && k = FFloat && b -> (* GCC allows a function definition to have a more precise float * type than a prototype that says "double" *) k | _ -> raise (Failure "different floating point types")) in TFloat (combineFK oldfk fk, cabsAddAttributes olda a) | TEnum (_, olda), TEnum (ei, a) -> TEnum (ei, cabsAddAttributes olda a) (* Strange one. But seems to be handled by GCC *) | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei, cabsAddAttributes olda a) (* Strange one. But seems to be handled by GCC *) | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, cabsAddAttributes olda a) | TComp (oldci, _, olda) , TComp (ci, _, a) -> if oldci.cstruct <> ci.cstruct then raise (Failure "different struct/union types"); let comb_a = cabsAddAttributes olda a in if oldci.cname = ci.cname then TComp (oldci, empty_size_cache (), comb_a) else (* Now maybe they are actually the same *) if H.mem isomorphicStructs (oldci.cname, ci.cname) then (* We know they are the same *) TComp (oldci, empty_size_cache (), comb_a) else begin (* If one has 0 fields (undefined) while the other has some fields * we accept it *) let oldci_nrfields = List.length oldci.cfields in let ci_nrfields = List.length ci.cfields in if oldci_nrfields = 0 then TComp (ci, empty_size_cache (), comb_a) else if ci_nrfields = 0 then TComp (oldci, empty_size_cache (), comb_a) else begin (* Make sure that at least they have the same number of fields *) if oldci_nrfields <> ci_nrfields then begin (* ignore (E.log "different number of fields: %s had %d and %s had %d\n" oldci.cname oldci_nrfields ci.cname ci_nrfields); *) raise (Failure "different structs(number of fields)"); end; (* Assume they are the same *) H.add isomorphicStructs (oldci.cname, ci.cname) true; H.add isomorphicStructs (ci.cname, oldci.cname) true; (* Check that the fields are isomorphic and watch for Failure *) (try List.iter2 (fun oldf f -> if oldf.fbitfield <> f.fbitfield then raise (Failure "different structs(bitfield info)"); if oldf.fattr <> f.fattr then raise (Failure "different structs(field attributes)"); (* Make sure the types are compatible *) ignore (combineTypes CombineOther oldf.ftype f.ftype); ) oldci.cfields ci.cfields with Failure _ as e -> begin (* Our assumption was wrong. Forget the isomorphism *) Kernel.debug "Failed in our assumption that %s and %s are isomorphic" oldci.cname ci.cname ; H.remove isomorphicStructs (oldci.cname, ci.cname); H.remove isomorphicStructs (ci.cname, oldci.cname); raise e end); (* We get here if we succeeded *) TComp (oldci, empty_size_cache (), comb_a) end end | TArray (oldbt, oldsz, _, olda), TArray (bt, sz, _, a) -> let newbt = combineTypes CombineOther oldbt bt in let newsz = match oldsz, sz with None, Some _ -> sz | Some _, None -> oldsz | None, None -> sz | Some oldsz', Some sz' -> (* They are not structurally equal. But perhaps they are equal if * we evaluate them. Check first machine independent comparison *) let checkEqualSize (machdep: bool) = compareExp (constFold machdep oldsz') (constFold machdep sz') in if checkEqualSize false then oldsz else if checkEqualSize true then begin Kernel.warning ~current:true "Array type comparison succeeds only based on machine-dependent \ constant evaluation: %a and %a\n" Cil_printer.pp_exp oldsz' Cil_printer.pp_exp sz' ; oldsz end else raise (Failure "different array lengths") in TArray (newbt, newsz, empty_size_cache (), cabsAddAttributes olda a) | TPtr (oldbt, olda), TPtr (bt, a) -> TPtr (combineTypes CombineOther oldbt bt, cabsAddAttributes olda a) | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) -> let rt_what = match what with | CombineFundef _ -> CombineFunret | _ -> CombineOther in let newrt = combineTypes rt_what oldrt rt in if oldva != va then raise (Failure "different vararg specifiers"); (* If one does not have arguments, believe the one with the * arguments *) let newargs, olda' = if oldargs = None then args, olda else if args = None then oldargs, olda else let oldargslist = argsToList oldargs in let argslist = argsToList args in if List.length oldargslist <> List.length argslist then raise (Failure "different number of arguments") else begin (* Construct a mapping between old and new argument names. *) let map = H.create 5 in List.iter2 (fun (on, _, _) (an, _, _) -> H.replace map on an) oldargslist argslist; (* Go over the arguments and update the old ones with the * adjusted types *) (* Format.printf "new type is %a@." Cil_printer.pp_typ t; *) let what = match what with CombineFundef b -> CombineFunarg b | _ -> CombineOther in Some (List.map2 (fun (on, ot, oa) (an, at, aa) -> (* Update the names. Always prefer the new name. This is * very important if the prototype uses different names than * the function definition. *) let n = if an <> "" then an else on in let t = combineTypes what ot at in let a = addAttributes oa aa in (n, t, a)) oldargslist argslist), olda end in (* Drop missingproto as soon as one of the type is a properly declared one*) let olda = if not (Cil.hasAttribute "missingproto" a) then Cil.dropAttribute "missingproto" olda' else olda' in let a = if not (Cil.hasAttribute "missingproto" olda') then Cil.dropAttribute "missingproto" a else a in TFun (newrt, newargs, oldva, cabsAddAttributes olda a) | TNamed (oldt, olda), TNamed (t, a) when oldt.tname = t.tname -> TNamed (oldt, cabsAddAttributes olda a) | TBuiltin_va_list olda, TBuiltin_va_list a -> TBuiltin_va_list (cabsAddAttributes olda a) (* Unroll first the new type *) | _, TNamed (t, a) -> let res = combineTypes what oldt t.ttype in cabsTypeAddAttributes a res (* And unroll the old type as well if necessary *) | TNamed (oldt, a), _ -> let res = combineTypes what oldt.ttype t in cabsTypeAddAttributes a res | _ -> raise (Failure "different type constructors") let compatibleTypes t1 t2 = let cleanup () = H.clear isomorphicStructs in try let r = combineTypes CombineOther t1 t2 in cleanup (); r with Failure _ as e -> cleanup (); raise e let extInlineSuffRe = Str.regexp "\\(.+\\)__extinline" (* Create and cache varinfo's for globals. Starts with a varinfo but if the * global has been declared already it might come back with another varinfo. * Returns the varinfo to use (might be the old one), and an indication * whether the variable exists already in the environment *) let makeGlobalVarinfo (isadef: bool) (vi: varinfo) : varinfo * bool = try (* See if already defined, in the global environment. We could also * look it up in the whole environment but in that case we might see a * local. This can happen when we declare an extern variable with * global scope but we are in a local scope. *) (* We lookup in the environement. If this is extern inline then the name * was already changed to foo__extinline. We lookup with the old name *) let lookupname = if vi.vstorage = Static then if Str.string_match extInlineSuffRe vi.vname 0 then let no_extinline_name = Str.matched_group 1 vi.vname in if no_extinline_name=vi.vorig_name then no_extinline_name else vi.vname else vi.vname else vi.vname in Kernel.debug "makeGlobalVarinfo isadef=%b vi.vname=%s (lookup = %s)" isadef vi.vname lookupname; (* This may throw an exception Not_found *) let oldvi, oldloc = lookupGlobalVar lookupname in Kernel.debug " %s(%d) already in the env at loc %a" vi.vname oldvi.vid Cil_printer.pp_location oldloc; (* It was already defined. We must reuse the varinfo. But clean up the * storage. *) let newstorage = (** See 6.2.2 *) match oldvi.vstorage, vi.vstorage with (* Extern and something else is that thing *) | Extern, other | other, Extern -> other | NoStorage, other | other, NoStorage -> other | _ -> if vi.vstorage != oldvi.vstorage then Kernel.warning ~current:true "Inconsistent storage specification for %s. \ Previous declaration: %a" vi.vname Cil_printer.pp_location oldloc; vi.vstorage in oldvi.vinline <- oldvi.vinline || vi.vinline; oldvi.vstorage <- newstorage; (* If the new declaration has a section attribute, remove any * preexisting section attribute. This mimics behavior of gcc that is * required to compile the Linux kernel properly. *) if hasAttribute "section" vi.vattr then oldvi.vattr <- dropAttribute "section" oldvi.vattr; (* Union the attributes *) oldvi.vattr <- cabsAddAttributes oldvi.vattr vi.vattr; begin try let what = if isadef then CombineFundef (hasAttribute "FC_OLDSTYLEPROTO" vi.vattr) else CombineOther in let mytype = combineTypes what oldvi.vtype vi.vtype in if not (Cil_datatype.Typ.equal oldvi.vtype vi.vtype) then DifferentDeclHook.apply (oldvi,vi); oldvi.vtype <- mytype with Failure reason -> Kernel.debug "old type = %a\nnew type = %a\n" Cil_printer.pp_typ oldvi.vtype Cil_printer.pp_typ vi.vtype ; Kernel.error ~once:true ~current:true "Declaration of %s does not match previous declaration from %a (%s)." vi.vname Cil_printer.pp_location oldloc reason; IncompatibleDeclHook.apply (oldvi,vi,reason) end; (* Found an old one. Keep the location always from the definition *) if isadef then begin oldvi.vdecl <- vi.vdecl; end; (* Let's mutate the formals vid's name attribute and type for function prototypes. Logic specifications refer to the varinfo in this table. *) begin match vi.vtype with | TFun (_,Some formals , _, _ ) -> (try let old_formals_env = getFormalsDecl oldvi in List.iter2 (fun old (name,typ,attr) -> if name <> "" then begin Kernel.debug "replacing formal %s with %s" old.vname name; old.vname <- name; old.vtype <- typ; old.vattr <- attr; (match old.vlogic_var_assoc with None -> () | Some old_lv -> old_lv.lv_name <- name; old_lv.lv_type <- Ctype typ;) end) old_formals_env formals; with | Invalid_argument "List.iter2" -> Kernel.abort "Inconsistent formals" ; | Not_found -> Cil.setFormalsDecl oldvi vi.vtype) | _ -> () end ; (* update the field [vdefined] *) if isadef then oldvi.vdefined <- true; (* the *immutable* vgenerated field in oldvi cannot be updated. We assume that all Frama-C builtins bear the FC_BUILTIN attribute - and thus are translated into variables with vgenerated fields at [true]. *) oldvi, true with Not_found -> begin (* A new one. *) Kernel.debug " %s not in the env already" vi.vname; (* Announce the name to the alpha conversion table. This will not * actually change the name of the vi. See the definition of * alphaConvertVarAndAddToEnv *) let vi = alphaConvertVarAndAddToEnv true vi in (* update the field [vdefined] *) if isadef then vi.vdefined <- true; vi.vattr <- dropAttribute "FC_OLDSTYLEPROTO" vi.vattr; vi, false end let conditionalConversion (t2: typ) (t3: typ) : typ = let tresult = (* ISO 6.5.15 *) match unrollType t2, unrollType t3 with (TInt _ | TEnum _ | TFloat _), (TInt _ | TEnum _ | TFloat _) -> arithmeticConversion t2 t3 | TComp (comp2,_,_), TComp (comp3,_,_) when comp2.ckey = comp3.ckey -> t2 | TPtr(_, _), TPtr(TVoid _, _) -> t2 | TPtr(TVoid _, _), TPtr(_, _) -> t3 | TPtr _, TPtr _ when Cil_datatype.Typ.equal t2 t3 -> t2 | TPtr _, TInt _ -> t2 (* most likely comparison with 0 *) | TInt _, TPtr _ -> t3 (* most likely comparison with 0 *) (* When we compare two pointers of diffent type, we combine them * using the same algorithm when combining multiple declarations of * a global *) | (TPtr _) as t2', (TPtr _ as t3') -> begin try combineTypes CombineOther t2' t3' with Failure msg -> begin Kernel.warning ~current:true "A.QUESTION: %a does not match %a (%s)" Cil_printer.pp_typ (unrollType t2) Cil_printer.pp_typ (unrollType t3) msg; t2 (* Just pick one *) end end | _, _ -> Kernel.fatal ~current:true "invalid implicit conversion from %a to %a" Cil_printer.pp_typ t2 Cil_printer.pp_typ t3 in tresult let logicConditionalConversion t1 t2 = match unrollType t1, unrollType t2 with | TPtr _ , TInt _ | TInt _, TPtr _ -> Kernel.fatal ~current:true "invalid implicit conversion from %a to %a" Cil_printer.pp_typ t2 Cil_printer.pp_typ t1 | _ -> conditionalConversion t1 t2 (* Some utilitites for doing initializers *) let debugInit = true type preInit = | NoInitPre | SinglePre of exp | CompoundPre of int ref (* the maximum used index *) * preInit array ref (* an array with initializers *) (* Set an initializer *) let rec setOneInit (this: preInit) (o: offset) (e: exp) : preInit = match o with NoOffset -> SinglePre e | _ -> let idx, (* Index in the current comp *) restoff (* Rest offset *) = match o with | Index({enode = Const(CInt64(i,_,_))}, off) -> Integer.to_int i, off | Field (f, off) -> (* Find the index of the field *) let rec loop (idx: int) = function | [] -> Kernel.abort ~current:true "Cannot find field %s" f.fname | f' :: _ when f'.fname = f.fname -> idx | _ :: restf -> loop (idx + 1) restf in loop 0 f.fcomp.cfields, off | _ -> Kernel.abort ~current:true "setOneInit: non-constant index" in let pMaxIdx, pArray = match this with NoInitPre -> (* No initializer so far here *) ref idx, ref (Array.create (max 32 (idx + 1)) NoInitPre) | CompoundPre (pMaxIdx, pArray) -> if !pMaxIdx < idx then begin pMaxIdx := idx; (* Maybe we also need to grow the array *) let l = Array.length !pArray in if l <= idx then begin let growBy = max (max 32 (idx + 1 - l)) (l / 2) in let newarray = Array.make (growBy + idx) NoInitPre in Array.blit !pArray 0 newarray 0 l; pArray := newarray end end; pMaxIdx, pArray | SinglePre _ -> Kernel.fatal ~current:true "Index %d is already initialized" idx in assert (idx >= 0 && idx < Array.length !pArray); let this' = setOneInit !pArray.(idx) restoff e in !pArray.(idx) <- this'; CompoundPre (pMaxIdx, pArray) (* collect a CIL initializer, given the original syntactic initializer * 'preInit'; this returns a type too, since initialization of an array * with unspecified size actually changes the array's type * (ANSI C, 6.7.8, para 22) *) let rec collectInitializer (this: preInit) (thistype: typ) : (init * typ) = let loc = CurrentLoc.get() in if this = NoInitPre then (makeZeroInit ~loc thistype), thistype else match unrollType thistype, this with | _ , SinglePre e -> SingleInit e, thistype | TArray (bt, leno, _, at), CompoundPre (pMaxIdx, pArray) -> let len, initializer_len_used = (* normal case: use array's declared length, newtype=thistype *) match leno with Some len -> begin match (constFold true len).enode with | Const(CInt64(ni, _, _)) when Integer.ge ni Integer.zero -> (Integer.to_int ni), false | _ -> Kernel.fatal ~current:true "Array length is not a constant expression %a" Cil_printer.pp_exp len end | _ -> (* unsized array case, length comes from initializers *) (!pMaxIdx + 1), true in if !pMaxIdx >= len then Kernel.abort ~current:true "collectInitializer: too many initializers(%d >= %d)" (!pMaxIdx+1) len; (* (* len could be extremely big. So omit the last initializers, if they * are many (more than 16). doInit will take care of that by * mem-setting everything to 0 in that case. *) let endAt = if len - 1 > !pMaxIdx + 16 then !pMaxIdx else len - 1 in (* Make one zero initializer to be used next *) let oneZeroInit = makeZeroInit ~loc bt in let rec collect (acc: (offset * init) list) (idx: int) = if idx = -1 then acc else let thisi = if idx > !pMaxIdx then oneZeroInit else (fst (collectInitializer !pArray.(idx) bt)) in collect ((Index(integer ~loc idx,NoOffset), thisi) :: acc) (idx - 1) in *) let collect_one_init v (idx,init,typ,len_used) = match v with | NoInitPre -> (idx-1,init,typ,len_used) | _ -> let (vinit,typ') = collectInitializer v typ in let len_used = len_used || not (Cil_datatype.Typ.equal typ typ') in (idx-1, (Index (integer ~loc idx,NoOffset), vinit)::init, typ', len_used) in let (_,init,typ, len_used) = Array.fold_right collect_one_init !pArray (Array.length !pArray - 1, [], bt, initializer_len_used) in let newtype = TArray (typ, Some (integer ~loc len), empty_size_cache (), at) in CompoundInit (newtype, (* collect [] endAt*)init), (* If the sizes of the initializers have not been used anywhere, we can fold back an eventual typedef. Otherwise, push the attributes to the elements of the array *) (if len_used then newtype else thistype) | TComp (comp, _, _), CompoundPre (pMaxIdx, pArray) when comp.cstruct -> let rec collect (idx: int) = function [] -> [] | f :: restf -> if f.fname = missingFieldName then collect (idx + 1) restf else let thisi = if idx > !pMaxIdx then makeZeroInit ~loc f.ftype else collectFieldInitializer !pArray.(idx) f in (Field(f, NoOffset), thisi) :: collect (idx + 1) restf in CompoundInit (thistype, collect 0 comp.cfields), thistype | TComp (comp, _, _), CompoundPre (pMaxIdx, pArray) when not comp.cstruct -> (* Find the field to initialize *) let rec findField (idx: int) = function | [] -> Kernel.abort ~current:true "collectInitializer: union" | _ :: rest when idx < !pMaxIdx && !pArray.(idx) = NoInitPre -> findField (idx + 1) rest | f :: _ when idx = !pMaxIdx -> Field(f, NoOffset), collectFieldInitializer !pArray.(idx) f | _ -> Kernel.fatal ~current:true "Can initialize only one field for union" in if theMachine.msvcMode && !pMaxIdx != 0 then Kernel.warning ~current:true "On MSVC we can initialize only the first field of a union"; CompoundInit (thistype, [ findField 0 comp.cfields ]), thistype | _ -> Kernel.fatal ~current:true "collectInitializer" and collectFieldInitializer (this: preInit) (f: fieldinfo) : init = (* collect, and rewrite type *) let init,newtype = (collectInitializer this f.ftype) in f.ftype <- newtype; init type stackElem = InArray of offset * typ * int * int ref (* offset of parent, base type, * length, current index. If the * array length is unspecified we * use Int.max_int *) | InComp of offset * compinfo * fieldinfo list (* offset of parent, base comp, current fields *) (* A subobject is given by its address. The address is read from the end of * the list (the bottom of the stack), starting with the current object *) type subobj = { mutable stack: stackElem list; (* With each stack element we * store the offset of its * PARENT *) mutable eof: bool; (* The stack is empty and we reached the * end *) mutable soTyp: typ; (* The type of the subobject. Set using * normalSubobj after setting stack. *) mutable soOff: offset; (* The offset of the subobject. Set * using normalSubobj after setting * stack. *) curTyp: typ; (* Type of current object. See ISO for * the definition of the current object *) curOff: offset; (* The offset of the current obj *) host: varinfo; (* The host that we are initializing. * For error messages *) } (* maps vid to visitor used to perform renaming on function spec when there's a spec on a declaration and a definition for the function. This is done after typing. *) let alpha_renaming = Hashtbl.create 59 let rename_spec = function GVarDecl(spec,v,_) -> (try let alpha = Hashtbl.find alpha_renaming v.vid in ignore (Cil.visitCilFunspec alpha spec) with Not_found -> ()) | _ -> () (* Make a subobject iterator *) let rec makeSubobj (host: varinfo) (curTyp: typ) (curOff: offset) = let so = { host = host; curTyp = curTyp; curOff = curOff; stack = []; eof = false; (* The next are fixed by normalSubobj *) soTyp = voidType; soOff = NoOffset } in normalSubobj so; so (* Normalize a stack so the we always point to a valid subobject. Do not * descend into type *) and normalSubobj (so: subobj) : unit = match so.stack with [] -> so.soOff <- so.curOff; so.soTyp <- so.curTyp (* The array is over *) | InArray (parOff, bt, leno, current) :: rest -> if leno = !current then begin (* The array is over *) if debugInit then Kernel.debug "Past the end of array"; so.stack <- rest; advanceSubobj so end else begin so.soTyp <- bt; so.soOff <- addOffset (Index(integer ~loc:(CurrentLoc.get()) !current, NoOffset)) parOff end (* The fields are over *) | InComp (parOff, _, nextflds) :: rest -> if nextflds == [] then begin (* No more fields here *) if debugInit then Kernel.debug "Past the end of structure"; so.stack <- rest; advanceSubobj so end else begin let fst = List.hd nextflds in so.soTyp <- fst.ftype; so.soOff <- addOffset (Field(fst, NoOffset)) parOff end (* Advance to the next subobject. Always apply to a normalized object *) and advanceSubobj (so: subobj) : unit = if so.eof then Kernel.abort ~current:true "advanceSubobj past end"; match so.stack with | [] -> if debugInit then Kernel.debug "Setting eof to true"; so.eof <- true | InArray (_, _, _, current) :: _ -> if debugInit then Kernel.debug " Advancing to [%d]" (!current + 1); (* so.stack <- InArray (parOff, bt, leno, current + 1) :: rest; *) incr current; normalSubobj so (* The fields are over *) | InComp (parOff, comp, nextflds) :: rest -> if debugInit then Kernel.debug "Advancing past .%s" (List.hd nextflds).fname; let flds' = try List.tl nextflds with Failure _ -> Kernel.abort ~current:true "advanceSubobj" in so.stack <- InComp(parOff, comp, flds') :: rest; normalSubobj so (* Find the fields to initialize in a composite. *) let fieldsToInit (comp: compinfo) (designator: string option) : fieldinfo list = (* Never look at anonymous fields *) let flds1 = List.filter (fun f -> f.fname <> missingFieldName) comp.cfields in let flds2 = match designator with None -> flds1 | Some fn -> let rec loop = function | [] -> Kernel.fatal ~current:true "Cannot find designated field %s" fn | (f :: _) as nextflds when f.fname = fn -> nextflds | _ :: rest -> loop rest in loop flds1 in (* If it is a union we only initialize one field *) match flds2 with [] -> [] | (f :: _) as toinit -> if comp.cstruct then toinit else [f] let integerArrayLength (leno: exp option) : int = match leno with | None -> max_int | Some len -> try lenOfArray leno with LenOfArray -> Kernel.fatal ~current:true "Initializing non-constant-length array with length=%a" Cil_printer.pp_exp len let anonCompFieldNameId = ref 0 let anonCompFieldName = "__anonCompField" let find_field_offset cond (fidlist: fieldinfo list) : offset = (* Depth first search for the field. This appears to be what GCC does. * MSVC checks that there are no ambiguous field names, so it does not * matter how we search *) let rec search = function [] -> raise Not_found | fid :: _ when cond fid -> Field(fid, NoOffset) | fid :: rest when prefix anonCompFieldName fid.fname -> begin match unrollType fid.ftype with | TComp (ci, _, _) -> (try let off = search ci.cfields in Field(fid,off) with Not_found -> search rest (* Continue searching *)) | _ -> Kernel.abort ~current:true "unnamed field type is not a struct/union" end | _ :: rest -> search rest in search fidlist let findField n fidlist = try find_field_offset (fun x -> x.fname = n) fidlist with Not_found -> Kernel.abort ~current:true "Cannot find field %s" n (* Utility ***) let rec replaceLastInList (lst: A.expression list) (how: A.expression -> A.expression) : A.expression list= match lst with [] -> [] | [e] -> [how e] | h :: t -> h :: replaceLastInList t how let convBinOp (bop: A.binary_operator) : binop = match bop with A.ADD -> PlusA | A.SUB -> MinusA | A.MUL -> Mult | A.DIV -> Div | A.MOD -> Mod | A.BAND -> BAnd | A.BOR -> BOr | A.XOR -> BXor | A.SHL -> Shiftlt | A.SHR -> Shiftrt | A.EQ -> Eq | A.NE -> Ne | A.LT -> Lt | A.LE -> Le | A.GT -> Gt | A.GE -> Ge | _ -> Kernel.fatal ~current:true "convBinOp" (**** PEEP-HOLE optimizations ***) (* Should we collapse [tmp = f(); lv = tmp;] where the result type of [f] is [tf], and the [lv] has type [tlv *) let allow_return_collapse ~tlv ~tf = Cil_datatype.Typ.equal tlv tf || Kernel.DoCollapseCallCast.get () && (match Cil.unrollType tlv, Cil.unrollType tf with | TPtr _, TPtr _ -> true (* useful for malloc and others. Could be restricted to void* -> any if needed *) | TInt (iklv, _), TInt (ikf, _) -> Cil.intTypeIncluded ikf iklv | TFloat (fklv, _), TFloat (fkf, _) -> Cil.frank fklv >= Cil.frank fkf | _, _ -> false ) let afterConversion ~ghost (c: chunk) : chunk = (* Now scan the statements and find Instr blocks *) (** We want to collapse sequences of the form "tmp = f(); v = tmp". This * will help significantly with the handling of calls to malloc, where it * is important to have the cast at the same place as the call *) let tcallres f = match unrollType (typeOf f) with | TFun (rt, _, _, _) -> rt | _ -> Kernel.abort ~current:true "Function call to a non-function" in let collapseCallCast (s1,s2) = match s1.skind, s2.skind with | Instr (Call(Some(Var vi, NoOffset), f, args, l)), Instr (Set(destlv, {enode = CastE (newt, {enode = Lval(Var vi', NoOffset)})}, _)) -> if (not vi.vglob && vi' == vi && String.length vi.vname >= 3 && (* Watch out for the possibility that we have an implied cast in * the call *) (let tcallres = tcallres f in Cil_datatype.Typ.equal tcallres vi.vtype && Cil_datatype.Typ.equal newt (typeOfLval destlv) && allow_return_collapse ~tf:tcallres ~tlv:newt) && IH.mem callTempVars vi.vid) then begin s1.skind <- Instr(Call(Some destlv, f, args, l)); Some [ s1 ] end else None | Instr (Call(Some(Var vi, NoOffset), f, args, l)), Instr (Set(destlv, {enode = Lval(Var vi', NoOffset)}, _)) -> if (not vi.vglob && vi' == vi && String.length vi.vname >= 3 && (* Watch out for the possibility that we have an implied cast in * the call *) IH.mem callTempVars vi.vid && Cil_datatype.Typ.equal vi.vtype (typeOfLval destlv) && allow_return_collapse ~tf:(tcallres f) ~tlv:vi.vtype ) then begin s1.skind <- Instr(Call(Some destlv, f, args, l)); Some [ s1 ] end else None | _ -> None in let block = c2block ~ghost ~collapse_block:false c in let sl = if Kernel.DoCollapseCallCast.get () then peepHole2 ~agressive:false collapseCallCast block.bstmts else block.bstmts in (* the call to c2block has taken care of a possible unspecified sequence. We do not need to keep track of effects at this level. *) let res = { c with stmts = (List.rev_map (fun x -> x,[],[],[],[]) sl); } in (* Format.eprintf "Before conversion@\n%a@\nAfter conversion@\n%a@\n@." d_chunk c d_chunk res; *) res (***** Try to suggest a name for the anonymous structures *) let suggestAnonName (nl: A.name list) = match nl with [] -> "" | (n, _, _, _) :: _ -> n (** Optional constant folding of binary operations *) let optConstFoldBinOp loc machdep bop e1 e2 t = if theMachine.lowerConstants then constFoldBinOp ~loc machdep bop e1 e2 t else new_exp ~loc (BinOp(bop, e1, e2, t)) let integral_cast ty t = raise (Failure (Pretty_utils.sfprintf "term %a has type %a, but %a is expected." Cil_printer.pp_term t Cil_printer.pp_logic_type Linteger Cil_printer.pp_typ ty)) module C_logic_env = struct let nb_loop = ref 0 let is_loop () = !nb_loop > 0 let anonCompFieldName = anonCompFieldName let conditionalConversion = logicConditionalConversion let find_macro _ = raise Not_found let find_var x = match H.find env x with | EnvVar vi, _ -> cvar_to_lvar vi | _ -> raise Not_found let find_enum_tag x = match H.find env x with | EnvEnum item,_ -> dummy_exp (Const (CEnum item)), typeOf item.eival | _ -> raise Not_found let find_comp_type ~kind s = findCompType kind s [] let find_comp_field info s = findField s info.cfields let find_type s = let t,_ = lookupTypeNoError "type" s in t include Logic_labels include Logic_env let add_logic_function = add_logic_function_gen Logic_utils.is_same_logic_profile let integral_cast = integral_cast end module Ltyping = Logic_typing.Make (C_logic_env) let startLoop iswhile = incr C_logic_env.nb_loop; continues := (if iswhile then While (ref "") else NotWhile (ref "")) :: !continues; enter_break_env () let exitLoop () = decr C_logic_env.nb_loop; exit_break_env (); match !continues with [] -> Kernel.error ~once:true ~current:true "exit Loop not in a loop" | _ :: rest -> continues := rest let enterScope () = scopes := (ref []) :: !scopes; C_logic_env.enter_scope () (* Exit a scope and clean the environment. We do not yet delete from * the name table *) let exitScope () = let this, rest = match !scopes with | [] -> Kernel.fatal ~current:true "Not in a scope" | car :: cdr -> car, cdr in scopes := rest; let rec loop = function [] -> () | UndoRemoveFromEnv n :: t -> H.remove env n; loop t | UndoRemoveFromAlphaTable n :: t -> H.remove alphaTable n; loop t | UndoResetAlphaCounter (vref, oldv) :: t -> vref := oldv; loop t in loop !this; C_logic_env.exit_scope () let consLabel ~ghost (l: string) (c: chunk) (loc: location) (in_original_program_text : bool) : chunk = (* Get the first statement and add the label to it *) let labstmt, stmts' = getFirstInChunk ~ghost ~loc c in (* Add the label *) add_label l labstmt; labstmt.labels <- Label (l, loc, in_original_program_text) :: labstmt.labels; if c.stmts == stmts' then c else {c with stmts = stmts'} let consLabContinue ~ghost (c: chunk) = match !continues with | [] -> Kernel.fatal ~current:true "labContinue not in a loop" | While lr :: _ -> begin assert (!doTransformWhile); if !lr = "" then c else consLabel ~ghost !lr c (CurrentLoc.get ()) false end | NotWhile lr :: _ -> if !lr = "" then c else consLabel ~ghost !lr c (CurrentLoc.get ()) false (* Was a continue instruction used inside the current loop *) let continueUsed () = match !continues with | [] -> Kernel.fatal ~current:true "not in a loop" | (While lr | NotWhile lr) :: _ -> !lr <> "" (****** TYPE SPECIFIERS *******) (* JS: return [Some s] if the attribute string is the attribute annotation [s] and [None] if it is not an annotation. *) let attrAnnot s = let r = Str.regexp "/\\*@ \\(.+\\) \\*/" in if Str.string_match r s 0 then try Some (Str.matched_group 1 s) with Not_found -> assert false else None type local_env = { authorized_reads: Lval.Set.t; known_behaviors: string list; is_ghost: bool } let empty_local_env = { authorized_reads = Lval.Set.empty; known_behaviors = []; is_ghost = false } let ghost_local_env ghost = {empty_local_env with is_ghost = ghost } (* weimer: Sat Dec 8 17:30:47 2001 MSVC NT kernel headers include * functions like long convert(x) { __asm { mov eax, x \n cdq } } * That set a return value via an ASM statement. As a result, I * am changing this so a final ASM statement does not count as * "fall through" for the purposes of this warning. *) (* matth: But it's better to assume assembly will fall through, * since most such blocks do. It's probably better to print an * unnecessary warning than to break CIL's invariant that * return statements are inserted properly. *) let rec compute_from_root f = function [] -> false (* We have a label, perhaps we can jump here *) | s :: rest when s.labels <> [] -> Kernel.debug ~level:4 "computeFromRoot call f from stmt %a" Cil_printer.pp_location (Stmt.loc s); f (s :: rest) | _ :: rest -> compute_from_root f rest let instrFallsThrough (i : instr) = match i with Set _ -> true | Call (None, {enode = Lval (Var e, NoOffset)}, _, _) -> (* See if this is exit, or if it has the noreturn attribute *) if e.vname = "exit" then false else if hasAttribute "noreturn" e.vattr then false else true | Call _ -> true | Asm _ -> true | Skip _ -> true | Code_annot _ -> true let rec stmtFallsThrough (s: stmt) : bool = Kernel.debug ~level:4 "stmtFallsThrough stmt %a" Cil_printer.pp_location (Stmt.loc s); match s.skind with Instr(il) -> instrFallsThrough il | UnspecifiedSequence seq -> blockFallsThrough (block_from_unspecified_sequence seq) | Return _ | Break _ | Continue _ -> false | Goto _ -> false | If (_, b1, b2, _) -> blockFallsThrough b1 || blockFallsThrough b2 | Switch (_e, b, targets, _) -> (* See if there is a "default" case *) if not (List.exists (fun s -> List.exists (function Default _ -> true | _ -> false) s.labels) targets) then begin true (* We fall through because there is no default *) end else begin (* We must examine all cases. If any falls through, * then the switch falls through. *) blockFallsThrough b || blockCanBreak b end | Loop (_,b, _, _, _) -> (* A loop falls through if it can break. *) blockCanBreak b | Block b -> blockFallsThrough b | TryFinally (_b, h, _) -> blockFallsThrough h | TryExcept (_b, _, _h, _) -> true (* Conservative *) and stmtListFallsThrough = function [] -> true | s :: rest -> if stmtFallsThrough s then begin stmtListFallsThrough rest end else begin (* If we are not falling through then maybe there * are labels who are *) compute_from_root stmtListFallsThrough rest end and blockFallsThrough b = stmtListFallsThrough b.bstmts (* will we leave this statement or block with a break command? *) and stmtCanBreak (s: stmt) : bool = Kernel.debug ~level:4 "stmtCanBreak stmt %a" Cil_printer.pp_location (Stmt.loc s); match s.skind with Instr _ | Return _ | Continue _ | Goto _ -> false | Break _ -> true | UnspecifiedSequence seq -> blockCanBreak (block_from_unspecified_sequence seq) | If (_, b1, b2, _) -> blockCanBreak b1 || blockCanBreak b2 | Switch _ | Loop _ -> (* switches and loops catch any breaks in their bodies *) false | Block b -> blockCanBreak b | TryFinally (b, h, _) -> blockCanBreak b || blockCanBreak h | TryExcept (b, _, h, _) -> blockCanBreak b || blockCanBreak h and blockCanBreak b = let rec aux = function [] -> false | s::tl -> Kernel.debug ~level:4 "blockCanBreak from stmt %a" Cil_printer.pp_location (Stmt.loc s); stmtCanBreak s || (if stmtFallsThrough s then aux tl else compute_from_root aux tl) in aux b.bstmts let chunkFallsThrough c = let get_stmt (s,_,_,_,_) = s in let stmts = List.rev_map get_stmt c.stmts in stmtListFallsThrough stmts let append_chunk_to_annot ~ghost annot_chunk current_chunk = match current_chunk.stmts with | [] -> annot_chunk @@ (current_chunk, ghost) (* don't forget locals of current_chunk *) (* if we have a single statement, we can avoid enclosing it into a block. *) | [ (_s,_,_,_,_) ] -> (* Format.eprintf "Statement is: %a@." d_stmt _s; *) annot_chunk @@ (current_chunk, ghost) (* Make a block, and put labels of the first statement on the block itself, so as to respect scoping rules for \at in further annotations. *) | _ -> let b = c2block ~ghost current_chunk in (* The statement may contain some local variable declarations coming from userland. We have to shift them from the inner block, otherwise they will not be accessible in the next statements. *) let locals = b.blocals in b.blocals <- []; b.battrs <- addAttributes [Attr(frama_c_keep_block,[])] b.battrs; let block = mkStmt ~ghost (Block b) in let chunk = s2c block in let chunk = { chunk with cases = current_chunk.cases } in annot_chunk @@ (List.fold_left local_var_chunk chunk (List.rev locals), ghost) let ensures_init vi off ini = let cast = false in let lv = Cil.cvar_to_lvar vi in let lo = Logic_utils.offset_to_term_offset ~cast off in let lini = Logic_utils.expr_to_term ~cast ini in let loc = lini.term_loc in let base = (TVar lv, lo) in let lval = Logic_const.term ~loc (TLval base) (Cil.typeOfTermLval base) in Logic_const.prel ~loc (Req,lval,lini) let zero_enum ~loc e = try let ei = List.find (fun e -> Cil.isZero e.eival) e.eitems in Cil.new_exp ~loc (Const (CEnum ei)) with Not_found -> Cil.kinteger ~loc e.ekind 0 (* memset to 0 an entire array. *) let set_to_zero ~ghost vi off typ = let loc = vi.vdecl in let bzero = try Cil.Frama_c_builtins.find "Frama_C_bzero" with Not_found -> Kernel.fatal "Incorrect Cil initialization: cannot find Frama_C_bzero builtin" in let zone = Cil.new_exp ~loc (CastE(TPtr(TInt (IUChar,[]),[]), Cil.new_exp ~loc (StartOf(Var vi,off)))) in let size = Cil.new_exp ~loc (CastE (TInt(IULong,[]), Cil.new_exp ~loc (SizeOf typ))) in Cil.mkStmt ~ghost (Instr (Call (None,Cil.evar ~loc bzero, [zone; size], loc))) (* Initialize the first cell of an array, and call Frama_C_copy_block to propagate this initialization to the rest of the array. Array is located at vi.off, of length len, and cells are of type base_type. *) let rec zero_init ~ghost vi off len base_typ = let loc = vi.vdecl in let copy = try Cil.Frama_c_builtins.find "Frama_C_copy_block" with Not_found -> Kernel.fatal "Incorrect Cil initialization: cannot find Frama_C_copy_block builtin" in let zone = Cil.new_exp ~loc (CastE(TPtr(TInt (IUChar,[]),[]), Cil.new_exp ~loc (StartOf(Var vi,off)))) in let size = Cil.new_exp ~loc (CastE (TInt(IULong,[]), Cil.new_exp ~loc (SizeOf base_typ))) in let len = Cil.kinteger ~loc IULong len in let off = Cil.addOffset (Index (Cil.integer ~loc 0, NoOffset)) off in let zero_init = zero_init_cell ~ghost vi off base_typ in zero_init +++ (Cil.mkStmt ~ghost (Instr (Call (None, Cil.evar ~loc copy, [zone; size; len], loc))), [],[], [(Var vi,off)]) and zero_init_cell ~ghost vi off typ = let loc = vi.vdecl in match Cil.unrollType typ with | TVoid _ -> empty | TInt(ikind,_) -> let lv = (Var vi,off) in s2c (Cil.mkStmt ~ghost (Instr (Set (lv, (Cil.kinteger ~loc ikind 0),loc)))) | TFloat (fkind,_) -> let lv = (Var vi,off) in s2c (Cil.mkStmt ~ghost (Instr (Set (lv, (Cil.kfloat ~loc fkind 0.),loc)))) | TPtr _ -> let lv = (Var vi,off) in let exp = Cil.new_exp ~loc (CastE(typ,Cil.zero ~loc)) in s2c (Cil.mkStmt ~ghost (Instr (Set (lv, exp,loc)))) | TArray(_,None,_,_) -> Kernel.fatal ~source:(fst loc) "Trying to zero-initialize variable with incomplete type" | TArray(typ,Some e,_,_) -> let len = match Cil.constFold true e with | { enode = Const (CInt64 (i,_,_)) } -> Integer.to_int i | _ -> Kernel.fatal ~source:(fst loc) "Trying to zero-initialize variable with incomplete type" in zero_init ~ghost vi off len typ | TFun _ -> Kernel.fatal "Trying to zero-initialize a function" | TNamed _ -> assert false (* guarded by unrollType *) | TComp (ci,_,_) -> let treat_one_field acc fi = let off = Cil.addOffset (Field (fi,NoOffset)) off in acc @@ (zero_init_cell ~ghost vi off fi.ftype, ghost) in if ci.cstruct then List.fold_left treat_one_field empty ci.cfields else begin (* Standard says that zero initializing an union is done by setting its first field to 0 *) match ci.cfields with | [] -> Kernel.fatal "Union type without fields" | fst :: _ -> treat_one_field empty fst end | TEnum (ei,_) -> let lv = (Var vi,off) in let zero = zero_enum ~loc ei in s2c (mkStmt ~ghost (Instr (Set (lv,zero,loc)))) | TBuiltin_va_list _ -> Kernel.fatal "Found builtin varargs in zero-initialization" let get_implicit_indexes loc vi len known_idx = let split_itv i itvs = let i = Integer.to_int i in let rec aux processed remaining = match remaining with | [] -> Kernel.warning ~current:true "Unexpected index in array initialization (bad computed length?)"; List.rev processed | (low,high) as itv :: tl -> if i < low then begin (* should have been captured by earlier interval*) Kernel.warning ~current:true "Unexpected index in array initialization \ (double initialization?)"; List.rev_append processed remaining end else if i > high then aux (itv::processed) tl else (* split the interval *) if i = low then if high = low then (* interval is a singleton, just remove it*) List.rev_append processed tl else (* remove first elt of interval *) List.rev_append processed ((low+1,high)::tl) else if i = high then (* remove last elt of interval, which is not singleton *) List.rev_append processed ((low,high-1)::tl) else (* split interval in two, non empty intervals. *) List.rev_append processed ((low,i-1)::(i+1,high)::tl) in aux [] itvs in let unknown_idx = Datatype.Big_int.Set.fold split_itv known_idx [0,pred len] in let one_range acc (low,high) = Logic_const.pand ~loc (acc,Logic_const.pand ~loc (Logic_const.prel ~loc (Rle, Logic_const.tinteger ~loc low, Logic_const.tvar vi), Logic_const.prel ~loc (Rle, Logic_const.tvar vi, Logic_const.tinteger ~loc high))) in List.fold_left one_range Logic_const.ptrue unknown_idx let ensures_is_zero_offset loc term typ = let rec aux nb_idx term typ = let mk_term () = Logic_const.term ~loc (TLval term) (Cil.typeOfTermLval term) in match Cil.unrollType typ with | TVoid _ -> Kernel.warning "trying to zero-initialize a void value"; Logic_const.ptrue | TInt _ -> Logic_const.prel(Req,mk_term (),Logic_const.tinteger ~loc 0) | TFloat _ -> Logic_const.prel (Req,mk_term (),Logic_const.treal ~loc 0.) | TPtr _ -> Logic_const.prel (Req, mk_term (), Logic_const.term ~loc Tnull (Ctype typ)) | TArray (t,e,_,_) -> let name = "__i" ^ string_of_int nb_idx in let vi = Cil_const.make_logic_var_quant name Linteger in let idx = Logic_const.tvar ~loc vi in let max = match e with | None -> Logic_const.ptrue | Some e -> Logic_const.prel ~loc (Rlt, idx, Logic_utils.expr_to_term ~cast:false e) in let pre = Logic_const.pand ~loc (Logic_const.prel ~loc (Rle, Logic_const.tinteger ~loc 0, idx),max) in let subterm = Logic_const.addTermOffsetLval (TIndex (idx,TNoOffset)) term in let cond = aux (nb_idx + 1) subterm t in Logic_const.pforall ~loc ([vi], Logic_const.pimplies ~loc (pre, cond)) | TFun _ -> Kernel.fatal "Trying to zero-initialize a function" | TNamed _ -> assert false (* protected by unrollType *) | TComp (c,_,_) -> let treat_one_field acc fi = let subterm = Logic_const.addTermOffsetLval (TField (fi,TNoOffset)) term in let cond = aux nb_idx subterm fi.ftype in Logic_const.pand ~loc (acc,cond) in if c.cstruct then List.fold_left treat_one_field Logic_const.ptrue c.cfields else (match c.cfields with | [] -> Kernel.fatal "zero-initialize a union with no members" | f :: _ -> treat_one_field Logic_const.ptrue f) | TEnum (e,_) -> let zero = Logic_utils.expr_to_term ~cast:false (zero_enum ~loc e) in Logic_const.prel ~loc (Req,mk_term (),zero) | TBuiltin_va_list _ -> Kernel.fatal "Trying to zero-initialize a vararg list" in aux 0 term typ (* Make a contract for a block that performs partial initialization of a local, relying on bzero for implicit zero-initialization. *) let make_implicit_ensures vi off base_typ len known_idx = let loc = vi.vdecl in let i = Cil_const.make_logic_var_quant "__i" Linteger in let pre = get_implicit_indexes loc i len known_idx in let lv = Cil.cvar_to_lvar vi in let lo = Logic_utils.offset_to_term_offset ~cast:false off in let base = (TVar lv, lo) in let term = Logic_const.addTermOffsetLval (TIndex (Logic_const.tvar i, TNoOffset)) base in let res = ensures_is_zero_offset loc term base_typ in let cond = Logic_const.pimplies ~loc (pre, res) in Logic_const.pforall ~loc ([i],cond) let default_argument_promotion idx exp = let name = "x_" ^ string_of_int idx in let arg_type = Cil.typeOf exp in let typ = match Cil.unrollType arg_type with | TVoid _ -> TVoid [] | TInt(k,_) when Cil.rank k <= Cil.rank IInt -> TInt(IInt,[]) | TInt(k,_) -> TInt(k,[]) | TFloat(FFloat,_) -> TFloat(FDouble,[]) | TFloat(k,_) -> TFloat(k,[]) | TPtr(t,_) | TArray(t,_,_,_) -> TPtr(t,[]) | (TFun _) as t -> TPtr(t,[]) | TComp(ci,_,_) -> TComp(ci,{ scache = Not_Computed },[]) | TEnum(ei,_) -> TEnum(ei,[]) | TBuiltin_va_list _ -> Kernel.abort ~current:true "implicit prototype cannot have variadic arguments" | TNamed _ -> assert false (* unrollType *) in (* if we make a promotion, take it explicitely into account in the argument itself *) let (_,e) = castTo arg_type typ exp in (name,typ,[]), e let rec doSpecList ghost (suggestedAnonName: string) (* This string will be part of * the names for anonymous * structures and enums *) (specs: A.spec_elem list) (* Returns the base type, the storage, whether it is inline and the * (unprocessed) attributes *) : typ * storage * bool * A.attribute list = (* Do one element and collect the type specifiers *) let isinline = ref false in (* If inline appears *) (* The storage is placed here *) let storage : storage ref = ref NoStorage in (* Collect the attributes. Unfortunately, we cannot treat GCC * __attributes__ and ANSI C const/volatile the same way, since they * associate with structures differently. Specifically, ANSI * qualifiers never apply to structures (ISO 6.7.3), whereas GCC * attributes always do (GCC manual 4.30). Therefore, they are * collected and processed separately. *) let attrs : A.attribute list ref = ref [] in (* __attribute__, etc. *) let cvattrs : A.cvspec list ref = ref [] in (* const/volatile *) let doSpecElem (se: A.spec_elem) (acc: A.typeSpecifier list) : A.typeSpecifier list = match se with A.SpecTypedef -> acc | A.SpecInline -> isinline := true; acc | A.SpecStorage st -> if !storage <> NoStorage then Kernel.error ~once:true ~current:true "Multiple storage specifiers"; let sto' = match st with A.NO_STORAGE -> NoStorage | A.AUTO -> NoStorage | A.REGISTER -> Register | A.STATIC -> Static | A.EXTERN -> Extern in storage := sto'; acc | A.SpecCV cv -> cvattrs := cv :: !cvattrs; acc | A.SpecAttr a -> attrs := a :: !attrs; acc | A.SpecType ts -> ts :: acc | A.SpecPattern _ -> Kernel.abort ~current:true "SpecPattern in cabs2cil input" in (* Now scan the list and collect the type specifiers. Preserve the order *) let tspecs = List.fold_right doSpecElem specs [] in let tspecs' = (* GCC allows a named type that appears first to be followed by things * like "short", "signed", "unsigned" or "long". *) match tspecs with A.Tnamed _ :: (_ :: _ as rest) when not theMachine.msvcMode -> (* If rest contains "short" or "long" then drop the Tnamed *) if List.exists (function A.Tshort -> true | A.Tlong -> true | _ -> false) rest then rest else tspecs | _ -> tspecs in let tspecs'' = match specs, List.rev tspecs' with | A.SpecTypedef :: _, A.Tnamed _ :: [] -> tspecs' | A.SpecTypedef :: _, A.Tnamed _ :: rest -> List.rev rest | _ -> tspecs' in (* Sort the type specifiers *) let sortedspecs = let order = function (* Don't change this *) | A.Tvoid -> 0 | A.Tsigned -> 1 | A.Tunsigned -> 2 | A.Tchar -> 3 | A.Tshort -> 4 | A.Tlong -> 5 | A.Tint -> 6 | A.Tint64 -> 7 | A.Tfloat -> 8 | A.Tdouble -> 9 | _ -> 10 (* There should be at most one of the others *) in List.stable_sort (fun ts1 ts2 -> Datatype.Int.compare (order ts1) (order ts2)) tspecs'' in let getTypeAttrs () : A.attribute list = (* Partitions the attributes in !attrs. Type attributes are removed from attrs and returned, so that they can go into the type definition. Name attributes are left in attrs, so they will be returned by doSpecAttr and used in the variable declaration. Testcase: small1/attr9.c *) let an, af, at = cabsPartitionAttributes ghost ~default:AttrType !attrs in attrs := an; (* Save the name attributes for later *) if af <> [] then Kernel.error ~once:true ~current:true "Invalid position for function type attributes."; at in (* And now try to make sense of it. See ISO 6.7.2 *) let bt = match sortedspecs with [A.Tvoid] -> TVoid [] | [A.Tchar] -> TInt(IChar, []) | [A.Tbool] -> TInt(IBool, []) | [A.Tsigned; A.Tchar] -> TInt(ISChar, []) | [A.Tunsigned; A.Tchar] -> TInt(IUChar, []) | [A.Tshort] -> TInt(IShort, []) | [A.Tsigned; A.Tshort] -> TInt(IShort, []) | [A.Tshort; A.Tint] -> TInt(IShort, []) | [A.Tsigned; A.Tshort; A.Tint] -> TInt(IShort, []) | [A.Tunsigned; A.Tshort] -> TInt(IUShort, []) | [A.Tunsigned; A.Tshort; A.Tint] -> TInt(IUShort, []) | [] -> TInt(IInt, []) | [A.Tint] -> TInt(IInt, []) | [A.Tsigned] -> TInt(IInt, []) | [A.Tsigned; A.Tint] -> TInt(IInt, []) | [A.Tunsigned] -> TInt(IUInt, []) | [A.Tunsigned; A.Tint] -> TInt(IUInt, []) | [A.Tlong] -> TInt(ILong, []) | [A.Tsigned; A.Tlong] -> TInt(ILong, []) | [A.Tlong; A.Tint] -> TInt(ILong, []) | [A.Tsigned; A.Tlong; A.Tint] -> TInt(ILong, []) | [A.Tunsigned; A.Tlong] -> TInt(IULong, []) | [A.Tunsigned; A.Tlong; A.Tint] -> TInt(IULong, []) | [A.Tlong; A.Tlong] -> TInt(ILongLong, []) | [A.Tsigned; A.Tlong; A.Tlong] -> TInt(ILongLong, []) | [A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, []) | [A.Tsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, []) | [A.Tunsigned; A.Tlong; A.Tlong] -> TInt(IULongLong, []) | [A.Tunsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(IULongLong, []) (* int64 is to support MSVC *) | [A.Tint64] -> TInt(ILongLong, []) | [A.Tsigned; A.Tint64] -> TInt(ILongLong, []) | [A.Tunsigned; A.Tint64] -> TInt(IULongLong, []) | [A.Tfloat] -> TFloat(FFloat, []) | [A.Tdouble] -> TFloat(FDouble, []) | [A.Tlong; A.Tdouble] -> TFloat(FLongDouble, []) (* Now the other type specifiers *) | [A.Tnamed n] -> if n = "__builtin_va_list" && Cil.theMachine.theMachine.has__builtin_va_list then TBuiltin_va_list [] else (match lookupType "type" n with | (TNamed _) as x, _ -> x | _ -> Kernel.fatal ~current:true "Named type %s is not mapped correctly" n) | [A.Tstruct (n, None, _)] -> (* A reference to a struct *) if n = "" then Kernel.error ~once:true ~current:true "Missing struct tag on incomplete struct"; findCompType "struct" n [] | [A.Tstruct (n, Some nglist, extraAttrs)] -> (* A definition of a struct *) let n' = if n <> "" then n else anonStructName "struct" suggestedAnonName in (* Use the (non-cv, non-name) attributes in !attrs now *) let a = extraAttrs @ (getTypeAttrs ()) in makeCompType ghost true n' ~norig:n nglist (doAttributes ghost a) | [A.Tunion (n, None, _)] -> (* A reference to a union *) if n = "" then Kernel.error ~once:true ~current:true "Missing union tag on incomplete union"; findCompType "union" n [] | [A.Tunion (n, Some nglist, extraAttrs)] -> (* A definition of a union *) let n' = if n <> "" then n else anonStructName "union" suggestedAnonName in (* Use the attributes now *) let a = extraAttrs @ (getTypeAttrs ()) in makeCompType ghost false n' ~norig:n nglist (doAttributes ghost a) | [A.Tenum (n, None, _)] -> (* Just a reference to an enum *) if n = "" then Kernel.error ~once:true ~current:true "Missing enum tag on incomplete enum"; findCompType "enum" n [] | [A.Tenum (n, Some eil, extraAttrs)] -> (* A definition of an enum *) let n' = if n <> "" then n else anonStructName "enum" suggestedAnonName in (* make a new name for this enumeration *) let n'', _ = newAlphaName true "enum" n' in (* Create the enuminfo, or use one that was created already for a * forward reference *) let enum, _ = createEnumInfo n'' ~norig:n in let a = extraAttrs @ (getTypeAttrs ()) in enum.eattr <- doAttributes ghost a; let res = TEnum (enum, []) in let smallest = ref Integer.zero in let largest = ref Integer.zero in (* Life is fun here. ANSI says: enum constants are ints, and there's an implementation-dependent underlying integer type for the enum, which must be capable of holding all the enum's values. For MSVC, we follow these rules and assume the enum's underlying type is int. GCC allows enum constants that don't fit in int: the enum constant's type is the smallest type (but at least int) that will hold the value, with a preference for unsigned types. The underlying type EI of the enum is picked as follows: - let T be the smallest integer type that holds all the enum's values; T is signed if any enum value is negative, unsigned otherwise - if the enum is packed or sizeof(T) >= sizeof(int), then EI = T - otherwise EI = int if T is signed and unsigned int otherwise Note that these rules make the enum unsigned if possible *) let updateEnum i : ikind = if Integer.lt i !smallest then smallest := i; if Integer.gt i !largest then largest := i; if theMachine.msvcMode then IInt else begin match Kernel.Enums.get () with (* gcc-short-enum will try to pack the enum _type_, not the enum constant... *) | "" | "help" | "gcc-enums" | "gcc-short-enums" -> if fitsInInt IInt i then IInt else if fitsInInt IUInt i then IUInt else if fitsInInt ILongLong i then ILongLong else IULongLong | "int" -> IInt | s -> Kernel.fatal "Unknown enums representations '%s'" s end in (* as each name,value pair is determined, this is called *) let rec processName kname (i: exp) loc rest = begin (* add the name to the environment, but with a faked 'typ' field; * we don't know the full type yet (since that includes all of the * tag values), but we won't need them in here *) (* add this tag to the list so that it ends up in the real * environment when we're finished *) let newname, _ = newAlphaName true "" kname in let item = { eiorig_name = kname; einame = newname; eival = i; eiloc = loc; eihost = enum } in addLocalToEnv kname (EnvEnum item); (kname, item) :: loop (increm i 1) rest end and loop i = function [] -> [] | (kname, { expr_node = A.NOTHING}, cloc) :: rest -> (* use the passed-in 'i' as the value, since none specified *) processName kname i (convLoc cloc) rest | (kname, e, cloc) :: rest -> (* constant-eval 'e' to determine tag value *) let e' = getIntConstExp ghost e in let e' = match isInteger (constFold true e') with | None -> Kernel.fatal ~current:true "Constant initializer %a not an integer" Cil_printer.pp_exp e' | Some i -> let ik = updateEnum i in if theMachine.lowerConstants then kinteger64 ~loc:e.expr_loc ik i else e' in processName kname e' (convLoc cloc) rest in (*TODO: find a better loc*) let fields = loop (zero ~loc:(CurrentLoc.get())) eil in (* Now set the right set of items *) enum.eitems <- List.map (fun (_, x) -> x) fields; (* Pick the enum's kind - see discussion above *) if not theMachine.msvcMode then begin let unsigned = Integer.ge !smallest Integer.zero in let smallKind = intKindForValue !smallest unsigned in let largeKind = intKindForValue !largest unsigned in let real_kind = if (bytesSizeOfInt smallKind) > (bytesSizeOfInt largeKind) then smallKind else largeKind in let ekind = match Kernel.Enums.get () with | "" | "help" | "gcc-enums" -> if hasAttribute "packed" enum.eattr || bytesSizeOfInt real_kind >= bytesSizeOfInt IInt then real_kind else if unsigned then IUInt else IInt | "int" -> IInt | "gcc-short-enums" -> real_kind | s -> Kernel.fatal "Unknown enum representation '%s'" s in enum.ekind <- ekind; end; (* Record the enum name in the environment *) addLocalToEnv (kindPlusName "enum" n'') (EnvTyp res); (* And define the tag *) cabsPushGlobal (GEnumTag (enum, CurrentLoc.get ())); res | [A.TtypeofE e] -> let (_, _, e', t) = doExp (ghost_local_env ghost) false e AType in let t' = match e'.enode with StartOf(lv) -> typeOfLval lv (* If this is a string literal, then we treat it as in sizeof*) | Const (CStr s) -> begin match typeOf e' with | TPtr(bt, _) -> (* This is the type of array elements *) TArray(bt, Some (new_exp ~loc:e'.eloc (SizeOfStr s)), empty_size_cache (), []) | _ -> Kernel.abort ~current:true "The typeOf a string is not a pointer type" end | _ -> t in (* ignore (E.log "typeof(%a) = %a\n" d_exp e' d_type t'); *) t' | [A.TtypeofT (specs, dt)] -> doOnlyType ghost specs dt | l -> Kernel.fatal ~current:true "Invalid combination of type specifiers:@ %a" (pp_list ~sep:"@ " Cprint.print_type_spec) l; in bt,!storage,!isinline,List.rev (!attrs @ (convertCVtoAttr !cvattrs)) (* given some cv attributes, convert them into named attributes for * uniform processing *) and convertCVtoAttr (src: A.cvspec list) : A.attribute list = match src with | [] -> [] | CV_CONST :: tl -> ("const",[]) :: (convertCVtoAttr tl) | CV_VOLATILE :: tl -> ("volatile",[]) :: (convertCVtoAttr tl) | CV_RESTRICT :: tl -> ("restrict",[]) :: (convertCVtoAttr tl) | CV_ATTRIBUTE_ANNOT a :: tl -> (mkAttrAnnot a, []) :: convertCVtoAttr tl and makeVarInfoCabs ~(ghost:bool) ~(isformal: bool) ~(isglobal: bool) ?(isgenerated=false) (ldecl : location) (bt, sto, inline, attrs) (n,ndt,a) : varinfo = let vtype, nattr = doType ghost isformal (AttrName false) ~allowVarSizeArrays:isformal (* For locals we handle var-sized arrays before makeVarInfoCabs; for formals we do it afterwards *) bt (A.PARENTYPE(attrs, ndt, a)) in (*Format.printf "Got yp:%a->%a(%a)@." d_type bt d_type vtype d_attrlist nattr;*) if inline && not (isFunctionType vtype) then Kernel.error ~once:true ~current:true "inline for a non-function: %s" n; let t = if not isglobal && not isformal then begin (* Sometimes we call this on the formal argument of a function with no * arguments. Don't call stripConstLocalType in that case *) (* ignore (E.log "stripConstLocalType(%a) for %s\n" d_type vtype n); *) stripConstLocalType vtype end else vtype in (* log "Looking at %s(%b): (%a)@." n isformal d_attrlist nattr;*) let vi = makeVarinfo ~generated:isgenerated isglobal isformal n t in vi.vstorage <- sto; vi.vattr <- nattr; vi.vdecl <- ldecl; vi.vghost <- ghost; (* if false then log "Created varinfo %s : %a\n" vi.vname d_type vi.vtype;*) vi (* Process a local variable declaration and allow variable-sized arrays *) and makeVarSizeVarInfo ghost (ldecl : location) spec_res (n,ndt,a) : varinfo * chunk * exp * bool = if not theMachine.msvcMode then match isVariableSizedArray ghost ndt with None -> makeVarInfoCabs ~ghost ~isformal:false ~isglobal:false ldecl spec_res (n,ndt,a), empty, zero ~loc:ldecl, false | Some (ndt', se, len) -> makeVarInfoCabs ~ghost ~isformal:false ~isglobal:false ldecl spec_res (n,ndt',a), se, len, true else makeVarInfoCabs ~ghost ~isformal:false ~isglobal:false ldecl spec_res (n,ndt,a), empty, zero ~loc:ldecl, false and doAttr ghost (a: A.attribute) : attribute list = (* Strip the leading and trailing underscore *) let stripUnderscore (n: string) : string = let l = String.length n in let rec start i = if i >= l then Kernel.error ~once:true ~current:true "Invalid attribute name %s" n; if String.get n i = '_' then start (i + 1) else i in let st = start 0 in let rec finish i = (* We know that we will stop at >= st >= 0 *) if String.get n i = '_' then finish (i - 1) else i in let fin = finish (l - 1) in String.sub n st (fin - st + 1) in match a with | ("__attribute__", []) -> [] (* An empty list of gcc attributes *) | (s, []) -> let s = stripUnderscore s in [ match attrAnnot s with None -> Attr(s, []) | Some s -> AttrAnnot s ] | (s, el) -> let rec attrOfExp (strip: bool) ?(foldenum=true) (a: A.expression) : attrparam = let loc = a.expr_loc in match a.expr_node with A.VARIABLE n -> begin let n' = if strip then stripUnderscore n else n in (** See if this is an enumeration *) try if not foldenum then raise Not_found; match H.find env n' with EnvEnum item, _ -> begin match isInteger (constFold true item.eival) with Some i64 when theMachine.lowerConstants -> AInt i64 | _ -> ACons(n', []) end | _ -> ACons (n', []) with Not_found -> ACons(n', []) end | A.CONSTANT (A.CONST_STRING s) -> AStr s | A.CONSTANT (A.CONST_INT str) -> begin match (parseIntExp ~loc str).enode with | Const (CInt64 (v64,_,_)) -> AInt v64 | _ -> Kernel.fatal ~current:true "Invalid attribute constant: %s" str end | A.CALL({expr_node = A.VARIABLE n}, args) -> begin let n' = if strip then stripUnderscore n else n in let ae' = List.map ae args in ACons(n', ae') end | A.EXPR_SIZEOF e -> ASizeOfE (ae e) | A.TYPE_SIZEOF (bt, dt) -> ASizeOf (doOnlyType ghost bt dt) | A.EXPR_ALIGNOF e -> AAlignOfE (ae e) | A.TYPE_ALIGNOF (bt, dt) -> AAlignOf (doOnlyType ghost bt dt) | A.BINARY(A.AND, aa1, aa2) -> ABinOp(LAnd, ae aa1, ae aa2) | A.BINARY(A.OR, aa1, aa2) -> ABinOp(LOr, ae aa1, ae aa2) | A.BINARY(abop, aa1, aa2) -> ABinOp (convBinOp abop, ae aa1, ae aa2) | A.UNARY(A.PLUS, aa) -> ae aa | A.UNARY(A.MINUS, aa) -> AUnOp (Neg, ae aa) | A.UNARY(A.BNOT, aa) -> AUnOp(BNot, ae aa) | A.UNARY(A.NOT, aa) -> AUnOp(LNot, ae aa) | A.MEMBEROF (e, s) -> ADot (ae e, s) | A.PAREN(e) -> attrOfExp strip ~foldenum:foldenum e | A.UNARY(A.MEMOF, aa) -> AStar (ae aa) | A.UNARY(A.ADDROF, aa) -> AAddrOf (ae aa) | A.MEMBEROFPTR (aa1, s) -> ADot(AStar(ae aa1), s) | A.INDEX(aa1, aa2) -> AIndex(ae aa1, ae aa2) | A.QUESTION(aa1, aa2, aa3) -> AQuestion(ae aa1, ae aa2, ae aa3) | _ -> Kernel.fatal ~current:true "cabs2cil: invalid expression in attribute: %a" Cprint.print_expression a and ae (e: A.expression) = attrOfExp false e in (* Sometimes we need to convert attrarg into attr *) let arg2attr = function | ACons (s, args) -> Attr (s, args) | a -> Kernel.fatal ~current:true "Invalid form of attribute: %a" Cil_printer.pp_attrparam a; in if s = "__attribute__" then (* Just a wrapper for many attributes*) List.map (fun e -> arg2attr (attrOfExp true ~foldenum:false e)) el else if s = "__blockattribute__" then (* Another wrapper *) List.map (fun e -> arg2attr (attrOfExp true ~foldenum:false e)) el else if s = "__declspec" then List.map (fun e -> arg2attr (attrOfExp false ~foldenum:false e)) el else [Attr(stripUnderscore s, List.map (attrOfExp ~foldenum:false false) el)] and doAttributes (ghost:bool) (al: A.attribute list) : attribute list = List.fold_left (fun acc a -> cabsAddAttributes (doAttr ghost a) acc) [] al (* A version of Cil.partitionAttributes that works on CABS attributes. It would be better to use Cil.partitionAttributes instead to avoid the extra doAttr conversions here, but that's hard to do in doSpecList.*) and cabsPartitionAttributes ghost ~(default:attributeClass) (attrs: A.attribute list) : A.attribute list * A.attribute list * A.attribute list = let rec loop (n,f,t) = function [] -> n, f, t | a :: rest -> let kind = match doAttr ghost a with [] -> default | (Attr(an, _) | AttrAnnot an)::_ -> (try attributeClass an with Not_found -> default) in match kind with AttrName _ -> loop (a::n, f, t) rest | AttrFunType _ -> loop (n, a::f, t) rest | AttrType -> loop (n, f, a::t) rest in loop ([], [], []) attrs and doType (ghost:bool) isFuncArg (nameortype: attributeClass) (* This is AttrName if we are doing * the type for a name, or AttrType * if we are doing this type in a * typedef *) ?(allowVarSizeArrays=false) (bt: typ) (* The base type *) (dt: A.decl_type) (* Returns the new type and the accumulated name (or type attribute if nameoftype = AttrType) attributes *) : typ * attribute list = (* Now do the declarator type. But remember that the structure of the * declarator type is as printed, meaning that it is the reverse of the * right one *) let rec doDeclType (bt: typ) (acc: attribute list) = function | A.JUSTBASE -> bt, acc | A.PARENTYPE (a1, d, a2) -> let a1' = doAttributes ghost a1 in let a1n, a1f, a1t = partitionAttributes AttrType a1' in let a2' = doAttributes ghost a2 in let a2n, a2f, a2t = partitionAttributes nameortype a2' in (*Format.printf "doType: @[a1n=%a@\na1f=%a@\na1t=%a@\na2n=%a@\na2f=%a@\na2t=%a@]@\n" d_attrlist a1n d_attrlist a1f d_attrlist a1t d_attrlist a2n d_attrlist a2f d_attrlist a2t;*) let bt' = cabsTypeAddAttributes a1t bt in (* log "bt' = %a@." d_type bt';*) let bt'', a1fadded = match unrollType bt with TFun _ -> cabsTypeAddAttributes a1f bt', true | _ -> bt', false in (* Now recurse *) let restyp, nattr = doDeclType bt'' acc d in (* Add some more type attributes *) let restyp = cabsTypeAddAttributes a2t restyp in (* See if we can add some more type attributes *) let restyp' = match unrollType restyp with TFun _ -> if a1fadded then cabsTypeAddAttributes a2f restyp else cabsTypeAddAttributes a2f (cabsTypeAddAttributes a1f restyp) | TPtr ((TFun _ as tf), ap) when not theMachine.msvcMode -> if a1fadded then TPtr(cabsTypeAddAttributes a2f tf, ap) else TPtr(cabsTypeAddAttributes a2f (cabsTypeAddAttributes a1f tf), ap) | _ -> if a1f <> [] && not a1fadded then Kernel.error ~once:true ~current:true "Invalid position for (prefix) function type attributes:%a" Cil_printer.pp_attributes a1f; if a2f <> [] then Kernel.error ~once:true ~current:true "Invalid position for (post) function type attributes:%a" Cil_printer.pp_attributes a2f; restyp in (* log "restyp' = %a@." d_type restyp';*) (* Now add the name attributes and return *) restyp', cabsAddAttributes a1n (cabsAddAttributes a2n nattr) | A.PTR (al, d) -> let al' = doAttributes ghost al in let an, af, at = partitionAttributes AttrType al' in (* Now recurse *) let restyp, nattr = doDeclType (TPtr(bt, at)) acc d in (* See if we can do anything with function type attributes *) let restyp' = match unrollType restyp with TFun _ -> cabsTypeAddAttributes af restyp | TPtr((TFun _ as tf), ap) -> TPtr(cabsTypeAddAttributes af tf, ap) | _ -> if af <> [] then Kernel.error ~once:true ~current:true "Invalid position for function type attributes:%a" Cil_printer.pp_attributes af; restyp in (* Now add the name attributes and return *) restyp', cabsAddAttributes an nattr | A.ARRAY (d, al, len) -> let lo = match len.expr_node with A.NOTHING -> None | _ -> (* Check that len is a constant expression. We used to also cast the length to int here, but that's theoretically too restrictive on 64-bit machines. *) let len' = doPureExp (ghost_local_env ghost) len in if not (isIntegralType (typeOf len')) then Kernel.error ~once:true ~current:true "Array length %a does not have an integral type." Cil_printer.pp_exp len'; if not allowVarSizeArrays then begin (* Assert that len' is a constant *) let cst = constFold true len' in (match cst.enode with | Const(CInt64(i, _, _)) -> if Integer.lt i Integer.zero then Kernel.error ~once:true ~current:true "Length of array is negative" else if Integer.equal i Integer.zero then Kernel.error ~once:true ~source:(fst len'.eloc) "Length of array is zero. This extension is unsupported"; | _ -> if isConstant cst then (* e.g., there may be a float constant involved. * We'll leave it to the user to ensure the length is * non-negative, etc.*) Kernel.warning ~current:true "Unable to do constant-folding on array length %a. \ Some CIL operations on this array may fail." Cil_printer.pp_exp cst else Kernel.error ~once:true ~current:true "Length of array is not a constant: %a" Cil_printer.pp_exp cst) end; Some len' in let al' = doAttributes ghost al in if not isFuncArg && hasAttribute "static" al' then Kernel.error ~once:true ~current:true "static specifier inside array argument is allowed only in \ function argument"; doDeclType (TArray(bt, lo, empty_size_cache (), al')) acc d | A.PROTO (d, args, isva) -> (* Start a scope for the parameter names *) enterScope (); (* Intercept the old-style use of varargs.h. On GCC this means that * we have ellipsis and a last argument "builtin_va_alist: * builtin_va_alist_t". On MSVC we do not have the ellipsis and we * have a last argument "va_alist: va_list" *) let args', isva' = if args != [] && theMachine.msvcMode = not isva then begin let newisva = ref isva in let rec doLast = function [([A.SpecType (A.Tnamed atn)], (an, A.JUSTBASE, [], _))] when isOldStyleVarArgTypeName atn && isOldStyleVarArgName an -> begin (* Turn it into a vararg *) newisva := true; (* And forget about this argument *) [] end | a :: rest -> a :: doLast rest | [] -> [] in let args' = doLast args in (args', !newisva) end else (args, isva) in (* Make the argument as for a formal *) let doOneArg (s, (n, ndt, a, cloc)) : varinfo = let s' = doSpecList ghost n s in let vi = makeVarInfoCabs ~ghost ~isformal:true ~isglobal:false (convLoc cloc) s' (n,ndt,a) in (* Add the formal to the environment, so it can be referenced by other formals (e.g. in an array type, although that will be changed to a pointer later, or though typeof). *) addLocalToEnv vi.vname (EnvVar vi); vi in let targs : varinfo list option = match List.map doOneArg args' with | [] -> None (* No argument list *) | [t] when isVoidType t.vtype -> Some [] | l -> Some l in exitScope (); (* Turn [] types into pointers in the arguments and the result type. * Turn function types into pointers to respective. This simplifies * our life a lot, and is what the standard requires. *) let turnArrayIntoPointer (bt: typ) (lo: exp option) (a: attributes) : typ = let _real_a = dropAttribute "static" a in let a' : attributes = match lo with None -> [] | Some l -> begin let static = if hasAttribute "static" a then [Attr ("static",[])] else [] in (* Transform the length into an attribute expression *) try let la : attrparam = expToAttrParam l in Attr("arraylen", [ la ]) :: static with NotAnAttrParam _ -> begin Kernel.warning ~once:true ~current:true "Cannot represent the length '%a'of array as an attribute" Cil_printer.pp_exp l ; static (* Leave unchanged *) end end in TPtr(bt, a') in let rec fixupArgumentTypes (argidx: int) (args: varinfo list) : unit = match args with [] -> () | a :: args' -> (match unrollType a.vtype with TArray(bt,lo,_,attr) -> (* Note that for multi-dimensional arrays we strip off only the first TArray and leave bt alone. *) a.vtype <- turnArrayIntoPointer bt lo attr | TFun _ -> a.vtype <- TPtr(a.vtype, []) | TComp (_, _,_) -> begin match isTransparentUnion a.vtype with None -> () | Some fstfield -> transparentUnionArgs := (argidx, a.vtype) :: !transparentUnionArgs; a.vtype <- fstfield.ftype; end | _ -> ()); fixupArgumentTypes (argidx + 1) args' in let args = match targs with None -> None | Some argl -> fixupArgumentTypes 0 argl; Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) argl) in let tres = match unrollType bt with TArray(t,lo,_,attr) -> turnArrayIntoPointer t lo attr | _ -> bt in doDeclType (TFun (tres, args, isva', [])) acc d in doDeclType bt [] dt (* If this is a declarator for a variable size array then turn it into a pointer type and a length *) and isVariableSizedArray ghost (dt: A.decl_type) : (A.decl_type * chunk * exp) option = let res = ref None in let rec findArray = function ARRAY (JUSTBASE, al, lo) when lo.expr_node != A.NOTHING -> (* Try to compile the expression to a constant *) let (_, se, e', _) = doExp (ghost_local_env ghost) true lo (AExp (Some intType)) in if isNotEmpty se || not (isConstant e') then begin res := Some (se, e'); PTR (al, JUSTBASE) end else ARRAY (JUSTBASE, al, lo) | ARRAY (dt, al, lo) -> ARRAY (findArray dt, al, lo) | PTR (al, dt) -> PTR (al, findArray dt) | JUSTBASE -> JUSTBASE | PARENTYPE (prea, dt, posta) -> PARENTYPE (prea, findArray dt, posta) | PROTO (dt, f, a) -> PROTO (findArray dt, f, a) in let dt' = findArray dt in match !res with None -> None | Some (se, e) -> Some (dt', se, e) and doOnlyType ghost (specs: A.spec_elem list) (dt: A.decl_type) : typ = let bt',sto,inl,attrs = doSpecList ghost "" specs in if sto <> NoStorage || inl then Kernel.error ~once:true ~current:true "Storage or inline specifier in type only"; let tres, nattr = doType ghost false AttrType bt' (A.PARENTYPE(attrs, dt, [])) in if nattr <> [] then Kernel.error ~once:true ~current:true "Name attributes in only_type: %a" Cil_printer.pp_attributes nattr; tres and makeCompType ghost (isstruct: bool) (n: string) ~(norig: string) (nglist: A.field_group list) (a: attribute list) = (* Make a new name for the structure *) let kind = if isstruct then "struct" else "union" in let n', _ = newAlphaName true kind n in (* Create the self cell for use in fields and forward references. Or maybe * one exists already from a forward reference *) let comp, _ = createCompInfo isstruct n' norig in let doFieldGroup ((s: A.spec_elem list), (nl: (A.name * A.expression option) list)) = (* Do the specifiers exactly once *) let sugg = match nl with [] -> "" | ((n, _, _, _), _) :: _ -> n in let bt, sto, inl, attrs = doSpecList ghost sugg s in (* Do the fields *) let makeFieldInfo (((n,ndt,a,cloc) : A.name), (widtho : A.expression option)) : fieldinfo = if sto <> NoStorage || inl then Kernel.error ~once:true ~current:true "Storage or inline not allowed for fields"; let ftype, nattr = doType ghost false (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in (* check for fields whose type is an undefined struct. This rules out circularity: struct C1 { struct C2 c2; }; //This line is now an error. struct C2 { struct C1 c1; int dummy; }; *) (match unrollType ftype with | TComp (ci',_,_) when not ci'.cdefined -> Kernel.error ~once:true ~current:true "Type of field %s is an undefined struct" n | _ -> ()); let width, ftype = match widtho with None -> None, ftype | Some w -> begin (match unrollType ftype with | TInt (_, _) -> () | TEnum _ -> () | _ -> Kernel.error ~once:true ~current:true "Base type for bitfield is not an integer type"); match isIntegerConstant ghost w with | None -> Kernel.fatal ~current:true "bitfield width is not an integer constant" | Some s as w -> let ftype = typeAddAttributes [Attr (bitfield_attribute_name, [AInt (Integer.of_int s)])] ftype in w, ftype end in (* If the field is unnamed and its type is a structure of union type * then give it a distinguished name *) let n' = if n = missingFieldName then begin match unrollType ftype with TComp _ -> begin incr anonCompFieldNameId; anonCompFieldName ^ (string_of_int !anonCompFieldNameId) end | _ -> n end else n in { fcomp = comp; forig_name = n; fname = n'; ftype = ftype; fbitfield = width; fattr = nattr; floc = convLoc cloc; faddrof = false; fsize_in_bits = None; foffset_in_bits = None; fpadding_in_bits = None; } in List.map makeFieldInfo nl in (* Do regular fields first. *) let flds = List.filter (function FIELD _ -> true | TYPE_ANNOT _ -> false) nglist in let flds = List.map (function FIELD (f,g) -> (f,g) | _ -> assert false) flds in let flds = List.concat (List.map doFieldGroup flds) in if comp.cfields <> [] then begin (* This appears to be a multiply defined structure. This can happen from * a construct like "typedef struct foo { ... } A, B;". This is dangerous * because at the time B is processed some forward references in { ... } * appear as backward references, which could lead to circularity in * the type structure. We do a thourough check and then we reuse the type * for A *) if List.length comp.cfields <> List.length flds || (List.exists2 (fun f1 f2 -> not (Cil_datatype.Typ.equal f1.ftype f2.ftype)) comp.cfields flds) then Kernel.error ~once:true ~current:true "%s seems to be multiply defined" (compFullName comp) end else comp.cfields <- flds; (* ignore (E.log "makeComp: %s: %a\n" comp.cname d_attrlist a); *) comp.cattr <- add_packing_attributes comp a; let res = TComp (comp,empty_size_cache (), []) in (* This compinfo is defined, even if there are no fields *) comp.cdefined <- true; (* Create a typedef for this one *) cabsPushGlobal (GCompTag (comp, CurrentLoc.get ())); (* There must be a self cell created for this already *) addLocalToEnv (kindPlusName kind n) (EnvTyp res); (* Now create a typedef with just this type *) res and preprocessCast ghost (specs: A.specifier) (dt: A.decl_type) (ie: A.init_expression) : A.specifier * A.decl_type * A.init_expression = let typ = doOnlyType ghost specs dt in (* If we are casting to a union type then we have to treat this as a * constructor expression. This is to handle the gcc extension that allows * cast from a type of a field to the type of the union *) (* However, it may just be casting of a whole union to its own type. We * will resolve this later, when we'll convert casts to unions. *) let ie' = match unrollType typ, ie with TComp (c, _, _), A.SINGLE_INIT _ when not c.cstruct -> A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field", A.NEXT_INIT), ie)] | _, _ -> ie in (* Maybe specs contains an unnamed composite. Replace with the name so that * when we do again the specs we get the right name *) let specs1 = match typ with TComp (ci, _, _) -> List.map (function A.SpecType (A.Tstruct ("", _, [])) -> A.SpecType (A.Tstruct (ci.cname, None, [])) | A.SpecType (A.Tunion ("", _, [])) -> A.SpecType (A.Tunion (ci.cname, None, [])) | s -> s) specs | _ -> specs in specs1, dt, ie' and getIntConstExp ghost (aexp) : exp = let loc = aexp.expr_loc in let _, c, e, _ = doExp (ghost_local_env ghost) true aexp (AExp None) in if not (isEmpty c) then Kernel.error ~once:true ~current:true "Constant expression %a has effects" Cil_printer.pp_exp e; match e.enode with (* first, filter for those Const exps that are integers *) | Const (CInt64 _ ) -> e | Const (CEnum _) -> e | Const (CChr i) -> new_exp ~loc (Const(charConstToInt i)) (* other Const expressions are not ok *) | Const _ -> Kernel.fatal ~current:true "Expected integer constant and got %a" Cil_printer.pp_exp e (* now, anything else that 'doExp true' returned is ok (provided that it didn't yield side effects); this includes, in particular, the various sizeof and alignof expression kinds *) | _ -> e (* this is like 'isIntConstExp', but retrieves the actual integer * the expression denotes; I have not extended it to work with * sizeof/alignof since (for CCured) we can't const-eval those, * and it's not clear whether they can be bitfield width specifiers * anyway (since that's where this function is used) * -- VP 2006-12-20: C99 explicitly says so (par. 6.6.6) *) and isIntegerConstant ghost (aexp) : int option = match doExp (ghost_local_env ghost) true aexp (AExp None) with (_, c, e, _) when isEmpty c -> begin match isInteger (Cil.constFold true e) with Some i64 -> Some (Integer.to_int i64) | _ -> None end | _ -> None (* Process an expression and in the process do some type checking, * extract the effects as separate statements. * doExp returns the following 4-uple: * - a list of read accesses performed for the evaluation of the expression * - a chunk representing side-effects occuring during evaluation * - the CIL expression * - its type. *) and doExp local_env (asconst: bool) (* This expression is used as a constant *) (e: A.expression) (what: expAction) = let ghost = local_env.is_ghost in let loc = e.expr_loc in (* will be reset at the end of the compilation of current expression. *) let oldLoc = CurrentLoc.get() in CurrentLoc.set loc; let checkVoidLval e t = if (match e.enode with Lval _ -> true | _ -> false) && isVoidType t then Kernel.fatal ~current:true "lvalue of type void: %a@\n" Cil_printer.pp_exp e in (* A subexpression of array type is automatically turned into StartOf(e). * Similarly an expression of function type is turned into AddrOf. So * essentially doExp should never return things of type TFun or TArray *) let processArrayFun e t = let loc = e.eloc in match e.enode, unrollType t with | (Lval(lv) | CastE(_, {enode = Lval lv})), TArray(tbase, _, _, a) -> mkStartOfAndMark loc lv, TPtr(tbase, a) | (Lval(lv) | CastE(_, {enode = Lval lv})), TFun _ -> mkAddrOfAndMark loc lv, TPtr(t, []) | _, (TArray _ | TFun _) -> Kernel.fatal ~current:true "Array or function expression is not lval: %a@\n" Cil_printer.pp_exp e | _ -> e, t in (* Before we return we call finishExp *) let finishExp ?(newWhat=what) reads (se: chunk) (e: exp) (t: typ) = match newWhat with ADrop | AType -> let (e', t') = processArrayFun e t in (reads, se, e', t') | AExpLeaveArrayFun -> (reads, se, e, t) (* It is important that we do not do "processArrayFun" in * this case. We exploit this when we process the typeOf construct *) | AExp _ -> let (e', t') = processArrayFun e t in checkVoidLval e' t'; (* ignore (E.log "finishExp: e'=%a, t'=%a\n" Cil_printer.pp_exp e' d_type t'); *) (reads, se, e', t') | ASet (is_real_write,lv, r, lvt) -> begin (* See if the set was done already *) match e.enode with Lval(lv') when lv == lv' -> (reads,se, e, t) (* if this is the case, the effects have also been taken into account in the chunk. *) | _ -> let (e', t') = processArrayFun e t in let (t'', e'') = castTo t' lvt e' in checkVoidLval e'' t''; (*Kernel.debug "finishExp: e = %a\n e'' = %a\n" Cil_printer.pp_exp e Cil_printer.pp_exp e'';*) let writes = if is_real_write then [lv] else [] in ([], (* the reads are incorporated in the chunk. *) ((unspecified_chunk empty) @@ (remove_reads lv se, ghost)) +++ (mkStmtOneInstr ~ghost (Set(lv, e'', CurrentLoc.get ())), writes,writes, List.filter (fun x -> not (Cil.compareLval x lv)) r @ reads), e'', t'') end in let result = try match e.expr_node with | A.PAREN _ -> Kernel.fatal ~current:true "stripParen" | A.NOTHING when what = ADrop -> finishExp [] (unspecified_chunk empty) (integer ~loc 0) intType | A.NOTHING -> let res = new_exp ~loc (Const(CStr "exp_nothing")) in finishExp [] (unspecified_chunk empty) res (typeOf res) (* Do the potential lvalues first *) | A.VARIABLE n -> begin (* Look up in the environment *) try let envdata = H.find env n in match envdata with EnvVar vi, _ -> let lval = var vi in let reads = if Lval.Set.mem lval local_env.authorized_reads then [] else [ lval ] in (* if isconst && not (isFunctionType vi.vtype) && not (isArrayType vi.vtype)then Cil.error "variable appears in constant"; *) finishExp reads (unspecified_chunk empty) (new_exp ~loc (Lval lval)) vi.vtype | EnvEnum item, _ -> let typ = Cil.typeOf item.eival in Kernel.debug "Looking for %s got enum %s : %a of type %a" n item.einame Cil_printer.pp_exp item.eival Cil_printer.pp_typ typ; if Cil.theMachine.Cil.lowerConstants then finishExp [] (unspecified_chunk empty) item.eival typ else finishExp [] (unspecified_chunk empty) (new_exp ~loc (Const (CEnum item))) typ | _ -> raise Not_found with Not_found -> begin if isOldStyleVarArgName n then Kernel.fatal ~current:true "Cannot resolve variable %s. \ This could be a CIL bug due to the handling of old-style variable argument \ functions" n else Kernel.fatal ~current:true "Cannot resolve variable %s" n end end | A.INDEX (e1, e2) -> begin (* Recall that doExp turns arrays into StartOf pointers *) let (r1, se1, e1', t1) = doExp local_env false e1 (AExp None) in let (r2,se2, e2', t2) = doExp local_env false e2 (AExp None) in let se = se1 @@ (se2, ghost) in let (e1'', t1, e2'', tresult) = (* Either e1 or e2 can be the pointer *) match unrollType t1, unrollType t2 with TPtr(t1e,_), (TInt _|TEnum _) -> e1', t1, e2', t1e | (TInt _|TEnum _), TPtr(t2e,_) -> e2', t2, e1', t2e | _ -> Kernel.fatal ~current:true "Expecting a pointer type in index:@\n t1=%a@\nt2=%a" Cil_printer.pp_typ t1 Cil_printer.pp_typ t2 in (* We have to distinguish the construction based on the type of e1'' *) let res = match e1''.enode with StartOf array -> (* A real array indexing operation *) addOffsetLval (Index(e2'', NoOffset)) array | _ -> (* Turn into *(e1 + e2) *) mkMem (new_exp ~loc:e1''.eloc (BinOp(IndexPI, e1'', e2'', t1))) NoOffset in (* Do some optimization of StartOf *) let reads = let l = r1 @ r2 in if Lval.Set.mem res local_env.authorized_reads then l else res :: l in finishExp reads se (new_exp ~loc (Lval res)) tresult end | A.UNARY (A.MEMOF, e) -> if asconst then Kernel.warning ~current:true "MEMOF in constant"; let (r,se, e', t) = doExp local_env false e (AExp None) in let tresult = match unrollType t with | TPtr(te, _) -> te | _ -> Kernel.fatal ~current:true "Expecting a pointer type in *. Got %a." Cil_printer.pp_typ t in let res = mkMem e' NoOffset in let reads = if Lval.Set.mem res local_env.authorized_reads then r else res :: r in finishExp reads se (new_exp ~loc (Lval res)) tresult (* e.str = (& e + off(str)). If e = (be + beoff) then e.str = (be * + beoff + off(str)) *) | A.MEMBEROF (e, str) -> (* member of is actually allowed if we only take the address *) (* if isconst then Cil.error "MEMBEROF in constant"; *) let (r,se, e', t') = doExp local_env false e (AExp None) in let lv = match e'.enode with Lval x -> x | CastE(_, { enode = Lval x}) -> x | _ -> Kernel.fatal ~current:true "Expected an lval in MEMBEROF (field %s)" str in (* We're not reading the whole lval, just a chunk of it. *) let r = List.filter (fun x -> not (Lval.equal x lv)) r in let field_offset = match unrollType t' with TComp (comp, _, _) -> findField str comp.cfields | _ -> Kernel.fatal ~current:true "expecting a struct with field %s" str in let lv' = addOffsetLval field_offset lv in let field_type = typeOf (dummy_exp (Lval lv')) in let reads = if Lval.Set.mem lv' local_env.authorized_reads then r else lv':: r in finishExp reads se (new_exp ~loc (Lval lv')) field_type (* e->str = * (e + off(str)) *) | A.MEMBEROFPTR (e, str) -> if asconst then Kernel.warning ~current:true "MEMBEROFPTR in constant"; let (r,se, e', t') = doExp local_env false e (AExp None) in let pointedt = match unrollType t' with | TPtr(t1, _) -> t1 | TArray(t1,_,_,_) -> t1 | _ -> Kernel.fatal ~current:true "expecting a pointer to a struct" in let field_offset = match unrollType pointedt with | TComp (comp, _, _) -> findField str comp.cfields | x -> Kernel.fatal ~current:true "expecting a struct with field %s. Found %a. t1 is %a" str Cil_printer.pp_typ x Cil_printer.pp_typ t' in let lv' = mkMem e' field_offset in let field_type = typeOf (dummy_exp (Lval lv')) in let reads = if Lval.Set.mem lv' local_env.authorized_reads then r else lv' :: r in finishExp reads se (new_exp ~loc (Lval lv')) field_type | A.CONSTANT ct -> begin let hasSuffix str = let l = String.length str in fun s -> let ls = String.length s in l >= ls && s = String.uppercase (String.sub str (l - ls) ls) in match ct with A.CONST_INT str -> begin let res = parseIntExp ~loc str in finishExp [] (unspecified_chunk empty) res (typeOf res) end | A.CONST_WSTRING (ws: int64 list) -> let res = new_exp ~loc (Const(CWStr ((* intlist_to_wstring *) ws))) in finishExp [] (unspecified_chunk empty) res (typeOf res) | A.CONST_STRING s -> (* Maybe we burried __FUNCTION__ in there *) let s' = try let start = String.index s (Char.chr 0) in let l = String.length s in let tofind = (String.make 1 (Char.chr 0)) ^ "__FUNCTION__" in let past = start + String.length tofind in if past <= l && String.sub s start (String.length tofind) = tofind then (if start > 0 then String.sub s 0 start else "") ^ !currentFunctionFDEC.svar.vname ^ (if past < l then String.sub s past (l - past) else "") else s with Not_found -> s in let res = new_exp ~loc (Const(CStr s')) in finishExp [] (unspecified_chunk empty) res (typeOf res) | A.CONST_CHAR char_list -> let a, b = (interpret_character_constant char_list) in finishExp [] (unspecified_chunk empty) (new_exp ~loc (Const a)) b | A.CONST_WCHAR char_list -> (* matth: I can't see a reason for a list of more than one char * here, since the kinteger64 below will take only the lower 16 * bits of value. ('abc' makes sense, because CHAR constants have * type int, and so more than one char may be needed to represent * the value. But L'abc' has type wchar, and so is equivalent to * L'c'). But gcc allows L'abc', so I'll leave this here in case * I'm missing some architecture dependent behavior. *) let value = reduce_multichar theMachine.wcharType char_list in let result = kinteger64 ~loc theMachine.wcharKind (Integer.of_int64 value) in finishExp [] (unspecified_chunk empty) result (typeOf result) | A.CONST_FLOAT str -> begin (* Maybe it ends in U or UL. Strip those *) let l = String.length str in let hasSuffix = hasSuffix str in let baseint, kind = if hasSuffix "L" then String.sub str 0 (l - 1), FLongDouble else if hasSuffix "F" then String.sub str 0 (l - 1), FFloat else if hasSuffix "D" then String.sub str 0 (l - 1), FDouble else str, FDouble in try Floating_point.set_round_nearest_even (); let basefloat = match kind with | FFloat -> Floating_point.single_precision_of_string baseint | FDouble | FLongDouble -> Floating_point.double_precision_of_string baseint in let open Floating_point in begin if basefloat.f_lower <> basefloat.f_upper && Kernel.WarnDecimalFloat.get() <> "none" then let msg = if Kernel.WarnDecimalFloat.get() = "once" then begin Kernel.WarnDecimalFloat.set "none"; ". See documentation for option " ^ Kernel.WarnDecimalFloat.name end else (* all *) "" in Kernel.warning ~current:true "Floating-point constant %s is not represented exactly. Will use %a%s" str (Floating_point.pretty_normal ~use_hex:true) basefloat.f_nearest msg ; end ; let node = Const(CReal(basefloat.f_nearest, kind, Some str)) in finishExp [] (unspecified_chunk empty) (new_exp ~loc node) (TFloat(kind,[])) with Failure s -> begin Kernel.error ~once:true ~current:true "float_of_string %s (%s)\n" str s; let res = new_exp ~loc (Const(CStr "booo CONS_FLOAT")) in finishExp [] (unspecified_chunk empty) res (typeOf res) end end end | A.TYPE_SIZEOF (bt, dt) -> let typ = doOnlyType local_env.is_ghost bt dt in finishExp [] (unspecified_chunk empty) (new_exp ~loc (SizeOf(typ))) theMachine.typeOfSizeOf (* Intercept the sizeof("string") *) | A.EXPR_SIZEOF ({ expr_node = A.CONSTANT (A.CONST_STRING _)} as e) -> begin (* Process the string first *) match doExp local_env asconst e (AExp None) with _, _, {enode = Const(CStr s)}, _ -> finishExp [] (unspecified_chunk empty) (new_exp ~loc (SizeOfStr s)) theMachine.typeOfSizeOf | _ -> Kernel.abort ~current:true "cabs2cil: sizeOfStr" end | A.EXPR_SIZEOF e -> (* Allow non-constants in sizeof *) (* Do not convert arrays and functions into pointers. *) let (_, se, e', _) = doExp local_env false e AExpLeaveArrayFun in (* ignore (E.log "sizeof: %a e'=%a, t=%a\n" Cil_printer.pp_location !currentLoc Cil_printer.pp_exp e' Cil_printer.pp_typ t); *) (* !!!! The book says that the expression is not evaluated, so we * drop the potential side-effects *) let scope_chunk = if isNotEmpty se then begin Kernel.warning ~current:true "Warning: Dropping side-effect in sizeof"; IgnoreSideEffectHook.apply (e, e'); let vars = List.filter (fun x -> Cil.appears_in_expr x e') se.locals in List.fold_left local_var_chunk empty vars end else empty in let size = match e'.enode with (* If we are taking the sizeof an * array we must drop the StartOf *) StartOf(lv) -> new_exp ~loc (SizeOfE (new_exp ~loc:e'.eloc(Lval(lv)))) (* Maybe we are taking the sizeof a variable-sized array *) | Lval (Var vi, NoOffset) -> begin try IH.find varSizeArrays vi.vid with Not_found -> new_exp ~loc (SizeOfE e') end | _ -> new_exp ~loc (SizeOfE e') in finishExp [] scope_chunk size theMachine.typeOfSizeOf | A.TYPE_ALIGNOF (bt, dt) -> let typ = doOnlyType local_env.is_ghost bt dt in finishExp [] (unspecified_chunk empty) (new_exp ~loc (AlignOf(typ))) theMachine.typeOfSizeOf | A.EXPR_ALIGNOF e -> let (_, se, e', _) = doExp local_env false e AExpLeaveArrayFun in (* !!!! The book says that the expression is not evaluated, so we * drop the potential side-effects *) if isNotEmpty se then begin Kernel.warning ~current:true "Warning: Dropping side-effect in sizeof"; IgnoreSideEffectHook.apply (e, e') end; let e'' = match e'.enode with (* If we are taking the alignof an * array we must drop the StartOf *) StartOf(lv) -> new_exp ~loc:e'.eloc (Lval(lv)) | _ -> e' in finishExp [] (unspecified_chunk empty) (new_exp ~loc (AlignOfE(e''))) theMachine.typeOfSizeOf | A.CAST ((specs, dt), ie) -> let s', dt', ie' = preprocessCast local_env.is_ghost specs dt ie in (* We know now that we can do s' and dt' many times *) let typ = doOnlyType local_env.is_ghost s' dt' in let what' = match what with AExp (Some _) -> AExp (Some typ) | AExp None -> what | ADrop | AType | AExpLeaveArrayFun -> what | ASet (_, _, _, lvt) -> (* If the cast from typ to lvt would be dropped, then we * continue with a Set *) if false && Cil_datatype.Typ.equal typ lvt then what else AExp None (* We'll create a temporary *) in (* Remember here if we have done the Set *) let (r,se, e', t'), (needcast: bool) = match ie' with A.SINGLE_INIT e -> doExp local_env asconst e what', true | A.NO_INIT -> Kernel.fatal ~current:true "missing expression in cast" | A.COMPOUND_INIT _ -> begin (* Pretend that we are declaring and initializing a brand new * variable *) let newvar = "__constr_expr_" ^ string_of_int (!constrExprId) in incr constrExprId; let spec_res = doSpecList local_env.is_ghost "" s' in let se1 = if !scopes == [] then begin (* This is a global. Mark the new vars as static *) let spec_res' = let t, _, inl, attrs = spec_res in t, Static, inl, attrs in ignore (createGlobal local_env.is_ghost None spec_res' ((newvar, dt', [], loc), ie')); (unspecified_chunk empty) end else createLocal local_env.is_ghost spec_res ((newvar, dt', [], loc), ie') in (* Now pretend that e is just a reference to the newly created * variable *) let v = { expr_node = A.VARIABLE newvar; expr_loc = loc } in let r, se, e', t' = doExp local_env asconst v what' in (* If typ is an array then the doExp above has already added a * StartOf. We must undo that now so that it is done once by * the finishExp at the end of this case *) let e2, t2 = match unrollType typ, e'.enode with TArray _, StartOf lv -> new_exp ~loc (Lval lv), typ | _, _ -> e', t' in (* If we are here, then the type t2 is guaranteed to match the * type of the expression e2, so we do not need a cast. We have * to worry about this because otherwise, we might need to cast * between arrays or structures. *) (r, se1 @@ (se, ghost), e2, t2), false end in let (t'', e'') = match typ with TVoid _ when what' = ADrop -> (t', e') (* strange GNU thing *) | _ -> (* Do this to check the cast, unless we are sure that we do not * need the check. *) let newtyp, newexp = if needcast then castTo ~fromsource:true t' typ e' else t', e' in newtyp, newexp in finishExp r se e'' t'' | A.UNARY(A.MINUS, e) -> let (r, se, e', t) = doExp local_env asconst e (AExp None) in if isIntegralType t then let tres = integralPromotion t in let e'' = new_exp ~loc (UnOp(Neg, makeCastT e' t tres, tres)) in finishExp r se e'' tres else if isArithmeticType t then finishExp r se (new_exp ~loc:e'.eloc (UnOp(Neg,e',t))) t else Kernel.fatal ~current:true "Unary - on a non-arithmetic type" | A.UNARY(A.BNOT, e) -> let (r, se, e', t) = doExp local_env asconst e (AExp None) in if isIntegralType t then let tres = integralPromotion t in let e'' = new_exp ~loc (UnOp(BNot, makeCastT e' t tres, tres)) in finishExp r se e'' tres else Kernel.fatal ~current:true "Unary ~ on a non-integral type" | A.UNARY(A.PLUS, e) -> doExp local_env asconst e what | A.UNARY(A.ADDROF, e) -> begin match e.expr_node with A.COMMA el -> (* GCC extension *) doExp local_env false { e with expr_node = A.COMMA (replaceLastInList el (fun e -> { e with expr_node = A.UNARY(A.ADDROF, e)})) } what | A.QUESTION (e1, e2, e3) -> (* GCC extension *) doExp local_env false { e with expr_node = A.QUESTION (e1, { e2 with expr_node = A.UNARY(A.ADDROF, e2)}, { e3 with expr_node = A.UNARY(A.ADDROF, e3)})} what | A.PAREN e1 -> doExp local_env false { e with expr_node = A.UNARY(A.ADDROF, e1)} what | A.VARIABLE s when isOldStyleVarArgName s && (match !currentFunctionFDEC.svar.vtype with TFun(_, _, true, _) -> true | _ -> false) -> (* We are in an old-style variable argument function and we are * taking the address of the argument that was removed while * processing the function type. We compute the address based on * the address of the last real argument *) if theMachine.msvcMode then begin let rec getLast = function | [] -> Kernel.fatal ~current:true "old-style variable argument function without real \ arguments" | [ a ] -> a | _ :: rest -> getLast rest in let last = getLast !currentFunctionFDEC.sformals in let res = mkAddrOfAndMark e.expr_loc (var last) in let tres = typeOf res in let tres', res' = castTo tres (TInt(IULong, [])) res in (* Now we must add to this address to point to the next * argument. Round up to a multiple of 4 *) let sizeOfLast = (((bitsSizeOf last.vtype) + 31) / 32) * 4 in let res'' = new_exp ~loc (BinOp(PlusA, res', kinteger ~loc IULong sizeOfLast, tres')) in let lv = var last in let reads = if Lval.Set.mem lv local_env.authorized_reads then [] else [ lv ] in finishExp reads (unspecified_chunk empty) res'' tres' end else begin (* On GCC the only reliable way to do this is to * call builtin_next_arg. If we take the address of * a local we are going to get the address of a copy * of the local ! *) doExp local_env asconst (cabs_exp loc (A.CALL (cabs_exp loc (A.VARIABLE "__builtin_next_arg"), [cabs_exp loc (A.CONSTANT (A.CONST_INT "0"))]))) what end | A.VARIABLE _ | A.UNARY (A.MEMOF, _) (* Regular lvalues *) | A.CONSTANT (A.CONST_STRING _) | A.CONSTANT (A.CONST_WSTRING _) | A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | A.CAST (_, A.COMPOUND_INIT _) -> begin let (r, se, e', t) = doExp local_env false e (AExp None) in (* ignore (E.log "ADDROF on %a : %a\n" Cil_printer.pp_exp e' Cil_printer.pp_typ t); *) match e'.enode with (Lval x | CastE(_, {enode = Lval x})) -> let reads = match x with | Mem _ ,_ -> r (* we're not really reading the pointed value, just calculating an offset. *) | Var _,_ -> if Lval.Set.mem x local_env.authorized_reads then r else x :: r in finishExp reads se (mkAddrOfAndMark loc x) (TPtr(t, [])) | StartOf (lv) -> let tres = TPtr(typeOfLval lv, []) in (* pointer to array *) let reads = match lv with | Mem _, _ -> r (* see above *) | Var _,_ -> if Lval.Set.mem lv local_env.authorized_reads then r else lv :: r in finishExp reads se (mkAddrOfAndMark loc lv) tres | Const (CStr _ | CWStr _) -> (* string to array *) finishExp r se e' (TPtr(t, [])) (* Function names are converted into pointers to the function. * Taking the address-of again does not change things *) | AddrOf (Var v, NoOffset) when isFunctionType v.vtype -> finishExp r se e' t | _ -> Kernel.fatal ~current:true "Expected lval for ADDROF. Got %a" Cil_printer.pp_exp e' end | _ -> Kernel.fatal ~current:true "Unexpected operand for addrof" end | A.UNARY((A.PREINCR|A.PREDECR) as uop, e) -> begin match e.expr_node with A.COMMA el -> (* GCC extension *) doExp local_env asconst (cabs_exp loc (A.COMMA (replaceLastInList el (fun e -> cabs_exp e.expr_loc (A.UNARY(uop, e)))))) what | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) doExp local_env asconst (cabs_exp loc (A.QUESTION (e1, cabs_exp e2q.expr_loc (A.UNARY(uop, e2q)), cabs_exp e3q.expr_loc (A.UNARY(uop, e3q))))) what | A.PAREN e1 -> doExp local_env asconst (cabs_exp loc (A.UNARY(uop, e1))) what | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | A.CAST _ (* A GCC extension *)) -> begin let uop' = if uop = A.PREINCR then PlusA else MinusA in if asconst then Kernel.warning ~current:true "PREINCR or PREDECR in constant"; let (r, se, e', t) = doExp local_env false e (AExp None) in let lv = match e'.enode with Lval x -> x | CastE (_, {enode = Lval x}) -> x (* A GCC extension. The operation is * done at the cast type. The result * is also of the cast type *) | _ -> Kernel.fatal ~current:true "Expected lval for ++ or --" in let se' = remove_reads lv se in let r' = List.filter (fun x -> not (Lval.equal x lv)) r in let tresult, result = doBinOp loc uop' e' t (one ~loc:e'.eloc) intType in finishExp [] (se' +++ (mkStmtOneInstr ~ghost:local_env.is_ghost (Set(lv, makeCastT result tresult t, CurrentLoc.get ())),[],[lv],r')) e' t end | _ -> Kernel.fatal ~current:true "Unexpected operand for prefix -- or ++" end | A.UNARY((A.POSINCR|A.POSDECR) as uop, e) -> begin match e.expr_node with A.COMMA el -> (* GCC extension *) doExp local_env asconst (cabs_exp loc (A.COMMA (replaceLastInList el (fun e -> cabs_exp e.expr_loc (A.UNARY(uop, e)))))) what | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) doExp local_env asconst (cabs_exp loc (A.QUESTION (e1, cabs_exp e2q.expr_loc (A.UNARY(uop, e2q)), cabs_exp e3q.expr_loc (A.UNARY(uop, e3q))))) what | A.PAREN e1 -> doExp local_env asconst (cabs_exp e1.expr_loc (A.UNARY(uop,e1))) what | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | A.CAST _ (* A GCC extension *) ) -> begin if asconst then Kernel.warning ~current:true "POSTINCR or POSTDECR in constant"; (* If we do not drop the result then we must save the value *) let uop' = if uop = A.POSINCR then PlusA else MinusA in let (r,se, e', t) = doExp local_env false e (AExp None) in let lv = match e'.enode with Lval x -> x | CastE (_, {enode = Lval x}) -> x (* GCC extension. The addition must * be be done at the cast type. The * result of this is also of the cast * type *) | _ -> Kernel.fatal ~current:true "Expected lval for ++ or --" in let se' = remove_reads lv se in let r' = List.filter (fun x -> not (Lval.equal x lv)) r in let tresult, opresult = doBinOp loc uop' e' t (one ~loc:e'.eloc) intType in let reads, se', result = if what <> ADrop && what <> AType then let descr = Pretty_utils.sfprintf "%a%s" Cil_descriptive_printer.pp_exp e' (if uop = A.POSINCR then "++" else "--") in let tmp = newTempVar (Some descr) true t in ([var tmp], local_var_chunk se' tmp +++ (mkStmtOneInstr ~ghost:local_env.is_ghost (Set(var tmp, e', CurrentLoc.get ())),[],[],[]), (* the tmp variable should not be investigated for unspecified writes: it occurs at the right place in the sequence. *) new_exp ~loc (Lval(var tmp))) else [],se, e' in finishExp reads (se' +++ (mkStmtOneInstr ~ghost:local_env.is_ghost (Set(lv, makeCastT opresult tresult (typeOfLval lv), CurrentLoc.get ())), [],[lv], r')) result t end | _ -> Kernel.fatal ~current:true "Unexpected operand for suffix ++ or --" end | A.BINARY(A.ASSIGN, e1, e2) -> begin match e1.expr_node with A.COMMA el -> (* GCC extension *) doExp local_env asconst (cabs_exp loc (A.COMMA (replaceLastInList el (fun e -> cabs_exp e.expr_loc (A.BINARY(A.ASSIGN, e, e2)))))) what | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) (*TODO: prevent duplication of e2: this is incorrect if it contains labels *) (* let r2,se2,e2,t2 = doExp authorized_reads ghost asconst e2 in*) doExp local_env asconst (cabs_exp loc (A.QUESTION (e1, cabs_exp e2q.expr_loc (A.BINARY(A.ASSIGN, e2q, e2)), cabs_exp e3q.expr_loc (A.BINARY(A.ASSIGN, e3q, e2))))) what | A.CAST (t, A.SINGLE_INIT e) -> (* GCC extension *) doExp local_env asconst (cabs_exp loc (A.CAST (t, A.SINGLE_INIT (cabs_exp e.expr_loc (A.BINARY (A.ASSIGN, e, (cabs_exp e2.expr_loc (A.CAST (t, A.SINGLE_INIT e2))))))))) what | A.PAREN e1 -> doExp local_env asconst (cabs_exp loc (A.BINARY(A.ASSIGN,e1,e2))) what | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ ) -> begin if asconst then Kernel.warning ~current:true "ASSIGN in constant"; let se0 = unspecified_chunk empty in let (r1,se1, e1', lvt) = doExp local_env false e1 (AExp None) in let lv = match e1'.enode with | Lval x -> x | _ -> Kernel.fatal ~current:true "Expected lval for assignment. Got %a" Cil_printer.pp_exp e1' in let se1' = remove_reads lv se1 in let r1' = List.filter (fun x -> not (Lval.equal x lv)) r1 in let local_env = { local_env with authorized_reads = Lval.Set.add lv local_env.authorized_reads } in (*[BM]: is this useful? let (_, _, _) = doExp ghost false e2 (ASet(lv, lvt)) in*) (* Catch the case of an lval that might depend on itself, e.g. p[p[0]] when p[0] == 0. We need to use a temporary here if the result of the expression will be used: tmp := e2; lv := tmp; use tmp as the result Test: small1/assign.c *) let needsTemp = not (isBitfield lv) && (* PC: BTS 933, 968 *) match what, lv with (ADrop|AType), _ -> false | _, (Mem e, off) -> not (isConstant e) || not (isConstantOffset off) | _, (Var _, off) -> not (isConstantOffset off) in let r1, tmplv, se3 = if needsTemp then let descr = Some (Pretty_utils.sfprintf "%a" Cil_descriptive_printer.pp_lval lv) in let tmp = newTempVar descr true lvt in let chunk = i2c (mkStmtOneInstr ~ghost:local_env.is_ghost (Set(lv, new_exp ~loc:e1'.eloc (Lval(var tmp)), loc)), [lv],[lv], r1') in ([],var tmp, local_var_chunk chunk tmp) else r1',lv, empty in let (r2,se2, _, _) = doExp local_env false e2 (ASet(not needsTemp,tmplv, r1, lvt)) in let (@@) s1 s2 = s1 @@ (s2, ghost) in (* Format.eprintf "chunk for assigns is %a@." d_chunk se2; *) (* r1 is read in the assignment part itself *) finishExp r2 ((empty @@ ((se0 @@ se1') @@ se2)) @@ se3) (new_exp ~loc (Lval tmplv)) lvt end | _ -> Kernel.fatal ~current:true "Invalid left operand for ASSIGN" end | A.BINARY((A.ADD|A.SUB|A.MUL|A.DIV|A.MOD|A.BAND|A.BOR|A.XOR| A.SHL|A.SHR|A.EQ|A.NE|A.LT|A.GT|A.GE|A.LE) as bop, e1, e2) -> let se0 = unspecified_chunk empty in let bop' = convBinOp bop in let (r1,se1, e1', t1) = doExp local_env asconst e1 (AExp None) in let (r2,se2, e2', t2) = doExp local_env asconst e2 (AExp None) in let tresult, result = doBinOp loc bop' e1' t1 e2' t2 in let (@@) s1 s2 = s1 @@ (s2, ghost) in finishExp (r1 @ r2) ((se0 @@ se1) @@ se2) result tresult (* assignment operators *) | A.BINARY((A.ADD_ASSIGN|A.SUB_ASSIGN|A.MUL_ASSIGN|A.DIV_ASSIGN| A.MOD_ASSIGN|A.BAND_ASSIGN|A.BOR_ASSIGN|A.SHL_ASSIGN| A.SHR_ASSIGN|A.XOR_ASSIGN) as bop, e1, e2) -> begin let se0 = unspecified_chunk empty in match e1.expr_node with A.COMMA el -> (* GCC extension *) doExp local_env asconst (cabs_exp loc (A.COMMA (replaceLastInList el (fun e -> cabs_exp e.expr_loc (A.BINARY(bop, e, e2)))))) what | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) doExp local_env asconst (cabs_exp loc (A.QUESTION (e1, cabs_exp e2q.expr_loc (A.BINARY(bop, e2q, e2)), cabs_exp e3q.expr_loc (A.BINARY(bop, e3q, e2))))) what | A.PAREN e1 -> doExp local_env asconst (cabs_exp loc (A.BINARY(bop,e1,e2))) what | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | A.CAST _ (* GCC extension *) ) -> begin if asconst then Kernel.warning ~current:true "op_ASSIGN in constant"; let bop' = match bop with A.ADD_ASSIGN -> PlusA | A.SUB_ASSIGN -> MinusA | A.MUL_ASSIGN -> Mult | A.DIV_ASSIGN -> Div | A.MOD_ASSIGN -> Mod | A.BAND_ASSIGN -> BAnd | A.BOR_ASSIGN -> BOr | A.XOR_ASSIGN -> BXor | A.SHL_ASSIGN -> Shiftlt | A.SHR_ASSIGN -> Shiftrt | _ -> Kernel.fatal ~current:true "binary +=" in let (r1,se1, e1', t1) = doExp local_env false e1 (AExp None) in let lv1 = match e1'.enode with Lval x -> x | CastE (_, {enode = Lval x}) -> x (* GCC extension. The operation and * the result are at the cast type *) | _ -> Kernel.fatal ~current:true "Expected lval for assignment with arith" in let se1' = remove_reads lv1 se1 in let r1' = List.filter (fun x -> not (Lval.equal x lv1)) r1 in let local_env = { local_env with authorized_reads = Lval.Set.add lv1 local_env.authorized_reads } in let (r2, se2, e2', t2) = doExp local_env false e2 (AExp None) in let se2 = remove_reads lv1 se2 in let tresult, result = doBinOp loc bop' e1' t1 e2' t2 in (* We must cast the result to the type of the lv1, which may be * different than t1 if lv1 was a Cast *) let _, result' = castTo tresult (typeOfLval lv1) result in (* The type of the result is the type of the left-hand side *) let (@@) s1 s2 = s1 @@ (s2, ghost) in finishExp [] (se0 @@ (empty @@ (se1' @@ se2) +++ (mkStmtOneInstr ~ghost:local_env.is_ghost (Set(lv1, result', loc)), [lv1],[lv1], r1' @ r2))) e1' t1 end | _ -> Kernel.fatal ~current:true "Unexpected left operand for assignment with arith" end | A.BINARY((A.AND|A.OR), _, _) | A.UNARY(A.NOT, _) -> begin let ce = doCondExp local_env asconst e in (* We must normalize the result to 0 or 1 *) match ce with CEExp (se, ({enode = Const _;eloc=loc} as c)) -> finishExp [] se (if isConstTrue c then one ~loc else zero ~loc) intType | CEExp (se, ({enode = UnOp(LNot, _, _)} as e)) -> (* already normalized to 0 or 1 *) finishExp [] se e intType | CEExp (se, e) -> let e' = let te = typeOf e in let _, zte = castTo intType te (zero ~loc:e.eloc) in new_exp ~loc (BinOp(Ne, e, zte, intType)) in finishExp [] se e' intType | _ -> let tmp = newTempVar (Some "") true intType in let condChunk = compileCondExp ~ghost false ce (empty +++ (mkStmtOneInstr ~ghost (Set(var tmp, integer ~loc 1,loc)),[],[],[])) (empty +++ (mkStmtOneInstr ~ghost (Set(var tmp, integer ~loc 0,loc)),[],[],[])) in finishExp [] (local_var_chunk condChunk tmp) (new_exp ~loc (Lval (var tmp))) intType end | A.CALL(f, args) -> if asconst then Kernel.warning ~current:true "CALL in constant"; let (rf,sf, f', ft') = match f.expr_node with (* Treat the VARIABLE case separate because we might be calling a * function that does not have a prototype. In that case assume it * takes INTs as arguments *) A.VARIABLE n -> begin try let vi, _ = lookupVar n in let reads = if Lval.Set.mem (var vi) local_env.authorized_reads || (vi.vglob && Cil.isFunctionType vi.vtype) then [] else [ var vi ] in (reads, unspecified_chunk empty, new_exp ~loc:f.expr_loc (Lval(var vi)), vi.vtype) (* Found. Do not use finishExp. Simulate what = AExp None *) with Not_found -> begin Kernel.debug ~level:3 "Calling function %s without prototype." n ; let ftype = TFun(intType, None, false, [Attr("missingproto",[])]) in (* Add a prototype to the environment *) let proto, _ = makeGlobalVarinfo false (makeGlobalVar ~generated:false n ftype) in (* Make it EXTERN *) proto.vstorage <- Extern; IH.add noProtoFunctions proto.vid true; proto.vdecl <- f.expr_loc; ImplicitPrototypeHook.apply proto; (* Add it to the file as well *) cabsPushGlobal (GVarDecl (empty_funspec (),proto, f.expr_loc)); ([var proto],unspecified_chunk empty, new_exp ~loc:f.expr_loc (Lval(var proto)), ftype) end end | _ -> doExp local_env false f (AExp None) in (* Get the result type and the argument types *) let (resType, argTypes, isvar, f'',attrs) = match unrollType ft' with TFun(rt,at,isvar,attrs) -> (rt,at,isvar,f',attrs) | TPtr (t, _) -> begin match unrollType t with TFun(rt,at,isvar,_) -> (* Make the function pointer * explicit *) let f'' = match f'.enode with AddrOf lv -> new_exp ~loc:f'.eloc (Lval(lv)) | _ -> new_exp ~loc:f'.eloc (Lval (mkMem f' NoOffset)) in (rt,at,isvar, f'',[]) | x -> Kernel.fatal ~current:true "Unexpected type of the called function %a: %a" Cil_printer.pp_exp f' Cil_printer.pp_typ x end | x -> Kernel.fatal ~current:true "Unexpected type of the called function %a: %a" Cil_printer.pp_exp f' Cil_printer.pp_typ x in let argTypesList = argsToList argTypes in (* Drop certain qualifiers from the result type *) let resType' = typeRemoveAttributes ["warn_unused_result"] resType in (* Before we do the arguments we try to intercept a few builtins. For * these we have defined then with a different type, so we do not * want to give warnings. We'll just leave the arguments of these * functions alone*) let isSpecialBuiltin = match f''.enode with Lval (Var fv, NoOffset) -> Cil.is_special_builtin fv.vname | _ -> false in let force_rlarg_eval = Kernel.ForceRLArgEval.get () in (** If [force_rlarg_eval], make sure we evaluate args right-to-left. *) let force_right_to_left_evaluation (r,c, e, t) = (* If chunk is empty then it is not already evaluated *) (* constants don't need to be pulled out *) if force_rlarg_eval && (not (isConstant e)) && not isSpecialBuiltin then (* create a temporary *) let tmp = newTempVar (Some (Pretty_utils.sfprintf "%a" Cil_descriptive_printer.pp_exp e)) true t in let c = local_var_chunk c tmp in (* create an instruction to give the e to the temporary *) let i = mkStmtOneInstr ~ghost:local_env.is_ghost (Set(var tmp, e, loc)) in (* add the instruction to the chunk *) (* change the expression to be the temporary *) (c +++ (i,[],[],[]), new_exp ~loc (Lval(var tmp)), t) else (add_reads loc r c, e, t) in let init_chunk = if force_rlarg_eval then empty else unspecified_chunk empty in (* Do the arguments. In REVERSE order !!! Both GCC and MSVC do this *) let rec loopArgs = function | ([], []) -> (init_chunk, []) | _, [] -> if not isSpecialBuiltin then Kernel.error ~once:true ~current:true "Too few arguments in call to %a." Cil_printer.pp_exp f' ; (init_chunk, []) | ((_, at, _) :: atypes, a :: args) -> let (ss, args') = loopArgs (atypes, args) in (* Do not cast as part of translating the argument. We let * the castTo do this work. This was necessary for * test/small1/union5, in which a transparent union is passed * as an argument *) let (sa, a', att) = force_right_to_left_evaluation (doExp local_env false a (AExp None)) in let (_, a'') = castTo att at a' in (ss @@ (sa, ghost), a'' :: args') | ([], args) -> (* No more types *) if not isvar && argTypes != None && not isSpecialBuiltin then (* Do not give a warning for functions without a prototype*) Kernel.error ~once:true ~current:true "Too many arguments in call to %a" Cil_printer.pp_exp f'; let rec loop = function [] -> (init_chunk, []) | a :: args -> let (ss, args') = loop args in let (sa, a', _) = force_right_to_left_evaluation (doExp local_env false a (AExp None)) in (ss @@ (sa, ghost), a' :: args') in let (chunk,args as res) = loop args in (match argTypes, f''.enode with | Some _,_ -> res | None, Lval (Var f, NoOffset) when not isSpecialBuiltin-> (* use default argument promotion to infer the type of the function, see 6.5.2.2.6 *) let (prm_types,args) = List.split (Extlib.mapi default_argument_promotion args) in let typ = TFun (resType, Some prm_types, false,attrs) in f.vtype <- typ; Cil.setFormalsDecl f typ; (chunk,args) | None, _ -> res (* TODO: treat function pointers. The issue is that their origin is more difficult to trace than plain variables (e.g. we'd have to take into account possible assignments, or update accordingly the signature of current function in case of a formal. *) ) in let (sargs, args') = loopArgs (argTypesList, args) in (* Setup some pointer to the elements of the call. We may change * these below *) let s0 = unspecified_chunk empty in (* there is a sequence point between evaluations of args and the call itself, but we have to check that args wo side-effects (thus not appearing anywhere in sargs) are not modified by others... The call must thus be in the unspecified chunk *) let sargs = if isEmpty sargs then empty else sargs in let prechunk = ref ((s0 @@ (sf, ghost)) @@ (sargs, ghost)) in (* Do we actually have a call, or an expression? *) let piscall: bool ref = ref true in let pf: exp ref = ref f'' in (* function to call *) let pargs: exp list ref = ref args' in (* arguments *) let pis__builtin_va_arg: bool ref = ref false in let pwhat: expAction ref = ref what in (* what to do with result *) let locals = ref [] in (* If we do not have a call, this is the result *) let pres: exp ref = ref (zero ~loc:e.expr_loc) in let prestype: typ ref = ref intType in let rec dropCasts e = match e.enode with CastE (_, e) -> dropCasts e | _ -> e in (* Get the name of the last formal *) let getNameLastFormal () : string = match !currentFunctionFDEC.svar.vtype with TFun(_, Some args, true, _) -> begin match List.rev args with (last_par_name, _, _) :: _ -> last_par_name | _ -> "" end | _ -> "" in (* Try to intercept some builtins *) (match (!pf).enode with Lval(Var fv, NoOffset) -> begin if fv.vname = "__builtin_va_arg" then begin match !pargs with marker :: ({enode = SizeOf resTyp} as size) :: _ -> begin (* Make a variable of the desired type *) let is_real, destlv, r, destlvtyp = match !pwhat with ASet (is_real,lv, r, lvt) -> is_real, lv, r, lvt | _ -> let v = newTempVar None true resTyp in locals := v::!locals; false, var v, [], resTyp in pwhat := (ASet (is_real, destlv, r, destlvtyp)); pargs := [marker; size; new_exp ~loc (CastE(voidPtrType, new_exp ~loc (AddrOf destlv)))]; pis__builtin_va_arg := true; end | _ -> Kernel.warning ~current:true "Invalid call to %s\n" fv.vname; end else if fv.vname = "__builtin_stdarg_start" || fv.vname = "__builtin_va_start" then begin match !pargs with marker :: last :: [] -> begin let isOk = match (dropCasts last).enode with Lval (Var lastv, NoOffset) -> lastv.vname = getNameLastFormal () | _ -> false in if not isOk then Kernel.warning ~current:true "The second argument in call to %s \ should be the last formal argument" fv.vname; (* Check that "lastv" is indeed the last variable in the * prototype and then drop it *) pargs := [ marker ] end | _ -> Kernel.warning ~current:true "Invalid call to %s\n" fv.vname; (* We have to turn uses of __builtin_varargs_start into uses * of __builtin_stdarg_start (because we have dropped the * __builtin_va_alist argument from this function) *) end else if fv.vname = "__builtin_varargs_start" then begin (* Lookup the prototype for the replacement *) let v, _ = try lookupGlobalVar "__builtin_stdarg_start" with Not_found -> Kernel.abort ~current:true "Cannot find __builtin_stdarg_start to replace %s" fv.vname in pf := new_exp ~loc (Lval (var v)) end else if fv.vname = "__builtin_next_arg" then begin match !pargs with last :: [] -> begin let isOk = match (dropCasts last).enode with Lval (Var lastv, NoOffset) -> lastv.vname = getNameLastFormal () | _ -> false in if not isOk then Kernel.warning ~current:true "The argument in call to %s should be \ the last formal argument\n" fv.vname; pargs := [ ] end | _ -> Kernel.warning ~current:true "Invalid call to %s\n" fv.vname; end else if fv.vname = "__builtin_constant_p" then begin (* Drop the side-effects *) prechunk := empty; (* Constant-fold the argument and see if it is a constant *) (match !pargs with [ arg ] -> begin match (constFold true arg).enode with Const _ -> piscall := false; pres := integer ~loc:e.expr_loc 1 ; prestype := intType | _ -> piscall := false; pres := integer ~loc:e.expr_loc 0; prestype := intType end | _ -> Kernel.warning ~current:true "Invalid call to builtin_constant_p"); end end | _ -> ()); (* Now we must finish the call *) if !piscall then begin let addCall ?(is_real_var=true) calldest res t = let my_write = match calldest with None -> [] | Some c when is_real_var -> [c] | Some _ -> [] in prechunk := (empty @@ (!prechunk, ghost)) +++ (mkStmtOneInstr ~ghost:local_env.is_ghost (Call(calldest,!pf,!pargs,loc)), [],my_write, rf); pres := res; prestype := t in match !pwhat with | ADrop -> addCall None (zero ~loc:e.expr_loc) intType | AType -> prestype := resType' | ASet(is_real_var, lv, _, vtype) when !pis__builtin_va_arg -> (* Make an exception here for __builtin_va_arg *) addCall ~is_real_var None (new_exp ~loc:e.expr_loc (Lval(lv))) vtype | ASet(is_real_var, lv, _, vtype) when (allow_return_collapse ~tf:resType' ~tlv:vtype) -> (* We can assign the result directly to lv *) addCall ~is_real_var (Some lv) (new_exp ~loc:e.expr_loc (Lval(lv))) vtype | _ -> begin let restype'' = match !pwhat with | AExp (Some t) when allow_return_collapse ~tf:resType' ~tlv:t -> t | _ -> resType' in let descr = Pretty_utils.sfprintf "%a(%a)" Cil_descriptive_printer.pp_exp !pf (Pretty_utils.pp_list ~sep:", " Cil_descriptive_printer.pp_exp) !pargs in let tmp = newTempVar (Some descr) false restype'' in locals:=tmp::!locals; (* Remember that this variable has been created for this * specific call. We will use this in collapseCallCast. *) IH.add callTempVars tmp.vid (); addCall ~is_real_var:false (Some (var tmp)) (new_exp ~loc:e.expr_loc (Lval(var tmp))) restype''; end end; List.iter (fun v -> prechunk:= local_var_chunk !prechunk v) !locals; finishExp [] !prechunk !pres !prestype | A.COMMA el -> if asconst then Kernel.warning ~current:true "COMMA in constant"; let rec loop sofar = function [e] -> let (r, se, e', t') = doExp local_env false e what in (* Pass on the action *) (r, sofar @@ (se, ghost), e', t') | e :: rest -> let (_, se, _, _) = doExp local_env false e ADrop in loop (sofar @@ (se, ghost)) rest | [] -> Kernel.fatal ~current:true "empty COMMA expression" in loop empty el | A.QUESTION (e1, e2, e3) -> begin (* Compile the conditional expression *) let ghost = local_env.is_ghost in let ce1 = doCondExp local_env asconst e1 in let what' = match what with | ADrop -> ADrop | _ -> AExp None in (* Now we must find the type of both branches, in order to compute * the type of the result *) let r2, se2, e2'o (* is an option. None means use e1 *), t2 = match e2.expr_node with A.NOTHING -> begin (* The same as the type of e1 *) match ce1 with CEExp (_, e1') -> [], unspecified_chunk empty, None, typeOf e1' (* Do not promote to bool *) | _ -> [], unspecified_chunk empty, None, intType end | _ -> let r2, se2, e2', t2 = doExp local_env asconst e2 what' in r2, se2, Some e2', t2 in (* Do e3 for real *) let r3, se3, e3', t3 = doExp local_env asconst e3 what' in (* Compute the type of the result *) let tresult = conditionalConversion t2 t3 in if not (isEmpty se2) then ConditionalSideEffectHook.apply (e,e2); if not (isEmpty se3) then ConditionalSideEffectHook.apply (e,e3); match ce1 with CEExp (se1, e1') when isConstFalse e1' && canDrop se2 -> finishExp r3 ((empty @@ (se1, ghost)) @@ (se3, ghost)) (snd (castTo t3 tresult e3')) tresult | CEExp (se1, e1') when isConstTrue e1' && canDrop se3 -> begin match e2'o with None -> (* use e1' *) finishExp r2 ((empty @@ (se1, ghost)) @@ (se2, ghost)) (snd (castTo t2 tresult e1')) tresult | Some e2' -> finishExp r2 ((empty @@ (se1, ghost)) @@ (se2, ghost)) (snd (castTo t2 tresult e2')) tresult end | _ when what = ADrop -> (* We are not interested by the result, but might want to evaluate e2 and e3 if they are dangerous expressions. *) let res = Cil.new_exp ~loc (CastE(Cil.voidType,Cil.zero ~loc)) in (match e2'o with | None when is_dangerous e3' || not (isEmpty se3) -> let tmp = newTempVar None true tresult in let tmp_var = var tmp in let tmp_lval = new_exp ~loc:e.expr_loc (Lval (tmp_var)) in let (r1, se1, _, _) = doExp local_env asconst e1 (ASet(false, tmp_var, [], tresult)) in let se1 = local_var_chunk se1 tmp in let dangerous = if is_dangerous e3' then keepPureExpr ~ghost e3' loc else skipChunk in finishExp (r1@r3) ((empty @@ (se1, ghost)) @@ (ifChunk ~ghost tmp_lval loc skipChunk (se3 @@ (dangerous, ghost)), ghost)) res Cil.voidType | None -> (* we can drop e3, just keep e1 in case it is dangerous *) let (r1,se1,e1,_) = doExp local_env asconst e1 ADrop in let dangerous = if is_dangerous e1 then keepPureExpr ~ghost e1 loc else skipChunk in finishExp (r1@r3) (se1 @@ (dangerous, ghost)) res Cil.voidType | Some e2' when is_dangerous e2' || is_dangerous e3' || not (isEmpty se2) || not (isEmpty se3) -> (* we have to keep e1 in order to know which dangerous expression is to be evaluated *) let se2 = if is_dangerous e2' then se2 @@ (keepPureExpr ~ghost e2' loc, ghost) else se2 in let se3 = if is_dangerous e3' then se3 @@ (keepPureExpr ~ghost e3' loc, ghost) else se3 in let cond = compileCondExp ~ghost false ce1 se2 se3 in finishExp (r2@r3) cond res Cil.voidType | Some _ -> (* we just keep e1 in case it is dangerous. everything else can be dropped *) let (r1,se1,e1,_) = doExp local_env asconst e1 ADrop in let dangerous = if is_dangerous e1 then keepPureExpr ~ghost e1 loc else skipChunk in finishExp (r1@r2@r3) (se1 @@ (dangerous, ghost)) res Cil.voidType) | _ -> (* Use a conditional *) begin match e2'o with | None -> (* has form "e1 ? : e3" *) let tmp = newTempVar None true tresult in let tmp_var = var tmp in let tmp_lval = new_exp ~loc:e.expr_loc (Lval (tmp_var)) in let (r1,se1, _, _) = doExp local_env asconst e1 (ASet(false, tmp_var, [], tresult)) in let se1 = local_var_chunk se1 tmp in let r3,se3,_,_ = finishExp ~newWhat:(ASet(false,tmp_var, [], tresult)) r3 se3 e3' t3 in finishExp (r1@r3) ((empty @@ (se1, ghost)) @@ (ifChunk ~ghost tmp_lval loc skipChunk se3, ghost)) tmp_lval tresult | Some e2' -> let is_real, lv, r, lvt, scope_chunk = match what with | ASet (is_real, lv, r, lvt) -> is_real, lv, r, lvt, empty | _ -> let tmp = newTempVar None true tresult in false, var tmp, [], tresult, local_var_chunk empty tmp in (* Now do e2 and e3 for real *) let (r2,se2, _, _) = finishExp ~newWhat:(ASet(is_real,lv,r,lvt)) r2 se2 e2' t2 in let (r3, se3, _, _) = finishExp ~newWhat:(ASet(is_real,lv, r, lvt)) r3 se3 e3' t3 in let cond = compileCondExp ~ghost false ce1 se2 se3 in finishExp (r2@r3) (scope_chunk @@ (cond, ghost)) (new_exp ~loc (Lval lv)) tresult end end | A.GNU_BODY b -> begin (* Find the last A.COMPUTATION and remember it. This one is invoked * on the reversed list of statements. *) let findLastComputation = function s :: _ -> let rec findLast st = match st.stmt_node with | A.SEQUENCE (_, s, _) -> findLast s | CASE (_, s, _) -> findLast s | CASERANGE (_, _, s, _) -> findLast s | LABEL (_, s, _) -> findLast s | A.COMPUTATION _ -> begin match local_env.is_ghost,st.stmt_ghost with | true,true | false, false -> st | true, false -> assert false | false, true -> raise Not_found end | _ -> raise Not_found in findLast s | [] -> raise Not_found in (* Save the previous data *) let old_gnu = ! gnu_body_result in let lastComp, isvoidbody = match what with ADrop -> (* We are dropping the result *) {stmt_ghost = local_env.is_ghost; stmt_node = A.NOP loc}, true | _ -> try findLastComputation (List.rev b.A.bstmts), false with Not_found -> Kernel.fatal ~current:true "Cannot find COMPUTATION in GNU.body" (* A.NOP cabslu, true *) in let loc = Cabshelper.get_statementloc lastComp in (* Prepare some data to be filled by doExp ghost *) let data : (exp * typ) option ref = ref None in gnu_body_result := (lastComp, data); let se = doBody local_env b in (*Kernel.debug "Body inside expression: %a@." d_chunk se;*) gnu_body_result := old_gnu; match !data with None when isvoidbody -> finishExp [] se (zero ~loc:e.expr_loc) voidType | None -> Kernel.abort ~current:true "Cannot find COMPUTATION in GNU.body" | Some (e, t) -> let se, e = match se.stmts with [ { skind = Block b},_, _, _, _ ] -> let vi = newTempVar (Some "GNU.body") true t in b.bstmts <- b.bstmts @ [Cil.mkStmtOneInstr ~ghost:local_env.is_ghost (Set (Cil.var vi, e,loc))]; (local_var_chunk se vi,Cil.new_exp ~loc (Lval (Cil.var vi))) | _ -> se,e in finishExp [] se e t end | A.LABELADDR l -> begin (* GCC's taking the address of a label *) let l = lookupLabel l in (* To support locallly declared labels *) let addrval = try H.find gotoTargetHash l with Not_found -> begin let res = !gotoTargetNextAddr in incr gotoTargetNextAddr; H.add gotoTargetHash l res; res end in finishExp [] (unspecified_chunk empty) (makeCast (integer ~loc addrval) voidPtrType) voidPtrType end | A.EXPR_PATTERN _ -> Kernel.abort ~current:true "EXPR_PATTERN in cabs2cil input" with _ when Cilmsg.had_errors () && continueOnError -> begin Kernel.error ~once:true ~current:true "ignoring expression"; ([], i2c (mkStmtOneInstr ~ghost:local_env.is_ghost (dInstr (Pretty_utils.sfprintf "booo_exp(%t)" Cil.pp_thisloc) loc), [],[],[]), integer ~loc 0, intType) end in (*let (_a,b,_c,_d) = result in Format.eprintf "doExp ~const:%b ~e:" asconst ; Cprint.print_expression e; Format.eprintf "@."; Format.eprintf "Got: chunk:'%a'@." d_chunk b;*) CurrentLoc.set oldLoc; result (* bop is always the arithmetic version. Change it to the appropriate pointer * version if necessary *) and doBinOp loc (bop: binop) (e1: exp) (t1: typ) (e2: exp) (t2: typ) = let doArithmetic () = let tres = arithmeticConversion t1 t2 in (* Keep the operator since it is arithmetic *) tres, optConstFoldBinOp loc false bop (makeCastT e1 t1 tres) (makeCastT e2 t2 tres) tres in let doArithmeticComp () = let tres = arithmeticConversion t1 t2 in (* Keep the operator since it is arithemtic *) intType, optConstFoldBinOp loc false bop (makeCastT e1 t1 tres) (makeCastT e2 t2 tres) intType in let doIntegralArithmetic () = let tres = unrollType (arithmeticConversion t1 t2) in match tres with TInt _ -> tres, optConstFoldBinOp loc false bop (makeCastT e1 t1 tres) (makeCastT e2 t2 tres) tres | _ -> Kernel.fatal ~current:true "%a operator on a non-integer type" Cil_printer.pp_binop bop in let pointerComparison e1 t1 e2 t2 = (* Cast both sides to an integer *) (* in Frama-C, do not add these non-standard useless casts *) let e1', e2' = if false && theMachine.insertImplicitCasts then let commontype = theMachine.upointType in (makeCastT e1 t1 commontype), (makeCastT e2 t2 commontype) else e1, e2 in intType, optConstFoldBinOp loc false bop e1' e2' intType in let do_shift e1 t1 e2 t2 = match e1.enode with StartOf lv -> { e1 with enode = AddrOf (addOffsetLval (Index (e2,NoOffset)) lv) } | _ -> optConstFoldBinOp loc false PlusPI e1 (makeCastT e2 t2 (integralPromotion t2)) t1 in match bop with (Mult|Div) -> doArithmetic () | (Mod|BAnd|BOr|BXor) -> doIntegralArithmetic () | (Shiftlt|Shiftrt) -> (* ISO 6.5.7. Only integral promotions. The result * has the same type as the left hand side *) if theMachine.msvcMode then (* MSVC has a bug. We duplicate it here *) doIntegralArithmetic () else let t1' = integralPromotion t1 in let t2' = integralPromotion t2 in t1', optConstFoldBinOp loc false bop (makeCastT e1 t1 t1') (makeCastT e2 t2 t2') t1' | (PlusA|MinusA) when isArithmeticType t1 && isArithmeticType t2 -> doArithmetic () | (Eq|Ne|Lt|Le|Ge|Gt) when isArithmeticType t1 && isArithmeticType t2 -> doArithmeticComp () | PlusA when isPointerType t1 && isIntegralType t2 -> t1, do_shift e1 t1 e2 t2 | PlusA when isIntegralType t1 && isPointerType t2 -> t2, do_shift e2 t2 e1 t1 | MinusA when isPointerType t1 && isIntegralType t2 -> t1, optConstFoldBinOp loc false MinusPI e1 (makeCastT e2 t2 (integralPromotion t2)) t1 | MinusA when isPointerType t1 && isPointerType t2 -> let commontype = t1 in intType, optConstFoldBinOp loc false MinusPP (makeCastT e1 t1 commontype) (makeCastT e2 t2 commontype) intType | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isPointerType t2 -> pointerComparison e1 t1 e2 t2 | (Eq|Ne) when isPointerType t1 && isZero e2 -> pointerComparison e1 t1 (makeCastT (zero ~loc)theMachine.upointType t1) t1 | (Eq|Ne) when isPointerType t2 && isZero e1 -> pointerComparison (makeCastT (zero ~loc)theMachine.upointType t2) t2 e2 t2 | (Eq|Ne) when isVariadicListType t1 && isZero e2 -> Kernel.debug ~level:3 "Comparison of va_list and zero"; pointerComparison e1 t1 (makeCastT (zero ~loc)theMachine.upointType t1) t1 | (Eq|Ne) when isVariadicListType t2 && isZero e1 -> Kernel.debug ~level:3 "Comparison of zero and va_list"; pointerComparison (makeCastT (zero ~loc)theMachine.upointType t2) t2 e2 t2 | (Eq|Ne|Le|Lt|Ge|Gt) when isPointerType t1 && isArithmeticType t2 -> Kernel.debug ~level:3 "Comparison of pointer and non-pointer"; (* Cast both values to upointType *) doBinOp loc bop (makeCastT e1 t1 theMachine.upointType) theMachine.upointType (makeCastT e2 t2 theMachine.upointType) theMachine.upointType | (Eq|Ne|Le|Lt|Ge|Gt) when isArithmeticType t1 && isPointerType t2 -> Kernel.debug ~level:3 "Comparison of pointer and non-pointer"; (* Cast both values to upointType *) doBinOp loc bop (makeCastT e1 t1 theMachine.upointType) theMachine.upointType (makeCastT e2 t2 theMachine.upointType) theMachine.upointType | _ -> Kernel.fatal ~current:true "doBinOp: %a" Cil_printer.pp_exp (dummy_exp(BinOp(bop,e1,e2,intType))) (* Constant fold a conditional. This is because we want to avoid having * conditionals in the initializers. So, we try very hard to avoid creating * new statements. *) and doCondExp local_env (asconst: bool) (** Try to evaluate the conditional expression * to TRUE or FALSE, because it occurs in a constant *) ?ctxt (* ctxt is used internally to determine if we should apply the conditional side effects hook (see above) and should not appear (i.e. be None) in toplevel calls. *) (e: A.expression) : condExpRes = let ghost = local_env.is_ghost in let rec addChunkBeforeCE (c0: chunk) ce = let c0 = remove_effects c0 in match ce with CEExp (c, e) -> CEExp ((empty @@ (c0, ghost)) @@ (c, ghost), e) | CEAnd (ce1, ce2) -> CEAnd (addChunkBeforeCE c0 ce1, ce2) | CEOr (ce1, ce2) -> CEOr (addChunkBeforeCE c0 ce1, ce2) | CENot ce1 -> CENot (addChunkBeforeCE c0 ce1) in let rec canDropCE = function CEExp (c, _e) -> canDrop c | CEAnd (ce1, ce2) | CEOr (ce1, ce2) -> canDropCE ce1 && canDropCE ce2 | CENot (ce1) -> canDropCE ce1 in let rec remove_effects_ce = function | CEExp(c,e) -> CEExp(remove_effects c,e) | CEAnd(ce1,ce2) -> CEAnd(remove_effects_ce ce1, remove_effects_ce ce2) | CEOr(ce1,ce2) -> CEOr(remove_effects_ce ce1, remove_effects_ce ce2) | CENot(ce) -> CENot(remove_effects_ce ce) in let loc = e.expr_loc in let result = match e.expr_node with A.BINARY (A.AND, e1, e2) -> begin let ce1 = doCondExp local_env asconst ?ctxt e1 in let ce2 = doCondExp local_env asconst ~ctxt:e e2 in let ce1 = remove_effects_ce ce1 in match ce1, ce2 with CEExp (se1, ({enode = Const _} as ci1)), _ -> if isConstTrue ci1 then addChunkBeforeCE se1 ce2 else (* se2 might contain labels so we cannot always drop it *) if canDropCE ce2 then ce1 else CEAnd (ce1, ce2) | CEExp(se1, e1'), CEExp (se2, e2') when theMachine.useLogicalOperators && isEmpty se1 && isEmpty se2 -> CEExp (empty, new_exp ~loc (BinOp(LAnd, makeCast e1' intType, makeCast e2' intType, intType))) | _ -> CEAnd (ce1, ce2) end | A.BINARY (A.OR, e1, e2) -> begin let ce1 = doCondExp local_env asconst ?ctxt e1 in let ce2 = doCondExp local_env asconst ~ctxt:e e2 in let ce1 = remove_effects_ce ce1 in match ce1, ce2 with CEExp (se1, ({enode = Const(CInt64 _)} as ci1)), _ -> if isConstFalse ci1 then addChunkBeforeCE se1 ce2 else (* se2 might contain labels so we cannot drop it *) if canDropCE ce2 then ce1 else CEOr (ce1, ce2) | CEExp (se1, e1'), CEExp (se2, e2') when theMachine.useLogicalOperators && isEmpty se1 && isEmpty se2 -> CEExp (empty, new_exp ~loc (BinOp(LOr, makeCast e1' intType, makeCast e2' intType, intType))) | _ -> CEOr (ce1, ce2) end | A.UNARY(A.NOT, e1) -> begin match doCondExp local_env asconst ?ctxt e1 with CEExp (se1, ({enode = Const _} as ci1)) -> if isConstFalse ci1 then CEExp (se1, one e1.expr_loc) else CEExp (se1, zero e1.expr_loc) | CEExp (se1, e) when isEmpty se1 -> let t = typeOf e in if not ((isPointerType t) || (isArithmeticType t))then Kernel.error ~once:true ~current:true "Bad operand to !"; CEExp (empty, new_exp ~loc (UnOp(LNot, e, intType))) | ce1 -> CENot ce1 end | _ -> let (r, se, e', t) = doExp local_env asconst e (AExp None) in (* No need to add reads here: we'll always have a sequence point, either because the expression is complete, or because of a logic operator. *) (match ctxt with None -> () | Some _ when isEmpty se -> () | Some orig -> ConditionalSideEffectHook.apply (orig,e)); ignore (checkBool t e'); Cabscond.bind e e' ; CEExp (add_reads e.expr_loc r se, if asconst || theMachine.lowerConstants then constFold asconst e' else e') in result (* If cabscond is true, then CIL-atomic expressions must be bound with Cabscond. *) and compileCondExp ~ghost cabscond ce st sf = match ce with | CEAnd (ce1, ce2) -> let loc = CurrentLoc.get () in let (duplicable, sf1, sf2) = (* If sf is small then will copy it *) try (true, sf, duplicateChunk sf) with Failure _ -> let lab = newLabelName "_LAND" in (false, gotoChunk ~ghost lab loc, consLabel ~ghost lab sf loc false) in let st' = compileCondExp ~ghost cabscond ce2 st sf1 in if not duplicable && !doAlternateConditional then let st_fall_through = chunkFallsThrough st' in (* if st does not fall through, we do not need to add a goto after the else part. This prevents spurious falls-through warning afterwards. *) let sf' = duplicateChunk sf1 in let lab = newLabelName "_LAND" in let gotostmt = if st_fall_through then gotoChunk ~ghost lab loc else skipChunk in let labstmt = if st_fall_through then consLabel ~ghost lab empty loc false else skipChunk in let (@@) s1 s2 = s1 @@ (s2, ghost) in (compileCondExp ~ghost cabscond ce1 st' sf') @@ gotostmt @@ sf2 @@ labstmt else let sf' = sf2 in compileCondExp ~ghost cabscond ce1 st' sf' | CEOr (ce1, ce2) -> let loc = CurrentLoc.get () in let (duplicable, st1, st2) = (* If st is small then will copy it *) try (true, st, duplicateChunk st) with Failure _ -> let lab = newLabelName "_LOR" in (false, gotoChunk ~ghost lab loc, consLabel ~ghost lab st loc false) in if not duplicable && !doAlternateConditional then let st' = duplicateChunk st1 in let sf' = compileCondExp ~ghost cabscond ce2 st1 sf in let sf_fall_through = chunkFallsThrough sf' in let lab = newLabelName "_LOR" in let gotostmt = if sf_fall_through then gotoChunk ~ghost lab loc else skipChunk in let labstmt = if sf_fall_through then consLabel ~ghost lab empty (CurrentLoc.get ()) false else skipChunk in let (@@) s1 s2 = s1 @@ (s2, ghost) in (compileCondExp ~ghost cabscond ce1 st' sf') @@ gotostmt @@ st2 @@ labstmt else let st' = st1 in let sf' = compileCondExp ~ghost cabscond ce2 st2 sf in (*Format.eprintf "result:@\nchunk then:@\n @[%a@]@\nchunk else: @[%a@]@." d_chunk st d_chunk sf;*) compileCondExp ~ghost cabscond ce1 st' sf' | CENot ce1 -> compileCondExp ~ghost cabscond ce1 sf st | CEExp (se, e) -> begin match e.enode with | Const(CInt64(i,_,_)) when (not (Integer.equal i Integer.zero)) && canDrop sf -> se @@ (st, ghost) | Const(CInt64(z,_,_)) when (Integer.equal z Integer.zero) && canDrop st -> se @@ (sf, ghost) | _ -> (empty @@ (se, ghost)) @@ (ifChunk ~ghost e e.eloc st sf, ghost) end (* A special case for conditionals *) and doCondition ?info local_env (isconst: bool) (* If we are in constants, we do our best to eliminate the conditional *) (e: A.expression) (st: chunk) (sf: chunk) : chunk = let cabscond = match info with | Some (descr,loc) -> Cabscond.push_condition descr loc e | None -> false in if not cabscond && isEmpty st && isEmpty sf(*TODO: ignore attribute FRAMA_C_KEEP_BLOCK*) then let (_, se,_,_) = doExp local_env cabscond e ADrop in se else let ce = doCondExp local_env isconst e in if cabscond then Cabscond.pop_condition () ; let chunk = compileCondExp ~ghost:local_env.is_ghost cabscond ce st sf in chunk and doPureExp local_env (e : A.expression) : exp = let (_,se, e', _) = doExp local_env true e (AExp None) in if isNotEmpty se then Kernel.error ~once:true ~current:true "%a has side-effects" Cprint.print_expression e; e' and doFullExp local_env const e what = let (r, se,e,t) = doExp local_env const e what in let se' = add_reads e.eloc r se in (* there is a sequence point after a full exp *) empty @@ (se', local_env.is_ghost),e,t and doInitializer local_env (vi: varinfo) (inite: A.init_expression) (* Return the accumulated chunk, the initializer and the new type (might be * different for arrays) *) : chunk * init * typ = (* Setup the pre-initializer *) let topPreInit = ref NoInitPre in if debugInit then Kernel.debug "@\nStarting a new initializer for %s : %a@\n" vi.vname Cil_printer.pp_typ vi.vtype; let topSetupInit (o: offset) (e: exp) = if debugInit then Kernel.debug " set %a := %a@\n" Cil_printer.pp_lval (Var vi, o) Cil_printer.pp_exp e; let newinit = setOneInit !topPreInit o e in if newinit != !topPreInit then topPreInit := newinit in let acc, restl = let so = makeSubobj vi vi.vtype NoOffset in doInit local_env vi.vglob Extlib.nop topSetupInit so (unspecified_chunk empty) [ (A.NEXT_INIT, inite) ] in if restl <> [] then Kernel.warning ~current:true "Ignoring some initializers"; (* sm: we used to do array-size fixups here, but they only worked * for toplevel array types; now, collectInitializer does the job, * including for nested array types *) let typ' = vi.vtype in if debugInit then Kernel.debug "Collecting the initializer for %s@\n" vi.vname; let (init, typ'') = collectInitializer !topPreInit typ' in if debugInit then Kernel.debug "Finished the initializer for %s@\n init=%a@\n typ=%a@\n acc=%a@\n" vi.vname Cil_printer.pp_init init Cil_printer.pp_typ typ' d_chunk acc; empty @@ (acc, local_env.is_ghost), init, typ'' and blockInitializer local_env vi inite = let ghost = local_env.is_ghost in let c,init,ty = doInitializer local_env vi inite in c2block ~ghost c, init, ty (* [VP-2012-03-01] As a matter of fact, this function is not tail-rec, but it seems that it's not an issue in practice. *) (* Consume some initializers. Watch out here. Make sure we use only * tail-recursion because these things can be big. *) and doInit local_env (isconst: bool) (add_implicit_ensures: predicate named -> unit) (* callback to add an ensures clause to contracts above current initialized part when it is partially initialized. Does nothing initially. *) (setone: offset -> exp -> unit) (* Use to announce an initializer *) (so: subobj) (acc: chunk) (initl: (A.initwhat * A.init_expression) list) (* Return the resulting chunk along with some unused initializers *) : chunk * (A.initwhat * A.init_expression) list = let whoami fmt = Cil_printer.pp_lval fmt (Var so.host, so.soOff) in let initl1 = match initl with | (A.NEXT_INIT, A.SINGLE_INIT ({ expr_node = A.CAST ((s, dt), ie)} as e)) :: rest -> let s', dt', ie' = preprocessCast local_env.is_ghost s dt ie in (A.NEXT_INIT, A.SINGLE_INIT ({expr_node = A.CAST ((s', dt'), ie'); expr_loc = e.expr_loc})) :: rest | _ -> initl in (* Sometimes we have a cast in front of a compound (in GCC). This * appears as a single initializer. Ignore the cast *) let initl2 = match initl1 with (what, A.SINGLE_INIT ({expr_node = A.CAST ((specs, dt), A.COMPOUND_INIT ci)})) :: rest -> let s', dt', _ie' = preprocessCast local_env.is_ghost specs dt (A.COMPOUND_INIT ci) in let typ = doOnlyType local_env.is_ghost s' dt' in if Typ.equal (Cil.typeDeepDropAllAttributes typ) (Cil.typeDeepDropAllAttributes so.soTyp) then (* Drop the cast *) (what, A.COMPOUND_INIT ci) :: rest else (* Keep the cast. A new var will be created to hold the intermediate value. *) initl1 | _ -> initl1 in let allinitl = initl2 in if debugInit then begin Kernel.debug "doInit for %t %s (current %a). Looking at: %t" whoami (if so.eof then "(eof)" else "") Cil_printer.pp_lval (Var so.host, so.curOff) (fun fmt -> match allinitl with [] -> Format.fprintf fmt "[]@." | (what, ie) :: _ -> Cprint.print_init_expression fmt (A.COMPOUND_INIT [(what, ie)])); end; match unrollType so.soTyp, allinitl with _, [] -> acc, [] (* No more initializers return *) (* No more subobjects *) | _, (A.NEXT_INIT, _) :: _ when so.eof -> acc, allinitl (* If we are at an array of characters and the initializer is a * string literal (optionally enclosed in braces) then explode the * string into characters *) | TArray(bt, leno, _, _ ), (A.NEXT_INIT, (A.SINGLE_INIT({ expr_node = A.CONSTANT (A.CONST_STRING s)} as e)| A.COMPOUND_INIT [(A.NEXT_INIT, A.SINGLE_INIT( { expr_node = A.CONSTANT (A.CONST_STRING s)} as e))])) :: restil when (match unrollType bt with | TInt((IChar|IUChar|ISChar), _) -> true | TInt _ -> (*Base type is a scalar other than char. Maybe a wchar_t?*) Kernel.fatal ~current:true "Using a string literal to initialize something other than \ a character array" | _ -> false (* OK, this is probably an array of strings. Handle *) ) (* it with the other arrays below.*) -> let charinits = let init c = A.NEXT_INIT, A.SINGLE_INIT { expr_node = A.CONSTANT (A.CONST_CHAR [c]); expr_loc = e.expr_loc } in let collector = (* ISO 6.7.8 para 14: final NUL added only if no size specified, or * if there is room for it; btw, we can't rely on zero-init of * globals, since this array might be a local variable *) if ((not (Extlib.has_some leno)) or ((String.length s) < (integerArrayLength leno))) then ref [init Int64.zero] else ref [] in for pos = String.length s - 1 downto 0 do collector := init (Int64.of_int (Char.code (s.[pos]))) :: !collector done; !collector in (* Create a separate object for the array *) let so' = makeSubobj so.host so.soTyp so.soOff in (* Go inside the array *) let leno = integerArrayLength leno in so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; normalSubobj so'; let acc', initl' = doInit local_env isconst add_implicit_ensures setone so' acc charinits in if initl' <> [] then Kernel.warning ~current:true "Too many initializers for character array %t" whoami; (* Advance past the array *) advanceSubobj so; (* Continue *) doInit local_env isconst add_implicit_ensures setone so acc' restil (* If we are at an array of WIDE characters and the initializer is a * WIDE string literal (optionally enclosed in braces) then explore * the WIDE string into characters *) (* [weimer] Wed Jan 30 15:38:05 PST 2002 * Despite what the compiler says, this match case is used and it is * important. *) | TArray(bt, leno, _, _), (A.NEXT_INIT, (A.SINGLE_INIT({expr_node = A.CONSTANT (A.CONST_WSTRING s)} as e)| A.COMPOUND_INIT [(A.NEXT_INIT, A.SINGLE_INIT( {expr_node = A.CONSTANT (A.CONST_WSTRING s)} as e))])) :: restil when (let bt' = unrollType bt in match bt' with (* compare bt to wchar_t, ignoring signed vs. unsigned *) TInt _ when (bitsSizeOf bt') = (bitsSizeOf theMachine.wcharType) -> true | TInt _ -> (*Base type is a scalar other than wchar_t. Maybe a char?*) Kernel.fatal ~current:true "Using a wide string literal to initialize \ something other than a wchar_t array" | _ -> false (* OK, this is probably an array of strings. Handle it with the other arrays below.*) ) -> let maxWChar = (* (2**(bitsSizeOf !wcharType)) - 1 *) Int64.sub (Int64.shift_left Int64.one (bitsSizeOf theMachine.wcharType)) Int64.one in let charinits = let init c = if Int64.compare c maxWChar > 0 then (* if c > maxWChar *) Kernel.error ~once:true ~current:true "cab2cil:doInit:character 0x%Lx too big." c; A.NEXT_INIT, A.SINGLE_INIT { expr_node = A.CONSTANT (A.CONST_INT (Int64.to_string c)); expr_loc = e.expr_loc } in (List.map init s) @ ( (* ISO 6.7.8 para 14: final NUL added only if no size specified, or * if there is room for it; btw, we can't rely on zero-init of * globals, since this array might be a local variable *) if (not (Extlib.has_some leno) || ((List.length s) < (integerArrayLength leno))) then [init Int64.zero] else []) in (* Create a separate object for the array *) let so' = makeSubobj so.host so.soTyp so.soOff in (* Go inside the array *) let leno = integerArrayLength leno in so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; normalSubobj so'; let acc', initl' = doInit local_env isconst add_implicit_ensures setone so' acc charinits in if initl' <> [] then (* sm: see above regarding ISO 6.7.8 para 14, which is not implemented * for wchar_t because, as far as I can tell, we don't even put in * the automatic NUL (!) *) Kernel.warning ~current:true "Too many initializers for wchar_t array %t" whoami; (* Advance past the array *) advanceSubobj so; (* Continue *) doInit local_env isconst add_implicit_ensures setone so acc' restil (* If we are at an array and we see a single initializer then it must * be one for the first element *) | TArray(bt, leno, _, _), (A.NEXT_INIT, A.SINGLE_INIT _oneinit) :: _restil -> (* Grab the length if there is one *) let leno = integerArrayLength leno in so.stack <- InArray(so.soOff, bt, leno, ref 0) :: so.stack; normalSubobj so; (* Start over with the fields *) doInit local_env isconst add_implicit_ensures setone so acc allinitl (* If we are at a composite and we see a single initializer of the same * type as the composite then grab it all. If the type is not the same * then we must go on and try to initialize the fields *) | TComp (comp, _, _), (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> let r,se, oneinit', t' = doExp local_env isconst oneinit (AExp None) in let se = add_reads oneinit'.eloc r se in if (match unrollType t' with TComp (comp', _, _) when comp'.ckey = comp.ckey -> true | _ -> false) then begin (* Initialize the whole struct *) setone so.soOff oneinit'; (* Advance to the next subobject *) advanceSubobj so; let se = acc @@ (se, local_env.is_ghost) in doInit local_env isconst add_implicit_ensures setone so se restil end else begin (* Try to initialize fields *) let toinit = fieldsToInit comp None in so.stack <- InComp(so.soOff, comp, toinit) :: so.stack; normalSubobj so; doInit local_env isconst add_implicit_ensures setone so acc allinitl end (* A scalar with a single initializer *) | _, (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> let r, se, oneinit', t' = doExp local_env isconst oneinit (AExp(Some so.soTyp)) in let se = add_reads oneinit'.eloc r se in Kernel.debug "oneinit'=%a, t'=%a, so.soTyp=%a" Cil_printer.pp_exp oneinit' Cil_printer.pp_typ t' Cil_printer.pp_typ so.soTyp; setone so.soOff (if theMachine.insertImplicitCasts then snd (castTo t' so.soTyp oneinit') else oneinit'); (* Move on *) advanceSubobj so; let se = acc @@ (se,local_env.is_ghost) in doInit local_env isconst add_implicit_ensures setone so se restil (* An array with a compound initializer. The initializer is for the * array elements *) | TArray (bt, leno, _, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil -> (* Create a separate object for the array *) let so' = makeSubobj so.host so.soTyp so.soOff in (* Go inside the array *) let leno = integerArrayLength leno in so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; normalSubobj so'; let acc', initl' = doInit local_env isconst add_implicit_ensures setone so' acc initl in if initl' <> [] then Kernel.warning ~current:true "Too many initializers for array %t" whoami; (* Advance past the array *) advanceSubobj so; (* Continue *) let res = doInit local_env isconst add_implicit_ensures setone so acc' restil in res (* We have a designator that tells us to select the matching union field. * This is to support a GCC extension *) | TComp(ci, _, _) as targ, [(A.NEXT_INIT, A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field", A.NEXT_INIT), A.SINGLE_INIT oneinit)])] when not ci.cstruct -> (* Do the expression to find its type *) let _, _, _, t' = doExp local_env isconst oneinit (AExp None) in let t'noattr = Cil.typeDeepDropAllAttributes t' in let rec findField = function | [] -> Kernel.fatal ~current:true "Cannot find matching union field in cast" | fi :: _rest when Typ.equal (Cil.typeDeepDropAllAttributes fi.ftype) t'noattr -> fi | _ :: rest -> findField rest in (* If this is a cast from union X to union X *) if Typ.equal t'noattr (Cil.typeDeepDropAllAttributes targ) then doInit local_env isconst add_implicit_ensures setone so acc [(A.NEXT_INIT, A.SINGLE_INIT oneinit)] else (* If this is a GNU extension with field-to-union cast find the field *) let fi = findField ci.cfields in (* Change the designator and redo *) doInit local_env isconst add_implicit_ensures setone so acc [A.INFIELD_INIT (fi.fname, A.NEXT_INIT), A.SINGLE_INIT oneinit] (* A structure with a composite initializer. We initialize the fields*) | TComp (comp, _, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil -> (* Create a separate subobject iterator *) let so' = makeSubobj so.host so.soTyp so.soOff in (* Go inside the comp *) so'.stack <- [InComp(so'.curOff, comp, fieldsToInit comp None)]; normalSubobj so'; let acc', initl' = doInit local_env isconst add_implicit_ensures setone so' acc initl in if initl' <> [] then Kernel.warning ~current:true "Too many initializers for structure"; (* Advance past the structure *) advanceSubobj so; (* Continue *) doInit local_env isconst add_implicit_ensures setone so acc' restil (* A scalar with a initializer surrounded by a number of braces *) | t, (A.NEXT_INIT, next) :: restil -> begin let rec find_one_init c = match c with | A.COMPOUND_INIT [A.NEXT_INIT,next] -> find_one_init next | A.SINGLE_INIT oneinit -> oneinit | _ -> raise Not_found in try let oneinit = find_one_init next in let r,se, oneinit', t' = doExp local_env isconst oneinit (AExp(Some so.soTyp)) in let se = add_reads oneinit'.eloc r se in setone so.soOff (makeCastT oneinit' t' so.soTyp); (* Move on *) advanceSubobj so; let se = acc @@ (se, local_env.is_ghost) in doInit local_env isconst add_implicit_ensures setone so se restil with Not_found -> Kernel.fatal ~current:true "doInit: unexpected NEXT_INIT for %a\n" Cil_printer.pp_typ t end (* We have a designator *) | _, (what, ie) :: restil when what != A.NEXT_INIT -> (* Process a designator and position to the designated subobject *) let addressSubobj (so: subobj) (what: A.initwhat) (acc: chunk) : chunk = (* Always start from the current element *) so.stack <- []; so.eof <- false; normalSubobj so; let rec address (what: A.initwhat) (acc: chunk) : chunk = match what with A.NEXT_INIT -> acc | A.INFIELD_INIT (fn, whatnext) -> begin match unrollType so.soTyp with TComp (comp, _, _) -> let toinit = fieldsToInit comp (Some fn) in so.stack <- InComp(so.soOff, comp, toinit) :: so.stack; normalSubobj so; address whatnext acc | _ -> Kernel.fatal ~current:true "Field designator %s not in a struct " fn end | A.ATINDEX_INIT(idx, whatnext) -> begin match unrollType so.soTyp with TArray (bt, leno, _, _) -> let ilen = integerArrayLength leno in let nextidx', doidx = let (r,doidx, idxe', _) = doExp local_env true idx (AExp(Some intType)) in let doidx = add_reads idxe'.eloc r doidx in match (constFold true idxe').enode, isNotEmpty doidx with Const(CInt64(x, _, _)), false -> Integer.to_int x, doidx | _ -> Kernel.abort ~current:true "INDEX initialization designator is not a constant" in if nextidx' < 0 || nextidx' >= ilen then Kernel.abort ~current:true "INDEX designator is outside bounds"; so.stack <- InArray(so.soOff, bt, ilen, ref nextidx') :: so.stack; normalSubobj so; address whatnext (acc @@ (doidx, local_env.is_ghost)) | _ -> Kernel.abort ~current:true "INDEX designator for a non-array" end | A.ATINDEXRANGE_INIT _ -> Kernel.abort ~current:true "addressSubobj: INDEXRANGE" in address what acc in (* First expand the INDEXRANGE by making copies *) let rec expandRange (top: A.initwhat -> A.initwhat) = function | A.INFIELD_INIT (fn, whatnext) -> expandRange (fun what -> top (A.INFIELD_INIT(fn, what))) whatnext | A.ATINDEX_INIT (idx, whatnext) -> expandRange (fun what -> top (A.ATINDEX_INIT(idx, what))) whatnext | A.ATINDEXRANGE_INIT (idxs, idxe) -> let (rs, doidxs, idxs', _) = doExp local_env true idxs (AExp(Some intType)) in let (re, doidxe, idxe', _) = doExp local_env true idxe (AExp(Some intType)) in let doidxs = add_reads idxs'.eloc rs doidxs in let doidxe = add_reads idxe'.eloc re doidxe in if isNotEmpty doidxs || isNotEmpty doidxe then Kernel.fatal ~current:true "Range designators are not constants"; let first, last = match (constFold true idxs').enode, (constFold true idxe').enode with Const(CInt64(s, _, _)), Const(CInt64(e, _, _)) -> Integer.to_int s, Integer.to_int e | _ -> Kernel.fatal ~current:true "INDEX_RANGE initialization designator is not a constant" in if first < 0 || first > last then Kernel.error ~once:true ~current:true "start index larger than end index in range initializer"; let rec loop (i: int) = if i > last then restil else (top (A.ATINDEX_INIT( { expr_node = A.CONSTANT(A.CONST_INT(string_of_int i)); expr_loc = fst idxs.expr_loc, snd idxe.expr_loc}, A.NEXT_INIT)), ie) :: loop (i + 1) in doInit local_env isconst add_implicit_ensures setone so acc (loop first) | A.NEXT_INIT -> (* We have not found any RANGE *) let acc' = addressSubobj so what acc in doInit local_env isconst add_implicit_ensures setone so acc' ((A.NEXT_INIT, ie) :: restil) in expandRange (fun x -> x) what | t, (_what, _ie) :: _ -> Kernel.abort ~current:true "doInit: cases for t=%a" Cil_printer.pp_typ t (* Create and add to the file (if not already added) a global. Return the * varinfo *) and createGlobal ghost logic_spec ((t,s,b,attr_list) : (typ * storage * bool * A.attribute list)) (((n,ndt,a,cloc), inite) : A.init_name) : varinfo = try if debugGlobal then Kernel.debug "createGlobal: %s" n; (* If the global is a Frama-C builtin, set the generated flag *) let is_fc_builtin {A.expr_node=enode} = match enode with A.VARIABLE "FC_BUILTIN" -> true | _ -> false in let isgenerated = List.exists (fun (_,el) -> List.exists is_fc_builtin el) a in (* Make a first version of the varinfo *) let vi = makeVarInfoCabs ~ghost ~isformal:false ~isglobal:true ~isgenerated (convLoc cloc) (t,s,b,attr_list) (n,ndt,a) in (* Add the variable to the environment before doing the initializer * because it might refer to the variable itself *) if isFunctionType vi.vtype then begin if inite != A.NO_INIT then Kernel.error ~once:true ~current:true "Function declaration with initializer (%s)\n" vi.vname; (* sm: if it's a function prototype, and the storage class *) (* isn't specified, make it 'extern'; this fixes a problem *) (* with no-storage prototype and static definition *) if vi.vstorage = NoStorage then vi.vstorage <- Extern; end; let vi, alreadyInEnv = makeGlobalVarinfo (inite != A.NO_INIT) vi in (* Do the initializer and complete the array type if necessary *) let init : init option = if inite = A.NO_INIT then None else let se, ie', et = doInitializer (ghost_local_env ghost) vi inite in (* Maybe we now have a better type? Use the type of the * initializer only if it really differs from the type of * the variable. *) if unrollType vi.vtype != unrollType et then vi.vtype <- et; if isNotEmpty se then begin Kernel.error ~once:true ~current:true "invalid global initializer @[%a@]" d_chunk se; end; Some ie' in try let oldloc = H.find alreadyDefined vi.vname in if init != None then begin (* function redefinition is taken care of elsewhere. *) Kernel.error ~once:true ~current:true "Global %s was already defined at %a" vi.vname Cil_printer.pp_location oldloc; end; if debugGlobal then Kernel.debug " global %s was already defined" vi.vname; (* Do not declare it again, but update the spec if any *) if isFunctionType vi.vtype then begin match logic_spec with None -> () | Some (spec,_) -> let l1 = get_formals vi in let l2 = Cil.getFormalsDecl vi in List.iter2 (fun x y -> if x != y then Kernel.fatal "Function %s: formals are not shared between AST and \ FormalDecls table" vi.vname) l1 l2; Cabshelper.continue_annot (cloc) (fun () -> let known_behaviors = find_existing_behaviors vi in let spec = Ltyping.funspec known_behaviors vi (Some(get_formals vi)) vi.vtype spec in update_funspec_in_theFile vi spec) (fun () -> ()) "Ignoring specification of function %s" vi.vname end ; vi with Not_found -> begin (* Not already defined *) if debugGlobal then Kernel.debug " first definition for %s(%d)\n" vi.vname vi.vid; if init != None then begin (* weimer: Sat Dec 8 17:43:34 2001 * MSVC NT Kernel headers include this lovely line: * extern const GUID __declspec(selectany) \ * MOUNTDEV_MOUNTED_DEVICE_GUID = { 0x53f5630d, 0xb6bf, 0x11d0, { \ * 0x94, 0xf2, 0x00, 0xa0, 0xc9, 0x1e, 0xfb, 0x8b } }; * So we allow "extern" + "initializer" if "const" is * around. *) (* sm: As I read the ISO spec, in particular 6.9.2 and 6.7.8, * "extern int foo = 3" is exactly equivalent to "int foo = 3"; * that is, if you put an initializer, then it is a definition, * and "extern" is redundantly giving the name external linkage. * gcc emits a warning, I guess because it is contrary to * usual practice, but I think CIL warnings should be about * semantic rather than stylistic issues, so I see no reason to * even emit a warning. *) if vi.vstorage = Extern then vi.vstorage <- NoStorage; (* equivalent and canonical *) H.add alreadyDefined vi.vname (CurrentLoc.get ()); IH.remove mustTurnIntoDef vi.vid; cabsPushGlobal (GVar(vi, {init = init}, CurrentLoc.get ())); vi end else begin if not (isFunctionType vi.vtype) && not (IH.mem mustTurnIntoDef vi.vid) then begin IH.add mustTurnIntoDef vi.vid true end; if not alreadyInEnv then begin (* Only one declaration *) (* If it has function type it is a prototype *) (* NB: We add the formal prms in the env*) if isFunctionType vi.vtype && not vi.vdefined then setFormalsDecl vi vi.vtype; let spec = match logic_spec with | None -> empty_funspec () | Some (spec,loc) -> begin Cabshelper.continue_annot loc (* it can not have old behavior names, since this is the first time we see the declaration. *) (fun () -> Ltyping.funspec [] vi None vi.vtype spec) (empty_funspec) "Ignoring specification of function %s" vi.vname end in cabsPushGlobal (GVarDecl (spec, vi, CurrentLoc.get ())); vi end else begin if debugGlobal then Kernel.debug " already in env %s" vi.vname; (match logic_spec with | None -> () | Some (spec,loc) -> let merge_spec = function | GVarDecl(old_spec, _, _) -> let behaviors = List.map (fun b -> b.b_name) old_spec.spec_behavior in let spec = Cabshelper.continue_annot loc (fun () -> Ltyping.funspec behaviors vi None vi.vtype spec) empty_funspec "Ignoring specification of function %s" vi.vname in Cil.CurrentLoc.set vi.vdecl; Logic_utils.merge_funspec old_spec spec | _ -> assert false in update_fundec_in_theFile vi merge_spec ); vi end end end with _ when Cilmsg.had_errors () && continueOnError -> begin Kernel.error ~once:true ~current:true "skipping global %s" n; cabsPushGlobal (dGlobal (Pretty_utils.sfprintf "booo - error in global %s (%t)" n Cil.pp_thisloc) (CurrentLoc.get ())); dummy_function.svar end (* ignore (E.log "Env after processing global %s is:@\n%t@\n" n docEnv); ignore (E.log "Alpha after processing global %s is:@\n%t@\n" n docAlphaTable) *) (* Must catch the Static local variables. Make them global *) and createLocal ghost ((_, sto, _, _) as specs) ((((n, ndt, a, cloc) : A.name), (inite: A.init_expression)) as init_name) : chunk = let loc = convLoc cloc in (* Check if we are declaring a function *) let rec isProto (dt: decl_type) : bool = match dt with | PROTO (JUSTBASE, _, _) -> true | PROTO (x, _, _) -> isProto x | PARENTYPE (_, x, _) -> isProto x | ARRAY (x, _, _) -> isProto x | PTR (_, x) -> isProto x | _ -> false in match ndt with (* Maybe we have a function prototype in local scope. Make it global. We * do this even if the storage is Static *) | _ when isProto ndt -> let vi = createGlobal ghost None specs init_name in (* Add it to the environment to shadow previous decls *) addLocalToEnv n (EnvVar vi); LocalFuncHook.apply vi; empty | _ when sto = Static -> if debugGlobal then Kernel.debug "createGlobal (local static): %s" n; (* Now alpha convert it to make sure that it does not conflict with * existing globals or locals from this function. *) let newname, _ = newAlphaName true "" n in (* Make it global *) let vi = makeVarInfoCabs ~ghost ~isformal:false ~isglobal:true loc specs (newname, ndt, a) in (* However, we have a problem if a real global appears later with the * name that we have happened to choose for this one. Remember these names * for later. *) H.add staticLocals vi.vname vi; (* Add it to the environment as a local so that the name goes out of * scope properly *) addLocalToEnv n (EnvVar vi); (* Maybe this is an array whose length depends on something with local scope, e.g. "static char device[ sizeof(local) ]". Const-fold the type to fix this. *) vi.vtype <- constFoldType vi.vtype; let init : init option = if inite = A.NO_INIT then None else begin let se, ie', et = doInitializer (ghost_local_env ghost) vi inite in (* Maybe we now have a better type? Use the type of the * initializer only if it really differs from the type of * the variable. *) if unrollType vi.vtype != unrollType et then vi.vtype <- et; if isNotEmpty se then Kernel.error ~once:true ~current:true "global static initializer"; (* Check that no locals are refered by the initializer *) check_no_locals_in_initializer ie'; (* Maybe the initializer refers to the function itself. Push a prototype for the function, just in case. *) cabsPushGlobal (GVarDecl (empty_funspec (), !currentFunctionFDEC.svar, CurrentLoc.get ())); Cil.setFormalsDecl !currentFunctionFDEC.svar !currentFunctionFDEC.svar.vtype; Some ie' end in cabsPushGlobal (GVar(vi, {init = init}, CurrentLoc.get ())); empty (* Maybe we have an extern declaration. Make it a global *) | _ when sto = Extern -> let vi = createGlobal ghost None specs init_name in (* Add it to the local environment to ensure that it shadows previous * local variables *) addLocalToEnv n (EnvVar vi); empty | _ -> (* Make a variable of potentially variable size. If se0 <> empty then * it is a variable size variable *) let vi,se0,len,isvarsize = makeVarSizeVarInfo ghost loc specs (n, ndt, a) in let vi = alphaConvertVarAndAddToEnv true vi in (* Replace vi *) let se1 = if isvarsize then begin (* Variable-sized array *) Kernel.warning ~current:true "Variable-sized local variable %s" vi.vname; (* Make a local variable to keep the length *) let savelen = makeVarInfoCabs ~ghost ~isformal:false ~isglobal:false loc (theMachine.typeOfSizeOf, NoStorage, false, []) ("__lengthof" ^ vi.vname,JUSTBASE, []) in (* Register it *) let savelen = alphaConvertVarAndAddToEnv true savelen in let se0 = local_var_chunk se0 savelen in (* Compute the sizeof *) let sizeof = new_exp ~loc (BinOp(Mult, new_exp ~loc (SizeOfE (new_exp ~loc (Lval (Mem(new_exp ~loc (Lval(var vi))), NoOffset)))), new_exp ~loc (Lval (var savelen)), theMachine.typeOfSizeOf)) in (* Register the length *) IH.add varSizeArrays vi.vid sizeof; (* There can be no initializer for this *) if inite != A.NO_INIT then Kernel.error ~once:true ~current:true "Variable-sized array cannot have initializer"; let setlen = se0 +++ (mkStmtOneInstr ~ghost (Set(var savelen, makeCast len savelen.vtype, CurrentLoc.get ())), [],[],[]) in (* Initialize the variable *) let alloca: varinfo = allocaFun () in if Kernel.DoCollapseCallCast.get () then (* do it in one step *) setlen +++ (mkStmtOneInstr ~ghost (Call(Some(var vi), new_exp ~loc (Lval(var alloca)), [ sizeof ], loc)), [],[var vi],[]) else begin (* do it in two *) let rt, _, _, _ = splitFunctionType alloca.vtype in let tmp = newTempVar (Some (Pretty_utils.sfprintf "alloca(%a)" Cil_printer.pp_exp sizeof)) false rt in (local_var_chunk setlen tmp) +++ (mkStmtOneInstr ~ghost (Call(Some(var tmp), new_exp ~loc (Lval(var alloca)), [ sizeof ], CurrentLoc.get ())),[],[],[]) +++ (mkStmtOneInstr ~ghost (Set((var vi), makeCast (new_exp ~loc (Lval(var tmp))) vi.vtype, CurrentLoc.get ())), [],[var vi],[var tmp]) end end else empty in let se1 = local_var_chunk se1 vi in if inite = A.NO_INIT then se1 (* skipChunk *) else begin let se4, ie', et = doInitializer (ghost_local_env ghost) vi inite in (* Fix the length *) (match vi.vtype, ie', et with (* We have a length now *) TArray(_,None, _, _), _, TArray(_, Some _, _, _) -> vi.vtype <- et (* Initializing a local array *) | TArray(TInt((IChar|IUChar|ISChar), _) as bt, None, l, a), SingleInit({enode = Const(CStr s);eloc=loc}), _ -> vi.vtype <- TArray(bt, Some (integer ~loc (String.length s + 1)), l, a) | _, _, _ -> ()); (* Now create assignments instead of the initialization *) (se1 @@ (se4, ghost)) @@ (assignInit ~ghost (Var vi, NoOffset) ie' et empty, ghost) end and doAliasFun vtype (thisname:string) (othername:string) (sname:single_name) (loc: cabsloc) : unit = (* This prototype declares that name is an alias for othername, which must be defined in this file *) (* E.log "%s is alias for %s at %a\n" thisname othername *) (* Cil_printer.pp_location !currentLoc; *) let rt, formals, isva, _ = splitFunctionType vtype in if isva then Kernel.error ~once:true ~current:true "alias unsupported with varargs"; let args = List.map (fun (n,_,_) -> { expr_loc = loc; expr_node = A.VARIABLE n}) (argsToList formals) in let call = A.CALL ({expr_loc = loc; expr_node = A.VARIABLE othername}, args) in let stmt = {stmt_ghost = false; stmt_node = if isVoidType rt then A.COMPUTATION({expr_loc = loc; expr_node = call}, loc) else A.RETURN({expr_loc = loc; expr_node = call}, loc)} in let body = { A.blabels = []; A.battrs = []; A.bstmts = [stmt] } in let fdef = A.FUNDEF (None, sname, body, loc, loc) in ignore (doDecl empty_local_env true fdef); (* get the new function *) let v,_ = try lookupGlobalVar thisname with Not_found -> Kernel.abort ~current:true "error in doDecl" in v.vattr <- dropAttribute "alias" v.vattr (* Do one declaration *) and doDecl local_env (isglobal: bool) : A.definition -> chunk = function | A.DECDEF (logic_spec, (s, nl), loc) -> CurrentLoc.set (convLoc loc); (* Do the specifiers exactly once *) let sugg = match nl with [] -> "" | ((n, _, _, _), _) :: _ -> n in let ghost = local_env.is_ghost in let spec_res = doSpecList local_env.is_ghost sugg s in (* Do all the variables and concatenate the resulting statements *) let doOneDeclarator (acc: chunk) (name: init_name) = let (n,ndt,a,l),_ = name in if isglobal then begin let bt,_,_,attrs = spec_res in let vtype, nattr = doType local_env.is_ghost false (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in (match filterAttributes "alias" nattr with [] -> (* ordinary prototype. *) ignore (createGlobal local_env.is_ghost logic_spec spec_res name) (* E.log "%s is not aliased\n" name *) | [Attr("alias", [AStr othername])] -> if not (isFunctionType vtype) || local_env.is_ghost then begin Kernel.warning ~current:true "%a: CIL only supports attribute((alias)) for C functions." Cil_printer.pp_location (CurrentLoc.get ()); ignore (createGlobal ghost logic_spec spec_res name) end else doAliasFun vtype n othername (s, (n,ndt,a,l)) loc | _ -> Kernel.error ~once:true ~current:true "Bad alias attribute at %a" Cil_printer.pp_location (CurrentLoc.get())); acc end else acc @@ (createLocal local_env.is_ghost spec_res name, ghost) in let res = List.fold_left doOneDeclarator empty nl in if isglobal then res else begin match logic_spec with | None -> res | Some (spec,loc) -> let loc' = convLoc loc in begin Cabshelper.continue_annot loc (fun () -> let spec = Ltyping.code_annot loc' local_env.known_behaviors (Ctype !currentReturnType) (AStmtSpec ([],spec)) in append_chunk_to_annot ~ghost (s2c (mkStmtOneInstr ~ghost:local_env.is_ghost (Code_annot (spec,loc')))) res ) (fun () -> res) "Ignoring logic code specification" ; end end | A.TYPEDEF (ng, loc) -> CurrentLoc.set (convLoc loc); doTypedef local_env.is_ghost ng; empty | A.ONLYTYPEDEF (s, loc) -> CurrentLoc.set (convLoc loc); doOnlyTypedef local_env.is_ghost s; empty | A.GLOBASM (s,loc) when isglobal -> CurrentLoc.set (convLoc loc); cabsPushGlobal (GAsm (s, CurrentLoc.get ())); empty | A.PRAGMA (a, loc) when isglobal -> begin CurrentLoc.set (convLoc loc); match doAttr local_env.is_ghost ("dummy", [a]) with [Attr("dummy", [a'])] -> let a'' = match a' with | ACons (s, args) -> process_align_pragma s args; process_pack_pragma s args | _ -> (* Cil.fatal "Unexpected attribute in #pragma" *) Kernel.warning ~current:true "Unexpected attribute in #pragma"; Some (Attr ("", [a'])) in Extlib.may (fun a'' -> cabsPushGlobal (GPragma (a'', CurrentLoc.get ()))) a''; empty | _ -> Kernel.fatal ~current:true "Too many attributes in pragma" end (* If there are multiple definitions of extern inline, turn all but the * first into a prototype *) | A.FUNDEF (spec,((specs,(n,dt,a,loc')) : A.single_name), (_body : A.block), loc, _) when isglobal && isExtern specs && isInline specs && (H.mem genv (n ^ "__extinline")) -> CurrentLoc.set (convLoc loc); let othervi, _ = lookupVar (n ^ "__extinline") in if othervi.vname = n then (* The previous entry in the env is also an extern inline version of n. *) Kernel.warning ~current:true "Duplicate extern inline definition for %s ignored" n else begin (* Otherwise, the previous entry is an ordinary function that happens to be named __extinline. Renaming n to n__extinline would confict with other, so report an error. *) Kernel.fatal ~current:true ("Trying to rename %s to\n %s__extinline, but %s__extinline" ^^ " already exists in the env.\n \"__extinline\" is" ^^ " reserved for CIL.\n") n n n end; (* Treat it as a prototype *) doDecl local_env isglobal (A.DECDEF (spec,(specs, [((n,dt,a,loc'), A.NO_INIT)]), loc)) | A.FUNDEF (spec,((specs,(n,dt,a, _)) : A.single_name), (body : A.block), loc1, loc2) when isglobal -> begin let ghost = local_env.is_ghost in let idloc = loc1 in let funloc = fst loc1, snd loc2 in let endloc = loc2 in if debugGlobal then Kernel.debug "Definition of %s at %a\n" n Cil_printer.pp_location idloc; CurrentLoc.set idloc; try IH.clear callTempVars; (* Make the fundec right away, and we'll populate it later. We * need this throughout the code to create temporaries. *) currentFunctionFDEC := { svar = makeGlobalVar ~generated:false n voidType; slocals = []; (* For now we'll put here both the locals and * the formals. Then "endFunction" will * separate them *) sformals = []; (* Not final yet *) smaxid = 0; sbody = dummy_function.sbody; (* Not final yet *) smaxstmtid = None; sallstmts = []; sspec = empty_funspec () }; !currentFunctionFDEC.svar.vdecl <- idloc; constrExprId := 0; (* Setup the environment. Add the formals to the locals. Maybe * they need alpha-conv *) enterScope (); (* Start the scope *) ignore (V.visitCabsBlock (new gatherLabelsClass) body); CurrentLoc.set idloc; IH.clear varSizeArrays; (* Enter all the function's labels into the alpha conversion table *) ignore (V.visitCabsBlock (new registerLabelsVisitor) body); CurrentLoc.set idloc; (* Do not process transparent unions in function definitions. * We'll do it later *) transparentUnionArgs := []; (* Fix the NAME and the STORAGE *) let _ = let bt,sto,inl,attrs = doSpecList local_env.is_ghost n specs in !currentFunctionFDEC.svar.vinline <- inl; let ftyp, funattr = doType local_env.is_ghost false (AttrName false) bt (A.PARENTYPE(attrs, dt, a)) in (* Format.printf "Attrs are %a@." d_attrlist funattr; *) !currentFunctionFDEC.svar.vtype <- ftyp; !currentFunctionFDEC.svar.vattr <- funattr; (* If this is the definition of an extern inline then we change * its name, by adding the suffix __extinline. We also make it * static *) let n', sto' = let n' = n ^ "__extinline" in if inl && sto = Extern then begin n', Static end else begin (* Maybe this is the body of a previous extern inline. Then * we must take that one out of the environment because it * is not used from here on. This will also ensure that * then we make this functions' varinfo we will not think * it is a duplicate definition *) (try ignore (lookupVar n'); (* if this succeeds, n' is defined*) let oldvi, _ = lookupVar n in if oldvi.vname = n' then begin (* oldvi is an extern inline function that has been renamed to n ^ "__extinline". Remove it from the environment. *) H.remove env n; H.remove genv n; H.remove env n'; H.remove genv n' end else (* oldvi is not a renamed extern inline function, and we should do nothing. The reason the lookup of n' succeeded is probably because there's an ordinary function that happens to be named, n ^ "__extinline", probably as a result of a previous pass through CIL. See small2/extinline.c*) () with Not_found -> ()); n, sto end in (* Now we have the name and the storage *) !currentFunctionFDEC.svar.vname <- n'; !currentFunctionFDEC.svar.vstorage <- sto' in let vi,has_decl = makeGlobalVarinfo true !currentFunctionFDEC.svar in (* Add the function itself to the environment. Add it before * you do the body because the function might be recursive. Add * it also before you add the formals to the environment * because there might be a formal with the same name as the * function and we want it to take precedence. *) (* Make a variable out of it and put it in the environment *) !currentFunctionFDEC.svar <- vi; (* If it is extern inline then we add it to the global * environment for the original name as well. This will ensure * that all uses of this function will refer to the renamed * function *) addGlobalToEnv n (EnvVar !currentFunctionFDEC.svar); if H.mem alreadyDefined !currentFunctionFDEC.svar.vname then Kernel.error ~once:true ~current:true "There is a definition already for %s" n; H.add alreadyDefined !currentFunctionFDEC.svar.vname idloc; (* ignore (E.log "makefunvar:%s@\n type=%a@\n vattr=%a@\n" n Cil_printer.pp_typ thisFunctionVI.vtype d_attrlist thisFunctionVI.vattr); *) (* makeGlobalVarinfo might have changed the type of the function * (when combining it with the type of the prototype). So get the * type only now. *) (**** Process the TYPE and the FORMALS ***) let _ = let (returnType, formals_t, isvararg, funta) = splitFunctionTypeVI !currentFunctionFDEC.svar in (* Record the returnType for doStatement *) currentReturnType := returnType; (* Create the formals and add them to the environment. *) (* sfg: extract tsets for the formals from dt *) let doFormal (loc : location) (fn, ft, fa) = let f = makeVarinfo ~generated:false false true fn ft in (f.vdecl <- loc; f.vattr <- fa; alphaConvertVarAndAddToEnv true f) in let rec doFormals fl' ll' = begin match (fl', ll') with | [], _ -> [] | fl, [] -> (* no more locs available *) List.map (doFormal (CurrentLoc.get ())) fl | f::fl, (_,(_,_,_,l))::ll -> (* sfg: these lets seem to be necessary to * force the right order of evaluation *) let f' = doFormal (convLoc l) f in let fl' = doFormals fl ll in f' :: fl' end in let fmlocs = (match dt with PROTO(_, fml, _) -> fml | _ -> []) in let formals = doFormals (argsToList formals_t) fmlocs in (* Recreate the type based on the formals. *) let ftype = TFun(returnType, Some (List.map (fun f -> (f.vname, f.vtype, f.vattr)) formals), isvararg, funta) in (*log "Funtype of %s: %a\n" n Cil_printer.pp_typ ftype;*) (* Now fix the names of the formals in the type of the function * as well *) !currentFunctionFDEC.svar.vtype <- ftype; !currentFunctionFDEC.sformals <- formals; (* we will revisit the spec for the declaration in order to change the formals according to the new variables. *) if has_decl then begin try Hashtbl.add alpha_renaming vi.vid (Cil.create_alpha_renaming (Cil.getFormalsDecl vi) formals) with Not_found -> (* the declaration comes from an implicit prototype. We do not have any spec anyway. However, we will have a declaration in the resulting AST, to which we must attach some formals. *) Cil.unsafeSetFormalsDecl vi formals end; in (* Now change the type of transparent union args back to what it * was so that the body type checks. We must do it this late * because makeGlobalVarinfo from above might choke if we give * the function a type containing transparent unions *) let _ = let rec fixbackFormals (idx: int) (args: varinfo list) : unit= match args with [] -> () | a :: args' -> (* Fix the type back to a transparent union type *) (try let origtype = List.assq idx !transparentUnionArgs in a.vtype <- origtype; with Not_found -> ()); fixbackFormals (idx + 1) args' in fixbackFormals 0 !currentFunctionFDEC.sformals; transparentUnionArgs := []; in let behaviors = find_existing_behaviors !currentFunctionFDEC.svar in (******* Now do the spec *******) begin match spec with | Some (spec,loc) -> Cabshelper.continue_annot loc (fun () -> !currentFunctionFDEC.sspec <- Ltyping.funspec behaviors !currentFunctionFDEC.svar (Some !currentFunctionFDEC.sformals) !currentFunctionFDEC.svar.vtype spec) (fun () -> ()) "ignoring logic specification of function %s" !currentFunctionFDEC.svar.vname | None -> () end; (* Merge pre-existing spec if needed. *) if has_decl then begin let merge_spec = function | GVarDecl(old_spec,_,loc) as g -> if not (Cil.is_empty_funspec old_spec) then begin rename_spec g; Cil.CurrentLoc.set loc; Logic_utils.merge_funspec !currentFunctionFDEC.sspec old_spec; Logic_utils.clear_funspec old_spec; end | _ -> assert false in update_fundec_in_theFile !currentFunctionFDEC.svar merge_spec end; (********** Now do the BODY *************) let _ = let stmts = doBody { empty_local_env with known_behaviors = (List.map (fun x -> x.b_name) !currentFunctionFDEC.sspec.spec_behavior) @ behaviors; is_ghost = local_env.is_ghost } body in (* Finish everything *) exitScope (); (* Now fill in the computed goto statement with cases. Do this * before mkFunctionbody which resolves the gotos *) (match !gotoTargetData with Some (_switchv, switch) -> let switche, loc = match switch.skind with | Switch (switche, _, _, l) -> switche, l | _ -> Kernel.fatal ~current:true "the computed goto statement not a switch" in (* Build a default chunk that segfaults *) let default = defaultChunk ~ghost loc (i2c (mkStmtOneInstr ~ghost:local_env.is_ghost (Set ((Mem (makeCast (integer ~loc 0) intPtrType), NoOffset), integer ~loc 0, loc)),[],[],[])) in let bodychunk = ref default in H.iter (fun lname laddr -> bodychunk := caseRangeChunk ~ghost [integer ~loc laddr] loc (gotoChunk ~ghost lname loc @@ (!bodychunk, ghost))) gotoTargetHash; (* Now recreate the switch *) let newswitch = switchChunk ~ghost switche !bodychunk loc in (* We must still share the old switch statement since we * have already inserted the goto's *) let newswitchkind = match newswitch.stmts with [ s, _, _,_,_] when newswitch.cases == []-> s.skind | _ -> Kernel.fatal ~current:true "Unexpected result from switchChunk" in switch.skind <- newswitchkind | None -> ()); (* Now finish the body and store it *) let body = mkFunctionBody ~ghost stmts in (* need to add temporary variables created at sbody level. *) body.blocals <- !currentFunctionFDEC.sbody.blocals @ body.blocals; (*Format.eprintf "Function %a: Temp variables created: %a@." Cil_printer.pp_varinfo !currentFunctionFDEC.svar (Pretty_utils.pp_list ~sep:Pretty_utils.space_sep Cil_printer.pp_varinfo) !currentFunctionFDEC.sbody.blocals; *) !currentFunctionFDEC.sbody <- body; (* Reset the global parameters *) gotoTargetData := None; H.clear gotoTargetHash; gotoTargetNextAddr := 0; in let rec dropFormals formals locals = match formals, locals with [], l -> l | f :: formals, l :: locals -> if f != l then Kernel.abort ~current:true "formal %s is not in locals (found instead %s)" f.vname l.vname; dropFormals formals locals | _ -> Kernel.abort ~current:true "Too few locals" in !currentFunctionFDEC.slocals <- dropFormals !currentFunctionFDEC.sformals (List.rev !currentFunctionFDEC.slocals); setMaxId !currentFunctionFDEC; (* Now go over the types of the formals and pull out the formals * with transparent union type. Replace them with some shadow * parameters and then add assignments *) let _ = let newformals, newbody = List.fold_right (* So that the formals come out in order *) (fun f (accform, accbody) -> match isTransparentUnion f.vtype with None -> (f :: accform, accbody) | Some fstfield -> (* A new shadow to be placed in the formals. Use * makeTempVar to update smaxid and all others but do not insert as a local variable of [f]. *) let loc = CurrentLoc.get () in let shadow = makeTempVar !currentFunctionFDEC ~insert:false fstfield.ftype in (* Now replace it with the current formal. *) (shadow :: accform, mkStmtOneInstr ~ghost:local_env.is_ghost (Set ((Var f, Field(fstfield, NoOffset)), new_exp ~loc (Lval (var shadow)), loc)) :: accbody)) !currentFunctionFDEC.sformals ([], !currentFunctionFDEC.sbody.bstmts) in !currentFunctionFDEC.sbody.bstmts <- newbody; (* To make sure sharing with the type is proper *) setFormals !currentFunctionFDEC newformals; in (* Now see whether we can fall through to the end of the function *) if blockFallsThrough !currentFunctionFDEC.sbody then begin let protect_return,retval = (* Guard the [return] instructions we add with an [\assert \false]*) let assert_false () = let annot = Logic_const.new_code_annotation (AAssert ([], Logic_const.unamed ~loc:endloc Pfalse)) in Cil.mkStmt ~ghost:local_env.is_ghost (Instr (Code_annot (annot, endloc))) in match unrollType !currentReturnType with | TVoid _ -> [], None | (TInt _ | TEnum _ | TFloat _ | TPtr _) as rt -> let res = Some (makeCastT (zero ~loc:endloc) intType rt) in if !currentFunctionFDEC.svar.vname = "main" then [],res else begin Kernel.warning ~current:true "Body of function %s falls-through. \ Adding a return statement" !currentFunctionFDEC.svar.vname; [assert_false ()], res end | _ -> Kernel.warning ~current:true "Body of function %s falls-through and \ cannot find an appropriate return value" !currentFunctionFDEC.svar.vname; [assert_false ()], None in if not (hasAttribute "noreturn" !currentFunctionFDEC.svar.vattr) then !currentFunctionFDEC.sbody.bstmts <- !currentFunctionFDEC.sbody.bstmts @ protect_return @ [mkStmt ~ghost:local_env.is_ghost (Return(retval, endloc))] end; (* ignore (E.log "The env after finishing the body of %s:\n%t\n" n docEnv); *) cabsPushGlobal (GFun (!currentFunctionFDEC, funloc)); empty with _ when Cilmsg.had_errors () && continueOnError -> begin Kernel.error ~once:true ~current:true "skipping function %s in collectFunction" n; cabsPushGlobal (GAsm("error in function " ^ n, CurrentLoc.get ())); empty end end (* FUNDEF *) | LINKAGE (n, loc, dl) -> CurrentLoc.set (convLoc loc); if n <> "C" then Kernel.warning ~current:true "Encountered linkage specification \"%s\"" n; if not isglobal then Kernel.error ~once:true ~current:true "Encountered linkage specification in local scope"; (* For now drop the linkage on the floor !!! *) List.iter (fun d -> let s = doDecl local_env isglobal d in if isNotEmpty s then Kernel.abort ~current:true "doDecl returns non-empty statement for global") dl; empty | A.GLOBANNOT (decl) when isglobal -> begin List.iter (fun decl -> let loc = convLoc decl.Logic_ptree.decl_loc in CurrentLoc.set loc; Cabshelper.continue_annot loc (fun () -> let tdecl = Ltyping.annot decl in cabsPushGlobal (GAnnot(tdecl,CurrentLoc.get ()))) (fun () -> ()) "Ignoring logic global annotation" ) decl; end; empty | A.CUSTOM (custom, name, location) when isglobal -> begin let loc = convLoc location in CurrentLoc.set loc; Cabshelper.continue_annot loc (fun () -> let tcustom = Ltyping.custom custom in cabsPushGlobal (GAnnot(Dcustom_annot(tcustom, name, CurrentLoc.get ()),CurrentLoc.get ()))) (fun () -> ()) "Ignoring custom global annotation"; Kernel.warning ~current:true "cabs2cil : custom" end; empty | A.CUSTOM _ | A.GLOBANNOT _ | A.PRAGMA _ | A.GLOBASM _ | A.FUNDEF _ -> Kernel.fatal ~current:true "this form of declaration must be global" (* Fragile pattern matching are bad practice | _ -> Kernel.fatal ~current:true "unexpected form of declaration" *) and doTypedef ghost ((specs, nl): A.name_group) = try (* Do the specifiers exactly once *) let bt, sto, inl, attrs = doSpecList ghost (suggestAnonName nl) specs in if sto <> NoStorage || inl then Kernel.error ~once:true ~current:true "Storage or inline specifier not allowed in typedef"; let createTypedef ((n,ndt,a,_) : A.name) = (* E.s (error "doTypeDef") *) try let newTyp, tattr = doType ghost false AttrType bt (A.PARENTYPE(attrs, ndt, a)) in let newTyp' = cabsTypeAddAttributes tattr newTyp in (* Create a new name for the type. Use the same name space as that of * variables to avoid confusion between variable names and types. This * is actually necessary in some cases. *) let n', _ = newAlphaName true "" n in let ti = { torig_name = n; tname = n'; ttype = newTyp'; treferenced = false } in (* Since we use the same name space, we might later hit a global with * the same name and we would want to change the name of the global. * It is better to change the name of the type instead. So, remember * all types whose names have changed *) H.add typedefs n' ti; let namedTyp = TNamed(ti, []) in (* Register the type. register it as local because we might be in a * local context *) addLocalToEnv (kindPlusName "type" n) (EnvTyp namedTyp); cabsPushGlobal (GType (ti, CurrentLoc.get ())) with _ when Cilmsg.had_errors () && continueOnError -> begin Kernel.error ~once:true ~current:true "skipping typedef"; cabsPushGlobal (GAsm ("booo_typedef:" ^ n, CurrentLoc.get ())) end in List.iter createTypedef nl with _ when Cilmsg.had_errors () && continueOnError -> begin Kernel.error ~once:true ~current:true "skipping typedef"; let fstname = match nl with [] -> "" | (n, _, _, _) :: _ -> n in cabsPushGlobal (GAsm ("booo_typedef: " ^ fstname, CurrentLoc.get ())) end and doOnlyTypedef ghost (specs: A.spec_elem list) : unit = try let bt, sto, inl, attrs = doSpecList ghost "" specs in if sto <> NoStorage || inl then Kernel.error ~once:true ~current:true "Storage or inline specifier not allowed in typedef"; let restyp, nattr = doType ghost false AttrType bt (A.PARENTYPE(attrs, A.JUSTBASE, [])) in if nattr <> [] then Kernel.warning ~current:true "Ignoring identifier attribute"; (* doSpec will register the type. *) (* See if we are defining a composite or enumeration type, and in that * case move the attributes from the defined type into the composite type * *) let isadef = List.exists (function A.SpecType(A.Tstruct(_, Some _, _)) -> true | A.SpecType(A.Tunion(_, Some _, _)) -> true | A.SpecType(A.Tenum(_, Some _, _)) -> true | _ -> false) specs in match restyp with TComp(ci, _, al) -> if isadef then begin ci.cattr <- cabsAddAttributes ci.cattr al; (* The GCompTag was already added *) end else (* Add a GCompTagDecl *) cabsPushGlobal (GCompTagDecl(ci, CurrentLoc.get ())) | TEnum(ei, al) -> if isadef then begin ei.eattr <- cabsAddAttributes ei.eattr al; end else cabsPushGlobal (GEnumTagDecl(ei, CurrentLoc.get ())) | _ -> Kernel.warning ~current:true "Ignoring un-named typedef that does not introduce a struct or \ enumeration type" with _ when Cilmsg.had_errors () && continueOnError -> begin Kernel.error ~once:true ~current:true "skipping A.ONLYTYPEDEF"; cabsPushGlobal (GAsm ("booo_typedef", CurrentLoc.get ())) end and assignInit ~ghost (lv: lval) ?(has_implicit_init=false) ?(explicit_init=(fun _ _ -> ())) ?(add_implicit_ensures=(fun _ -> ())) (ie: init) (iet: typ) (acc: chunk) : chunk = match ie with SingleInit e -> let (_, e'') = castTo iet (typeOfLval lv) e in explicit_init lv e''; acc +++ (mkStmtOneInstr ~ghost (Set(lv, e'', CurrentLoc.get ())),[],[lv],[]) | CompoundInit (t, initl) -> (match t with | TArray(bt,len,_,_) -> let l = integerArrayLength len in if List.length initl < l then begin (* For big arrays in local variables, the implicit initialization to 0 is not done completely. We'll do that ourselves, with - a bzero to 0 - a contract for plugins that do not want to rely on bzero. All that is done at the toplevel occurence of implicit initialization. *) let (curr_host,curr_off) = lv in let vi = match curr_host with | Var vi -> vi | _ -> Kernel.fatal "Trying to initialize a anonymous block" in let ensures = ref [] in let known_idx = ref Datatype.Big_int.Set.empty in let explicit_init (_,off as lv) v = if not has_implicit_init then begin (* just add ensures at the toplevel init *) let pred = ensures_init vi off v in let post_cond = (Normal, Logic_const.new_predicate pred) in ensures:= post_cond :: !ensures end; (* find which index is initialized. This is not necessarily the last one in case of array of complex structures. *) let rec aux off = let my_off, last_off = Cil.removeOffset off in if Cil_datatype.Offset.equal curr_off my_off then begin match last_off with | Index(i,_) -> (match Cil.constFold true i with | { enode = Const (CInt64 (v,_,_)) } -> known_idx := Datatype.Big_int.Set.add v !known_idx | _ -> Kernel.abort ~current:true "Non constant index in designator for array \ initialization: %a" Cil_printer.pp_exp i) | NoOffset | Field _ -> assert false (* We are supposed to have an array here. *) end else match last_off with | NoOffset -> () | _ -> aux my_off in aux off; explicit_init lv v in let add_implicit_ensures = if has_implicit_init then add_implicit_ensures else fun e -> ensures:= (Normal, Logic_const.new_predicate e) :: !ensures in (* do the initialization of the array only. *) let my_init = foldLeftCompound ~implicit:false ~doinit:(fun off i it acc -> assignInit ~ghost (addOffsetLval off lv) ~has_implicit_init:true ~explicit_init ~add_implicit_ensures i it acc) ~ct:t ~initl:initl ~acc:empty in let base_init = if has_implicit_init then empty (* this location has already been zero-initialized by toplevel implicit init. *) else if Kernel.InitializedPaddingLocals.get () then s2c (set_to_zero ~ghost vi curr_off t) (* use bzero to clear whole region*) else zero_init ~ghost vi curr_off l bt (* zero-init each field, so as to leave padding bits uninitialized. *) in let init_block = base_init @@ (my_init, ghost) in (* lift at toplevel contract implicit zero-initialization. *) let my_ensures = make_implicit_ensures vi curr_off bt l !known_idx in add_implicit_ensures my_ensures; let annot_chunk = if has_implicit_init then empty else begin let tlv = Logic_utils.lval_to_term_lval ~cast:false lv in let loc = vi.vdecl in let rec all_zone tlv = match Logic_utils.unroll_type (Cil.typeOfTermLval tlv) with | Ctype (TArray (_,len,_,_)) | Ltype ({ lt_name = "set"},[Ctype(TArray (_,len,_,_))])-> let tlen = Extlib.opt_map (Logic_utils.expr_to_term ~cast:false) len in let upper = Extlib.opt_map (fun tlen -> Logic_const.term ~loc (TBinOp(MinusA,tlen,Logic_const.tinteger ~loc 1)) Linteger) tlen in let all_range = Logic_const.trange ~loc (Some (Logic_const.tinteger ~loc 0), upper) in all_zone (Logic_const.addTermOffsetLval (TIndex (all_range, TNoOffset)) tlv) | t -> Logic_const.term ~loc (TLval tlv) t in let tlocs = all_zone tlv in let assigns = Writes [Logic_const.new_identified_term tlocs,FromAny] in let post_cond = List.rev !ensures in let contract = { spec_behavior = [Cil.mk_behavior ~name:"Frama_C_implicit_init" ~assigns ~post_cond () ]; spec_variant = None; spec_terminates = None; spec_complete_behaviors = []; spec_disjoint_behaviors = []; } in let code_annot = Logic_const.new_code_annotation (AStmtSpec ([],contract)) in s2c (Cil.mkStmt ~ghost (Instr (Code_annot (code_annot,Cabshelper.currentLoc())))) end in let init_chunk = append_chunk_to_annot ~ghost annot_chunk init_block in acc @@ (init_chunk, ghost) end else begin foldLeftCompound ~implicit:false ~doinit: (fun off i it acc -> assignInit ~ghost (addOffsetLval off lv) ~has_implicit_init ~explicit_init ~add_implicit_ensures i it acc) ~ct:t ~initl:initl ~acc:acc end | _ -> foldLeftCompound ~implicit:false ~doinit: (fun off i it acc -> assignInit ~ghost (addOffsetLval off lv) ~has_implicit_init ~explicit_init ~add_implicit_ensures i it acc) ~ct:t ~initl:initl ~acc:acc) and blockInit ~ghost (lv: lval) (ie: init) (iet: typ) : block = c2block ~ghost (assignInit ~ghost lv ie iet empty) (* Now define the processors for body and statement *) and doBody local_env (blk: A.block) : chunk = let ghost = local_env.is_ghost in enterScope (); (* Rename the labels and add them to the environment *) List.iter (fun l -> ignore (genNewLocalLabel l)) blk.blabels; (* See if we have some attributes *) let battrs = doAttributes ghost blk.A.battrs in let bodychunk = afterConversion ~ghost (snd (List.fold_left (* !!! @ evaluates its arguments backwards *) (fun ((new_behaviors,keep_block),prev) s -> let local_env = { local_env with known_behaviors = new_behaviors @ local_env.known_behaviors } in (* Format.eprintf "Considering statement: %a@." Cprint.print_statement s; *) let res = doStatement local_env s in (* Keeps stmts originating from the same source statement in a single block when the statement follows a code annotation, so that the annotation will be attached to the whole result and not to the first Cil statement *) let new_behaviors, keep_next = match s.stmt_node with CODE_ANNOT _ -> [], true | CODE_SPEC (s,_) -> List.map (fun x -> x.b_name) s.spec_behavior, true | _ -> [], false in (* Format.eprintf "Done statement %a@." d_chunk res; *) let chunk = if keep_block then append_chunk_to_annot ~ghost prev res else prev @@ (res, ghost) in ((new_behaviors, keep_next), chunk)) (([],false),empty) blk.A.bstmts)) in exitScope (); if battrs == [] && bodychunk.locals == [] then begin (* keep block marked with FRAMA_C_KEEP_BLOCK or that defines local variables as independent blocks whatever happens. *) bodychunk end else begin let b = c2block ~ghost bodychunk in b.battrs <- battrs; let res = s2c (mkStmt ~ghost (Block b)) in { res with cases = bodychunk.cases } end and doStatement local_env (s : A.statement) : chunk = let mk_loop_annot a loc = Cabshelper.continue_annot loc (fun () -> List.map (Ltyping.code_annot loc local_env.known_behaviors (Ctype !currentReturnType)) a) (fun () -> []) "Ignoring all logic loop annotations" in let ghost = s.stmt_ghost in let local_env = { local_env with is_ghost = ghost } in try match s.stmt_node with A.NOP loc -> { empty with stmts = [mkEmptyStmt ~ghost ~loc (), [],[],[],[]]} | A.COMPUTATION (e, loc) -> CurrentLoc.set (convLoc loc); let (lasts, data) = !gnu_body_result in if lasts == s then begin (* This is the last in a GNU_BODY *) let (s', e', t') = doFullExp local_env false e (AExp None) in data := Some (e', t'); (* Record the result *) s' end else let (s', e', _) = doFullExp local_env false e ADrop in (* drop the side-effect free expression unless the whole computation is pure and it contains potential threats (i.e. dereference) *) if isEmpty s' && is_dangerous e' then s' @@ (keepPureExpr ~ghost e' loc, ghost) else begin if (isEmpty s') then begin let name = !currentFunctionFDEC.svar.vorig_name in IgnorePureExpHook.apply (name, e'); end; s' end | A.BLOCK (b, loc,_) -> CurrentLoc.set (convLoc loc); let c = doBody local_env b in let b = c2block ~ghost c in b.battrs <- addAttributes [Attr(frama_c_keep_block,[])] b.battrs; let res = s2c (mkStmt ~ghost (Block b)) in { res with cases = c.cases } | A.SEQUENCE (s1, s2, _) -> let c1 = doStatement local_env s1 in let c2 = doStatement local_env s2 in c1 @@ (c2, ghost) | A.IF(e,st,sf,loc) -> let st' = doStatement local_env st in let sf' = doStatement local_env sf in CurrentLoc.set (convLoc loc); doCondition ~info:(Cabscond.IF,loc) local_env false e st' sf' | A.WHILE(a,e,s,loc) -> let a = mk_loop_annot a loc in startLoop true; let s' = doStatement local_env s in let s' = if !doTransformWhile then s' @@ (consLabContinue ~ghost skipChunk, ghost) else s' in let loc' = convLoc loc in let break_cond = breakChunk ~ghost loc' in exitLoop (); CurrentLoc.set loc'; loopChunk ~ghost a ((doCondition ~info:(Cabscond.WHILE,loc) local_env false e skipChunk break_cond) @@ (s', ghost)) | A.DOWHILE(a, e,s,loc) -> let a = mk_loop_annot a loc in startLoop false; let s' = doStatement local_env s in let loc' = convLoc loc in CurrentLoc.set loc'; (* No 'break' instruction can exit the chunk *) let no_break chunk = List.for_all (fun (s, _, _, _, _) -> not (stmtCanBreak s)) chunk.stmts in (* Check if we are translating 'do { } while (0)'. If so, translate it sito '' instead. Not active for now as it can impact plugins that compare the shape of the Cabs and of the Cil files. *) if false && isCabsZeroExp e (* exp is 0 or something equivalent *) && a = [] (* No loop annot *) && not (continueUsed ()) (* no 'continue' inside s *) && no_break s' (* no break that exists s *) then ( exitLoop (); s' ) else let s'' = consLabContinue ~ghost (doCondition ~info:(Cabscond.DOWHILE,loc) local_env false e skipChunk (breakChunk ~ghost loc')) in exitLoop (); loopChunk ~ghost a (s' @@ (s'', ghost)) | A.FOR(a,fc1,e2,e3,s,loc) -> begin let loc' = convLoc loc in CurrentLoc.set loc'; enterScope (); (* Just in case we have a declaration *) ForLoopHook.apply (fc1,e2,e3,s); let (se1, _, _) , has_decl = match fc1 with FC_EXP e1 -> doFullExp local_env false e1 ADrop, false | FC_DECL d1 -> (doDecl local_env false d1, zero ~loc, voidType), true in let a = mk_loop_annot a loc in let (se3, _, _) = doFullExp local_env false e3 ADrop in startLoop false; let s' = doStatement local_env s in (*Kernel.debug "Loop body : %a" d_chunk s';*) CurrentLoc.set loc'; let s'' = consLabContinue ~ghost se3 in let break_cond = breakChunk ~ghost loc' in exitLoop (); let res = match e2.expr_node with A.NOTHING -> (* This means true *) se1 @@ (loopChunk ~ghost a (s' @@ (s'', ghost)), ghost) | _ -> se1 @@ (loopChunk ~ghost a (((doCondition ~info:(Cabscond.FOR,loc) local_env false e2 skipChunk break_cond) @@ (s', ghost)) @@ (s'', ghost)), ghost) in exitScope (); if has_decl then begin let chunk = s2c (mkStmt ~ghost (Block (c2block ~ghost res))) in { chunk with cases = res.cases } end else res end | A.BREAK loc -> let loc' = convLoc loc in CurrentLoc.set loc'; breakChunk ~ghost loc' | A.CONTINUE loc -> let loc' = convLoc loc in CurrentLoc.set loc'; continueOrLabelChunk ~ghost loc' | A.RETURN ({ expr_node = A.NOTHING}, loc) -> let loc' = convLoc loc in CurrentLoc.set loc'; if not (isVoidType !currentReturnType) then Kernel.warning ~current:true "Return statement without a value in function returning %a\n" Cil_printer.pp_typ !currentReturnType; returnChunk ~ghost None loc' | A.RETURN (e, loc) -> let loc' = convLoc loc in CurrentLoc.set loc'; (* Sometimes we return the result of a void function call *) if isVoidType !currentReturnType then begin Kernel.warning ~current:true "Return statement with a value in function returning void"; let (se, _, _) = doFullExp local_env false e ADrop in se @@ (returnChunk ~ghost None loc', ghost) end else begin let rt = typeRemoveAttributes ["warn_unused_result"] !currentReturnType in let (se, e', et) = doFullExp local_env false e (AExp (Some rt)) in let (_, e'') = castTo et rt e' in se @@ (returnChunk ~ghost (Some e'') loc', ghost) end | A.SWITCH (e, s, loc) -> let loc' = convLoc loc in CurrentLoc.set loc'; let (se, e', et) = doFullExp local_env false e (AExp None) in if not (Cil.isIntegralType et) then Kernel.error ~once:true ~current:true "Switch on a non-integer expression."; let et' = Cil.integralPromotion et in let e' = makeCastT ~e:e' ~oldt:et ~newt:et' in enter_break_env (); let s' = doStatement local_env s in exit_break_env (); se @@ (switchChunk ~ghost e' s' loc', ghost) | A.CASE (e, s, loc) -> let loc' = convLoc loc in CurrentLoc.set loc'; let (se, e', _) = doFullExp local_env true e (AExp None) in if isNotEmpty se || not (Cil.isIntegerConstant e') then Kernel.error ~once:true ~current:true "Case statement with a non-constant"; caseRangeChunk ~ghost [if theMachine.lowerConstants then constFold false e' else e'] loc' (doStatement local_env s) | A.CASERANGE (el, eh, s, loc) -> let loc' = convLoc loc in CurrentLoc.set loc; let (sel, el', _) = doFullExp local_env false el (AExp None) in let (seh, eh', _) = doFullExp local_env false eh (AExp None) in if isNotEmpty sel || isNotEmpty seh then Kernel.error ~once:true ~current:true "Case statement with a non-constant"; let il, ih = match (constFold true el').enode, (constFold true eh').enode with Const(CInt64(il, _, _)), Const(CInt64(ih, _, _)) -> Integer.to_int il, Integer.to_int ih | _ -> Kernel.fatal ~current:true "Cannot understand the constants in case range" in if il > ih then Kernel.error ~once:true ~current:true "Empty case range"; let rec mkAll (i: int) = if i > ih then [] else integer ~loc i :: mkAll (i + 1) in caseRangeChunk ~ghost (mkAll il) loc' (doStatement local_env s) | A.DEFAULT (s, loc) -> let loc' = convLoc loc in CurrentLoc.set loc'; defaultChunk ~ghost loc' (doStatement local_env s) | A.LABEL (l, s, loc) -> let loc' = convLoc loc in CurrentLoc.set loc'; C_logic_env.add_current_label l; (* Lookup the label because it might have been locally defined *) let chunk = consLabel ~ghost (lookupLabel l) (doStatement local_env s) loc' true in C_logic_env.reset_current_label (); chunk | A.GOTO (l, loc) -> let loc' = convLoc loc in CurrentLoc.set loc'; (* Maybe we need to rename this label *) gotoChunk ~ghost (lookupLabel l) loc' | A.COMPGOTO (e, loc) -> begin let loc' = convLoc loc in CurrentLoc.set loc'; (* Do the expression *) let se, e', _ = doFullExp local_env false e (AExp (Some voidPtrType)) in match !gotoTargetData with Some (switchv, switch) -> (* We have already generated this one *) (se @@ (i2c(mkStmtOneInstr ~ghost (Set (var switchv, makeCast e' intType, loc')), [],[],[]), ghost)) @@ (s2c(mkStmt ~ghost (Goto (ref switch, loc'))), ghost) | None -> begin (* Make a temporary variable *) let vchunk = createLocal local_env.is_ghost (intType, NoStorage, false, []) (("__compgoto", A.JUSTBASE, [], loc), A.NO_INIT) in if not (isEmpty vchunk) then Kernel.fatal ~current:true "Non-empty chunk in creating temporary for goto *"; let switchv, _ = try lookupVar "__compgoto" with Not_found -> Kernel.abort ~current:true "Cannot find temporary for goto *"; in (* Make a switch statement. We'll fill in the statements at the * end of the function *) let switch = mkStmt ~ghost (Switch (new_exp ~loc (Lval(var switchv)), mkBlock [], [], loc')) in (* And make a label for it since we'll goto it *) switch.labels <- [Label ("__docompgoto", loc', false)]; gotoTargetData := Some (switchv, switch); (se @@ (i2c (mkStmtOneInstr ~ghost (Set (var switchv, makeCast e' intType, loc')),[],[],[]), ghost)) @@ (s2c switch, ghost) end end | A.DEFINITION d -> let s = doDecl local_env false d in (* Kernel.debug "Def at %a: %a\n" Cil_printer.pp_location (currentLoc()) d_chunk s; *) s | A.ASM (asmattr, tmpls, details, loc) -> (* Make sure all the outs are variables *) let loc' = convLoc loc in let attr' = doAttributes local_env.is_ghost asmattr in CurrentLoc.set loc'; let stmts : chunk ref = ref empty in let (tmpls', outs', ins', clobs') = match details with | None -> let tmpls' = if theMachine.msvcMode then tmpls else let pattern = Str.regexp "%" in let escape = Str.global_replace pattern "%%" in List.map escape tmpls in (tmpls', [], [], []) | Some { aoutputs = outs; ainputs = ins; aclobbers = clobs } -> let outs' = List.map (fun (id, c, e) -> let (se, e', _) = doFullExp local_env false e (AExp None) in let lv = match e'.enode with | Lval lval | StartOf lval -> lval | _ -> Kernel.fatal ~current:true "Expected lval for ASM outputs" in stmts := !stmts @@ (se, ghost); (id, c, lv)) outs in (* Get the side-effects out of expressions *) let ins' = List.map (fun (id, c, e) -> let (r, se, e', _) = doExp local_env false e (AExp None) in let se = add_reads e'.eloc r se in stmts := !stmts @@ (se, ghost); (id, c, e')) ins in (tmpls, outs', ins', clobs) in !stmts @@ (i2c(mkStmtOneInstr ~ghost:local_env.is_ghost (Asm(attr', tmpls', outs', ins', clobs', loc')),[],[],[]), ghost) | TRY_FINALLY (b, h, loc) -> let loc' = convLoc loc in CurrentLoc.set loc'; let b': chunk = doBody local_env b in let h': chunk = doBody local_env h in if b'.cases <> [] || h'.cases <> [] then Kernel.error ~once:true ~current:true "Try statements cannot contain switch cases"; s2c (mkStmt ~ghost (TryFinally (c2block ~ghost b', c2block ~ghost h', loc'))) | TRY_EXCEPT (b, e, h, loc) -> let loc' = convLoc loc in CurrentLoc.set loc'; let b': chunk = doBody local_env b in (* Now do e *) let ((se: chunk), e', _) = doFullExp local_env false e (AExp None) in let h': chunk = doBody local_env h in if b'.cases <> [] || h'.cases <> [] || se.cases <> [] then Kernel.error ~once:true ~current:true "Try statements cannot contain switch cases"; (* Now take se and try to convert it to a list of instructions. This * might not be always possible *) let stmt_to_instrs s = List.rev_map (function (s,_,_,_,_) -> match s.skind with | Instr s -> s | _ -> Kernel.fatal ~current:true "Except expression contains unexpected statement") s in let il' = stmt_to_instrs se.stmts in s2c (mkStmt ~ghost (TryExcept (c2block ~ghost b',(il', e'), c2block ~ghost h', loc'))) | CODE_ANNOT (a, loc) -> let loc' = convLoc loc in begin Cabshelper.continue_annot loc (fun () -> let typed_annot = Ltyping.code_annot loc' local_env.known_behaviors (Ctype !currentReturnType) a in s2c (mkStmtOneInstr ~ghost (Code_annot (typed_annot,loc')))) (fun () -> BlockChunk.empty) "Ignoring logic code annotation" ; end | CODE_SPEC (a, loc) -> let loc' = convLoc loc in begin Cabshelper.continue_annot loc (fun () -> let spec = Ltyping.code_annot loc' local_env.known_behaviors (Ctype !currentReturnType) (AStmtSpec ([],a)) in s2c (mkStmtOneInstr ~ghost (Code_annot (spec,loc')))) (fun () -> BlockChunk.empty) "Ignoring logic code specification" ; end with _ when Cilmsg.had_errors () && continueOnError -> begin Kernel.error "Ignoring statement" ; consLabel ~ghost "booo_statement" empty (convLoc (C.get_statementloc s)) false end let rec stripParenLocal e = match e.expr_node with | A.PAREN e2 -> stripParenLocal e2 | _ -> e class stripParenClass : V.cabsVisitor = object inherit V.nopCabsVisitor method vexpr e = match e.expr_node with | A.PAREN e2 -> ChangeDoChildrenPost (stripParenLocal e2,stripParenLocal) | _ -> DoChildren end let stripParenFile file = V.visitCabsFile (new stripParenClass) file (* Translate a file *) let convFile (f : A.file) : Cil_types.file = (* remove parentheses from the Cabs *) let fname,dl = stripParenFile f in (* Clean up the global types *) Cilmsg.clear_errors(); initGlobals(); startFile (); IH.clear noProtoFunctions; H.clear compInfoNameEnv; H.clear enumInfoNameEnv; IH.clear mustTurnIntoDef; H.clear alreadyDefined; H.clear staticLocals; H.clear typedefs; H.clear isomorphicStructs; H.clear alpha_renaming; Stack.clear packing_pragma_stack; current_packing_pragma := None; H.clear pragma_align_by_struct; current_pragma_align := None; Logic_env.prepare_tables (); anonCompFieldNameId := 0; Kernel.debug ~level:2 "Converting CABS->CIL" ; (* Setup the built-ins, but do not add their prototypes to the file *) let setupBuiltin name (resTyp, argTypes, isva) = let v = makeGlobalVar name (TFun(resTyp, Some (List.map (fun at -> ("", at, [])) argTypes), isva, [])) in ignore (alphaConvertVarAndAddToEnv true v); (* Add it to the file as well *) cabsPushGlobal (GVarDecl (empty_funspec (), v, Cil.builtinLoc)); Cil.setFormalsDecl v v.vtype in Cil.Builtin_functions.iter setupBuiltin; let globalidx = ref 0 in let doOneGlobal (ghost,(d: A.definition)) = let local_env = ghost_local_env ghost in let s = doDecl local_env true d in if isNotEmpty s then Kernel.abort ~current:true "doDecl returns non-empty statement for global"; in List.iter doOneGlobal dl; let globals = ref (fileGlobals ()) in List.iter rename_spec !globals; Logic_env.prepare_tables (); IH.clear noProtoFunctions; IH.clear mustTurnIntoDef; H.clear alreadyDefined; H.clear compInfoNameEnv; H.clear enumInfoNameEnv; H.clear isomorphicStructs; H.clear staticLocals; H.clear typedefs; H.clear env; H.clear genv; IH.clear callTempVars; H.clear alpha_renaming; if false then Kernel.debug "Cabs2cil converted %d globals" !globalidx; (* We are done *) { fileName = fname; globals = !globals; globinit = None; globinitcalled = false; } (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/frontc/frontc.mli0000644000175000017500000000733712155630365020644 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Signals that we are in MS VC mode *) val setMSVCMode: unit -> unit (** Raised when the front-end is requested to print the CABS and return *) exception CabsOnly (** add a syntactic transformation that will be applied to all freshly parsed C files. *) val add_syntactic_transformation: (Cabs.file -> Cabs.file) -> unit (** the main command to parse a file. Return a thunk that can be used to convert the AST to CIL. *) val parse: string -> (unit -> Cil_types.file*Cabs.file) frama-c-Fluorine-20130601/cil/src/frontc/cabsbranches.mli0000644000175000017500000000754212155630365021765 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Original Source Branches --- *) (* -------------------------------------------------------------------------- *) open Cil_types val compute : unit -> unit (** Force the link for branches *) val branches : stmt -> ( block list * block list ) option (** If the [stmt] is an original "if-then-else" statement, returns the list of blocks associated to "then" and "else" branches *) val pp_comment : Format.formatter -> stmt -> unit (** Print the internal maps for debug *) frama-c-Fluorine-20130601/cil/src/frontc/lexerhack.ml0000755000175000017500000000753112155630365021145 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* We provide here a pointer to a function. It will be set by the lexer and * used by the parser. In Ocaml lexers depend on parsers, so we we have put * such functions in a separate module. *) let add_identifier: (string -> unit) ref = ref (fun _ -> Kernel.fatal "Uninitialized add_identifier") let add_type: (string -> unit) ref = ref (fun _ -> Kernel.fatal "Uninitialized add_type") let push_context: (unit -> unit) ref = ref (fun _ -> Kernel.fatal "Uninitialized push_context") let pop_context: (unit -> unit) ref = ref (fun _ -> Kernel.fatal "You called an uninitialized pop_context") frama-c-Fluorine-20130601/cil/src/frontc/cabscond.mli0000644000175000017500000001061212155630365021113 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Original Conditions --- *) (* -------------------------------------------------------------------------- *) type cond = | And of cond * cond | Or of cond * cond | Not of cond | Atom of Cil_types.exp | Blob type kind = | IF | FOR | WHILE | DOWHILE type info = { id : int ; kind : kind ; file : string ; line : int ; cond : cond ; } val active : bool ref (** Interface to be used during Cabs2cil *) val push_condition : kind -> Cabs.cabsloc -> Cabs.expression -> bool (** Call it when entering [Cabs2cil.doCondition] Return false if inactive. *) val pop_condition : unit -> unit (** Call it when exiting [Cabs2cil.doCondition] *) val bind : Cabs.expression -> Cil_types.exp -> unit (** Call it when constructing an [ifChunk] *) (** Interface to be used after CIL *) val lookup : Cil_types.exp -> info option val pp_kind : Format.formatter -> kind -> unit val pp_where : Format.formatter -> (string * Cil_types.exp * cond) -> unit val pp_comment : Format.formatter -> Cil_types.stmt -> unit frama-c-Fluorine-20130601/cil/src/frontc/errorloc.mli0000644000175000017500000001545312155630365021176 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* * * Copyright (c) 2001-2002, * George C. Necula * Scott McPeak * Wes Weimer * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * 3. The names of the contributors may not be used to endorse or promote * products derived from this software without specific prior written * permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * *) (* Copied and modified from [cil/src/errormsg.mli] *) val newline: unit -> unit (* Call this function to announce a new line *) val getPosition: unit -> Lexing.position * Lexing.position (* The module stores the current file,line, and working directory in a hidden internal state, modified by the three following functions. *) (** This function is used especially when the preprocessor has generated linemarkers in the output that let us know the current working directory at the time of preprocessing (option -fworking-directory for GNU CPP). *) val setCurrentWorkingDirectory: string -> unit (** If normalize is false, [setCurrentFile ~normalize:false path] accepts [path] as the current file "as is". Else (the default), if [path] is relative, make it relative to the current working directory if it has been set; then in any case attempts to shorten the path to the current file using [Filepath.normalize]. This function should not be called with a string argument which has been already normalized (because normalization can make [path] relative to a different path). *) val setCurrentFile: ?normalize:bool -> string -> unit val setCurrentLine: int -> unit (** Type for source-file locations *) type location = { file: string; (** The file name *) line: int; (** The line number *) } val d_loc: location Pretty_utils.formatter val parse_error: string (* A message *) -> 'a (** An unknown location for use when you need one but you don't have one *) val locUnknown: location (* Call this function to start parsing. useBasename is by default "true", * meaning that the error information maintains only the basename. If the * file name is - then it reads from stdin. *) val startParsing: ?useBasename:bool -> string -> Lexing.lexbuf val finishParsing: unit -> unit (* Call this function to finish parsing and * close the input channel *) frama-c-Fluorine-20130601/cil/src/frontc/cabshelper.mli0000644000175000017500000001123512155630365021451 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** Helper functions for Cabs *) val nextident : int ref (** Try do do the job. If exception and continue on error is set, catch it and to the fallback with proper warning. Usage: [continue_annot job backtrack "Ignoring foo"] *) val continue_annot : Cabs.cabsloc -> (unit -> 'a) -> (unit -> 'a) -> ('b,Format.formatter,unit,'a) format4 -> 'b val getident : unit -> int val currentLoc : unit -> Cabs.cabsloc val cabslu : Cabs.cabsloc (* List of comments together with the location where they are found. *) module Comments: sig val self: State.t (* adds a comment at a given location. *) val add: Cabs.cabsloc -> string -> unit (* gets all the comment located between the two positions. *) val get: Cabs.cabsloc -> string list (* iter over all registered comments. *) val iter: (Cabs.cabsloc -> string -> unit) -> unit (* fold over all registered comments. *) val fold: (Cabs.cabsloc -> string -> 'a -> 'a) -> 'a -> 'a end val missingFieldDecl : string * Cabs.decl_type * 'a list * Cabs.cabsloc val isStatic : Cabs.spec_elem list -> bool val isExtern : Cabs.spec_elem list -> bool val isInline : Cabs.spec_elem list -> bool val isTypedef : Cabs.spec_elem list -> bool val get_definitionloc : Cabs.definition -> Cabs.cabsloc val get_statementloc : Cabs.statement -> Cabs.cabsloc val explodeStringToInts : string -> int64 list val valueOfDigit : char -> int64 val d_cabsloc : Cabs.cabsloc Pretty_utils.formatter frama-c-Fluorine-20130601/cil/src/frontc/clexer.mli0000644000175000017500000000766112155630365020633 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (** The C Lexer. *) val init: filename:string -> Lexing.lexbuf val finish: unit -> unit val initial: Lexing.lexbuf -> Cparser.token (** This is the main lexing function *) val push_context: unit -> unit (** Start a context *) val add_type: string -> unit (** Add a new string as a type name *) val add_identifier: string -> unit (** Add a new string as a variable name *) val pop_context: unit -> unit (** Remove all names added in this context *) val annot_char : char ref (** The character to recognize logic formulae in comments *) val currentLoc : unit -> Cabs.cabsloc val is_c_keyword: string -> bool (** [true] if the given string is a C keyword. @since Nitrogen-20111001 *) frama-c-Fluorine-20130601/cil/src/frontc/cabsvisit.mli0000644000175000017500000001355412155630365021336 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* cabsvisit.mli *) (* interface for cabsvisit.ml *) open Cil type nameKind = NVar (** Variable or function prototype name *) | NFun (** Function definition name *) | NField (** The name of a field *) | NType (** The name of a type *) (* All visit methods are called in preorder! (but you can use * ChangeDoChildrenPost to change the order) *) class type cabsVisitor = object method vexpr: Cabs.expression -> Cabs.expression visitAction (* expressions *) method vinitexpr: Cabs.init_expression -> Cabs.init_expression visitAction method vstmt: Cabs.statement -> Cabs.statement list visitAction method vblock: Cabs.block -> Cabs.block visitAction method vvar: string -> string (* use of a variable * names *) method vdef: Cabs.definition -> Cabs.definition list visitAction method vtypespec: Cabs.typeSpecifier -> Cabs.typeSpecifier visitAction method vdecltype: Cabs.decl_type -> Cabs.decl_type visitAction (* For each declaration we call vname *) method vname: nameKind -> Cabs.specifier -> Cabs.name -> Cabs.name visitAction method vspec: Cabs.specifier -> Cabs.specifier visitAction (* specifier *) method vattr: Cabs.attribute -> Cabs.attribute list visitAction method vEnterScope: unit -> unit method vExitScope: unit -> unit end class nopCabsVisitor: cabsVisitor val visitCabsTypeSpecifier: cabsVisitor -> Cabs.typeSpecifier -> Cabs.typeSpecifier val visitCabsSpecifier: cabsVisitor -> Cabs.specifier -> Cabs.specifier (** Visits a decl_type. The bool argument is saying whether we are ina * function definition and thus the scope in a PROTO should extend until the * end of the function *) val visitCabsDeclType: cabsVisitor -> bool -> Cabs.decl_type -> Cabs.decl_type val visitCabsDefinition: cabsVisitor -> Cabs.definition -> Cabs.definition list val visitCabsBlock: cabsVisitor -> Cabs.block -> Cabs.block val visitCabsStatement: cabsVisitor -> Cabs.statement -> Cabs.statement list val visitCabsExpression: cabsVisitor -> Cabs.expression -> Cabs.expression val visitCabsAttributes: cabsVisitor -> Cabs.attribute list -> Cabs.attribute list val visitCabsName: cabsVisitor -> nameKind -> Cabs.specifier -> Cabs.name -> Cabs.name val visitCabsFile: cabsVisitor -> Cabs.file -> Cabs.file (* (** Set by the visitor to the current location *) val visitorLocation: Cabs.cabsloc ref *) frama-c-Fluorine-20130601/cil/src/frontc/cabscond.ml0000644000175000017500000001741712155630365020754 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Original Conditions --- *) (* -------------------------------------------------------------------------- *) open Cabs type cond = | And of cond * cond | Or of cond * cond | Not of cond | Atom of Cil_types.exp | Blob type kind = | IF | FOR | WHILE | DOWHILE type info = { id : int ; kind : kind ; file : string ; line : int ; cond : cond ; } type lazy_cond = | LzAnd of lazy_cond * lazy_cond | LzOr of lazy_cond * lazy_cond | LzNot of lazy_cond | LzAtom of Cabs.expression let rec lazy_cond e = match e.expr_node with | Cabs.BINARY(Cabs.AND,e1,e2) -> LzAnd(lazy_cond e1,lazy_cond e2) | Cabs.BINARY(Cabs.OR,e1,e2) -> LzOr(lazy_cond e1,lazy_cond e2) | Cabs.UNARY(Cabs.NOT,e) -> LzNot(lazy_cond e) | _ -> LzAtom e type binding = | Lazy of int * lazy_cond | Info of info type context = { c_kind : kind ; c_loc : Cabs.cabsloc ; mutable c_binder : binding ; mutable c_if : string option ; mutable c_then : string option ; mutable c_else : string option ; } let c_info = ref 0 let active = ref false let c_stack : context list ref = ref [] let inconsistent from = match !c_stack with | context::_ -> Kernel.warning "[%s] Inconsistent state when binding condition at %a" from Cabshelper.d_cabsloc context.c_loc ; active := false | _ -> Kernel.warning "[%s] Inconsistent condition stack (no condition expression stacked)" from ; active := false module Emap = Hashtbl.Make (struct type t = Cabs.expression let equal = (==) let hash = Hashtbl.hash end) let atoms : Cil_types.exp Emap.t = Emap.create 371 let conditions : (int,context) Hashtbl.t = Hashtbl.create 371 let rec cond = function | LzAnd(x,y) -> And(cond x,cond y) | LzOr(x,y) -> Or(cond x,cond y) | LzNot x -> Not(cond x) | LzAtom a -> try Atom(Emap.find atoms a) with Not_found -> Blob let push_condition kind loc a = if !active then let k = !c_info in incr c_info ; let context = { c_loc = loc ; c_kind = kind ; c_binder = Lazy(k,lazy_cond a) ; c_if = None ; c_then = None ; c_else = None ; } in c_stack := context :: !c_stack ; true else false let pop_condition () = if !active then match !c_stack with | ({ c_binder=Lazy(id,lzc) } as context) :: stk -> begin c_stack := stk ; context.c_binder <- Info { id = id ; kind = context.c_kind ; file = (fst context.c_loc).Lexing.pos_fname ; line = (fst context.c_loc).Lexing.pos_lnum ; cond = cond lzc ; } ; end | _ -> inconsistent "pop-condition" let top_context () = match !c_stack with | context :: _ when !active -> context | _ -> raise Not_found let bind (a : Cabs.expression) (e : Cil_types.exp) = try let context = top_context () in begin Emap.replace atoms a e ; Hashtbl.replace conditions e.Cil_types.eid context ; end with Not_found -> () (* -------------------------------------------------------------------------- *) (* --- Retrieving Conditions --- *) (* -------------------------------------------------------------------------- *) let lookup e = try match Hashtbl.find conditions e.Cil_types.eid with | {c_binder=Info info} -> Some info | _ -> None with Not_found -> None (* -------------------------------------------------------------------------- *) (* --- Pretty-Print --- *) (* -------------------------------------------------------------------------- *) let pp_kind fmt kd = Format.pp_print_string fmt (match kd with | IF -> "IF" | FOR -> "FOR" | WHILE -> "WHILE" | DOWHILE -> "DO WHILE") let pp_where fmt (name,e,cond) = let rec pp fmt = function | And(x,y) -> Format.fprintf fmt "(%a && %a)" pp x pp y | Or(x,y) -> Format.fprintf fmt "(%a || %a)" pp x pp y | Not x -> Format.fprintf fmt "!(%a)" pp x | Atom a -> if a.Cil_types.eid = e.Cil_types.eid then Format.pp_print_string fmt name else Format.pp_print_char fmt '_' | Blob -> Format.pp_print_char fmt '_' in pp fmt cond open Cil_types let pp_comment fmt s = if !active then match s.skind with | If(e,_,_,_) -> begin match lookup e with | Some info -> Format.fprintf fmt "/*[CID:%d] %a @[%a@] */@ " info.id pp_kind info.kind pp_where ("here",e,info.cond) | None -> () end | _ -> () frama-c-Fluorine-20130601/cil/src/frontc/cparser.mly0000644000175000017500000017717712155630365021042 0ustar mehdimehdi/****************************************************************************/ /* */ /* Copyright (C) 2001-2003 */ /* George C. Necula */ /* Scott McPeak */ /* Wes Weimer */ /* Ben Liblit */ /* All rights reserved. */ /* */ /* Redistribution and use in source and binary forms, with or without */ /* modification, are permitted provided that the following conditions */ /* are met: */ /* */ /* 1. Redistributions of source code must retain the above copyright */ /* notice, this list of conditions and the following disclaimer. */ /* */ /* 2. Redistributions in binary form must reproduce the above copyright */ /* notice, this list of conditions and the following disclaimer in the */ /* documentation and/or other materials provided with the distribution. */ /* */ /* 3. The names of the contributors may not be used to endorse or */ /* promote products derived from this software without specific prior */ /* written permission. */ /* */ /* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS */ /* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT */ /* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS */ /* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE */ /* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, */ /* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, */ /* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; */ /* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER */ /* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT */ /* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN */ /* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE */ /* POSSIBILITY OF SUCH DAMAGE. */ /* */ /* File modified by CEA (Commissariat l'nergie atomique et aux */ /* nergies alternatives) */ /* and INRIA (Institut National de Recherche en Informatique */ /* et Automatique). */ /****************************************************************************/ /* 3.22.99 Hugues Cass First version. 2.0 George Necula 12/12/00: Practically complete rewrite. */ %{ open Cabs open Cabshelper let parse_error msg = Errorloc.parse_error msg (* ** Expression building *) let smooth_expression lst = match lst with [] -> { expr_loc = cabslu; expr_node = NOTHING } | [expr] -> expr | _ -> let beg_loc = fst (List.hd lst).expr_loc in let end_loc = snd (Extlib.last lst).expr_loc in { expr_loc = (beg_loc,end_loc); expr_node = COMMA (lst) } (* To be called only inside a grammar rule. *) let make_expr e = { expr_loc = symbol_start_pos (), symbol_end_pos (); expr_node = e } let currentFunctionName = ref "" (* Go through all the parameter names and mark them as identifiers *) let rec findProto = function PROTO (d, args, _) when isJUSTBASE d -> List.iter (fun (_, (an, _, _, _)) -> !Lexerhack.add_identifier an) args | PROTO (d, _, _) -> findProto d | PARENTYPE (_, d, _) -> findProto d | PTR (_, d) -> findProto d | ARRAY (d, _, _) -> findProto d | _ -> raise Parsing.Parse_error and isJUSTBASE = function JUSTBASE -> true | PARENTYPE (_, d, _) -> isJUSTBASE d | _ -> false let announceFunctionName ((n, decl, _, _):name) = !Lexerhack.add_identifier n; (* Start a context that includes the parameter names and the whole body. * Will pop when we finish parsing the function body *) !Lexerhack.push_context (); (try findProto decl with Parsing.Parse_error -> parse_error "Cannot find the prototype in a function definition"); currentFunctionName := n let check_funspec_abrupt_clauses fname (spec,_) = List.iter (fun bhv -> List.iter (function | (Cil_types.Normal | Cil_types.Exits),_ -> () | (Cil_types.Breaks | Cil_types.Continues | Cil_types.Returns), {Logic_ptree.lexpr_loc = (loc,_)} -> Kernel.error ~source:loc "Specification of function %s can only contain ensures or \ exits post-conditions" fname; raise Parsing.Parse_error) bhv.Cil_types.b_post_cond) spec.Cil_types.spec_behavior let applyPointer (ptspecs: attribute list list) (dt: decl_type) : decl_type = (* Outer specification first *) let rec loop = function [] -> dt | attrs :: rest -> PTR(attrs, loop rest) in loop ptspecs let doDeclaration logic_spec (loc: cabsloc) (specs: spec_elem list) (nl: init_name list) = if isTypedef specs then begin (* Tell the lexer about the new type names *) List.iter (fun ((n, _, _, _), _) -> !Lexerhack.add_type n) nl; TYPEDEF ((specs, List.map (fun (n, _) -> n) nl), loc) end else if nl = [] then ONLYTYPEDEF (specs, loc) else begin (* Tell the lexer about the new variable names *) List.iter (fun ((n, _, _, _), _) -> !Lexerhack.add_identifier n) nl; !Lexerhack.push_context (); List.iter (fun ((_,t,_,_),_) -> try findProto t with Parsing.Parse_error -> ()) nl; let logic_spec = match logic_spec with None -> None | Some ls -> Cabshelper.continue_annot loc (fun () -> let (_,spec) = Logic_lexer.spec ls in let name = match nl with [ (n,_,_,_),_ ] -> n | _ -> "unknown function" in check_funspec_abrupt_clauses name spec; Some spec) (fun () -> None) "Skipping annotation" in !Lexerhack.pop_context (); DECDEF (logic_spec, (specs, nl), loc) end let doFunctionDef spec (loc: cabsloc) (lend: cabsloc) (specs: spec_elem list) (n: name) (b: block) : definition = let fname = (specs, n) in let name = match n with (n,_,_,_) -> n in Extlib.may_map ~dft:() (check_funspec_abrupt_clauses name) spec; FUNDEF (spec, fname, b, loc, lend) let doOldParDecl (names: string list) ((pardefs: name_group list), (isva: bool)) : single_name list * bool = let findOneName n = (* Search in pardefs for the definition for this parameter *) let rec loopGroups = function [] -> ([SpecType Tint], (n, JUSTBASE, [], cabslu)) | (specs, names) :: restgroups -> let rec loopNames = function [] -> loopGroups restgroups | ((n',_, _, _) as sn) :: _ when n' = n -> (specs, sn) | _ :: restnames -> loopNames restnames in loopNames names in loopGroups pardefs in let args = List.map findOneName names in (args, isva) let int64_to_char value = if (Int64.compare value (Int64.of_int 255) > 0) || (Int64.compare value Int64.zero < 0) then parse_error (Printf.sprintf "integral literal 0x%Lx too big" value) else Char.chr (Int64.to_int value) (* takes a not-nul-terminated list, and converts it to a string. *) let rec intlist_to_string (str: int64 list):string = match str with [] -> "" (* add nul-termination *) | value::rest -> let this_char = int64_to_char value in (String.make 1 this_char) ^ (intlist_to_string rest) let fst3 (result, _, _) = result let trd3 (_, _, result) = result let fourth4 (_,_,_,result) = result (* transform: __builtin_offsetof(type, member) into : (size_t) (&(type * ) 0)->member *) let transformOffsetOf (speclist, dtype) member = let mk_expr e = { expr_loc = member.expr_loc; expr_node = e } in let rec addPointer = function | JUSTBASE -> PTR([], JUSTBASE) | PARENTYPE (attrs1, dtype, attrs2) -> PARENTYPE (attrs1, addPointer dtype, attrs2) | ARRAY (dtype, attrs, expr) -> ARRAY (addPointer dtype, attrs, expr) | PTR (attrs, dtype) -> PTR (attrs, addPointer dtype) | PROTO (dtype, names, variadic) -> PROTO (addPointer dtype, names, variadic) in let nullType = (speclist, addPointer dtype) in let nullExpr = mk_expr (CONSTANT (CONST_INT "0")) in let castExpr = mk_expr (CAST (nullType, SINGLE_INIT nullExpr)) in let rec replaceBase e = let node = match e.expr_node with | VARIABLE field -> MEMBEROFPTR (castExpr, field) | MEMBEROF (base, field) -> MEMBEROF (replaceBase base, field) | INDEX (base, index) -> INDEX (replaceBase base, index) | _ -> parse_error "malformed offset expression in __builtin_offsetof" in { e with expr_node = node } in let memberExpr = replaceBase member in let addrExpr = { memberExpr with expr_node = UNARY (ADDROF, memberExpr)} in (* slight cheat: hard-coded assumption that size_t == unsigned int *) let sizeofType = [SpecType Tunsigned], JUSTBASE in { addrExpr with expr_node = CAST (sizeofType, SINGLE_INIT addrExpr)} let no_ghost_stmt s = {stmt_ghost = false ; stmt_node = s} let no_ghost = List.map no_ghost_stmt let in_ghost = let ghost_me = object inherit Cabsvisit.nopCabsVisitor method vstmt s = s.stmt_ghost <- true; Cil.DoChildren end in List.map (fun s -> ignore (Cabsvisit.visitCabsStatement ghost_me s); s) let in_block l = match l with [] -> no_ghost_stmt (NOP cabslu) | [s] -> s | _::_ -> no_ghost_stmt (BLOCK ({ blabels = []; battrs = []; bstmts = l}, get_statementloc (List.hd l), get_statementloc (Extlib.last l))) %} %token SPEC %token DECL %token CODE_ANNOT %token LOOP_ANNOT %token ATTRIBUTE_ANNOT %token CUSTOM_ANNOT %token IDENT %token CST_CHAR %token CST_WCHAR %token CST_INT %token CST_FLOAT %token NAMED_TYPE /* Each character is its own list element, and the terminating nul is not included in this list. */ %token CST_STRING %token CST_WSTRING %token EOF %token BOOL CHAR INT DOUBLE FLOAT VOID INT64 INT32 %token ENUM STRUCT TYPEDEF UNION %token SIGNED UNSIGNED LONG SHORT %token VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER %token THREAD %token SIZEOF ALIGNOF %token EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ %token AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ %token ARROW DOT %token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ %token PLUS MINUS STAR %token SLASH PERCENT %token TILDE AND %token PIPE CIRC %token EXCLAM AND_AND %token PIPE_PIPE %token INF_INF SUP_SUP %token PLUS_PLUS MINUS_MINUS %token RPAREN %token LPAREN RBRACE %token LBRACE %token LBRACKET RBRACKET %token COLON %token SEMICOLON %token COMMA ELLIPSIS QUEST %token BREAK CONTINUE GOTO RETURN %token SWITCH CASE DEFAULT %token WHILE DO FOR %token IF TRY EXCEPT FINALLY %token ELSE %token ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__ %token LABEL__ %token BUILTIN_VA_ARG ATTRIBUTE_USED %token BUILTIN_VA_LIST %token BLOCKATTRIBUTE %token BUILTIN_TYPES_COMPAT BUILTIN_OFFSETOF %token DECLSPEC %token MSASM MSATTR %token PRAGMA_LINE %token PRAGMA %token PRAGMA_EOL /*Frama-C: ghost bracketing */ %token LGHOST RGHOST /* operator precedence */ %nonassoc IF %nonassoc ELSE %left COMMA %right EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ %right QUEST COLON %left PIPE_PIPE %left AND_AND %left PIPE %left CIRC %left AND %left EQ_EQ EXCLAM_EQ %left INF SUP INF_EQ SUP_EQ %left INF_INF SUP_SUP %left PLUS MINUS %left STAR SLASH PERCENT CONST RESTRICT VOLATILE %right EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF %left LBRACKET %left DOT ARROW LPAREN LBRACE %right NAMED_TYPE /* We'll use this to handle redefinitions of * NAMED_TYPE as variables */ %left IDENT /* Non-terminals informations */ %start interpret file %type <(bool*Cabs.definition) list> file interpret globals %type global %type attributes attributes_with_asm asmattr %type constant %type string_constant %type expression %type opt_expression %type init_expression %type comma_expression %type paren_comma_expression %type arguments %type bracket_comma_expression %type string_list %type wstring_list %type initializer_single %type <(Cabs.initwhat * Cabs.init_expression) list> initializer_list %type init_designators init_designators_opt %type decl_spec_list %type type_spec %type struct_decl_list %type old_proto_decl %type parameter_decl %type enumerator %type enum_list %type declaration function_def %type function_def_start %type type_name %type block %type block_element_list %type local_labels local_label_names %type old_parameter_list_ne %type init_declarator %type init_declarator_list %type declarator %type field_decl %type <(Cabs.name * expression option) list> field_decl_list %type direct_decl %type abs_direct_decl abs_direct_decl_opt %type abstract_decl /* (* Each element is a "* ". *) */ %type pointer pointer_opt %type location %type cvspec %% interpret: file { $1 } file: globals EOF {$1} globals: /* empty */ { [] } | global globals { (false,$1) :: $2 } | LGHOST ghost_globals globals { $2 @ $3 } | SEMICOLON globals { $2 } ; location: /* empty */ { currentLoc () } %prec IDENT ; /* Rules for global ghosts: TODO keep the ghost status! */ ghost_globals: | declaration ghost_globals { (true,$1)::$2 } | function_def ghost_globals { (true,$1)::$2 } | RGHOST { [] } ; /*** Global Definition ***/ global: | DECL { GLOBANNOT $1 } | CUSTOM_ANNOT { let (x,y,z) = $1 in CUSTOM(x,y,z) } | declaration { $1 } | function_def { $1 } /*(* Some C header files are shared with the C++ compiler and have linkage * specification *)*/ | EXTERN string_constant declaration { LINKAGE (fst $2, (*handleLoc*) (snd $2), [ $3 ]) } | EXTERN string_constant LBRACE globals RBRACE { LINKAGE (fst $2, (*handleLoc*) (snd $2), List.map (fun (x,y) -> if x then parse_error "invalid ghost in extern linkage specification" else y) $4) } | ASM LPAREN string_constant RPAREN SEMICOLON { GLOBASM (fst $3, (*handleLoc*) $1) } | pragma { $1 } /* (* Old-style function prototype. This should be somewhere else, like in * "declaration". For now we keep it at global scope only because in local * scope it looks too much like a function call *) */ | IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list SEMICOLON { let loc = Parsing.rhs_start_pos 1, Parsing.rhs_end_pos 1 in (* Convert pardecl to new style *) let pardecl, isva = doOldParDecl $3 $5 in (* Make the function declarator *) doDeclaration None loc [] [(($1, PROTO(JUSTBASE, pardecl,isva), ["FC_OLDSTYLEPROTO",[]], loc), NO_INIT)] } /* (* Old style function prototype, but without any arguments *) */ | IDENT LPAREN RPAREN SEMICOLON { (* Make the function declarator *) let loc = Parsing.rhs_start_pos 1, Parsing.rhs_end_pos 1 in doDeclaration None loc [] [(($1, PROTO(JUSTBASE,[],false), [], loc), NO_INIT)] } | location error SEMICOLON { PRAGMA (make_expr (VARIABLE "parse_error"), $1) } ; id_or_typename_as_id: IDENT { $1 } | NAMED_TYPE { $1 } ; id_or_typename: id_or_typename_as_id { $1 } ; maybecomma: /* empty */ { () } | COMMA { () } ; /* *** Expressions *** */ primary_expression: /*(* 6.5.1. *)*/ | IDENT { make_expr (VARIABLE $1) } | constant { make_expr (CONSTANT (fst $1)) } | paren_comma_expression { make_expr (PAREN (smooth_expression $1)) } | LPAREN block RPAREN { make_expr (GNU_BODY (fst3 $2)) } ; postfix_expression: /*(* 6.5.2 *)*/ | primary_expression { $1 } | postfix_expression bracket_comma_expression {make_expr (INDEX ($1, smooth_expression $2))} | postfix_expression LPAREN arguments RPAREN {make_expr (CALL ($1, $3))} | BUILTIN_VA_ARG LPAREN expression COMMA type_name RPAREN { let b, d = $5 in let loc = Parsing.rhs_start_pos 5, Parsing.rhs_end_pos 5 in let loc_f = Parsing.rhs_start_pos 1, Parsing.rhs_end_pos 1 in make_expr (CALL ({ expr_loc = loc_f; expr_node = VARIABLE "__builtin_va_arg"}, [$3; { expr_loc = loc; expr_node = TYPE_SIZEOF (b, d)}])) } | BUILTIN_TYPES_COMPAT LPAREN type_name COMMA type_name RPAREN { let b1,d1 = $3 in let b2,d2 = $5 in let loc_f = Parsing.rhs_start_pos 1, Parsing.rhs_end_pos 1 in let loc1 = Parsing.rhs_start_pos 3, Parsing.rhs_end_pos 3 in let loc2 = Parsing.rhs_start_pos 5, Parsing.rhs_end_pos 5 in make_expr (CALL ({expr_loc = loc_f; expr_node = VARIABLE "__builtin_types_compatible_p"}, [ { expr_loc = loc1; expr_node = TYPE_SIZEOF(b1,d1)}; { expr_loc = loc2; expr_node = TYPE_SIZEOF(b2,d2)}])) } | BUILTIN_OFFSETOF LPAREN type_name COMMA offsetof_member_designator RPAREN { transformOffsetOf $3 $5 } | postfix_expression DOT id_or_typename { make_expr (MEMBEROF ($1, $3))} | postfix_expression ARROW id_or_typename { make_expr (MEMBEROFPTR ($1, $3)) } | postfix_expression PLUS_PLUS { make_expr (UNARY (POSINCR, $1)) } | postfix_expression MINUS_MINUS { make_expr (UNARY (POSDECR, $1)) } /* (* We handle GCC constructor expressions *) */ | LPAREN type_name RPAREN LBRACE initializer_list_opt RBRACE { make_expr (CAST($2, COMPOUND_INIT $5)) } ; offsetof_member_designator: /* GCC extension for __builtin_offsetof */ | id_or_typename { make_expr (VARIABLE $1) } | offsetof_member_designator DOT IDENT { make_expr (MEMBEROF ($1, $3)) } | offsetof_member_designator bracket_comma_expression { make_expr (INDEX ($1, smooth_expression $2)) } ; unary_expression: /*(* 6.5.3 *)*/ | postfix_expression { $1 } | PLUS_PLUS unary_expression {make_expr (UNARY (PREINCR, $2))} | MINUS_MINUS unary_expression {make_expr (UNARY (PREDECR, $2))} | SIZEOF unary_expression {make_expr (EXPR_SIZEOF $2)} | SIZEOF LPAREN type_name RPAREN {let b, d = $3 in make_expr (TYPE_SIZEOF (b, d)) } | ALIGNOF unary_expression { make_expr (EXPR_ALIGNOF $2) } | ALIGNOF LPAREN type_name RPAREN {let b, d = $3 in make_expr (TYPE_ALIGNOF (b, d)) } | PLUS cast_expression { make_expr (UNARY (PLUS, $2)) } | MINUS cast_expression { make_expr (UNARY (MINUS, $2)) } | STAR cast_expression {make_expr (UNARY (MEMOF, $2)) } | AND cast_expression {make_expr (UNARY (ADDROF, $2))} | EXCLAM cast_expression { make_expr (UNARY (NOT, $2)) } | TILDE cast_expression { make_expr (UNARY (BNOT, $2)) } /* (* GCC allows to take address of a label (see COMPGOTO statement) *) */ | AND_AND id_or_typename_as_id { make_expr (LABELADDR $2) } ; cast_expression: /*(* 6.5.4 *)*/ | unary_expression { $1 } | LPAREN type_name RPAREN cast_expression { make_expr (CAST($2, SINGLE_INIT $4)) } ; multiplicative_expression: /*(* 6.5.5 *)*/ | cast_expression { $1 } | multiplicative_expression STAR cast_expression { make_expr (BINARY(MUL, $1, $3)) } | multiplicative_expression SLASH cast_expression { make_expr (BINARY(DIV, $1, $3)) } | multiplicative_expression PERCENT cast_expression { make_expr (BINARY(MOD, $1, $3)) } ; additive_expression: /*(* 6.5.6 *)*/ | multiplicative_expression { $1 } | additive_expression PLUS multiplicative_expression { make_expr (BINARY(ADD, $1, $3)) } | additive_expression MINUS multiplicative_expression { make_expr (BINARY(SUB, $1, $3)) } ; shift_expression: /*(* 6.5.7 *)*/ | additive_expression { $1 } | shift_expression INF_INF additive_expression {make_expr (BINARY(SHL, $1, $3)) } | shift_expression SUP_SUP additive_expression { make_expr (BINARY(SHR, $1, $3)) } ; relational_expression: /*(* 6.5.8 *)*/ | shift_expression { $1 } | relational_expression INF shift_expression { make_expr (BINARY(LT, $1, $3)) } | relational_expression SUP shift_expression { make_expr (BINARY(GT, $1, $3)) } | relational_expression INF_EQ shift_expression { make_expr (BINARY(LE, $1, $3)) } | relational_expression SUP_EQ shift_expression { make_expr (BINARY(GE, $1, $3)) } ; equality_expression: /*(* 6.5.9 *)*/ | relational_expression { $1 } | equality_expression EQ_EQ relational_expression { make_expr (BINARY(EQ, $1, $3)) } | equality_expression EXCLAM_EQ relational_expression { make_expr (BINARY(NE, $1, $3)) } ; bitwise_and_expression: /*(* 6.5.10 *)*/ | equality_expression { $1 } | bitwise_and_expression AND equality_expression { make_expr (BINARY(BAND, $1, $3)) } ; bitwise_xor_expression: /*(* 6.5.11 *)*/ | bitwise_and_expression { $1 } | bitwise_xor_expression CIRC bitwise_and_expression { make_expr (BINARY(XOR, $1, $3)) } ; bitwise_or_expression: /*(* 6.5.12 *)*/ | bitwise_xor_expression { $1 } | bitwise_or_expression PIPE bitwise_xor_expression { make_expr (BINARY(BOR, $1, $3)) } ; logical_and_expression: /*(* 6.5.13 *)*/ | bitwise_or_expression { $1 } | logical_and_expression AND_AND bitwise_or_expression { make_expr (BINARY(AND, $1, $3)) } ; logical_or_expression: /*(* 6.5.14 *)*/ | logical_and_expression { $1 } | logical_or_expression PIPE_PIPE logical_and_expression { make_expr (BINARY(OR, $1, $3)) } ; conditional_expression: /*(* 6.5.15 *)*/ | logical_or_expression { $1 } | logical_or_expression QUEST opt_expression COLON conditional_expression { make_expr (QUESTION ($1, $3, $5)) } ; /*(* The C spec says that left-hand sides of assignment expressions are unary * expressions. GCC allows cast expressions in there ! *)*/ assignment_expression: /*(* 6.5.16 *)*/ | conditional_expression { $1 } | cast_expression EQ assignment_expression { make_expr (BINARY(ASSIGN, $1, $3)) } | cast_expression PLUS_EQ assignment_expression { make_expr (BINARY(ADD_ASSIGN, $1, $3)) } | cast_expression MINUS_EQ assignment_expression { make_expr (BINARY(SUB_ASSIGN, $1, $3)) } | cast_expression STAR_EQ assignment_expression { make_expr (BINARY(MUL_ASSIGN, $1, $3)) } | cast_expression SLASH_EQ assignment_expression { make_expr (BINARY(DIV_ASSIGN, $1, $3)) } | cast_expression PERCENT_EQ assignment_expression { make_expr (BINARY(MOD_ASSIGN, $1, $3)) } | cast_expression AND_EQ assignment_expression { make_expr (BINARY(BAND_ASSIGN, $1, $3)) } | cast_expression PIPE_EQ assignment_expression { make_expr (BINARY(BOR_ASSIGN, $1, $3)) } | cast_expression CIRC_EQ assignment_expression { make_expr (BINARY(XOR_ASSIGN, $1, $3)) } | cast_expression INF_INF_EQ assignment_expression { make_expr (BINARY(SHL_ASSIGN, $1, $3)) } | cast_expression SUP_SUP_EQ assignment_expression { make_expr (BINARY(SHR_ASSIGN, $1, $3))} ; expression: /*(* 6.5.17 *)*/ assignment_expression { $1 } ; constant: CST_INT {CONST_INT (fst $1), snd $1} | CST_FLOAT {CONST_FLOAT (fst $1), snd $1} | CST_CHAR {CONST_CHAR (fst $1), snd $1} | CST_WCHAR {CONST_WCHAR (fst $1), snd $1} | string_constant {CONST_STRING (fst $1), snd $1} | wstring_list {CONST_WSTRING (fst $1), snd $1} ; string_constant: /* Now that we know this constant isn't part of a wstring, convert it back to a string for easy viewing. */ string_list { let queue, location = $1 in let buffer = Buffer.create (Queue.length queue) in Queue.iter (List.iter (fun value -> let char = int64_to_char value in Buffer.add_char buffer char)) queue; Buffer.contents buffer, location } ; one_string_constant: /* Don't concat multiple strings. For asm templates. */ CST_STRING {intlist_to_string (fst $1) } ; string_list: one_string { let queue = Queue.create () in Queue.add (fst $1) queue; queue, snd $1 } | string_list one_string { Queue.add (fst $2) (fst $1); $1 } ; wstring_list: CST_WSTRING { $1 } | wstring_list one_string { (fst $1) @ (fst $2), snd $1 } | wstring_list CST_WSTRING { (fst $1) @ (fst $2), snd $1 } /* Only the first string in the list needs an L, so L"a" "b" is the same * as L"ab" or L"a" L"b". */ one_string: CST_STRING {$1} | FUNCTION__ {(Cabshelper.explodeStringToInts !currentFunctionName), $1} | PRETTY_FUNCTION__ {(Cabshelper.explodeStringToInts !currentFunctionName), $1} ; init_expression: expression { SINGLE_INIT $1 } | LBRACE initializer_list_opt RBRACE { COMPOUND_INIT $2} initializer_list: /* ISO 6.7.8. Allow a trailing COMMA */ initializer_single { [$1] } | initializer_single COMMA initializer_list_opt { $1 :: $3 } ; initializer_list_opt: /* empty */ { [] } | initializer_list { $1 } ; initializer_single: init_designators eq_opt init_expression { ($1, $3) } | gcc_init_designators init_expression { ($1, $2) } | init_expression { (NEXT_INIT, $1) } ; eq_opt: EQ { () } /*(* GCC allows missing = *)*/ | /*(* empty *)*/ { () } ; init_designators: DOT id_or_typename init_designators_opt { INFIELD_INIT($2, $3) } | LBRACKET expression RBRACKET init_designators_opt { ATINDEX_INIT($2, $4) } | LBRACKET expression ELLIPSIS expression RBRACKET { ATINDEXRANGE_INIT($2, $4) } ; init_designators_opt: /* empty */ { NEXT_INIT } | init_designators { $1 } ; gcc_init_designators: /*(* GCC supports these strange things *)*/ id_or_typename COLON { INFIELD_INIT($1, NEXT_INIT) } ; arguments: /* empty */ { [] } | comma_expression { $1 } ; opt_expression: /* empty */ {make_expr NOTHING} | comma_expression {smooth_expression $1 } ; comma_expression: expression { [$1] } | expression COMMA comma_expression { $1 :: $3 } | error COMMA comma_expression { $3 } ; comma_expression_opt: /* empty */ { make_expr NOTHING } | comma_expression { smooth_expression $1 } ; paren_comma_expression: LPAREN comma_expression RPAREN { $2 } | LPAREN error RPAREN { [] } ; bracket_comma_expression: LBRACKET comma_expression RBRACKET { $2 } | LBRACKET error RBRACKET { [] } ; /*** statements ***/ block: /* ISO 6.8.2 */ block_begin local_labels block_attrs block_element_list RBRACE {!Lexerhack.pop_context(); { blabels = $2; battrs = $3; bstmts = $4 }, $1, $5 } | error location RBRACE { { blabels = []; battrs = []; bstmts = [] }, $2, $3 } ; block_begin: LBRACE { !Lexerhack.push_context (); $1 } ; block_attrs: /* empty */ { [] } | BLOCKATTRIBUTE paren_attr_list_ne { [("__blockattribute__", $2)] } ; /* statements and declarations in a block, in any order (for C99 support) */ block_element_list: | annot_list_opt { $1 } | annot_list_opt declaration block_element_list { $1 @ no_ghost_stmt (DEFINITION($2)) :: $3 } | annot_list_opt statement block_element_list { $1 @ $2 @ $3 } | annot_list_opt pragma block_element_list { $1 @ $3 } /*(* GCC accepts a label at the end of a block *)*/ | annot_list_opt id_or_typename_as_id COLON { let loc = Parsing.rhs_start_pos 2, Parsing.rhs_end_pos 3 in $1 @ no_ghost [LABEL ($2, no_ghost_stmt (NOP loc), loc)] } ; annot_list_opt: /* empty */ { [] } | annot_list { $1 } ; annot_list: CODE_ANNOT annot_list_opt { no_ghost [Cabs.CODE_ANNOT $1] @ $2} | LGHOST block_element_list RGHOST annot_list_opt { (in_ghost $2) @ $4 } ; local_labels: /* empty */ { [] } | LABEL__ local_label_names SEMICOLON local_labels { $2 @ $4 } ; local_label_names: id_or_typename_as_id { [ $1 ] } | id_or_typename_as_id COMMA local_label_names { $1 :: $3 } ; annotated_statement: | statement { $1 } | annot_list statement { $1 @ $2 } ; statement: SEMICOLON { no_ghost [NOP $1] } | SPEC annotated_statement { let bs = $2 in Cabshelper.continue_annot (currentLoc()) (fun () -> let (_,spec) = Logic_lexer.spec $1 in let spec = no_ghost [Cabs.CODE_SPEC spec] in spec @ $2) (fun () -> bs) "Skipping annotation" } | comma_expression SEMICOLON { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos () in no_ghost [COMPUTATION (smooth_expression $1,loc)]} | block { let (x,y,z) = $1 in no_ghost [BLOCK (x, y, z)]} | IF paren_comma_expression annotated_statement { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos () in no_ghost [IF (smooth_expression $2, in_block $3, no_ghost_stmt (NOP loc), loc)]} | IF paren_comma_expression annotated_statement ELSE annotated_statement { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos () in no_ghost [IF (smooth_expression $2, in_block $3, in_block $5, loc)]} | SWITCH paren_comma_expression annotated_statement { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos () in no_ghost [SWITCH (smooth_expression $2, in_block $3, loc)]} | opt_loop_annotations WHILE paren_comma_expression annotated_statement { let loc = Parsing.rhs_start_pos 2, Parsing.symbol_end_pos () in no_ghost [WHILE ($1, smooth_expression $3, in_block $4, loc)] } | opt_loop_annotations DO annotated_statement WHILE paren_comma_expression SEMICOLON { let loc = Parsing.rhs_start_pos 2, Parsing.symbol_end_pos () in no_ghost [DOWHILE ($1, smooth_expression $5, in_block $3, loc)]} | opt_loop_annotations FOR LPAREN for_clause opt_expression SEMICOLON opt_expression RPAREN annotated_statement { let loc = Parsing.rhs_start_pos 2, Parsing.symbol_end_pos () in no_ghost [FOR ($1, $4, $5, $7, in_block $9, loc)]} | id_or_typename_as_id COLON attribute_nocv_list annotated_statement {(* The only attribute that should appear here is "unused". For now, we drop this on the floor, since unused labels are usually removed anyways by Rmtmps. *) let loc = Parsing.rhs_start_pos 1, Parsing.rhs_end_pos 2 in no_ghost [LABEL ($1, in_block $4, loc)]} | CASE expression COLON annotated_statement { let loc = Parsing.symbol_start_pos (), Parsing.rhs_end_pos 3 in no_ghost [CASE ($2, in_block $4, loc)]} | CASE expression ELLIPSIS expression COLON annotated_statement { let loc = Parsing.symbol_start_pos (), Parsing.rhs_end_pos 5 in no_ghost [CASERANGE ($2, $4, in_block $6, loc)]} | DEFAULT COLON { let loc = Parsing.symbol_start_pos(), Parsing.symbol_end_pos () in no_ghost [DEFAULT (no_ghost_stmt (NOP loc), loc)]} | RETURN SEMICOLON { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos () in no_ghost [RETURN ({ expr_loc = loc; expr_node = NOTHING}, loc)] } | RETURN comma_expression SEMICOLON { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos () in no_ghost [RETURN (smooth_expression $2, loc)] } | BREAK SEMICOLON { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos () in no_ghost [BREAK loc] } | CONTINUE SEMICOLON { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos () in no_ghost [CONTINUE loc] } | GOTO id_or_typename_as_id SEMICOLON { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos () in no_ghost [GOTO ($2, loc)] } | GOTO STAR comma_expression SEMICOLON { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos () in no_ghost [COMPGOTO (smooth_expression $3, loc) ] } | ASM asmattr LPAREN asmtemplate asmoutputs RPAREN SEMICOLON { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos () in no_ghost [ASM ($2, $4, $5, loc)] } | MSASM { no_ghost [ASM ([], [fst $1], None, snd $1)]} | TRY block EXCEPT paren_comma_expression block { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos () in let loc_e = Parsing.rhs_start_pos 4, Parsing.rhs_end_pos 4 in let b, _, _ = $2 in let h, _, _ = $5 in if not !Cprint.msvcMode then parse_error "try/except in GCC code"; no_ghost [TRY_EXCEPT (b, {expr_loc = loc_e; expr_node = COMMA $4}, h, loc)] } | TRY block FINALLY block { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos () in let b, _, _ = $2 in let h, _, _ = $4 in if not !Cprint.msvcMode then parse_error "try/finally in GCC code"; no_ghost [TRY_FINALLY (b, h, loc)] } | error location SEMICOLON { no_ghost [NOP $2]} ; opt_loop_annotations: /* epsilon */ { [] } | loop_annotations { $1 } ; loop_annotations: loop_annotation { $1 } /* Not in ACSL Grammar | loop_annotation loop_annotations { { Cil_types.invariant = $1.Cil_types.invariant @ $2.Cil_types.invariant; Cil_types.loop_assigns = $1.Cil_types.loop_assigns @ $2.Cil_types.loop_assigns ; Cil_types.variant = $1.Cil_types.variant @ $2.Cil_types.variant; Cil_types.pragma = $1.Cil_types.pragma @ $2.Cil_types.pragma } } */ ; loop_annotation: LOOP_ANNOT { fst $1 } ; for_clause: opt_expression SEMICOLON { FC_EXP $1 } | declaration { FC_DECL $1 } ; declaration: /* ISO 6.7.*/ decl_spec_list init_declarator_list SEMICOLON { doDeclaration None ((snd $1)) (fst $1) $2 } | decl_spec_list SEMICOLON { doDeclaration None ((snd $1)) (fst $1) [] } | SPEC decl_spec_list init_declarator_list SEMICOLON { doDeclaration (Some $1) ((snd $2)) (fst $2) $3 } | SPEC decl_spec_list SEMICOLON { doDeclaration (Some $1) ((snd $2)) (fst $2) [] } ; init_declarator_list: /* ISO 6.7 */ init_declarator { [$1] } | init_declarator COMMA init_declarator_list { $1 :: $3 } ; init_declarator: /* ISO 6.7 */ declarator { ($1, NO_INIT) } | declarator EQ init_expression { ($1, $3) } ; decl_spec_list: /* ISO 6.7 */ /* ISO 6.7.1 */ | TYPEDEF decl_spec_list_opt { SpecTypedef :: $2, $1 } | EXTERN decl_spec_list_opt { SpecStorage EXTERN :: $2, $1 } | STATIC decl_spec_list_opt { SpecStorage STATIC :: $2, $1 } | AUTO decl_spec_list_opt { SpecStorage AUTO :: $2, $1 } | REGISTER decl_spec_list_opt { SpecStorage REGISTER :: $2, $1} /* ISO 6.7.2 */ | type_spec decl_spec_list_opt_no_named { SpecType (fst $1) :: $2, snd $1 } /* ISO 6.7.4 */ | INLINE decl_spec_list_opt { SpecInline :: $2, $1 } | cvspec decl_spec_list_opt { (fst $1) :: $2, snd $1 } | attribute_nocv decl_spec_list_opt { SpecAttr (fst $1) :: $2, snd $1 } ; /* (* In most cases if we see a NAMED_TYPE we must shift it. Thus we declare * NAMED_TYPE to have right associativity *) */ decl_spec_list_opt: /* empty */ { [] } %prec NAMED_TYPE | decl_spec_list { fst $1 } ; /* (* We add this separate rule to handle the special case when an appearance * of NAMED_TYPE should not be considered as part of the specifiers but as * part of the declarator. IDENT has higher precedence than NAMED_TYPE *) */ decl_spec_list_opt_no_named: /* empty */ { [] } %prec IDENT | decl_spec_list { fst $1 } ; type_spec: /* ISO 6.7.2 */ VOID { Tvoid, $1} | CHAR { Tchar, $1 } | BOOL { Tbool, $1 } | SHORT { Tshort, $1 } | INT { Tint, $1 } | LONG { Tlong, $1 } | INT64 { Tint64, $1 } | FLOAT { Tfloat, $1 } | DOUBLE { Tdouble, $1 } | SIGNED { Tsigned, $1 } | UNSIGNED { Tunsigned, $1 } | STRUCT id_or_typename { Tstruct ($2, None, []), $1 } | STRUCT just_attributes id_or_typename { Tstruct ($3, None, $2), $1 } | STRUCT id_or_typename LBRACE struct_decl_list RBRACE { Tstruct ($2, Some $4, []), $1 } | STRUCT LBRACE struct_decl_list RBRACE { Tstruct ("", Some $3, []), $1 } | STRUCT just_attributes id_or_typename LBRACE struct_decl_list RBRACE { Tstruct ($3, Some $5, $2), $1 } | STRUCT just_attributes LBRACE struct_decl_list RBRACE { Tstruct ("", Some $4, $2), $1 } | UNION id_or_typename { Tunion ($2, None, []), $1 } | UNION id_or_typename LBRACE struct_decl_list RBRACE { Tunion ($2, Some $4, []), $1 } | UNION LBRACE struct_decl_list RBRACE { Tunion ("", Some $3, []), $1 } | UNION just_attributes id_or_typename LBRACE struct_decl_list RBRACE { Tunion ($3, Some $5, $2), $1 } | UNION just_attributes LBRACE struct_decl_list RBRACE { Tunion ("", Some $4, $2), $1 } | ENUM id_or_typename { Tenum ($2, None, []), $1 } | ENUM id_or_typename LBRACE enum_list maybecomma RBRACE { Tenum ($2, Some $4, []), $1 } | ENUM LBRACE enum_list maybecomma RBRACE { Tenum ("", Some $3, []), $1 } | ENUM just_attributes id_or_typename LBRACE enum_list maybecomma RBRACE { Tenum ($3, Some $5, $2), $1 } | ENUM just_attributes LBRACE enum_list maybecomma RBRACE { Tenum ("", Some $4, $2), $1 } | NAMED_TYPE { (Tnamed $1, (Parsing.symbol_start_pos (), Parsing.symbol_end_pos())) } | TYPEOF LPAREN expression RPAREN { TtypeofE $3, $1 } | TYPEOF LPAREN type_name RPAREN { let s, d = $3 in TtypeofT (s, d), $1 } ; struct_decl_list: /* (* ISO 6.7.2. Except that we allow empty structs. We * also allow missing field names. *) */ /* empty */ { [] } | decl_spec_list SEMICOLON struct_decl_list { FIELD (fst $1, [(missingFieldDecl, None)]) :: $3 } /*(* GCC allows extra semicolons *)*/ | SEMICOLON struct_decl_list { $2 } | decl_spec_list field_decl_list SEMICOLON struct_decl_list { FIELD (fst $1, $2) :: $4 } /*(* MSVC allows pragmas in strange places *)*/ | pragma struct_decl_list { $2 } | error SEMICOLON struct_decl_list { $3 } ; field_decl_list: /* (* ISO 6.7.2 *) */ field_decl { [$1] } | field_decl COMMA field_decl_list { $1 :: $3 } ; field_decl: /* (* ISO 6.7.2. Except that we allow unnamed fields. *) */ | declarator { ($1, None) } | declarator COLON expression attributes { let (n,decl,al,loc) = $1 in let al' = al @ $4 in ((n,decl,al',loc), Some $3) } | COLON expression { (missingFieldDecl, Some $2) } ; enum_list: /* (* ISO 6.7.2.2 *) */ enumerator {[$1]} | enum_list COMMA enumerator {$1 @ [$3]} | enum_list COMMA error { $1 } ; enumerator: IDENT { let loc = Parsing.symbol_start_pos (), Parsing.symbol_end_pos() in ($1, { expr_node = NOTHING; expr_loc = loc }, loc) } | IDENT EQ expression { ($1, $3, (Parsing.symbol_start_pos (),Parsing.symbol_end_pos())) } ; declarator: /* (* ISO 6.7.5. Plus Microsoft declarators.*) */ pointer_opt direct_decl attributes_with_asm { let (n, decl) = $2 in (n, applyPointer (fst $1) decl, $3, (snd $1)) } ; attributes_or_static: /* 6.7.5.2/3 */ | attributes comma_expression_opt { $1,$2 } | attribute attributes STATIC comma_expression { fst $1::$2 @ ["static",[]], smooth_expression $4 } | STATIC attributes comma_expression { ("static",[]) :: $2, smooth_expression $3 } ; direct_decl: /* (* ISO 6.7.5 *) */ /* (* We want to be able to redefine named * types as variable names *) */ | id_or_typename { ($1, JUSTBASE) } | LPAREN attributes declarator RPAREN { let (n,decl,al,_) = $3 in (n, PARENTYPE($2,decl,al)) } | direct_decl LBRACKET attributes_or_static RBRACKET { let (n, decl) = $1 in let (attrs, size) = $3 in (n, ARRAY(decl, attrs, size)) } | direct_decl parameter_list_startscope rest_par_list RPAREN { let (n, decl) = $1 in let (params, isva) = $3 in !Lexerhack.pop_context (); (n, PROTO(decl, params, isva)) } ; parameter_list_startscope: LPAREN { !Lexerhack.push_context () } ; rest_par_list: | /* empty */ { ([], false) } | parameter_decl rest_par_list1 { let (params, isva) = $2 in ($1 :: params, isva) } ; rest_par_list1: /* empty */ { ([], false) } | COMMA ELLIPSIS { ([], true) } | COMMA parameter_decl rest_par_list1 { let (params, isva) = $3 in ($2 :: params, isva) } ; parameter_decl: /* (* ISO 6.7.5 *) */ decl_spec_list declarator { (fst $1, $2) } | decl_spec_list abstract_decl { let d, a = $2 in (fst $1, ("", d, a, (*CEA*) cabslu)) } | decl_spec_list { (fst $1, ("", JUSTBASE, [], (*CEA*) cabslu)) } | LPAREN parameter_decl RPAREN { $2 } ; /* (* Old style prototypes. Like a declarator *) */ old_proto_decl: pointer_opt direct_old_proto_decl { let (n, decl, a) = $2 in (n, applyPointer (fst $1) decl, a, snd $1) } ; direct_old_proto_decl: direct_decl LPAREN old_parameter_list_ne RPAREN old_pardef_list { let par_decl, isva = doOldParDecl $3 $5 in let n, decl = $1 in (n, PROTO(decl, par_decl, isva), ["FC_OLDSTYLEPROTO",[]]) } | direct_decl LPAREN RPAREN { let n, decl = $1 in (n, PROTO(decl, [], false), []) } /* (* appears sometimesm but generates a shift-reduce conflict. *) | LPAREN STAR direct_decl LPAREN old_parameter_list_ne RPAREN RPAREN LPAREN RPAREN old_pardef_list { let par_decl, isva = doOldParDecl $5 $10 in let n, decl = $3 in (n, PROTO(decl, par_decl, isva), []) } */ ; old_parameter_list_ne: | IDENT { [$1] } | IDENT COMMA old_parameter_list_ne { $1::$3 } ; old_pardef_list: /* empty */ { ([], false) } | decl_spec_list old_pardef SEMICOLON ELLIPSIS { ([(fst $1, $2)], true) } | decl_spec_list old_pardef SEMICOLON old_pardef_list { let rest, isva = $4 in ((fst $1, $2) :: rest, isva) } ; old_pardef: declarator { [$1] } | declarator COMMA old_pardef { $1 :: $3 } | error { [] } ; pointer: /* (* ISO 6.7.5 *) */ STAR attributes pointer_opt { $2 :: fst $3, $1 } ; pointer_opt: /**/ { let l = currentLoc () in ([], l) } | pointer { $1 } ; type_name: /* (* ISO 6.7.6 *) */ decl_spec_list abstract_decl { let d, a = $2 in if a <> [] then parse_error "attributes in type name" ; (fst $1, d) } | decl_spec_list { (fst $1, JUSTBASE) } ; abstract_decl: /* (* ISO 6.7.6. *) */ pointer_opt abs_direct_decl attributes { applyPointer (fst $1) $2, $3 } | pointer { applyPointer (fst $1) JUSTBASE, [] } ; abs_direct_decl: /* (* ISO 6.7.6. We do not support optional declarator for * functions. Plus Microsoft attributes. See the * discussion for declarator. *) */ | LPAREN attributes abstract_decl RPAREN { let d, a = $3 in PARENTYPE ($2, d, a) } | LPAREN error RPAREN { JUSTBASE } | abs_direct_decl_opt LBRACKET comma_expression_opt RBRACKET { ARRAY($1, [], $3) } /*(* The next should be abs_direct_decl_opt but we get conflicts *)*/ | abs_direct_decl parameter_list_startscope rest_par_list RPAREN { let (params, isva) = $3 in !Lexerhack.pop_context (); PROTO ($1, params, isva) } ; abs_direct_decl_opt: abs_direct_decl { $1 } | /* empty */ { JUSTBASE } ; function_def: /* (* ISO 6.9.1 *) */ SPEC function_def_start block { let (loc, specs, decl) = $2 in let spec = Cabshelper.continue_annot loc (fun () -> Some (snd (Logic_lexer.spec $1 ))) (fun () -> None) "Ignoring specification of function %s" !currentFunctionName in currentFunctionName := "<__FUNCTION__ used outside any functions>"; !Lexerhack.pop_context (); (* The context pushed by * announceFunctionName *) doFunctionDef spec loc (trd3 $3) specs decl (fst3 $3) } | function_def_start block { let (loc, specs, decl) = $1 in currentFunctionName := "<__FUNCTION__ used outside any functions>"; !Lexerhack.pop_context (); (* The context pushed by * announceFunctionName *) (*OCAMLYACC BUG??? Format.printf "%a@." d_cabsloc (trd3 $2);*) doFunctionDef None ((*handleLoc*) loc) (trd3 $2) specs decl (fst3 $2) } function_def_start: /* (* ISO 6.9.1 *) */ decl_spec_list declarator { announceFunctionName $2; (fourth4 $2, fst $1, $2) } /* (* Old-style function prototype *) */ | decl_spec_list old_proto_decl { announceFunctionName $2; (snd $1, fst $1, $2) } /* (* New-style function that does not have a return type *) */ | IDENT parameter_list_startscope rest_par_list RPAREN { let (params, isva) = $3 in let loc = Parsing.rhs_start_pos 1, Parsing.rhs_end_pos 1 in let fdec = ($1, PROTO(JUSTBASE, params, isva), [], loc) in announceFunctionName fdec; (* Default is int type *) let defSpec = [SpecType Tint] in (loc, defSpec, fdec) } /* (* No return type and old-style parameter list *) */ | IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list { (* Convert pardecl to new style *) let pardecl, isva = doOldParDecl $3 $5 in let loc = Parsing.rhs_start_pos 1, Parsing.rhs_end_pos 1 in (* Make the function declarator *) let fdec = ($1, PROTO(JUSTBASE, pardecl,isva), [], loc) in announceFunctionName fdec; (* Default is int type *) let defSpec = [SpecType Tint] in (loc, defSpec, fdec) } /* (* No return type and no parameters *) */ | IDENT LPAREN RPAREN { (* Make the function declarator *) let loc = Parsing.rhs_start_pos 1, Parsing.rhs_end_pos 1 in let fdec = ($1, PROTO(JUSTBASE, [], false), [], loc) in announceFunctionName fdec; (* Default is int type *) let defSpec = [SpecType Tint] in (loc, defSpec, fdec) } ; /* const/volatile as type specifier elements */ cvspec: | CONST { SpecCV(CV_CONST), $1 } | VOLATILE { SpecCV(CV_VOLATILE), $1 } | RESTRICT { SpecCV(CV_RESTRICT), $1 } | ATTRIBUTE_ANNOT { let annot, loc = $1 in SpecCV(CV_ATTRIBUTE_ANNOT annot), loc } ; /*** GCC attributes ***/ attributes: /* empty */ { []} | attribute attributes { fst $1 :: $2 } ; /* (* In some contexts we can have an inline assembly to specify the name to * be used for a global. We treat this as a name attribute *) */ attributes_with_asm: /* empty */ { [] } | attribute attributes_with_asm { fst $1 :: $2 } | ASM LPAREN string_constant RPAREN attributes { let loc = Parsing.rhs_start_pos 3, Parsing.rhs_end_pos 3 in ("__asm__", [{ expr_node = CONSTANT(CONST_STRING (fst $3)); expr_loc = loc}]) :: $5 } ; /* things like __attribute__, but no const/volatile */ attribute_nocv: ATTRIBUTE LPAREN paren_attr_list RPAREN { ("__attribute__", $3), $1 } /*(* | ATTRIBUTE_USED { ("__attribute__", [ VARIABLE "used" ]), $1 } *)*/ | DECLSPEC paren_attr_list_ne { ("__declspec", $2), $1 } | MSATTR { (fst $1, []), snd $1 } /* ISO 6.7.3 */ | THREAD { ("__thread",[]), $1 } ; attribute_nocv_list: /* empty */ { []} | attribute_nocv attribute_nocv_list { fst $1 :: $2 } ; /* __attribute__ plus const/volatile */ attribute: attribute_nocv { $1 } | CONST { ("const", []), $1 } | RESTRICT { ("restrict",[]), $1 } | VOLATILE { ("volatile",[]), $1 } | ATTRIBUTE_ANNOT { let annot, loc = $1 in ("$annot:" ^ annot, []), loc } ; /* (* sm: I need something that just includes __attribute__ and nothing more, * to support them appearing between the 'struct' keyword and the type name. * Actually, a declspec can appear there as well (on MSVC) *) */ just_attribute: ATTRIBUTE LPAREN paren_attr_list RPAREN { ("__attribute__", $3) } | DECLSPEC paren_attr_list_ne { ("__declspec", $2) } ; /* this can't be empty, b/c I folded that possibility into the calling * productions to avoid some S/R conflicts */ just_attributes: just_attribute { [$1] } | just_attribute just_attributes { $1 :: $2 } ; /** (* PRAGMAS and ATTRIBUTES *) ***/ pragma: | PRAGMA PRAGMA_EOL { PRAGMA (make_expr (VARIABLE ("")), $1) } | PRAGMA attr PRAGMA_EOL { PRAGMA ($2, $1) } | PRAGMA attr SEMICOLON PRAGMA_EOL { PRAGMA ($2, $1) } | PRAGMA_LINE { PRAGMA (make_expr (VARIABLE (fst $1)), snd $1) } ; /* (* We want to allow certain strange things that occur in pragmas, so we * cannot use directly the language of expressions *) */ var_attr: | IDENT { make_expr (VARIABLE $1) } | NAMED_TYPE { make_expr (VARIABLE $1) } | DEFAULT COLON CST_INT { make_expr (VARIABLE ("default:" ^ fst $3)) } /* Const when it appears in attribute lists, is translated to aconst */ | CONST { make_expr (VARIABLE "aconst") } /*(** GCC allows this as an attribute for functions, synonym for noreturn **)*/ | VOLATILE { make_expr (VARIABLE ("__noreturn__")) } | IDENT COLON CST_INT { make_expr (VARIABLE ($1 ^ ":" ^ fst $3)) } | NAMED_TYPE COLON CST_INT { make_expr (VARIABLE ($1 ^ ":" ^ fst $3)) } /*(* The following rule conflicts with the ? : attributes. We give it a very * low priority *)*/ | CST_INT COLON CST_INT { make_expr (VARIABLE (fst $1 ^ ":" ^ fst $3)) } ; basic_attr: | CST_INT { make_expr (CONSTANT(CONST_INT (fst $1))) } | var_attr { $1 } ; basic_attr_list_ne: basic_attr { [$1] } | basic_attr basic_attr_list_ne { $1::$2 } ; parameter_attr_list_ne: basic_attr_list_ne { $1 } | basic_attr_list_ne string_constant { $1 @ [make_expr (CONSTANT(CONST_STRING (fst $2)))] } | basic_attr_list_ne string_constant parameter_attr_list_ne { $1 @ ([make_expr (CONSTANT(CONST_STRING (fst $2)))] @ $3) } ; param_attr_list_ne: parameter_attr_list_ne { $1 } | string_constant { [make_expr (CONSTANT(CONST_STRING (fst $1)))] } ; primary_attr: basic_attr { $1 } | LPAREN attr RPAREN { $2 } | string_constant { make_expr (CONSTANT(CONST_STRING (fst $1))) } ; postfix_attr: primary_attr { $1 } | id_or_typename_as_id paren_attr_list_ne { let loc = Parsing.rhs_start_pos 1, Parsing.rhs_end_pos 1 in make_expr (CALL({ expr_loc = loc; expr_node = VARIABLE $1}, $2)) } /* (* use a VARIABLE "" so that the parentheses are printed *) */ | id_or_typename_as_id LPAREN RPAREN { let loc1 = Parsing.rhs_start_pos 1, Parsing.rhs_end_pos 1 in let loc2 = Parsing.rhs_start_pos 2, Parsing.rhs_end_pos 3 in let f = { expr_node = VARIABLE $1; expr_loc = loc1 } in let arg = { expr_node = VARIABLE ""; expr_loc = loc2 } in make_expr (CALL(f, [arg])) } /* (* use a VARIABLE "" so that the parameters are printed without * parentheses nor comma *) */ | basic_attr param_attr_list_ne { let loc = Parsing.rhs_start_pos 1, Parsing.rhs_end_pos 1 in make_expr (CALL({ expr_node = VARIABLE ""; expr_loc = loc}, $1::$2)) } | postfix_attr ARROW id_or_typename { make_expr (MEMBEROFPTR ($1, $3))} | postfix_attr DOT id_or_typename { make_expr (MEMBEROF ($1, $3)) } | postfix_attr LBRACKET attr RBRACKET { make_expr (INDEX ($1, $3)) } ; /*(* Since in attributes we use both IDENT and NAMED_TYPE as indentifiers, * that leads to conflicts for SIZEOF and ALIGNOF. In those cases we require * that their arguments be expressions, not attributes *)*/ unary_attr: postfix_attr { $1 } | SIZEOF unary_expression { make_expr (EXPR_SIZEOF $2) } | SIZEOF LPAREN type_name RPAREN {let b, d = $3 in make_expr (TYPE_SIZEOF (b, d)) } | ALIGNOF unary_expression {make_expr (EXPR_ALIGNOF $2) } | ALIGNOF LPAREN type_name RPAREN {let b, d = $3 in make_expr (TYPE_ALIGNOF (b, d)) } | PLUS cast_attr {make_expr (UNARY (PLUS, $2))} | MINUS cast_attr {make_expr (UNARY (MINUS, $2)) } | STAR cast_attr {make_expr (UNARY (MEMOF, $2)) } | AND cast_attr { make_expr (UNARY (ADDROF, $2)) } | EXCLAM cast_attr { make_expr (UNARY (NOT, $2)) } | TILDE cast_attr { make_expr (UNARY (BNOT, $2)) } ; cast_attr: unary_attr { $1 } ; multiplicative_attr: cast_attr { $1 } | multiplicative_attr STAR cast_attr {make_expr (BINARY(MUL ,$1 , $3))} | multiplicative_attr SLASH cast_attr {make_expr (BINARY(DIV ,$1 , $3))} | multiplicative_attr PERCENT cast_attr {make_expr (BINARY(MOD ,$1 , $3))} ; additive_attr: multiplicative_attr { $1 } | additive_attr PLUS multiplicative_attr {make_expr (BINARY(ADD ,$1 , $3))} | additive_attr MINUS multiplicative_attr {make_expr (BINARY(SUB ,$1 , $3))} ; shift_attr: additive_attr { $1 } | shift_attr INF_INF additive_attr {make_expr (BINARY(SHL ,$1 , $3))} | shift_attr SUP_SUP additive_attr {make_expr (BINARY(SHR ,$1 , $3))} ; relational_attr: shift_attr { $1 } | relational_attr INF shift_attr {make_expr (BINARY(LT ,$1 , $3))} | relational_attr SUP shift_attr {make_expr (BINARY(GT ,$1 , $3))} | relational_attr INF_EQ shift_attr {make_expr (BINARY(LE ,$1 , $3))} | relational_attr SUP_EQ shift_attr {make_expr (BINARY(GE ,$1 , $3))} ; equality_attr: relational_attr { $1 } | equality_attr EQ_EQ relational_attr {make_expr (BINARY(EQ ,$1 , $3))} | equality_attr EXCLAM_EQ relational_attr {make_expr (BINARY(NE ,$1 , $3))} ; bitwise_and_attr: equality_attr { $1 } | bitwise_and_attr AND equality_attr {make_expr (BINARY(BAND ,$1 , $3))} ; bitwise_xor_attr: bitwise_and_attr { $1 } | bitwise_xor_attr CIRC bitwise_and_attr {make_expr (BINARY(XOR ,$1 , $3))} ; bitwise_or_attr: bitwise_xor_attr { $1 } | bitwise_or_attr PIPE bitwise_xor_attr {make_expr (BINARY(BOR ,$1 , $3))} ; logical_and_attr: bitwise_or_attr { $1 } | logical_and_attr AND_AND bitwise_or_attr {make_expr (BINARY(AND ,$1 , $3))} ; logical_or_attr: logical_and_attr { $1 } | logical_or_attr PIPE_PIPE logical_and_attr {make_expr (BINARY(OR ,$1 , $3))} ; conditional_attr: logical_or_attr { $1 } /* This is in conflict for now */ | logical_or_attr QUEST conditional_attr COLON conditional_attr { make_expr (QUESTION($1, $3, $5)) } attr: conditional_attr { $1 } ; attr_list_ne: | attr { [$1] } | attr COMMA attr_list_ne { $1 :: $3 } | error COMMA attr_list_ne { $3 } ; attr_list: /* empty */ { [] } | attr_list_ne { $1 } ; paren_attr_list_ne: LPAREN attr_list_ne RPAREN { $2 } | LPAREN error RPAREN { [] } ; paren_attr_list: LPAREN attr_list RPAREN { $2 } | LPAREN error RPAREN { [] } ; /*** GCC ASM instructions ***/ asmattr: /* empty */ { [] } | VOLATILE asmattr { ("volatile", []) :: $2 } | CONST asmattr { ("const", []) :: $2 } ; asmtemplate: one_string_constant { [$1] } | one_string_constant asmtemplate { $1 :: $2 } ; asmoutputs: /* empty */ { None } | COLON asmoperands asminputs { let (ins, clobs) = $3 in Some {aoutputs = $2; ainputs = ins; aclobbers = clobs} } ; asmoperands: /* empty */ { [] } | asmoperandsne { List.rev $1 } ; asmoperandsne: asmoperand { [$1] } | asmoperandsne COMMA asmoperand { $3 :: $1 } ; asmoperand: asmopname string_constant LPAREN expression RPAREN { ($1, fst $2, $4) } | asmopname string_constant LPAREN error RPAREN { let loc = Parsing.rhs_start_pos 4, Parsing.rhs_end_pos 4 in ($1, fst $2, { expr_loc = loc; expr_node = NOTHING} ) } ; asminputs: /* empty */ { ([], []) } | COLON asmoperands asmclobber { ($2, $3) } ; asmopname: /* empty */ { None } | LBRACKET IDENT RBRACKET { Some $2 } ; asmclobber: /* empty */ { [] } | COLON asmcloberlst_ne { $2 } ; asmcloberlst_ne: one_string_constant { [$1] } | one_string_constant COMMA asmcloberlst_ne { $1 :: $3 } ; %% frama-c-Fluorine-20130601/cil/src/frontc/cprint.ml0000644000175000017500000005460512155630365020477 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* cprint -- pretty printer of C program from abstract syntax ** ** Project: FrontC ** File: cprint.ml ** Version: 2.1e ** Date: 9.1.99 ** Author: Hugues Cass ** ** 1.0 2.22.99 Hugues Cass First version. ** 2.0 3.18.99 Hugues Cass Compatible with Frontc 2.1, use of CAML ** pretty printer. ** 2.1 3.22.99 Hugues Cass More efficient custom pretty printer used. ** 2.1a 4.12.99 Hugues Cass Correctly handle: ** char *m, *m, *p; m + (n - p) ** 2.1b 4.15.99 Hugues Cass x + (y + z) stays x + (y + z) for ** keeping computation order. ** 2.1c 7.23.99 Hugues Cass Improvement of case and default display. ** 2.1d 8.25.99 Hugues Cass Rebuild escape sequences in string and ** characters. ** 2.1e 9.1.99 Hugues Cass Fix, recognize and correctly display '\0'. *) (* George Necula: I changed this pretty dramatically since CABS changed *) open Format open Pretty_utils open Logic_print open Cabs open Escape let version = "Cprint 2.1e 9.1.99 Hugues Cass" let msvcMode = ref false let printLn = ref true let printLnComment = ref false let printCounters = ref false let printComments = ref false (* ** Expression printing ** Priorities ** 16 variables ** 15 . -> [] call() ** 14 ++, -- (post) ** 13 ++ -- (pre) ~ ! - + & *(cast) ** 12 * / % ** 11 + - ** 10 << >> ** 9 < <= > >= ** 8 == != ** 7 & ** 6 ^ ** 5 | ** 4 && ** 3 || ** 2 ? : ** 1 = ?= ** 0 , *) let cast_level = 13 let get_operator exp = match exp.expr_node with NOTHING -> ("", 16) | PAREN _ -> ("", 16) | UNARY (op, _) -> (match op with MINUS -> ("-", 13) | PLUS -> ("+", 13) | NOT -> ("!", 13) | BNOT -> ("~", 13) | MEMOF -> ("*", 13) | ADDROF -> ("&", 13) | PREINCR -> ("++", 13) | PREDECR -> ("--", 13) | POSINCR -> ("++", 14) | POSDECR -> ("--", 14)) | LABELADDR _ -> ("", 16) (* Like a constant *) | BINARY (op, _, _) -> (match op with MUL -> ("*", 12) | DIV -> ("/", 12) | MOD -> ("%", 12) | ADD -> ("+", 11) | SUB -> ("-", 11) | SHL -> ("<<", 10) | SHR -> (">>", 10) | LT -> ("<", 9) | LE -> ("<=", 9) | GT -> (">", 9) | GE -> (">=", 9) | EQ -> ("==", 8) | NE -> ("!=", 8) | BAND -> ("&", 7) | XOR -> ("^", 6) | BOR -> ("|", 5) | AND -> ("&&", 4) | OR -> ("||", 3) | ASSIGN -> ("=", 1) | ADD_ASSIGN -> ("+=", 1) | SUB_ASSIGN -> ("-=", 1) | MUL_ASSIGN -> ("*=", 1) | DIV_ASSIGN -> ("/=", 1) | MOD_ASSIGN -> ("%=", 1) | BAND_ASSIGN -> ("&=", 1) | BOR_ASSIGN -> ("|=", 1) | XOR_ASSIGN -> ("^=", 1) | SHL_ASSIGN -> ("<<=", 1) | SHR_ASSIGN -> (">>=", 1)) | QUESTION _ -> ("", 2) | CAST _ -> ("", cast_level) | CALL _ -> ("", 15) | COMMA _ -> ("", 0) | CONSTANT _ -> ("", 16) | VARIABLE _ -> ("", 16) | EXPR_SIZEOF _ -> ("", 16) | TYPE_SIZEOF _ -> ("", 16) | EXPR_ALIGNOF _ -> ("", 16) | TYPE_ALIGNOF _ -> ("", 16) | INDEX (_, _) -> ("", 15) | MEMBEROF (_, _) -> ("", 15) | MEMBEROFPTR (_, _) -> ("", 15) | GNU_BODY _ -> ("", 17) | EXPR_PATTERN _ -> ("", 16) (* sm: not sure about this *) (* ** FrontC Pretty printer *) let print_string fmt s = fprintf fmt "\"%s\"" (escape_string s) let print_wstring fmt s = fprintf fmt "\"%s\"" (escape_wstring s) (* ** Base Type Printing *) let rec print_specifiers fmt (specs: spec_elem list) = let print_spec_elem fmt = function SpecTypedef -> fprintf fmt "typedef" | SpecInline -> fprintf fmt "inline" | SpecStorage NO_STORAGE -> fprintf fmt "/* no storage */" | SpecStorage AUTO -> fprintf fmt "auto" | SpecStorage STATIC -> fprintf fmt "static" | SpecStorage EXTERN -> fprintf fmt "extern" | SpecStorage REGISTER -> fprintf fmt "register" | SpecCV CV_CONST -> fprintf fmt "const" | SpecCV CV_VOLATILE -> fprintf fmt "volatile" | SpecCV CV_RESTRICT -> fprintf fmt "restrict" | SpecCV (CV_ATTRIBUTE_ANNOT a) -> fprintf fmt "/*@@ %s */" a | SpecAttr al -> print_attribute fmt al | SpecType bt -> print_type_spec fmt bt | SpecPattern name -> fprintf fmt "@@specifier(%s)" name in Pretty_utils.pp_list ~sep:"@ " print_spec_elem fmt specs and print_type_spec fmt = function Tvoid -> fprintf fmt "void" | Tchar -> fprintf fmt "char" | Tbool -> fprintf fmt "_Bool" | Tshort -> fprintf fmt "short" | Tint -> fprintf fmt "int" | Tlong -> fprintf fmt "long" | Tint64 -> fprintf fmt "__int64" | Tfloat -> fprintf fmt "float" | Tdouble -> fprintf fmt "double " | Tsigned -> fprintf fmt "signed" | Tunsigned -> fprintf fmt "unsigned" | Tnamed s -> fprintf fmt "%s" s | Tstruct (n, None, _) -> fprintf fmt "struct %s" n | Tstruct (n, Some flds, extraAttrs) -> fprintf fmt "@[%a@ {@ %a@;}@]" (print_struct_name_attr "struct") (n, extraAttrs) print_fields flds | Tunion (n, None, _) -> fprintf fmt "union %s" n | Tunion (n, Some flds, extraAttrs) -> fprintf fmt "@[%a@ {@ %a@;}@]" (print_struct_name_attr "union") (n, extraAttrs) print_fields flds | Tenum (n, None, _) -> fprintf fmt "enum %s" n | Tenum (n, Some enum_items, extraAttrs) -> fprintf fmt "@[%a@ {@ %a@;}@]" (print_struct_name_attr "enum") (n, extraAttrs) print_enum_items enum_items | TtypeofE e -> fprintf fmt "__typeof__(@[%a@])" print_expression e | TtypeofT (s,d) -> fprintf fmt "__typeof__(@[%a@])"print_onlytype (s, d) (* print "struct foo", but with specified keyword and a list of * attributes to put between keyword and name *) and print_struct_name_attr keyword fmt (name, extraAttrs) = fprintf fmt "%s%a%a@ %s" keyword (pp_cond (extraAttrs <> [])) "@ " print_attributes extraAttrs name (* This is the main printer for declarations. It is easy bacause the * declarations are laid out as they need to be printed. *) and print_decl (n: string) fmt = function JUSTBASE -> let cond = n = "___missing_field_name" in fprintf fmt "%a%s%a" (pp_cond cond) "/*@ " n (pp_cond cond) "@ */" | PARENTYPE (al1, d, al2) -> fprintf fmt "(@[%a%a%a@])" print_attributes al1 (print_decl n) d print_attributes al2 | PTR (al, d) -> fprintf fmt "*%a%a" print_attributes al (print_decl n) d | ARRAY (d, al, e) -> fprintf fmt "%a[@[%a%a@]]" (print_decl n) d print_attributes al print_expression e | PROTO(d, args, isva) -> fprintf fmt "@[%a@;(%a)@]" (print_decl n) d print_params (args,isva) and print_fields fmt (flds : field_group list) = pp_list ~sep:"@ " print_field_group fmt flds and print_enum_items fmt items = let print_item fmt (id,exp,_) = fprintf fmt "%s%a%a" id (pp_cond (exp.expr_node=NOTHING)) "@ =@ " print_expression exp in pp_list ~sep:",@ " print_item fmt items and print_onlytype fmt (specs, dt) = fprintf fmt "%a%a" print_specifiers specs (print_decl "") dt and print_name fmt ((n, decl, attrs, _) : name) = fprintf fmt "%a%a" (print_decl n) decl print_attributes attrs and print_init_name fmt ((n, i) : init_name) = match i with NO_INIT -> print_name fmt n | _ -> fprintf fmt "%a@ =@ %a" print_name n print_init_expression i and print_name_group fmt (specs, names) = fprintf fmt "%a@ %a" print_specifiers specs (pp_list ~sep:",@ " print_name) names and print_field_group fmt fld = match fld with | FIELD (specs, fields) -> fprintf fmt "%a@ %a;" print_specifiers specs (pp_list ~sep:",@ " print_field) fields | TYPE_ANNOT annot -> fprintf fmt "@\n/*@@@[@ %a@]@ */@\n" Logic_print.print_type_annot annot and print_field fmt (name, widtho) = match widtho with None -> print_name fmt name | Some w -> fprintf fmt "%a:@ %a" print_name name print_expression w and print_init_name_group fmt (specs, names) = fprintf fmt "%a@ @[%a@]" print_specifiers specs (pp_list ~sep:",@ " print_init_name) names and print_single_name fmt (specs, name) = fprintf fmt "%a@ %a" print_specifiers specs print_name name and print_params fmt (pars,ell) = pp_list ~sep:",@ " print_single_name fmt pars; if ell then begin match pars with [] -> pp_print_string fmt "..." | _ -> fprintf fmt ",@ ..." end and print_comma_exps fmt exps = pp_list ~sep:",@ " print_expression fmt exps and print_init_expression fmt (iexp: init_expression) = match iexp with NO_INIT -> () | SINGLE_INIT e -> print_expression fmt e | COMPOUND_INIT initexps -> let doinitexp fmt = function NEXT_INIT, e -> print_init_expression fmt e | i, e -> let rec doinit fmt = function NEXT_INIT -> () | INFIELD_INIT (fn, i) -> fprintf fmt ".%s%a" fn doinit i | ATINDEX_INIT (e, i) -> fprintf fmt "[@[%a@]]%a" print_expression e doinit i | ATINDEXRANGE_INIT (s, e) -> fprintf fmt "@[%a@;...@;%a@]" print_expression s print_expression e in fprintf fmt "%a@ =@ %a" doinit i print_init_expression e in fprintf fmt "{@[%a@]}" (pp_list ~sep:",@ " doinitexp) initexps and print_cast_expression fmt = function NO_INIT -> Kernel.fatal "no init in cast" | COMPOUND_INIT _ as ie -> fprintf fmt "(@[%a@])" print_init_expression ie | SINGLE_INIT e -> print_expression_level cast_level fmt e and print_expression fmt (exp: expression) = print_expression_level 0 fmt exp and print_expression_level (lvl: int) fmt (exp : expression) = let (txt, lvl') = get_operator exp in let print_expression fmt exp = print_expression_level lvl' fmt exp in let print_exp fmt e = Cil_const.CurrentLoc.set e.expr_loc; match e.expr_node with NOTHING -> () | PAREN exp -> print_expression fmt exp (* parentheses are added by the level matching. *) | UNARY ((POSINCR|POSDECR), exp') -> fprintf fmt "%a%s" print_expression exp' txt | UNARY (_,exp') -> fprintf fmt "%s%a" txt print_expression exp' | LABELADDR l -> fprintf fmt "&&%s" l | BINARY (_op, exp1, exp2) -> fprintf fmt "%a@ %s@ %a" print_expression exp1 txt print_expression exp2 | QUESTION (exp1, exp2, exp3) -> fprintf fmt "%a@ ?@ %a@ :@ %a" print_expression exp1 print_expression exp2 print_expression exp3 | CAST (typ, iexp) -> fprintf fmt "(@[%a@])@;%a" print_onlytype typ print_cast_expression iexp | CALL ({ expr_node = VARIABLE "__builtin_va_arg"}, [arg; { expr_node = TYPE_SIZEOF (bt, dt) } ]) -> fprintf fmt "__builtin_va_arg(@[%a,@ %a@])" (print_expression_level 0) arg print_onlytype (bt, dt) | CALL (exp, args) -> fprintf fmt "%a(@[@;%a@])" print_expression exp print_comma_exps args | CONSTANT (CONST_INT i) -> pp_print_string fmt i | CONSTANT (CONST_FLOAT f) -> pp_print_string fmt f | CONSTANT (CONST_CHAR c) -> fprintf fmt "'%s'" (escape_wstring c) | CONSTANT (CONST_WCHAR c) -> fprintf fmt "L'%s'" (escape_wstring c) | CONSTANT (CONST_STRING s) -> print_string fmt s | CONSTANT (CONST_WSTRING s) -> print_wstring fmt s | VARIABLE name -> pp_print_string fmt name | EXPR_SIZEOF exp -> fprintf fmt "sizeof%a" print_expression exp | TYPE_SIZEOF (bt,dt) -> fprintf fmt "sizeof(@[%a@])" print_onlytype (bt,dt) | EXPR_ALIGNOF exp -> fprintf fmt "__alignof__%a" print_expression exp | TYPE_ALIGNOF (bt,dt) -> fprintf fmt "__alignof__(@[%a@])" print_onlytype (bt, dt) | INDEX (exp, idx) -> fprintf fmt "%a[@[%a@]]" print_expression exp (print_expression_level 0) idx | MEMBEROF (exp, fld) -> fprintf fmt "%a.%s" print_expression exp fld | MEMBEROFPTR (exp, fld) -> fprintf fmt "%a->%s" print_expression exp fld | GNU_BODY blk -> fprintf fmt "(@[%a@])" print_block blk | EXPR_PATTERN (name) -> fprintf fmt "@@expr(%s)" name | COMMA l -> pp_list ~sep:",@ " print_expression fmt l in if lvl >= lvl' then fprintf fmt "(@[%a@])" print_exp exp else print_exp fmt exp (* ** Statement printing *) and print_for_init fmt fc = match fc with FC_EXP exp -> print_expression fmt exp | FC_DECL dec -> print_def fmt dec and print_statement fmt stat = let loc = Cabshelper.get_statementloc stat in Cil_const.CurrentLoc.set loc; if Kernel.debug_atleast 2 then fprintf fmt "@\n/* %a */@\n" Cil_printer.pp_location loc; match stat.stmt_node with NOP _ -> pp_print_string fmt ";" | COMPUTATION (exp,_) -> fprintf fmt "%a;" print_expression exp | BLOCK (blk, _,_) -> print_block fmt blk | SEQUENCE (s1, s2,_) -> fprintf fmt "%a;@ %a" print_statement s1 print_statement s2 | IF (exp, s1, s2, _) -> fprintf fmt "@[if@ (@[%a@])@ %a" print_expression exp print_substatement s1; (match s2.stmt_node with | NOP(_) -> fprintf fmt "@]" | _ -> fprintf fmt "@ else@ %a@]" print_substatement s2) | WHILE (annot,exp, stat,_) -> fprintf fmt "%a@[while@ (@[%a@])@ %a@]" (pp_list ~pre:"/*@@ @[" ~sep:"@\n" ~suf:"@]*/" print_code_annot) annot print_expression exp print_substatement stat | DOWHILE (annot,exp, stat, _) -> fprintf fmt "%a@[do@ %a@ while@ (@[%a@])@]" (pp_list ~pre:"/*@@ @[" ~sep:"@\n" ~suf:"@]*/" print_code_annot) annot print_substatement stat print_expression exp | FOR (annot,fc1, exp2, exp3, stat, _) -> fprintf fmt "%a@[for(@[%a;@ %a;@ %a@])@ %a@]" (pp_list ~pre:"/*@@ @[" ~sep:"@\n" ~suf:"@]*/" print_code_annot) annot print_for_init fc1 print_expression exp2 print_expression exp3 print_substatement stat | BREAK _ -> pp_print_string fmt "break;" | CONTINUE _ -> pp_print_string fmt "continue;" | RETURN (exp, _) -> let has_paren exp = match exp.expr_node with | PAREN _ -> true | _ -> false in fprintf fmt "return%a%a;" (pp_cond (not (exp.expr_node = NOTHING || has_paren exp))) "@ " print_expression exp | SWITCH (exp, stat,_) -> fprintf fmt "@[switch@ (@[%a@])@ %a@]" print_expression exp print_substatement stat | CASE (exp, stat, _) -> fprintf fmt "@[<2>case@ %a:@ %a@]" print_expression exp print_substatement stat | CASERANGE (expl, exph, stat, _) -> fprintf fmt "@[<2>case@ %a@;...@;%a:@ %a@]" print_expression expl print_expression exph print_substatement stat | DEFAULT (stat,_) -> fprintf fmt "@[<2>default:@ %a@]" print_substatement stat | LABEL (name, stat, _) -> fprintf fmt "@[<2>%s:@ %a@]" name print_substatement stat | GOTO (name, _) -> fprintf fmt "goto %s;" name | COMPGOTO (exp, _) -> fprintf fmt "goto@ @[*%a@];" print_expression exp | DEFINITION d -> print_def fmt d | ASM (attrs, tlist, details, _) -> let print_asm_operand fmt (_identop,cnstr, e) = fprintf fmt "@[%s@ (@[%a@])@]" cnstr print_expression e in if !msvcMode then begin fprintf fmt "__asm@ {@[%a@]}" (pp_list ~sep:"@\n" pp_print_string) tlist end else begin let print_details fmt { aoutputs = outs; ainputs = ins; aclobbers = clobs } = pp_list ~sep:",@ " print_asm_operand fmt outs; pp_cond (ins<>[]||clobs<>[]) fmt ":@ "; pp_list ~sep:",@ " print_asm_operand fmt ins; pp_cond (clobs<>[]) fmt ":@ "; pp_list ~sep:",@ " pp_print_string fmt clobs in fprintf fmt "@[__asm__%a@;(@[%a%a])@]" print_attributes attrs (pp_list ~sep:"@ " pp_print_string) tlist (pp_opt ~pre:":@ " print_details) details end | TRY_FINALLY (b, h, _) -> fprintf fmt "__try@ @[%a@]@ __finally@ @[%a@]" print_block b print_block h | TRY_EXCEPT (b, e, h, _) -> fprintf fmt "__try@ @[%a@]@ __except(@[%a@])@ @[%a@]" print_block b print_expression e print_block h | CODE_ANNOT (a, _) -> fprintf fmt "/*@@@ @[%a@]@ */" Logic_print.print_code_annot a | CODE_SPEC (a, _) -> fprintf fmt "/*@@@ @[%a@]@ */" Logic_print.print_spec a and print_block fmt blk = fprintf fmt "@ {@ @[%a%a%a@]@ }" (pp_list ~pre:"__label__@ " ~sep:",@ " ~suf:";@\n" pp_print_string) blk.blabels (pp_list ~suf:"@ " print_attribute) blk.battrs (pp_list ~sep:"@ " print_statement) blk.bstmts and print_substatement fmt stat = match stat.stmt_node with IF _ | SEQUENCE _ | DOWHILE _ -> fprintf fmt "@ {@ @[%a@]@ }" print_statement stat | _ -> print_statement fmt stat (* ** GCC Attributes *) and print_attribute fmt (name,args) = match args with [] -> pp_print_string fmt name | _ -> let cond = name = "__attribute__" in let print_args fmt = function [{expr_node = VARIABLE "aconst"}] -> pp_print_string fmt "const" | [{expr_node = VARIABLE "restrict"}] -> pp_print_string fmt "restrict" | args -> pp_list ~sep:",@ " print_expression fmt args in fprintf fmt "%s(%a@[%a@]%a)" name (pp_cond cond) "(" print_args args (pp_cond cond) ")" (* Print attributes. *) and print_attributes fmt attrs = pp_list ~pre:"@ " ~sep:"@ " ~suf:"@ " print_attribute fmt attrs (* ** Declaration printing *) and print_defs fmt defs = let prev = ref false in List.iter (fun (ghost,def) -> (match def with DECDEF _ -> prev := false | _ -> if not !prev then pp_print_newline fmt (); prev := true); if ghost then fprintf fmt "/*@@@ @[ghost@ %a@]@ */" print_def def else print_def fmt def ) defs and print_def fmt def = Cil_const.CurrentLoc.set (Cabshelper.get_definitionloc def); match def with FUNDEF (_spec, proto, body, loc, _) -> if !printCounters then begin try let fname = match proto with (_, (n, _, _, _)) -> n in print_def fmt (DECDEF (None,([SpecType Tint], [(fname ^ "__counter", JUSTBASE, [], loc), NO_INIT]), loc)); with Not_found -> pp_print_string fmt "/* can't print the counter */" end; fprintf fmt "@[%a@\n%a@]@\n" print_single_name proto print_block body | DECDEF (_,names, _) -> fprintf fmt "@[%a;@\n@]" print_init_name_group names | TYPEDEF (names, _) -> fprintf fmt "@[%a;@\n@]" print_name_group names | ONLYTYPEDEF (specs, _) -> fprintf fmt "@[%a;@\n@]" print_specifiers specs | GLOBASM (asm, _) -> fprintf fmt "@[__asm__(%s);@\n@]" asm | GLOBANNOT (annot) -> fprintf fmt "@[/*@@@ @[%a@]@ */@]@\n" (pp_list ~sep:"@\n" Logic_print.print_decl) annot | CUSTOM _ -> fprintf fmt "" | PRAGMA (a,_) -> fprintf fmt "@[#pragma %a@]@\n" print_expression a | LINKAGE (n, _, dl) -> fprintf fmt "@[<2>extern@ %s@ {%a@;}@]" n (pp_list print_def) dl (* print abstrac_syntax -> () ** Pretty printing the given abstract syntax program. *) let printFile fmt ((_fname, defs) : file) = print_defs fmt defs (* Local Variables: compile-command: "make -C ../../.." End: *) frama-c-Fluorine-20130601/cil/src/frontc/cabsvisit.ml0000644000175000017500000005240212155630365021160 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) (* cabsvisit.ml *) (* tree visitor and rewriter for cabs *) open Cabs open Cabshelper open Cil type nameKind = NVar (* Variable or function prototype name *) | NFun (* A function definition name *) | NField (* The name of a field *) | NType (* The name of a type *) (* All visit methods are called in preorder! (but you can use * ChangeDoChildrenPost to change the order) *) class type cabsVisitor = object method vexpr: expression -> expression visitAction (* expressions *) method vinitexpr: init_expression -> init_expression visitAction method vstmt: statement -> statement list visitAction method vblock: block -> block visitAction method vvar: string -> string (* use of a variable * names *) method vdef: definition -> definition list visitAction method vtypespec: typeSpecifier -> typeSpecifier visitAction method vdecltype: decl_type -> decl_type visitAction (* For each declaration we call vname *) method vname: nameKind -> specifier -> name -> name visitAction method vspec: specifier -> specifier visitAction (* specifier *) method vattr: attribute -> attribute list visitAction method vEnterScope: unit -> unit method vExitScope: unit -> unit end (* a default visitor which does nothing to the tree *) class nopCabsVisitor : cabsVisitor = object method vexpr (_e:expression) = DoChildren method vinitexpr (_e:init_expression) = DoChildren method vstmt (s: statement) = CurrentLoc.set (get_statementloc s); DoChildren method vblock (_b: block) = DoChildren method vvar (s: string) = s method vdef (d: definition) = CurrentLoc.set (get_definitionloc d); DoChildren method vtypespec (_ts: typeSpecifier) = DoChildren method vdecltype (_dt: decl_type) = DoChildren method vname _k (_s:specifier) (_n: name) = DoChildren method vspec (_s:specifier) = DoChildren method vattr (_a: attribute) = DoChildren method vEnterScope () = () method vExitScope () = () end let doVisit vis startvisit children node = Cil.doVisit vis vis (fun x -> x) startvisit children node let doVisitList vis startvisit children node = Cil.doVisitList vis vis (fun x -> x) startvisit children node let rec visitCabsTypeSpecifier (vis: cabsVisitor) (ts: typeSpecifier) = doVisit vis vis#vtypespec childrenTypeSpecifier ts and childrenTypeSpecifier vis ts = let childrenFieldGroup input = match input with | FIELD (s, nel) -> let s' = visitCabsSpecifier vis s in let doOneField ((n, eo) as input) = let n' = visitCabsName vis NField s' n in let eo' = match eo with None -> None | Some e -> let e' = visitCabsExpression vis e in if e' != e then Some e' else eo in if n' != n || eo' != eo then (n', eo') else input in let nel' = mapNoCopy doOneField nel in if s' != s || nel' != nel then FIELD (s', nel') else input | TYPE_ANNOT _ -> input in match ts with Tstruct (n, Some fg, extraAttrs) -> (*(trace "sm" (dprintf "visiting struct %s\n" n));*) let fg' = mapNoCopy childrenFieldGroup fg in if fg' != fg then Tstruct( n, Some fg', extraAttrs) else ts | Tunion (n, Some fg, extraAttrs) -> let fg' = mapNoCopy childrenFieldGroup fg in if fg' != fg then Tunion( n, Some fg', extraAttrs) else ts | Tenum (n, Some ei, extraAttrs) -> let doOneEnumItem ((s, e, loc) as ei) = let e' = visitCabsExpression vis e in if e' != e then (s, e', loc) else ei in vis#vEnterScope (); let ei' = mapNoCopy doOneEnumItem ei in vis#vExitScope(); if ei' != ei then Tenum( n, Some ei', extraAttrs) else ts | TtypeofE e -> let e' = visitCabsExpression vis e in if e' != e then TtypeofE e' else ts | TtypeofT (s, dt) -> let s' = visitCabsSpecifier vis s in let dt' = visitCabsDeclType vis false dt in if s != s' || dt != dt' then TtypeofT (s', dt') else ts | ts -> ts and childrenSpecElem (vis: cabsVisitor) (se: spec_elem) : spec_elem = match se with SpecTypedef | SpecInline | SpecStorage _ | SpecPattern _ -> se | SpecCV _ -> se (* cop out *) | SpecAttr a -> begin let al' = visitCabsAttribute vis a in match al' with [a''] when a'' == a -> se | [a''] -> SpecAttr a'' | _ -> Kernel.fatal "childrenSpecElem: visitCabsAttribute returned a list" end | SpecType ts -> let ts' = visitCabsTypeSpecifier vis ts in if ts' != ts then SpecType ts' else se and visitCabsSpecifier (vis: cabsVisitor) (s: specifier) : specifier = doVisit vis vis#vspec childrenSpec s and childrenSpec vis s = mapNoCopy (childrenSpecElem vis) s and visitCabsDeclType vis (isfundef: bool) (dt: decl_type) : decl_type = doVisit vis vis#vdecltype (childrenDeclType isfundef) dt and childrenDeclType isfundef vis dt = match dt with JUSTBASE -> dt | PARENTYPE (prea, dt1, posta) -> let prea' = mapNoCopyList (visitCabsAttribute vis) prea in let dt1' = visitCabsDeclType vis isfundef dt1 in let posta'= mapNoCopyList (visitCabsAttribute vis) posta in if prea' != prea || dt1' != dt1 || posta' != posta then PARENTYPE (prea', dt1', posta') else dt | ARRAY (dt1, al, e) -> let dt1' = visitCabsDeclType vis isfundef dt1 in let al' = mapNoCopy (childrenAttribute vis) al in let e'= visitCabsExpression vis e in if dt1' != dt1 || al' != al || e' != e then ARRAY(dt1', al', e') else dt | PTR (al, dt1) -> let al' = mapNoCopy (childrenAttribute vis) al in let dt1' = visitCabsDeclType vis isfundef dt1 in if al' != al || dt1' != dt1 then PTR(al', dt1') else dt | PROTO (dt1, snl, b) -> (* Do not propagate isfundef further *) let dt1' = visitCabsDeclType vis false dt1 in let _ = vis#vEnterScope () in let snl' = mapNoCopy (childrenSingleName vis NVar) snl in (* Exit the scope only if not in a function definition *) let _ = if not isfundef then vis#vExitScope () in if dt1' != dt1 || snl' != snl then PROTO(dt1', snl', b) else dt and childrenNameGroup vis (kind: nameKind) ((s, nl) as input) = let s' = visitCabsSpecifier vis s in let nl' = mapNoCopy (visitCabsName vis kind s') nl in if s' != s || nl' != nl then (s', nl') else input and visitCabsName vis (k: nameKind) (s: specifier) (n: name) : name = doVisit vis (vis#vname k s) (childrenName s k) n and childrenName (_s: specifier) (k: nameKind) vis (n: name) : name = let (sn, dt, al, loc) = n in let dt' = visitCabsDeclType vis (k = NFun) dt in let al' = mapNoCopy (childrenAttribute vis) al in if dt' != dt || al' != al then (sn, dt', al', loc) else n and childrenInitName vis (s: specifier) (inn: init_name) : init_name = let (n, ie) = inn in let n' = visitCabsName vis NVar s n in let ie' = visitCabsInitExpression vis ie in if n' != n || ie' != ie then (n', ie') else inn and childrenSingleName vis (k: nameKind) (sn: single_name) : single_name = let s, n = sn in let s' = visitCabsSpecifier vis s in let n' = visitCabsName vis k s' n in if s' != s || n' != n then (s', n') else sn and visitCabsDefinition vis (d: definition) : definition list = doVisitList vis vis#vdef childrenDefinition d and childrenDefinition vis d = match d with FUNDEF (spec,sn, b, l, lend) -> let sn' = childrenSingleName vis NFun sn in let b' = visitCabsBlock vis b in (* End the scope that was started by childrenFunctionName *) vis#vExitScope (); if sn' != sn || b' != b then FUNDEF (spec,sn', b', l, lend) else d | DECDEF (spec,(s, inl), l) -> let s' = visitCabsSpecifier vis s in let inl' = mapNoCopy (childrenInitName vis s') inl in if s' != s || inl' != inl then DECDEF (spec,(s', inl'), l) else d | TYPEDEF (ng, l) -> let ng' = childrenNameGroup vis NType ng in if ng' != ng then TYPEDEF (ng', l) else d | ONLYTYPEDEF (s, l) -> let s' = visitCabsSpecifier vis s in if s' != s then ONLYTYPEDEF (s', l) else d | GLOBASM _ -> d | PRAGMA (e, l) -> let e' = visitCabsExpression vis e in if e' != e then PRAGMA (e', l) else d | LINKAGE (n, l, dl) -> let dl' = mapNoCopyList (visitCabsDefinition vis) dl in if dl' != dl then LINKAGE (n, l, dl') else d | GLOBANNOT _ -> d | CUSTOM _ -> d and visitCabsBlock vis (b: block) : block = doVisit vis vis#vblock childrenBlock b and childrenBlock vis (b: block) : block = let _ = vis#vEnterScope () in let battrs' = mapNoCopyList (visitCabsAttribute vis) b.battrs in let bstmts' = mapNoCopyList (visitCabsStatement vis) b.bstmts in let _ = vis#vExitScope () in if battrs' != b.battrs || bstmts' != b.bstmts then { blabels = b.blabels; battrs = battrs'; bstmts = bstmts' } else b and visitCabsStatement vis (s: statement) : statement list = doVisitList vis vis#vstmt childrenStatement s and childrenStatement vis s = let ve e = visitCabsExpression vis e in let vs l s = match visitCabsStatement vis s with [s'] -> s' | sl -> { s with stmt_node = BLOCK ({blabels = []; battrs = []; bstmts = sl }, l, l(*LRICEA*))} in match s.stmt_node with NOP _ -> s | COMPUTATION (e, l) -> let e' = ve e in if e' != e then {s with stmt_node = COMPUTATION (e', l)} else s | BLOCK (b, l, l') -> let b' = visitCabsBlock vis b in if b' != b then {s with stmt_node = BLOCK (b', l, l')} else s | SEQUENCE (s1, s2, l) -> let s1' = vs l s1 in let s2' = vs l s2 in if s1' != s1 || s2' != s2 then {s with stmt_node = SEQUENCE (s1', s2', l)} else s | IF (e, s1, s2, l) -> let e' = ve e in let s1' = vs l s1 in let s2' = vs l s2 in if e' != e || s1' != s1 || s2' != s2 then {s with stmt_node = IF (e', s1', s2', l)} else s | WHILE (a, e, s1, l) -> let e' = ve e in let s1' = vs l s1 in if e' != e || s1' != s1 then {s with stmt_node = WHILE (a, e', s1', l)} else s | DOWHILE (a, e, s1, l) -> let e' = ve e in let s1' = vs l s1 in if e' != e || s1' != s1 then {s with stmt_node = DOWHILE (a, e', s1', l)} else s | FOR (a, fc1, e2, e3, s4, l) -> let _ = vis#vEnterScope () in let fc1' = match fc1 with FC_EXP e1 -> let e1' = ve e1 in if e1' != e1 then FC_EXP e1' else fc1 | FC_DECL d1 -> let d1' = match visitCabsDefinition vis d1 with [d1'] -> d1' | _ -> Kernel.fatal "visitCabs: for can have only one definition" in if d1' != d1 then FC_DECL d1' else fc1 in let e2' = ve e2 in let e3' = ve e3 in let s4' = vs l s4 in let _ = vis#vExitScope () in if fc1' != fc1 || e2' != e2 || e3' != e3 || s4' != s4 then {s with stmt_node = FOR (a, fc1', e2', e3', s4', l)} else s | BREAK _ | CONTINUE _ | GOTO _ -> s | RETURN (e, l) -> let e' = ve e in if e' != e then {s with stmt_node = RETURN (e', l)} else s | SWITCH (e, s1, l) -> let e' = ve e in let s1' = vs l s1 in if e' != e || s1' != s1 then {s with stmt_node = SWITCH (e', s1', l)} else s | CASE (e, s1, l) -> let e' = ve e in let s1' = vs l s1 in if e' != e || s1' != s1 then {s with stmt_node = CASE (e', s1', l)} else s | CASERANGE (e1, e2, s3, l) -> let e1' = ve e1 in let e2' = ve e2 in let s3' = vs l s3 in if e1' != e1 || e2' != e2 || s3' != s3 then {s with stmt_node = CASERANGE (e1', e2', s3', l)} else s | DEFAULT (s1, l) -> let s1' = vs l s1 in if s1' != s1 then {s with stmt_node = DEFAULT (s1', l)} else s | LABEL (n, s1, l) -> let s1' = vs l s1 in if s1' != s1 then {s with stmt_node = LABEL (n, s1', l)} else s | COMPGOTO (e, l) -> let e' = ve e in if e' != e then {s with stmt_node = COMPGOTO (e', l)} else s | DEFINITION d -> begin match visitCabsDefinition vis d with [d'] when d' == d -> s | [d'] -> {s with stmt_node = DEFINITION d' } | dl -> let l = get_definitionloc d in let dl' = List.map (fun d' -> {s with stmt_node = DEFINITION d'}) dl in {s with stmt_node = BLOCK ({blabels = []; battrs = []; bstmts = dl' }, l, l(*LRICEA*))} end | ASM (sl, b, details, l) -> let childrenIdentStringExp ((i,s, e) as input) = let e' = ve e in if e' != e then (i,s, e') else input in let details' = match details with | None -> details | Some { aoutputs = outl; ainputs = inl; aclobbers = clobs } -> let outl' = mapNoCopy childrenIdentStringExp outl in let inl' = mapNoCopy childrenIdentStringExp inl in if outl' == outl && inl' == inl then details else Some { aoutputs = outl'; ainputs = inl'; aclobbers = clobs } in if details' != details then {s with stmt_node = ASM (sl, b, details', l)} else s | TRY_FINALLY (b1, b2, l) -> let b1' = visitCabsBlock vis b1 in let b2' = visitCabsBlock vis b2 in if b1' != b1 || b2' != b2 then {s with stmt_node = TRY_FINALLY(b1', b2', l)} else s | TRY_EXCEPT (b1, e, b2, l) -> let b1' = visitCabsBlock vis b1 in let e' = visitCabsExpression vis e in let b2' = visitCabsBlock vis b2 in if b1' != b1 || e' != e || b2' != b2 then {s with stmt_node = TRY_EXCEPT(b1', e', b2', l)} else s | CODE_ANNOT _ | CODE_SPEC _ -> s and visitCabsExpression vis (e: expression) : expression = doVisit vis vis#vexpr childrenExpression e and childrenExpression vis e = let ve e = visitCabsExpression vis e in match e.expr_node with NOTHING | LABELADDR _ -> e | UNARY (uo, e1) -> let e1' = ve e1 in if e1' != e1 then { e with expr_node = UNARY (uo, e1')} else e | BINARY (bo, e1, e2) -> let e1' = ve e1 in let e2' = ve e2 in if e1' != e1 || e2' != e2 then { e with expr_node = BINARY (bo, e1', e2')} else e | QUESTION (e1, e2, e3) -> let e1' = ve e1 in let e2' = ve e2 in let e3' = ve e3 in if e1' != e1 || e2' != e2 || e3' != e3 then { e with expr_node = QUESTION (e1', e2', e3')} else e | CAST ((s, dt), ie) -> let s' = visitCabsSpecifier vis s in let dt' = visitCabsDeclType vis false dt in let ie' = visitCabsInitExpression vis ie in if s' != s || dt' != dt || ie' != ie then { e with expr_node = CAST ((s', dt'), ie')} else e | CALL (f, el) -> let f' = ve f in let el' = mapNoCopy ve el in if f' != f || el' != el then { e with expr_node = CALL (f', el')} else e | COMMA el -> let el' = mapNoCopy ve el in if el' != el then { e with expr_node = COMMA (el') } else e | CONSTANT _ -> e | PAREN e1 -> let e1' = ve e1 in if e1' != e1 then { e with expr_node = PAREN (e1') } else e | VARIABLE s -> let s' = vis#vvar s in if s' != s then { e with expr_node = VARIABLE s' } else e | EXPR_SIZEOF (e1) -> let e1' = ve e1 in if e1' != e1 then { e with expr_node = EXPR_SIZEOF (e1') } else e | TYPE_SIZEOF (s, dt) -> let s' = visitCabsSpecifier vis s in let dt' = visitCabsDeclType vis false dt in if s' != s || dt' != dt then { e with expr_node = TYPE_SIZEOF (s' ,dt') } else e | EXPR_ALIGNOF (e1) -> let e1' = ve e1 in if e1' != e1 then { e with expr_node = EXPR_ALIGNOF e1'} else e | TYPE_ALIGNOF (s, dt) -> let s' = visitCabsSpecifier vis s in let dt' = visitCabsDeclType vis false dt in if s' != s || dt' != dt then { e with expr_node = TYPE_ALIGNOF (s' ,dt')} else e | INDEX (e1, e2) -> let e1' = ve e1 in let e2' = ve e2 in if e1' != e1 || e2' != e2 then { e with expr_node = INDEX (e1', e2') } else e | MEMBEROF (e1, n) -> let e1' = ve e1 in if e1' != e1 then { e with expr_node = MEMBEROF (e1', n)} else e | MEMBEROFPTR (e1, n) -> let e1' = ve e1 in if e1' != e1 then { e with expr_node = MEMBEROFPTR (e1', n) } else e | GNU_BODY b -> let b' = visitCabsBlock vis b in if b' != b then { e with expr_node = GNU_BODY b' } else e | EXPR_PATTERN _ -> e and visitCabsInitExpression vis (ie: init_expression) : init_expression = doVisit vis vis#vinitexpr childrenInitExpression ie and childrenInitExpression vis ie = let rec childrenInitWhat iw = match iw with NEXT_INIT -> iw | INFIELD_INIT (n, iw1) -> let iw1' = childrenInitWhat iw1 in if iw1' != iw1 then INFIELD_INIT (n, iw1') else iw | ATINDEX_INIT (e, iw1) -> let e' = visitCabsExpression vis e in let iw1' = childrenInitWhat iw1 in if e' != e || iw1' != iw1 then ATINDEX_INIT (e', iw1') else iw | ATINDEXRANGE_INIT (e1, e2) -> let e1' = visitCabsExpression vis e1 in let e2' = visitCabsExpression vis e2 in if e1' != e1 || e2' != e2 then ATINDEXRANGE_INIT (e1', e2') else iw in match ie with NO_INIT -> ie | SINGLE_INIT e -> let e' = visitCabsExpression vis e in if e' != e then SINGLE_INIT e' else ie | COMPOUND_INIT il -> let childrenOne ((iw, ie) as input) = let iw' = childrenInitWhat iw in let ie' = visitCabsInitExpression vis ie in if iw' != iw || ie' != ie then (iw', ie') else input in let il' = mapNoCopy childrenOne il in if il' != il then COMPOUND_INIT il' else ie and visitCabsAttribute vis (a: attribute) : attribute list = doVisitList vis vis#vattr childrenAttribute a and childrenAttribute vis ((n, el) as input) = let el' = mapNoCopy (visitCabsExpression vis) el in if el' != el then (n, el') else input and visitCabsAttributes vis (al: attribute list) : attribute list = mapNoCopyList (visitCabsAttribute vis) al let visitCabsFile (vis: cabsVisitor) ((fname, f): file) : file = (fname, mapNoCopyList (fun ((ghost,f) as glob) -> let f' = visitCabsDefinition vis f in match f' with [f'] when f == f' -> [glob] | _ -> List.map (fun f -> (ghost, f)) f' ) f) (* end of file *) frama-c-Fluorine-20130601/cil/src/cil_state_builder.ml0000644000175000017500000000715712155630367021364 0ustar mehdimehdi(****************************************************************************) (* *) (* Copyright (C) 2001-2003 *) (* George C. Necula *) (* Scott McPeak *) (* Wes Weimer *) (* Ben Liblit *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* *) (* 1. Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* *) (* 2. Redistributions in binary form must reproduce the above copyright *) (* notice, this list of conditions and the following disclaimer in the *) (* documentation and/or other materials provided with the distribution. *) (* *) (* 3. The names of the contributors may not be used to endorse or *) (* promote products derived from this software without specific prior *) (* written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *) (* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *) (* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *) (* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *) (* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *) (* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *) (* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *) (* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *) (* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *) (* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *) (* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *) (* POSSIBILITY OF SUCH DAMAGE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives) *) (* and INRIA (Institut National de Recherche en Informatique *) (* et Automatique). *) (****************************************************************************) open State_builder open Cil_datatype module Stmt_set_ref = Set_ref(Stmt.Set) module Kinstr_hashtbl = Hashtbl(Kinstr.Hashtbl) module Stmt_hashtbl = Hashtbl(Stmt.Hashtbl) module Varinfo_hashtbl = Hashtbl(Varinfo.Hashtbl) (* module Code_annotation_hashtbl = State_builder.Hashtbl(Cil_datatype.Code_Annotation) *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/config.h.in0000644000175000017500000000361212155630370016024 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #undef HAVE_WCHAR_T #undef HAVE_STDLIB_H #undef HAVE_STRINGS_H #undef HAVE_SYS_TIME_H #undef HAVE_UNISTD_H #undef HAVE_CONST #undef HAVE_INLINE #undef HAVE_TIME_H #undef HAVE_MEMCP #undef HAVE_MKDIR #undef HAVE_SELECT #undef HAVE_SOCKET #undef TYPE_SIZE_T #undef TYPE_WCHAR_T #undef TYPE_PTRDIFF_T frama-c-Fluorine-20130601/bin/0000755000175000017500000000000012155634040014545 5ustar mehdimehdiframa-c-Fluorine-20130601/bin/sed_get_make_major0000644000175000017500000000004512155630367020276 0ustar mehdimehdis/.* Make[^0-9]*\([0-9]*\)\..*$/\1/p frama-c-Fluorine-20130601/bin/oxygen2fluorine.sh0000755000175000017500000002256512155630367020265 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## #! /bin/sh # # oxygen2fluorine: # convert a Frama-C plugin from Frama-C Oxygen to Frama-C Fluorine # as most as possible (no guarantee that the result is fully compatible) # # known miss features: don't work if a directory name contains some spaces NAME=oxygen2fluorine ARGS=$@ DIR= # verbosing on by default VERBOSE="v" sedi () { if [ -n "`sed --help 2> /dev/null | grep \"\\-i\" 2> /dev/null`" ]; then eval sed -i "$@" else # option '-i' is not recognized by sed: use a tmp file new_temp=`mktemp /tmp/frama-c.XXXXXXX` || exit 1 eval sed "$@" > $new_temp eval last=\${$#} mv $new_temp $last fi } dirs () { if [ -z "$DIR" ]; then DIR=. fi } safe_goto () { dir=$1 cd $dir $3 cd $2 } goto () { if [ -d $1 ]; then safe_goto $1 $2 $3 else echo "Directory '$1' does not exist. Omitted." fi } process_file () { file=$1 if [ "$VERBOSE" ]; then echo "Processing file $file" fi sedi \ -e "\"s/Cilutil.out_some/Extlib.the/g\"" \ -e "\"s/Cil_types.rooted_code_annotation/Cil_types.code_annotation/g\"" \ -e "\"s/Ast_info.is_trivial_rooted_assertion/Ast_info.is_trivial_annotation/g\"" \ -e "\"s/Ast_info.lift_annot_func//g\"" \ -e "\"s/Ast_info.lift_annot_list_func//g\"" \ -e "\"s/Ast_printer.d_rooted_code_annotation/Ast_printer.d_code_annotation/g\"" \ -e "\"s/Annotation.code_annotation_of_rooted//g\"" \ -e "\"s/V_Offsetmap_ext/V_Offsetmap/g\"" \ -e "\"s/My_bigint/Integer/g\"" \ -e "\"s/State_dependency_graph.Static/State_dependency_graph/g\"" \ \ -e "\"s/#pVarName/#varname/g\"" \ -e "\"s/#pVar/#varinfo/g\"" \ -e "\"s/#pVDecl/#vdecl/g\"" \ -e "\"s/#pAttr/#attribute/g\"" \ -e "\"s/#pType/#typ/g\"" \ -e "\"s/#pOffset/#offset/g\"" \ -e "\"s/#pExp/#exp/g\"" \ -e "\"s/#pLval/#lval/g\"" \ -e "\"s/#pInstr/#instr/g\"" \ -e "\"s/#pStmt/#stmt/g\"" \ -e "\"s/#pStmtNext/#next_stmt/g\"" \ -e "\"s/#pCode_annot/#code_annotation/g\"" \ -e "\"s/#pGlobal/#global/g\"" \ -e "\"s/#pLabel/#label/g\"" \ -e "\"s/#pBlock/#block/g\"" \ -e "\"s/#pFieldDecl/#fieldinfo/g\"" \ -e "\"s/#pSpec/#funspec/g\"" \ -e "\"s/#pLogic_type/#logic_type/g\"" \ -e "\"s/#pTerm/#term/g\"" \ -e "\"s/#pLogic_const/#logic_constant/g\"" \ -e "\"s/#pPredicate/#predicate/g\"" \ -e "\"s/#pIdentified/#identified/g\"" \ -e "\"s/#pAssigns/#assigns/g\"" \ -e "\"s/#pFrom/#from/g\"" \ -e "\"s/#pDecreases/#decreases/g\"" \ -e "\"s/#pAssumes/#assumes/g\"" \ -e "\"s/#pRequires/#requires/g\"" \ -e "\"s/#pPost_cond/#post_cond/g\"" \ -e "\"s/#pAllocation/#allocation/g\"" \ -e "\"s/#pBehavior/#behavior/g\"" \ -e "\"s/#pCompleteBehavior/#complete_behavior/g\"" \ -e "\"s/#pDisjointBehavior/#disjoint_behavior/g\"" \ -e "\"s/#pSpec/#funspec/g\"" \ -e "\"s/#pAnnotation/#global_annotation/g\"" \ \ -e "\"s/!Ast_printer.d_funspec/Printer.pp_funspec/g\"" \ -e "\"s/!Ast_printer.d_global/Printer.pp_global/g\"" \ -e "\"s/!Ast_printer.d_stmt/Printer.pp_stmt/g\"" \ -e "\"s/!Ast_printer.d_exp/Printer.pp_exp/g\"" \ -e "\"s/!Ast_printer.d_type/Printer.pp_typ/g\"" \ -e "\"s/!Ast_printer.d_ident/Format.pp_print_string/g\"" \ -e "\"s/!Ast_printer.d_var/Printer.pp_varinfo/g\"" \ -e "\"s/!Ast_printer.d_block/Printer.pp_block/g\"" \ -e "\"s/!Ast_printer.d_label/Printer.pp_label/g\"" \ -e "\"s/!Ast_printer.d_term/Printer.pp_term/g\"" \ -e "\"s/!Ast_printer.d_logic_type/Printer.pp_logic_type/g\"" \ -e "\"s/!Ast_printer.d_lval/Printer.pp_lval/g\"" \ -e "\"s/!Ast_printer.d_instr/Printer.pp_instr/g\"" \ -e "\"s/!Ast_printer.d_attrlist/Printer.pp_attributes/g\"" \ -e "\"s/!Ast_printer.d_file/Printer.pp_file/g\"" \ -e "\"s/!Ast_printer.d_code_annotation/Printer.pp_code_annotation/g\"" \ -e "\"s/!Ast_printer.d_predicate_named/Printer.pp_predicate_named/g\"" \ -e "\"s/!Ast_printer.d_relation/Printer.pp_relation/g\"" \ -e "\"s/!Ast_printer.d_term_lval/Printer.pp_term_lval/g\"" \ -e "\"s/!Ast_printer.d_logic_var/Printer.pp_logic_var/g\"" \ -e "\"s/!Ast_printer.d_unop/Printer.pp_unop/g\"" \ -e "\"s/!Ast_printer.d_binop/Printer.pp_binop/g\"" \ \ -e "\"s/Cil.compareLoc/Cil_datatype.Location.compare/g\"" \ -e "\"s/Cil.d_thisLoc/Cil.pp_thisLoc/g\"" \ -e "\"s/Cil.d_loc/Printer.pp_location/g\"" \ -e "\"s/Cil.d_constant/Printer.pp_constant/g\"" \ -e "\"s/Cil.d_ikind/Printer.pp_ikind/g\"" \ -e "\"s/Cil.d_type/Printer.pp_typ/g\"" \ -e "\"s/Cil.d_exp/Printer.pp_exp/g\"" \ -e "\"s/Cil.d_var/Printer.pp_varinfo/g\"" \ -e "\"s/Cil.d_lval/Printer.pp_lval/g\"" \ -e "\"s/Cil.d_offset/Printer.pp_offset/g\"" \ -e "\"s/Cil.d_init/Printer.pp_init/g\"" \ -e "\"s/Cil.d_binop/Printer.pp_binop/g\"" \ -e "\"s/Cil.d_unop/Printer.pp_unop/g\"" \ -e "\"s/Cil.d_attr/Printer.pp_attribute/g\"" \ -e "\"s/Cil.d_attrparam/Printer.pp_attrparam/g\"" \ -e "\"s/Cil.d_attrlist/Printer.pp_attributes/g\"" \ -e "\"s/Cil.d_label/Printer.pp_label/g\"" \ -e "\"s/Cil.d_stmt/Printer.pp_stmt/g\"" \ -e "\"s/Cil.d_block/Printer.pp_block/g\"" \ -e "\"s/Cil.d_global/Printer.pp_global/g\"" \ -e "\"s/Cil.d_file/Printer.pp_file/g\"" \ -e "\"s/Cil.d_relation/Printer.pp_relation/g\"" \ -e "\"s/Cil.d_model_info/Printer.pp_model_info/g\"" \ -e "\"s/Cil.d_term_lval/Printer.pp_term_lval/g\"" \ -e "\"s/Cil.d_logic_var/Printer.pp_logic_var/g\"" \ -e "\"s/Cil.d_logic_type/Printer.pp_logic_type/g\"" \ -e "\"s/Cil.d_identified_term/Printer.pp_identified_term/g\"" \ -e "\"s/Cil.d_term/Printer.pp_term/g\"" \ -e "\"s/Cil.d_term_offset/Printer.pp_term_offset/g\"" \ -e "\"s/Cil.d_predicate_named/Printer.pp_predicate_named/g\"" \ -e "\"s/Cil.d_identified_predicate/Printer.pp_identified_predicate/g\"" \ -e "\"s/Cil.d_code_annotation/Printer.pp_code_annotation/g\"" \ -e "\"s/Cil.d_funspec/Printer.pp_funspec/g\"" \ -e "\"s/Cil.d_behavior/Printer.pp_behavior/g\"" \ -e "\"s/Cil.d_annotation/Printer.pp_code_annotation/g\"" \ -e "\"s/Cil.d_decreases/Printer.pp_decreases/g\"" \ -e "\"s/Cil.d_loop_variant/Printer.pp_variant/g\"" \ -e "\"s/Cil.d_from/Printer.pp_from/g\"" \ -e "\"s/Cil.d_assigns/Printer.pp_assigns/g\"" \ -e "\"s/Cil.d_allocation/Printer.pp_allocation/g\"" \ -e "\"s/Cil.d_loop_from/Printer.pp_loop_from/g\"" \ -e "\"s/Cil.defaultCilPrinterClass/Printer.extensible_printer/g\"" \ -e "\"s/!Cilutil.list_last/Extlib.last/g\"" \ -e "\"s/!Cilutil.list_iteri/Extlib.iteri/g\"" \ -e "\"s/!Cilutil.swap/Extlib.swap/g\"" \ -e "\"s/!Cilutil./Extlib./g\"" \ -e "\"s/location_shift/shift/g\"" \ -e "\"s/alignOf_int/bytesAlignOf/g\"" \ -e "\"s/valid_enumerate_bits/enumerate_valid_bits/g\"" \ -e "\"s/Value_aux.accept_base/!Db.Semantic_callgraph.accept_base/g\"" \ -e "\"s/Value_aux/Value_types/g\"" \ \ $file } apply_one_dir () { if [ "$VERBOSE" ]; then echo "Processing directory `pwd`" fi for f in `ls -p1 *.ml* 2> /dev/null`; do process_file $f done } apply_recursively () { apply_one_dir for d in `ls -p1 | grep \/`; do safe_goto $d .. apply_recursively done } applying_to_list () { dirs tmpdir=`pwd` for d in $DIR; do goto $d $tmpdir $1 done } help () { echo "Usage: $NAME [options | directories] Options are: -r | --recursive Check subdirectories recursively -h | --help Display help message -q | --quiet Quiet mode (i.e. non-verbose mode) -v | --verbose Verbose mode (default)" exit 0 } error () { echo "$1. Do \"$NAME -h\" for help." exit 1 } FN="apply_one_dir" parse_arg () { case $1 in -r | --recursive) FN="apply_recursively";; -h | -help ) help; exit 0;; -q | --quiet ) VERBOSE=;; -v | --verbose ) VERBOSE="v";; -* ) error "Invalid option $1";; * ) DIR="$DIR $1";; esac } cmd_line () { for s in $ARGS; do parse_arg $s done applying_to_list $FN } cmd_line exit 0 frama-c-Fluorine-20130601/bin/sed_get_make_minor0000644000175000017500000000005312155630367020311 0ustar mehdimehdis/.* Make[^0-9]*[0-9]*\.\([0-9]*\).*$/\1/p frama-c-Fluorine-20130601/.make-clean0000644000175000017500000000000012155630370015763 0ustar mehdimehdiframa-c-Fluorine-20130601/licenses/0000755000175000017500000000000012155634040015602 5ustar mehdimehdiframa-c-Fluorine-20130601/licenses/GPLv30000644000175000017500000010451312155630331016423 0ustar mehdimehdi GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program 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 for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . frama-c-Fluorine-20130601/licenses/LGPLv30000644000175000017500000001672712155630331016550 0ustar mehdimehdi GNU LESSER GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. This version of the GNU Lesser General Public License incorporates the terms and conditions of version 3 of the GNU General Public License, supplemented by the additional permissions listed below. 0. Additional Definitions. As used herein, "this License" refers to version 3 of the GNU Lesser General Public License, and the "GNU GPL" refers to version 3 of the GNU General Public License. "The Library" refers to a covered work governed by this License, other than an Application or a Combined Work as defined below. An "Application" is any work that makes use of an interface provided by the Library, but which is not otherwise based on the Library. Defining a subclass of a class defined by the Library is deemed a mode of using an interface provided by the Library. A "Combined Work" is a work produced by combining or linking an Application with the Library. The particular version of the Library with which the Combined Work was made is also called the "Linked Version". The "Minimal Corresponding Source" for a Combined Work means the Corresponding Source for the Combined Work, excluding any source code for portions of the Combined Work that, considered in isolation, are based on the Application, and not on the Linked Version. The "Corresponding Application Code" for a Combined Work means the object code and/or source code for the Application, including any data and utility programs needed for reproducing the Combined Work from the Application, but excluding the System Libraries of the Combined Work. 1. Exception to Section 3 of the GNU GPL. You may convey a covered work under sections 3 and 4 of this License without being bound by section 3 of the GNU GPL. 2. Conveying Modified Versions. If you modify a copy of the Library, and, in your modifications, a facility refers to a function or data to be supplied by an Application that uses the facility (other than as an argument passed when the facility is invoked), then you may convey a copy of the modified version: a) under this License, provided that you make a good faith effort to ensure that, in the event an Application does not supply the function or data, the facility still operates, and performs whatever part of its purpose remains meaningful, or b) under the GNU GPL, with none of the additional permissions of this License applicable to that copy. 3. Object Code Incorporating Material from Library Header Files. The object code form of an Application may incorporate material from a header file that is part of the Library. You may convey such object code under terms of your choice, provided that, if the incorporated material is not limited to numerical parameters, data structure layouts and accessors, or small macros, inline functions and templates (ten or fewer lines in length), you do both of the following: a) Give prominent notice with each copy of the object code that the Library is used in it and that the Library and its use are covered by this License. b) Accompany the object code with a copy of the GNU GPL and this license document. 4. Combined Works. You may convey a Combined Work under terms of your choice that, taken together, effectively do not restrict modification of the portions of the Library contained in the Combined Work and reverse engineering for debugging such modifications, if you also do each of the following: a) Give prominent notice with each copy of the Combined Work that the Library is used in it and that the Library and its use are covered by this License. b) Accompany the Combined Work with a copy of the GNU GPL and this license document. c) For a Combined Work that displays copyright notices during execution, include the copyright notice for the Library among these notices, as well as a reference directing the user to the copies of the GNU GPL and this license document. d) Do one of the following: 0) Convey the Minimal Corresponding Source under the terms of this License, and the Corresponding Application Code in a form suitable for, and under terms that permit, the user to recombine or relink the Application with a modified version of the Linked Version to produce a modified Combined Work, in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source. 1) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (a) uses at run time a copy of the Library already present on the user's computer system, and (b) will operate properly with a modified version of the Library that is interface-compatible with the Linked Version. e) Provide Installation Information, but only if you would otherwise be required to provide such information under section 6 of the GNU GPL, and only to the extent that such information is necessary to install and execute a modified version of the Combined Work produced by recombining or relinking the Application with a modified version of the Linked Version. (If you use option 4d0, the Installation Information must accompany the Minimal Corresponding Source and Corresponding Application Code. If you use option 4d1, you must provide the Installation Information in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source.) 5. Combined Libraries. You may place library facilities that are a work based on the Library side by side in a single library together with other library facilities that are not Applications and are not covered by this License, and convey such a combined library under terms of your choice, if you do both of the following: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities, conveyed under the terms of this License. b) Give prominent notice with the combined library that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 6. Revised Versions of the GNU Lesser General Public License. The Free Software Foundation may publish revised and/or new versions of the GNU Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library as you received it specifies that a certain numbered version of the GNU Lesser General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that published version or of any later version published by the Free Software Foundation. If the Library as you received it does not specify a version number of the GNU Lesser General Public License, you may choose any version of the GNU Lesser General Public License ever published by the Free Software Foundation. If the Library as you received it specifies that a proxy can decide whether future versions of the GNU Lesser General Public License shall apply, that proxy's public statement of acceptance of any version is permanent authorization for you to choose that version for the Library. frama-c-Fluorine-20130601/licenses/LGPLv2.10000644000175000017500000005747612155630331016714 0ustar mehdimehdi GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS frama-c-Fluorine-20130601/licenses/LGPLv20000644000175000017500000006144712155630331016546 0ustar mehdimehdi GNU LIBRARY GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1991 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the library GPL. It is numbered 2 because it goes with version 2 of the ordinary GPL.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Library General Public License, applies to some specially designated Free Software Foundation software, and to any other libraries whose authors decide to use it. You can use it for your libraries, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library, or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link a program with the library, you must provide complete object files to the recipients so that they can relink them with the library, after making changes to the library and recompiling it. And you must show them these terms so they know their rights. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also compile or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. c) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. d) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Library General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! frama-c-Fluorine-20130601/licenses/Q_MODIFIED_LICENSE0000644000175000017500000007577612155630331020354 0ustar mehdimehdiIn the following, "the Library" refers to the following file: standard.mly and "the Generator" refers to all files marked "Copyright INRIA" in the root directory. The Generator is distributed under the terms of the Q Public License version 1.0 with a change to choice of law (included below). The Library is distributed under the terms of the GNU Library General Public License version 2 (included below). As a special exception to the Q Public Licence, you may develop application programs, reusable components and other software items that link with the original or modified versions of the Generator and are not made available to the general public, without any of the additional requirements listed in clause 6c of the Q Public licence. As a special exception to the GNU Library General Public License, you may link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Library General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library as distributed by INRIA, or a modified version of the Library that is distributed under the conditions defined in clause 3 of the GNU Library General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Library General Public License. ---------------------------------------------------------------------- THE Q PUBLIC LICENSE version 1.0 Copyright (C) 1999 Troll Tech AS, Norway. Everyone is permitted to copy and distribute this license document. The intent of this license is to establish freedom to share and change the software regulated by this license under the open source model. This license applies to any software containing a notice placed by the copyright holder saying that it may be distributed under the terms of the Q Public License version 1.0. Such software is herein referred to as the Software. This license covers modification and distribution of the Software, use of third-party application programs based on the Software, and development of free software which uses the Software. Granted Rights 1. You are granted the non-exclusive rights set forth in this license provided you agree to and comply with any and all conditions in this license. Whole or partial distribution of the Software, or software items that link with the Software, in any form signifies acceptance of this license. 2. You may copy and distribute the Software in unmodified form provided that the entire package, including - but not restricted to - copyright, trademark notices and disclaimers, as released by the initial developer of the Software, is distributed. 3. You may make modifications to the Software and distribute your modifications, in a form that is separate from the Software, such as patches. The following restrictions apply to modifications: a. Modifications must not alter or remove any copyright notices in the Software. b. When modifications to the Software are released under this license, a non-exclusive royalty-free right is granted to the initial developer of the Software to distribute your modification in future versions of the Software provided such versions remain available under these terms in addition to any other license(s) of the initial developer. 4. You may distribute machine-executable forms of the Software or machine-executable forms of modified versions of the Software, provided that you meet these restrictions: a. You must include this license document in the distribution. b. You must ensure that all recipients of the machine-executable forms are also able to receive the complete machine-readable source code to the distributed Software, including all modifications, without any charge beyond the costs of data transfer, and place prominent notices in the distribution explaining this. c. You must ensure that all modifications included in the machine-executable forms are available under the terms of this license. 5. You may use the original or modified versions of the Software to compile, link and run application programs legally developed by you or by others. 6. You may develop application programs, reusable components and other software items that link with the original or modified versions of the Software. These items, when distributed, are subject to the following requirements: a. You must ensure that all recipients of machine-executable forms of these items are also able to receive and use the complete machine-readable source code to the items without any charge beyond the costs of data transfer. b. You must explicitly license all recipients of your items to use and re-distribute original and modified versions of the items in both machine-executable and source code forms. The recipients must be able to do so without any charges whatsoever, and they must be able to re-distribute to anyone they choose. c. If the items are not available to the general public, and the initial developer of the Software requests a copy of the items, then you must supply one. Limitations of Liability In no event shall the initial developers or copyright holders be liable for any damages whatsoever, including - but not restricted to - lost revenue or profits or other direct, indirect, special, incidental or consequential damages, even if they have been advised of the possibility of such damages, except to the extent invariable law, if any, provides otherwise. No Warranty The Software and this license document are provided AS IS with NO WARRANTY OF ANY KIND, INCLUDING THE WARRANTY OF DESIGN, MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. Choice of Law This license is governed by the Laws of France. ---------------------------------------------------------------------- GNU LIBRARY GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1991 Free Software Foundation, Inc. 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the library GPL. It is numbered 2 because it goes with version 2 of the ordinary GPL.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Library General Public License, applies to some specially designated Free Software Foundation software, and to any other libraries whose authors decide to use it. You can use it for your libraries, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library, or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link a program with the library, you must provide complete object files to the recipients so that they can relink them with the library, after making changes to the library and recompiling it. And you must show them these terms so they know their rights. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also compile or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. c) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. d) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Library General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! frama-c-Fluorine-20130601/.make-ocamlgraph0000644000175000017500000000000012155634034017017 0ustar mehdimehdiframa-c-Fluorine-20130601/doc/0000755000175000017500000000000012155634040014542 5ustar mehdimehdiframa-c-Fluorine-20130601/doc/code/0000755000175000017500000000000012155634040015454 5ustar mehdimehdiframa-c-Fluorine-20130601/doc/code/style.css0000644000175000017500000001255712155630361017342 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ * { margin: 0; padding: 0 } body { color: #222; font-family: "Verdana", sans; font-size: 11px; width: 18cm; margin-left: 2.5cm; margin-top: 0.5cm; margin-bottom: 1cm; padding: 4mm 18mm 4mm 28mm; background: #ffffff url(frama-c.png) no-repeat fixed 5mm 1cm ; } h1 { width: 18cm; font-family: "Optima", "Verdana", "Arial", sans; text-align: left; margin-top: 5mm; margin-bottom: 2mm; padding-left: 3mm; border-left: 20px solid darkorange; } h2 { width: 18cm; font-family: "Optima", "Verdana", "Arial", sans; margin-top: 5mm; margin-bottom: 2mm; padding-left: 3mm; border-bottom: thin solid #404040; } h1.chapter { clear: both; text-align: left; font-family: "Optima", "Verdana", "Arial", sans; font-size: 2.0em; font-weight: normal; color: black; margin: 0.4em 0em 0.4em 0em; padding: 0.4em 0em 0em 0em; border-left: none; border-bottom: thin solid #404040; } h2.section { width: 18cm; font-family: "Optima", "Verdana", "Arial", sans; margin-top: 5mm; margin-bottom: 2mm; padding-left: 3mm; border-bottom: none; border-left: 20px solid darkorange; color: darkred; } h2.section .directory { font-size: smaller ; color: #707070 ; font-familly: "Everson Mono", monospace ; } h3 { width: 18cm; font-family: "Optima", "Verdana", "Arial", sans; color: black; margin-top: 5mm; margin-bottom: 3mm; border-bottom: thin solid #404040; } h4,h5,h6, div.h7, div.h8, div.h9 { margin-left: 4mm; margin-top: 4mm; margin-bottom: 1mm; font-family: "Optima", "Verdana", "Arial", sans; font-size: 10px; font-style: italic; font-weight: bold; color: darkred; } p,ul { margin: 2mm; width: 15cm; margin-left: 0mm; } hr { border: none ; border-top: 1px solid #404040; margin-top: 4mm; margin-bottom: 4mm } a:visited { color: darkblue; text-decoration: none } a:link { color: darkblue; text-decoration: none } a:hover { background-color: lightgray; color: firebrick } a:active { background-color: lightgray; color: darkgreen } .navbar { margin-left: 1cm ; margin-bottom: 4mm ; font-size: 9px ; } .navbar a:link { color: darkgreen; } .navbar a:visited { color: darkgreen; } .keyword { font-weight : bold; color: darkgoldenrod } .keywordsign { color : #C04600 } .superscript { font-size: 7px } .subscript { font-size: 7px } .warning { color: firebrick ; font-style: italic; margin-right:1ex } .info { padding: 1mm 1mm 1mm 1em; margin-top: 0mm; margin-bottom: 2mm; margin-left: 1em; margin-right: 3em; border-left: thin dotted darkgreen; } table .info { border: none } .param_info { margin-top: 4px; margin-left : 3em; margin-right : 3em } .typetable { border-style : hidden } .indextable { margin-left: 3mm; margin-top: 2mm ; padding: 2mm 6mm 2mm 4mm ; border-style : hidden ; border-left: darkgreen thin solid ; } .paramstable { border-style : hidden ; padding: 5pt 5pt } tr { font-size: 11px } td { padding:0 ; margin:2px 5px 2px 10px ; vertical-align: top } td .info { padding:0 ; margin-top:0 ; margin-bottom:0 ; border-left: none ; vertical-align: top } td.typefieldcomment { font-family: serif; color: darkgreen } pre { color : #263F71 ; font-size: 11px; font-family: "Everson Mono", monospace; margin-top: 1mm } .code { color : #465F91 ; font-size: 11px; font-family: "Everson Mono", monospace } .comment { color : darkgreen; font-family: serif } .constructor { color : darkblue } .type { color: #5C6585 } .string { color: maroon } div.sig_block {margin-left: 2em} li { margin-left: 2em } .copyright { margin-top: 5mm; font-size:10px; padding-top: 2mm; border-top: thin solid #404040; } .copyright a:visited { color:darkred } .copyright a:link { color:darkred }frama-c-Fluorine-20130601/doc/code/docgen_lt400.ml0000644000175000017500000003313012155630361020172 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Odoc_module open Odoc_info open Odoc_html let doc_path = ref "." let lib_files = ref [] let add_libfiles analyse s = let f = Odoc_args.Intf_file s in lib_files := (String.capitalize (Filename.chop_extension (Filename.basename s))) :: !lib_files; if analyse then Odoc_args.files := f :: !Odoc_args.files let rec root_name s = let simple = Odoc_info.Name.simple s in let father = Odoc_info.Name.father s in if father = "" then simple else root_name father let equal_module_name m s = let n = m.m_name in n = s && n = root_name n let equal_module m1 m2 = equal_module_name m1 m2.m_name type chapter = Chapter of int * string * string | Directory of string let compare_chapter c1 c2 = match c1 , c2 with | Chapter(a,_,_) , Chapter(b,_,_) -> a-b | Directory a , Directory b -> compare a b | Chapter _ , Directory _ -> (-1) | Directory _ , Chapter _ -> 1 let merge3 (s1 : 'a -> 'a -> int) (s2 : 'b -> 'b -> int) (s3 : 'c -> 'c -> int) (triplets : ('a * 'b * 'c) list) : ('a * ('b * 'c list) list) list = let sort3_rev s1 s2 s3 (x,y,z) (x',y',z') = let c = s1 x' x in if c <> 0 then c else let c = s2 y' y in if c <> 0 then c else s3 z' z in let rec merge3_rev acc triplets = match triplets , acc with | [] , _ -> acc | (a,b,c)::tail , (dir_a,all_a)::a_merged when a = dir_a -> begin match all_a with | (dir_b,all_b)::b_merged when b = dir_b -> merge3_rev ((dir_a,(dir_b,c::all_b)::b_merged)::a_merged) tail | _ -> merge3_rev ((dir_a,(b,[c])::all_a)::a_merged) tail end | (a,b,c)::tail , merged -> merge3_rev (( a , [b,[c]] )::merged) tail in merge3_rev [] (List.sort (sort3_rev s1 s2 s3) triplets) class gen = object (self) inherit html as super val mutable memo = [] method loaded_modules = match memo with | [] -> let l = List.flatten (List.map (fun f -> Odoc_info.verbose (Odoc_messages.loading f); try let l = Odoc_analyse.load_modules f in Odoc_info.verbose Odoc_messages.ok; l with Failure s -> prerr_endline s ; incr Odoc_global.errors ; [] ) !Odoc_args.load ) in memo <- l; l | (_ :: _) as l -> l method path s = let name = root_name s in if List.exists (fun m -> m = name) !lib_files then "http://caml.inria.fr/pub/docs/manual-ocaml/libref/" else if List.exists (fun m -> m.m_name = name) self#loaded_modules then !doc_path ^ "/" else "./" method create_fully_qualified_idents_links m_name s = let f str_t = let match_s = Str.matched_string str_t in let rel = Odoc_info.Name.get_relative m_name match_s in let s_final = Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s rel in if StringSet.mem match_s known_types_names then "" ^ s_final ^ "" else if StringSet.mem match_s known_classes_names then let (html_file, _) = Naming.html_files match_s in ""^s_final^"" else s_final in let s2 = Str.global_substitute (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") f s in s2 (** Take a string and return the string where fully qualified module idents have been replaced by links to the module referenced by the ident.*) method create_fully_qualified_module_idents_links m_name s = let f str_t = let match_s = Str.matched_string str_t in let rel = Odoc_info.Name.get_relative m_name match_s in let s_final = Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s rel in if StringSet.mem match_s known_modules_names then let (html_file, _) = Naming.html_files match_s in ""^s_final^"" else s_final in let s2 = Str.global_substitute (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)") f s in s2 (** redefine from file odoc_html.ml *) method html_of_Module_list b l = let dir f = (* , *) let chop dir f = let n = Str.search_forward (Str.regexp dir) f 0 in let f = String.sub f n (String.length f - n) in let d = Filename.dirname f in String.capitalize (Filename.basename d) in try Chapter(2,"C & ACSL","cil") , chop "cil/" f with Not_found -> try Chapter(1,"Frama-C","src") , chop "src/" f with Not_found -> let d = Filename.dirname f in Directory (Filename.basename (Filename.dirname d)) , String.capitalize (Filename.basename d) in let structured_modules (* chapter, section, module *) = (List.map (fun name -> let m = List.find (fun m -> m.m_name = name) self#list_modules in let dir,name = dir m.m_file in dir,name,m) l) in let toc_modules (* chapter/section/modules *) = merge3 compare_chapter compare compare structured_modules in List.iter (fun (chapter, subdirs) -> let dir = ( match chapter with | Chapter (n,a,d) -> bp b "

Chapter %d. %s

" n a ; d | Directory d -> bp b "

Directory %s

" d ; d) in List.iter (fun (subdir,modules) -> bp b "

Section %s (in %s/%s)

\n" subdir dir (String.lowercase subdir) ; bs b "
\n\n"; List.iter (fun m -> bs b "" html m.m_name; bs b "\n") modules; bs b "
"; (try let (html, _) = Naming.html_files m.m_name in bp b "%s"; self#html_of_info_first_sentence b m.m_info; with Not_found -> Odoc_messages.pwarning (Odoc_messages.cross_module_not_found m.m_name); bp b "%s" m.m_name); bs b "
\n") subdirs) toc_modules (** Print html code for an included module. *) method html_of_included_module b im = bs b "
";
    bs b ((self#keyword "include")^" ");
    (
      match im.im_module with
        None ->
          bs b im.im_name
      | Some mmt ->
        let (file, name) =
          match mmt with
            Mod m ->
              let (html_file, _) = Naming.html_files m.m_name in
              (html_file, m.m_name)
          | Modtype mt ->
            let (html_file, _) =
	      Naming.html_files mt.mt_name
	    in
            (html_file, mt.mt_name)
        in
        bp b "%s" (self#path name) file name
    );
    bs b "
\n"; self#html_of_info b im.im_info (** Generate all the html files from a module list. The main file is [.html]. *) method generate module_list = (* init the style *) self#init_style ; (* init the lists of elements *) list_values <- Odoc_info.Search.values module_list ; list_exceptions <- Odoc_info.Search.exceptions module_list ; list_types <- Odoc_info.Search.types module_list ; list_attributes <- Odoc_info.Search.attributes module_list ; list_methods <- Odoc_info.Search.methods module_list ; list_classes <- Odoc_info.Search.classes module_list ; list_class_types <- Odoc_info.Search.class_types module_list ; list_modules <- Odoc_info.Search.modules module_list ; list_module_types <- Odoc_info.Search.module_types module_list ; (* prepare the page header *) self#prepare_header module_list ; (* Get the names of all known types. *) let types = Odoc_info.Search.types module_list in known_types_names <- List.fold_left (fun acc t -> StringSet.add t.Odoc_type.ty_name acc) known_types_names types ; (* Get the names of all class and class types. *) let classes = Odoc_info.Search.classes module_list in let class_types = Odoc_info.Search.class_types module_list in known_classes_names <- List.fold_left (fun acc c -> StringSet.add c.Odoc_class.cl_name acc) known_classes_names classes ; known_classes_names <- List.fold_left (fun acc ct -> StringSet.add ct.Odoc_class.clt_name acc) known_classes_names class_types ; (* Get the names of all known modules and module types. *) let module_types = Odoc_info.Search.module_types module_list in let modules = Odoc_info.Search.modules module_list in known_modules_names <- List.fold_left (fun acc m -> StringSet.add m.m_name acc) known_modules_names modules ; known_modules_names <- List.fold_left (fun acc mt -> StringSet.add mt.mt_name acc) known_modules_names module_types ; (* generate html for each module *) let keep_list = let keep m = not (List.exists (equal_module m) self#loaded_modules) && not (List.exists (equal_module_name m) !lib_files) in List.filter keep module_list in if not !Odoc_args.index_only then self#generate_elements self#generate_for_module keep_list ; (* reinit the lists of elements *) list_values <- Odoc_info.Search.values keep_list ; list_exceptions <- Odoc_info.Search.exceptions keep_list ; list_types <- Odoc_info.Search.types keep_list ; list_attributes <- Odoc_info.Search.attributes keep_list ; list_methods <- Odoc_info.Search.methods keep_list ; list_classes <- Odoc_info.Search.classes keep_list ; list_class_types <- Odoc_info.Search.class_types keep_list ; list_modules <- Odoc_info.Search.modules keep_list ; list_module_types <- Odoc_info.Search.module_types keep_list ; try self#generate_index keep_list; self#generate_values_index keep_list ; self#generate_exceptions_index keep_list ; self#generate_types_index keep_list ; self#generate_attributes_index keep_list ; self#generate_methods_index keep_list ; self#generate_classes_index keep_list ; self#generate_class_types_index keep_list ; self#generate_modules_index keep_list ; self#generate_module_types_index keep_list ; with Failure s -> prerr_endline s ; incr Odoc_info.errors method private html_of_plugin_developer_guide _t = "Consult the Plugin Development Guide for additional details.
\n" method private html_of_ignore _t = "" method private html_of_modify t = match t with | [] -> Odoc_info.warning "Found an empty @modify tag"; "" | Raw s :: l -> let time, explanation = try let idx = String.index s ' ' in String.sub s 0 idx, ":" ^ String.sub s idx (String.length s - idx) with Not_found -> s, "" in let text = Bold [ Raw "Change in "; Raw time ] :: Raw explanation :: l in let buf = Buffer.create 7 in self#html_of_text buf text; Buffer.add_string buf "
\n"; Buffer.contents buf | _ :: _ -> assert false method private html_of_call t = match t with | [] -> Odoc_info.warning "Found an empty @call tag"; "" | l -> let buf = Buffer.create 97 in Buffer.add_string buf "Access it by "; self#html_of_text buf l; Buffer.add_string buf "\n"; Buffer.contents buf (* Write the subtitle (eg. "Frama-C Kernel" after the main title instead of before, for users that use many tabs in their browser *) method inner_title s = match self#title with "" -> "" | t -> self#escape s ^ " - " ^ t initializer tag_functions <- ("modify", self#html_of_modify) :: ("ignore", self#html_of_ignore) :: ("call", self#html_of_call) :: ("plugin", self#html_of_plugin_developer_guide) :: tag_functions end let () = Odoc_args.set_doc_generator (Some (new gen :> Odoc_args.doc_generator)); Odoc_args.add_option ("-docpath", Arg.Set_string doc_path, "Frama-C documentation directory"); Odoc_args.add_option ("-stdlib", Arg.String (add_libfiles true), "Standard library files"); Odoc_args.add_option ("-stdlib-path", Arg.String (add_libfiles false), "Standard library files") frama-c-Fluorine-20130601/doc/code/toc_head.htm0000644000175000017500000000375112155630361017744 0ustar mehdimehdi Frama-C API

Frama-C API Documentation

  • Frama-C Kernel
    • frama-c-Fluorine-20130601/doc/code/intro_wp.txt0000644000175000017500000000345512155630361020067 0ustar mehdimehdi@ignore @ignore @ignore This file is part of WP plug-in of Frama-C. @ignore @ignore Copyright (C) 2007-2013 @ignore CEA (Commissariat a l'energie atomique et aux energies @ignore alternatives) @ignore @ignore you can redistribute it and/or modify it under the terms of the GNU @ignore Lesser General Public License as published by the Free Software @ignore Foundation, version 2.1. @ignore @ignore It is distributed in the hope that it will be useful, @ignore but WITHOUT ANY WARRANTY; without even the implied warranty of @ignore MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the @ignore GNU Lesser General Public License for more details. @ignore @ignore See the GNU Lesser General Public License version 2.1 @ignore for more details (enclosed in the file licenses/LGPLv2.1). @ignore @ignore {2 Overview} The WP plugin is dedicated to compute Weakest-Preconditions using different memory models. It is experimental and still under development. frama-c-Fluorine-20130601/doc/code/intro_sparecode.txt0000644000175000017500000000550112155630361021400 0ustar mehdimehdi@ignore @ignore @ignore This file is part of Frama-C. @ignore @ignore Copyright (C) 2007-2013 @ignore CEA (Commissariat l'nergie atomique et aux nergies @ignore alternatives) @ignore @ignore you can redistribute it and/or modify it under the terms of the GNU @ignore Lesser General Public License as published by the Free Software @ignore Foundation, version 2.1. @ignore @ignore It is distributed in the hope that it will be useful, @ignore but WITHOUT ANY WARRANTY; without even the implied warranty of @ignore MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the @ignore GNU Lesser General Public License for more details. @ignore @ignore See the GNU Lesser General Public License version 2.1 @ignore for more details (enclosed in the file licenses/LGPLv2.1). @ignore @ignore {2 Overview} The Sparecode module aims at removing the unused code. It is composed of to parts : - one (in module {!module:Marks}) that computes some information to say what has to be kept in the result. It uses the generic PDG marking facility {{:../pdg/PdgMarks.html}PdgMarks}+{{:../pdg/Marks.html}Marks}, - and a second one (module {!module:Transform}) that read thoses results to produce a new application. This part mainly use {{:../html/Filter.html}Filter} which provides a functor that filters an application to create another one. To select the useful statements, we start from the [main] outputs and the reachable annotations, and mark backward all the dependencies. When reaching a function call, the called function statements are also marked according to the needed outputs, but the inputs are not propagated immediately because it would make every function call visible. The information provided by the PDG marking system is kept to be used later. So, after the first step, we iterate on the input marks to propagate, and propagate them only for the visible calls, ie those which have at least one visible output. This process is repeated as long as there are some modification. frama-c-Fluorine-20130601/doc/code/intro_scope.txt0000644000175000017500000000411212155630361020541 0ustar mehdimehdi@ignore @ignore @ignore This file is part of Frama-C. @ignore @ignore Copyright (C) 2007-2013 @ignore CEA (Commissariat l'nergie atomique et aux nergies @ignore alternatives) @ignore @ignore you can redistribute it and/or modify it under the terms of the GNU @ignore Lesser General Public License as published by the Free Software @ignore Foundation, version 2.1. @ignore @ignore It is distributed in the hope that it will be useful, @ignore but WITHOUT ANY WARRANTY; without even the implied warranty of @ignore MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the @ignore GNU Lesser General Public License for more details. @ignore @ignore See the GNU Lesser General Public License version 2.1 @ignore for more details (enclosed in the file licenses/LGPLv2.1). @ignore @ignore {2 Overview} See how to use the plugin in the {{:../../www/src/scope.html}user documentation}. (see also {{:../../scope/scope.txt}there} for a discussion on how we arrived to those definitions) {2 Inside the plugin} The code of this plugin is quite simple. It is only composed of : - {!module:Datascope_gui} that handles the GUI part, - and {!module:Datascope} that makes the computations. Some explanations can be found in the code. frama-c-Fluorine-20130601/doc/code/print_api/0000755000175000017500000000000012155634040017441 5ustar mehdimehdiframa-c-Fluorine-20130601/doc/code/print_api/grammar.mly0000644000175000017500000000461112155630361021616 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ %{ %} %token WORD %token LPAR %token RPAR %token COMMA %token EOF %start main %type main %% main: type_string EOF { $1 } word: WORD { $1 } type_string: word { $1 } | type_string word { "'a "^$2 } | LPAR type_string COMMA type_string RPAR word { "('a,'b) "^$6 } | LPAR type_string COMMA type_string COMMA type_string RPAR word { "('a,'b,'c) "^$8 } | LPAR type_string COMMA type_string COMMA type_string COMMA type_string RPAR word { "('a,'b,'c,'d) "^$10 } frama-c-Fluorine-20130601/doc/code/print_api/print_interface.ml0000644000175000017500000002637112155630361023162 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Register the new plugin. *) module Self = Plugin.Register (struct let name = "Print interface" let shortname = "print_api" let help = "This plugin creates a file containing all\ the registered signatures of the dynamic plugins" end) (** Register the new Frama-C option "-print_api". *) module Enabled = Self.String (struct let option_name = "-print_api" let help = "creates a .mli file for the dynamic plugins" let arg_name = " the absolute path for the .mli to be created" let default = "" end) type function_element = { name: string; type_string: string; datatype_string: string } (** Each object of the table is going to be composed of : (function_name, type_string) and its corresponding key is "plugin_name" *) let functions_tbl = Hashtbl.create 97 (** [type_to_add] contains types not referenced in [reference] and to be added in the interface. The list [reference] contains the names of the regular types of OCaml and the registered types of static plugins and kernel *) let type_to_add = Hashtbl.create 97 let reference = Config.compilation_unit_names (** Comments are registered appart in the module Dynamic *) let comment_tbl:(string,string) Hashtbl.t = Hashtbl.create 97 let add_comment s1 s2 = match s2 with | "" -> () | _ -> Hashtbl.add comment_tbl s1 s2 (**returns a list of the substrings *) let split_dot s = Str.split (Str.regexp_string ".") s let get_name i s = let li = split_dot s in let rec get_name_aux i j l = if i < j then match i,l with | _,[] -> "" | 0,h::_ -> h | _,_::q -> get_name_aux (i-1) (j-1) q else "" in get_name_aux i (List.length li) li let sub_string_dot i s = let rec sub_string_dot_aux j st = if j < i then get_name j st ^ "." ^ sub_string_dot_aux (j+1) st else get_name i st in sub_string_dot_aux 0 s (** when considering s= "plugin_name_0.plugin_name_1.function_name", [function_name s] = "function_name" *) let function_name s = let rec function_name_aux i s = match i , get_name (i+2) s , get_name (i+1) s with | 0,"","" -> "" | _,"",f -> f | _,_,_ -> function_name_aux (i+1) s in function_name_aux 0 s (** when considering s = "plugin_name_0.plugin_name_1.function_name", [plugin_name s] ="plugin_name_0.plugin_name_1" *) let plugin_name s = let rec plugin_name_aux i s = match i , get_name (i+2) s , get_name (i+1) s with | 0,"","" -> get_name 0 s | _,"",_ -> sub_string_dot i s | _,_,_ -> plugin_name_aux (i+1) s in plugin_name_aux 0 s let sub_string_dot_compare i s1 s2 = sub_string_dot i s1 = sub_string_dot i s2 (** [analyse_type] is called each time a new value is added to [functions_tbl] in the function [fill_tbl]. It considers what is given by [Type.get_embedded_type_name type_string], tests if the type to analyse is not already recorded in the [reference] list or creates the corresponding type in the Hashtable [type_to add] where the key is the module name of this type. *) let analyse_type name l = let add_type tbl name module_name typ = let add_type_aux t s ty = let temp = try Hashtbl.find_all t s with Not_found ->[] in if not(List.mem ty temp) then Hashtbl.add t s ty in if function_name name = module_name then add_type_aux tbl name typ else add_type_aux tbl module_name typ in let analyse_type_aux s = if not (String.contains s '>') && (String.contains s '.') then if not (String.contains s ' ') then begin let s_name = get_name 0 s in if not (List.mem s_name reference) && not (List.mem (String.lowercase s_name) reference) then let typ_n = function_name s in let module_name = plugin_name s in add_type type_to_add name module_name typ_n end else let lexbuf = Lexing.from_string s in let param,type_name = match Str.split (Str.regexp_string " ") (Grammar.main Lexer.token lexbuf) with | h::[] -> "",h | h1::h2::[] -> h1,h2 | _ -> "","" in let ty_name = get_name 0 type_name in if String.contains type_name '.' && not (List.mem ty_name reference) && not (List.mem (String.lowercase ty_name) reference) then let typ_n =param^" "^(function_name type_name) in let module_name = plugin_name type_name in add_type type_to_add name module_name typ_n in List.iter analyse_type_aux (List.rev l) let is_option key = String.length key > 1 && String.rcontains_from key 1 '-' (** It fills [function_tbl] with the content of [dynamic_values] which is a Hashtable recorded in the module Dynamic. This Hashtable also contains options like: "-hello-help" or "-hello-debug". The 'if' is taking away this useless strings and the module named "Dynamic" and fills the table with the suitable names. *) let fill_tbl key typ _ = if not (is_option key || get_name 0 key = "Dynamic") then let type_list = Type.get_embedded_type_names typ in let func_elem = { name = function_name key ; type_string = Type.name typ ; datatype_string = Type.ml_name typ } in Hashtbl.add functions_tbl (plugin_name key) func_elem; analyse_type (plugin_name key) type_list (** It replaces the sub-strings "Plugin.type" of all the string [type_string] used in the module named "Plugin" by "type". It also removes the option stucture (ex : "~gid:string" is replaced by "string"). *) let repair_type module_name type_string = let rec remove_param_name s = try let c= String.index s ':' in try let n = String.index s '~' in if n < c then match n with | 0 -> remove_param_name (Str.string_after s (c+1)) | _ -> remove_param_name (Str.string_before s n) ^ remove_param_name (Str.string_after s (c+1)) else s with Not_found -> (match c with | 0 -> remove_param_name (Str.string_after s (c+1)) | _ -> let sp = String.rindex (Str.string_before s c) ' ' in remove_param_name (Str.string_before s (sp + 1)) ^ remove_param_name (Str.string_after s (c + 1))) with Not_found -> s in let remove_name_module s module_n = Str.global_replace (Str.regexp (module_n ^ "\\.")) "" s in match split_dot module_name with | [] -> type_string | _ as l -> List.fold_left remove_name_module (remove_param_name type_string) l (** For each key of the table [functions_tbl], [print_plugin] takes all the pieces of information found in the Hashtable [dynamic_values] of the module Dynamic and stored in the 3 Hashtables ([functions_tb]l, [type_to_add], [comment_tbl]) and builds up a string in order to write the signature of this module in the .mli file *) let print_plugin chan = let module_list = ref [] in let rec space i = match i with | 0 -> "" | _ -> space (i-1) ^ " " in let rec print_type c sp l = match l with | [] -> () | h :: q -> output_string c ("\n" ^ sp ^ "type " ^ h); print_type c sp q in let rec print_one_plugin channel i key1 = if not (get_name i key1 = "") then let module_name = sub_string_dot i key1 in if not (List.mem module_name !module_list) then begin module_list := module_name::!module_list ; let s = get_name i key1 in output_string channel ("\n \n" ^ space i ^ "module " ^ String.capitalize s ^ ":\n" ^ space i ^ "sig ") ; let module_types = try Hashtbl.find_all type_to_add module_name with Not_found -> [] in print_type channel (space i) module_types ; let print_one_plugin_aux key elem = if sub_string_dot i key = module_name then let succ_i = succ i in if get_name succ_i key = "" then begin let typ_name = elem.type_string in let fct_name = elem.name in let message = "\n" ^ space i ^ " val "^ fct_name ^ " : " ^ repair_type module_name typ_name in let standard_comment = "@call Dynamic.get ~plugin:\"" ^ module_name ^ "\" \"" ^ fct_name ^ "\" " ^ elem.datatype_string in let found_comment = try Hashtbl.find comment_tbl (key ^ "." ^ fct_name) with Not_found -> "" in let comment = "\n" ^ space i ^ " (**" ^ standard_comment ^ "\n" ^ found_comment ^ " *)\n" in output_string channel (message ^ comment); Hashtbl.remove functions_tbl key end else print_one_plugin channel succ_i key in Hashtbl.iter print_one_plugin_aux functions_tbl ; output_string channel ("\n" ^ space i ^ "end") end in let print_all i key _ = print_one_plugin chan i key in Hashtbl.iter (print_all 0) functions_tbl (** [print] is the main function of this module. It takes one argument which is the path and opens the file path/dynamic_plugins.mli. It fills [functions_tbl], [comment_tbl] and [type_to_add] using the functions [fill_tbl] and [add_comment] and then prints the plugins in the file with [print_plugin] *) let print path = try let channel = open_out (path^"/dynamic_plugins.mli") in Dynamic.iter fill_tbl; Dynamic.iter_comment add_comment; output_string channel "(**This module contains all the dynamically \ registered plugins *)" ; print_plugin channel; close_out channel with Sys_error _ as e -> Self.error "%s" (Printexc.to_string e) (** register [print (path : string)] *) let print = Dynamic.register ~comment: "this creates a .mli file used in the Makefile (make doc) \ to create (with ocamldoc) a html documentation.\ It takes the path where to create this file as an argument." ~plugin:"Print_api" "run" ~journalize:true (Datatype.func Datatype.string Datatype.unit) print let run () = if not (Enabled.is_default ()) then print (Enabled.get ()) let () = Db.Main.extend run frama-c-Fluorine-20130601/doc/code/print_api/lexer.mll0000644000175000017500000000352112155630361021271 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) { } rule token = parse | [' ' '\t'] { token lexbuf } | [ ^ '(' ',' ')' ' ' ]* { Grammar.WORD (Lexing.lexeme lexbuf) } | '(' { Grammar.LPAR } | ')' { Grammar.RPAR } | ',' { Grammar.COMMA } | eof {Grammar.EOF } frama-c-Fluorine-20130601/doc/code/print_api/Makefile0000644000175000017500000000435512155630361021112 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## # Print_api plugin ################## # Frama-C should be properly installed with "make install" # befor any use of this makefile ifndef FRAMAC_SHARE FRAMAC_SHARE :=$(shell frama-c.byte -print-path) endif ifndef FRAMAC_LIBDIR FRAMAC_LIBDIR :=$(shell frama-c.byte -print-libpath) endif PLUGIN_DIR ?= . PLUGIN_NAME := Print_api PLUGIN_CMO := grammar lexer print_interface PLUGIN_GENERATED:= $(PLUGIN_DIR)/grammar.ml $(PLUGIN_DIR)/grammar.mli \ $(PLUGIN_DIR)/lexer.ml include $(FRAMAC_SHARE)/Makefile.dynamic clean:: $(RM) $(Print_api_DIR)/dynamic_plugins.mli $(RM) $(Print_api_DIR)/grammar.output $(RM) $(Print_api_DIR)/grammar.ml $(RM) $(Print_api_DIR)/grammar.mli $(RM) $(Print_api_DIR)/lexer.ml frama-c-Fluorine-20130601/doc/code/intro_plugin_D_and_S.txt0000644000175000017500000000457712155630361022314 0ustar mehdimehdi@ignore @ignore @ignore This file is part of Frama-C. @ignore @ignore Copyright (C) 2007-2013 @ignore CEA (Commissariat l'nergie atomique et aux nergies @ignore alternatives) @ignore @ignore you can redistribute it and/or modify it under the terms of the GNU @ignore Lesser General Public License as published by the Free Software @ignore Foundation, version 2.1. @ignore @ignore It is distributed in the hope that it will be useful, @ignore but WITHOUT ANY WARRANTY; without even the implied warranty of @ignore MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the @ignore GNU Lesser General Public License for more details. @ignore @ignore See the GNU Lesser General Public License version 2.1 @ignore for more details (enclosed in the file licenses/LGPLv2.1). @ignore @ignore {2 API Documentation} The _PluginName_ plugin is integrated with the Frama-C kernel: - {{:../index.html}Frama-C} complete kernel API - {{:../html/Db._PluginName_.html}_PluginName_} available kernel API This plugin is also dynamically registered: - {{:../dynamic_plugins/Dynamic_plugins._PluginName_.html}_PluginName_} dynamic API - {{:../dynamic_plugins/Dynamic_plugins.html}dynamically registered plugins} index - {{:../html/Dynamic.html}Dynamic} kernel registery for plugins' API {2 Internal Documentation} - {{:modules.svg}_PluginName_} architecture (SVG format) - Index of {{:index_modules.html}Modules} - Index of {{:index_types.html}Types} - Index of {{:index_values.html}Values} - Index of {{:index_exceptions.html}Exceptions} frama-c-Fluorine-20130601/doc/code/intro_occurrence.txt0000644000175000017500000000432112155630361021562 0ustar mehdimehdi@ignore @ignore @ignore This file is part of Frama-C. @ignore @ignore Copyright (C) 2007-2013 @ignore CEA (Commissariat l'nergie atomique et aux nergies @ignore alternatives) @ignore @ignore you can redistribute it and/or modify it under the terms of the GNU @ignore Lesser General Public License as published by the Free Software @ignore Foundation, version 2.1. @ignore @ignore It is distributed in the hope that it will be useful, @ignore but WITHOUT ANY WARRANTY; without even the implied warranty of @ignore MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the @ignore GNU Lesser General Public License for more details. @ignore @ignore See the GNU Lesser General Public License version 2.1 @ignore for more details (enclosed in the file licenses/LGPLv2.1). @ignore @ignore {2 Overview} The Occurrence module aims at highlighting the occurrence of any variable in the Frama-C GUI. Details about the use of this plugin may be found in {{:http://frama-c.cea.fr/occurrence.html}the user documentation}. {2 Inside the plug-in} The code of this plug-in is quite simple. It is splitted into the analysis itself and the extension to the GUI. The code of this plug-in is quite short but uses most advanced Frama-C features (visitor, projects, journalisation, log, gui). So it is a good complete not-toy example of a (kernel-integrated) Frama-C plug-in. frama-c-Fluorine-20130601/doc/code/intro_plugin.txt0000644000175000017500000000437612155630361020742 0ustar mehdimehdi@ignore @ignore @ignore This file is part of Frama-C. @ignore @ignore Copyright (C) 2007-2013 @ignore CEA (Commissariat l'nergie atomique et aux nergies @ignore alternatives) @ignore @ignore you can redistribute it and/or modify it under the terms of the GNU @ignore Lesser General Public License as published by the Free Software @ignore Foundation, version 2.1. @ignore @ignore It is distributed in the hope that it will be useful, @ignore but WITHOUT ANY WARRANTY; without even the implied warranty of @ignore MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the @ignore GNU Lesser General Public License for more details. @ignore @ignore See the GNU Lesser General Public License version 2.1 @ignore for more details (enclosed in the file licenses/LGPLv2.1). @ignore @ignore {2 API Documentation} The _PluginName_ API is dynamically registered: - {{:../dynamic_plugins/Dynamic_plugins._PluginName_.html} _PluginName_} API - {{:../dynamic_plugins/Dynamic_plugins.html} Dynamically registered plugins} index - {{:../index.html}Frama-C} complete kernel API - {{:../html/Dynamic.html}Dynamic} kernel registry for plugins' API {2 Plugin Internal Documentation} - {{:modules.svg}_PluginName_} architecture (SVG format) - Index of {{:index_modules.html}Modules} - Index of {{:index_types.html}Types} - Index of {{:index_values.html}Values} - Index of {{:index_exceptions.html}Exceptions} frama-c-Fluorine-20130601/doc/code/toc_tail.htm0000644000175000017500000000342112155630361017766 0ustar mehdimehdi
frama-c.com
© 2007-2012 CEA-LIST
frama-c-Fluorine-20130601/doc/code/intro_kernel_plugin.txt0000644000175000017500000000414212155630361022271 0ustar mehdimehdi@ignore @ignore @ignore This file is part of Frama-C. @ignore @ignore Copyright (C) 2007-2013 @ignore CEA (Commissariat l'nergie atomique et aux nergies @ignore alternatives) @ignore @ignore you can redistribute it and/or modify it under the terms of the GNU @ignore Lesser General Public License as published by the Free Software @ignore Foundation, version 2.1. @ignore @ignore It is distributed in the hope that it will be useful, @ignore but WITHOUT ANY WARRANTY; without even the implied warranty of @ignore MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the @ignore GNU Lesser General Public License for more details. @ignore @ignore See the GNU Lesser General Public License version 2.1 @ignore for more details (enclosed in the file licenses/LGPLv2.1). @ignore @ignore {2 API Documentation} The _PluginName_ plugin is integrated with the Frama-C kernel: - {{:../index.html}Frama-C} complete kernel API - {{:../html/Db._PluginName_.html}_PluginName_} available kernel API {2 Internal Documentation} - {{:modules.svg}_PluginName_} architecture (SVG format) - Index of {{:index_modules.html}Modules} - Index of {{:index_types.html}Types} - Index of {{:index_values.html}Values} - Index of {{:index_exceptions.html}Exceptions} frama-c-Fluorine-20130601/doc/code/intro_pdg.txt0000644000175000017500000001216512155630361020211 0ustar mehdimehdi@ignore @ignore @ignore This file is part of Frama-C. @ignore @ignore Copyright (C) 2007-2013 @ignore CEA (Commissariat l'nergie atomique et aux nergies @ignore alternatives) @ignore @ignore you can redistribute it and/or modify it under the terms of the GNU @ignore Lesser General Public License as published by the Free Software @ignore Foundation, version 2.1. @ignore @ignore It is distributed in the hope that it will be useful, @ignore but WITHOUT ANY WARRANTY; without even the implied warranty of @ignore MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the @ignore GNU Lesser General Public License for more details. @ignore @ignore See the GNU Lesser General Public License version 2.1 @ignore for more details (enclosed in the file licenses/LGPLv2.1). @ignore @ignore {2 Overview} The main modules are : - {!module: PdgIndex} that can be used to store different kind of information related to a function (not only related to PDG) - the types are defined in {!module: PdgTypes}. - the PDG computation is done in {!module: Build}. It also use the lexical successor graph, which is computed in {!module:Lexical_successors}. - {!module:Sets} provides functions to read a PDG. - {!module:Print} provides functions to print a PDG either in textual form or in a dot file (See {i "How to see a PDG"} below). {2 What is a PDG ?} A {b Program Dependences Graph} represent the dependences between the statements of a function. So the nodes of the graph mainly represent the statements (some more nodes are used to represents things like declarations, inputs, outputs, etc.) and the edges represent the dependences. [Y -> X] means that the computation of the statement Y depend on (the result of) the statement X. Example : {C {v X : x = a + b; Y : y = x + 1; v}} There are three kinds of dependencies : - a {b data} dependency : the simpler one, illustrated by the above example, - a {b control} dependency : {C Example : {v if (c) X : x = a + b; v}} X is control dependent on (c) because the statement will be executed or not according to the evaluation of the condition, - an {b address} dependency : dependencies on the elements that are used to compute the left part of an assignment, ie that decide which data will be modified. {C Example : {v t[i] = 3; v}} We say that this statement have address dependencies on the declaration of [tab] and the computation of [i]. A dependency between two nodes can have any combination of these kinds. You can find more documentation, particularly on how this graph is built, in this {{:../../pdg/index.html}report} (in French). {2 Dynamic dependencies} After having built the PDG for a function, there is a way of adding dynamically some dependencies to it. There are not stored directly in the PDG so they can be cleared later on. As PDG doesn't interpret the annotations of the code, this feature can for instance be used to add dependencies on assertions. To see an example of how to use it, please have a look at [tests/pdg/dyn_dpds.ml]. {2 How to see a PDG ?} Please, use the [-help] option of the tool to get the PDG options names. The PDG of a function can be seen either in textual form or exported in a {b dot} file which is the format of the {{:http://www.graphviz.org/}Graphviz} tool set. They can be viewed using {{:http://zvtm.sourceforge.net/zgrviewer.html}zgrviewer} or exported in SVG format to be seen with some browser or {{:http://www.inkscape.org/}Inkscape}. The graph is unfortunately generated with the output of the function at the top and its inputs at the bottom. If you find it uncomfortable to read, just change [TB] by [BT] in the [rankdir] property at the beginning of the dot file before viewing it. The color and the shape of the nodes are used to make it easier to read the graph, but add no more meaning. For the edges : - the color (blue) represent the {b data} dependency, - the shape of the arrow (circled) represent the {b control} dependency, - and the kind of line (dotted) represent the {b address} dependency. So a solid blue edge with a circle arrow represent a data+control dependency for instance, while a dotted black edge with a triangle arrow represent a address dependency. You are invited to look at {{:../../../tests/pdg/doc.g.svg}a simple example} to see the different kinds of dependencies. frama-c-Fluorine-20130601/doc/code/intro_plugin_default.txt0000644000175000017500000000426312155630361022441 0ustar mehdimehdi@ignore @ignore @ignore This file is part of Frama-C. @ignore @ignore Copyright (C) 2007-2013 @ignore CEA (Commissariat l'nergie atomique et aux nergies @ignore alternatives) @ignore @ignore you can redistribute it and/or modify it under the terms of the GNU @ignore Lesser General Public License as published by the Free Software @ignore Foundation, version 2.1. @ignore @ignore It is distributed in the hope that it will be useful, @ignore but WITHOUT ANY WARRANTY; without even the implied warranty of @ignore MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the @ignore GNU Lesser General Public License for more details. @ignore @ignore See the GNU Lesser General Public License version 2.1 @ignore for more details (enclosed in the file licenses/LGPLv2.1). @ignore @ignore {2 API Documentation} The _PluginName_ API is dynamically registered. - {{:../index.html}Frama-C} complete kernel API - {{:../html/Dynamic.html}Dynamic} kernel registry for plugins' API - {{:../dynamic_plugins/Dynamic_plugins.html} Dynamically registered plugins} API index {2 Plugin Internal Documentation} - {{:modules.svg}_PluginName_} architecture (SVG format) - Index of {{:index_modules.html}Modules} - Index of {{:index_types.html}Types} - Index of {{:index_values.html}Values} - Index of {{:index_exceptions.html}Exceptions} frama-c-Fluorine-20130601/doc/code/intro_slicing.txt0000644000175000017500000001074712155630361021073 0ustar mehdimehdi@ignore @ignore @ignore This file is part of Frama-C. @ignore @ignore Copyright (C) 2007-2013 @ignore CEA (Commissariat l'nergie atomique et aux nergies @ignore alternatives) @ignore @ignore you can redistribute it and/or modify it under the terms of the GNU @ignore Lesser General Public License as published by the Free Software @ignore Foundation, version 2.1. @ignore @ignore It is distributed in the hope that it will be useful, @ignore but WITHOUT ANY WARRANTY; without even the implied warranty of @ignore MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the @ignore GNU Lesser General Public License for more details. @ignore @ignore See the GNU Lesser General Public License version 2.1 @ignore for more details (enclosed in the file licenses/LGPLv2.1). @ignore @ignore {2 Overview} To have more details about what we are trying to do, you may have a look to the {{:../../slicing/index.html}specification} report (in French). The internal types module ({!module:SlicingTypes.Internals}) can give a pretty good idea of the kind of objects that we deal with in this module. You can also find some general information below. {3 Project} The project was the global repository of the results obtained so far. If is mainly composed of a list of actions waiting to be applied, and the already computed slices. More precisely, see its type definition {!type:SlicingTypes.Internals.t_project} if you want to know what it is composed of, and the module {!module:SlicingProject} of the functions to handle it. {3 Program Dependence Graph} This computation is not part of this module anymore. See the {{:../html/Db.Pdg.html}API of Pdg module}. It is enough to know that the PDG of a function is a graph composed of nodes that represent the elements of a function (declarations, statements, and so on) and of edges that represent the dependencies relations between those elements. {3 Sliced function} A sliced function contains a mapping between the PDG nodes of a function and the some marks that are computed by the application of the actions. It also has a mapping between the function calls and the function called by the slice that can be either some other slices, or the source function (or nothing if the call is invisible in that slice). There can be more than one slice for a source function. See their type {!type:SlicingTypes.Internals.t_fct_slice}, and the associated functions in {!module:Fct_slice}. See also {!module:SlicingMarks} for more information about the low level marks computation. {3 Actions} The actions are the way of giving an order to modify the current application. There are many kinds of actions, but only one is really used to build the slice which is a list of nodes from the PDG of a function, and their associated marks. All the other actions dealing with the marks are first decomposed before being applied. Some other actions are can be used to manage the interprocedural part, ie. which slice to call where. See the top type {!type:SlicingTypes.Internals.t_criterion} or the functions in {!module:SlicingActions}. {3 Options} The propagation of the marks to the function call depend on a {!type:SlicingTypes.Internals.t_call_option}. Chosing this level makes it possible to obtain a more or less precise result. {3 High level commands} The module {!module:SlicingCmds} is a bit external because it only uses the {{:../html/Db.Pdg.html}slicing API} to define higher level function that are only a composition of the basic functions. {3 Producing a result } When there are non more actions in the task list, the project can be exported. This is done in {!module:SlicingTransform} module by building a new CIL application. frama-c-Fluorine-20130601/doc/code/docgen_ge400.ml0000644000175000017500000003420112155630361020146 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Odoc_module open Odoc_info open Odoc_html let doc_path = ref "." let lib_files = ref [] let add_libfiles analyse s = let f = Odoc_global.Intf_file s in lib_files := (String.capitalize (Filename.chop_extension (Filename.basename s))) :: !lib_files; if analyse then Odoc_global.files := f :: !Odoc_global.files let rec root_name s = let simple = Odoc_info.Name.simple s in let father = Odoc_info.Name.father s in if father = "" then simple else root_name father let equal_module_name m s = let n = m.m_name in n = s && n = root_name n let equal_module m1 m2 = equal_module_name m1 m2.m_name type chapter = Chapter of int * string * string | Directory of string let compare_chapter c1 c2 = match c1 , c2 with | Chapter(a,_,_) , Chapter(b,_,_) -> a-b | Directory a , Directory b -> compare a b | Chapter _ , Directory _ -> (-1) | Directory _ , Chapter _ -> 1 let merge3 (s1 : 'a -> 'a -> int) (s2 : 'b -> 'b -> int) (s3 : 'c -> 'c -> int) (triplets : ('a * 'b * 'c) list) : ('a * ('b * 'c list) list) list = let sort3_rev s1 s2 s3 (x,y,z) (x',y',z') = let c = s1 x' x in if c <> 0 then c else let c = s2 y' y in if c <> 0 then c else s3 z' z in let rec merge3_rev acc triplets = match triplets , acc with | [] , _ -> acc | (a,b,c)::tail , (dir_a,all_a)::a_merged when a = dir_a -> begin match all_a with | (dir_b,all_b)::b_merged when b = dir_b -> merge3_rev ((dir_a,(dir_b,c::all_b)::b_merged)::a_merged) tail | _ -> merge3_rev ((dir_a,(b,[c])::all_a)::a_merged) tail end | (a,b,c)::tail , merged -> merge3_rev (( a , [b,[c]] )::merged) tail in merge3_rev [] (List.sort (sort3_rev s1 s2 s3) triplets) module Generator (G:Odoc_html.Html_generator) = struct class html = object (self) inherit G.html as super val mutable memo = [] method private loaded_modules = match memo with | [] -> let l = List.flatten (List.map (fun f -> Odoc_info.verbose (Odoc_messages.loading f); try let l = Odoc_analyse.load_modules f in Odoc_info.verbose Odoc_messages.ok; l with Failure s -> prerr_endline s ; incr Odoc_global.errors ; [] ) !Odoc_global.load ) in memo <- l; l | (_ :: _) as l -> l method private path s = let name = root_name s in if List.exists (fun m -> m = name) !lib_files then "http://caml.inria.fr/pub/docs/manual-ocaml/libref/" else if List.exists (fun m -> m.m_name = name) self#loaded_modules then !doc_path ^ "/" else "./" method create_fully_qualified_idents_links m_name s = let f str_t = let match_s = Str.matched_string str_t in let rel = Odoc_info.Name.get_relative m_name match_s in let s_final = Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s rel in if StringSet.mem match_s known_types_names then "" ^ s_final ^ "" else if StringSet.mem match_s known_classes_names then let (html_file, _) = Naming.html_files match_s in ""^s_final^"" else s_final in let s2 = Str.global_substitute (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") f s in s2 (** Take a string and return the string where fully qualified module idents have been replaced by links to the module referenced by the ident.*) method create_fully_qualified_module_idents_links m_name s = let f str_t = let match_s = Str.matched_string str_t in let rel = Odoc_info.Name.get_relative m_name match_s in let s_final = Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s rel in if StringSet.mem match_s known_modules_names then let (html_file, _) = Naming.html_files match_s in ""^s_final^"" else s_final in let s2 = Str.global_substitute (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)") f s in s2 (** redefine from file odoc_html.ml *) method html_of_Module_list b l = let dir f = (* , *) let chop dir f = let n = Str.search_forward (Str.regexp dir) f 0 in let f = String.sub f n (String.length f - n) in let d = Filename.dirname f in String.capitalize (Filename.basename d) in try Chapter(2,"C & ACSL","cil") , chop "cil/" f with Not_found -> try Chapter(1,"Frama-C","src") , chop "src/" f with Not_found -> let d = Filename.dirname f in Directory (Filename.basename (Filename.dirname d)) , String.capitalize (Filename.basename d) in let structured_modules (* chapter, section, module *) = (List.map (fun name -> let m = List.find (fun m -> m.m_name = name) self#list_modules in let dir,name = dir m.m_file in dir,name,m) l) in let toc_modules (* chapter/section/modules *) = merge3 compare_chapter compare compare structured_modules in List.iter (fun (chapter, subdirs) -> let dir = ( match chapter with | Chapter (n,a,d) -> bp b "

Chapter %d. %s

" n a ; d | Directory d -> bp b "

Directory %s

" d ; d) in List.iter (fun (subdir,modules) -> bp b "

Section %s (in %s/%s)

\n" subdir dir (String.lowercase subdir) ; bs b "
\n\n"; List.iter (fun m -> bs b "" html m.m_name; bs b "\n") modules; bs b "
"; (try let (html, _) = Naming.html_files m.m_name in bp b "%s"; self#html_of_info_first_sentence b m.m_info; with Not_found -> Odoc_global.pwarning (Odoc_messages.cross_module_not_found m.m_name); bp b "%s" m.m_name); bs b "
\n") subdirs) toc_modules (** Print html code for an included module. *) method html_of_included_module b im = bs b "
";
      bs b ((self#keyword "include")^" ");
      (
        match im.im_module with
          None ->
            bs b im.im_name
        | Some mmt ->
          let (file, name) =
            match mmt with
              Mod m ->
                let (html_file, _) = Naming.html_files m.m_name in
                (html_file, m.m_name)
            | Modtype mt ->
              let (html_file, _) =
		Naming.html_files mt.mt_name
	      in
              (html_file, mt.mt_name)
          in
          bp b "%s" (self#path name) file name
      );
      bs b "
\n"; self#html_of_info b im.im_info (** Generate all the html files from a module list. The main file is [.html]. *) method generate module_list = (* init the style *) self#init_style ; (* init the lists of elements *) list_values <- Odoc_info.Search.values module_list ; list_exceptions <- Odoc_info.Search.exceptions module_list ; list_types <- Odoc_info.Search.types module_list ; list_attributes <- Odoc_info.Search.attributes module_list ; list_methods <- Odoc_info.Search.methods module_list ; list_classes <- Odoc_info.Search.classes module_list ; list_class_types <- Odoc_info.Search.class_types module_list ; list_modules <- Odoc_info.Search.modules module_list ; list_module_types <- Odoc_info.Search.module_types module_list ; (* prepare the page header *) self#prepare_header module_list ; (* Get the names of all known types. *) let types = Odoc_info.Search.types module_list in known_types_names <- List.fold_left (fun acc t -> StringSet.add t.Odoc_type.ty_name acc) known_types_names types ; (* Get the names of all class and class types. *) let classes = Odoc_info.Search.classes module_list in let class_types = Odoc_info.Search.class_types module_list in known_classes_names <- List.fold_left (fun acc c -> StringSet.add c.Odoc_class.cl_name acc) known_classes_names classes ; known_classes_names <- List.fold_left (fun acc ct -> StringSet.add ct.Odoc_class.clt_name acc) known_classes_names class_types ; (* Get the names of all known modules and module types. *) let module_types = Odoc_info.Search.module_types module_list in let modules = Odoc_info.Search.modules module_list in known_modules_names <- List.fold_left (fun acc m -> StringSet.add m.m_name acc) known_modules_names modules ; known_modules_names <- List.fold_left (fun acc mt -> StringSet.add mt.mt_name acc) known_modules_names module_types ; (* generate html for each module *) let keep_list = let keep m = not (List.exists (equal_module m) self#loaded_modules) && not (List.exists (equal_module_name m) !lib_files) in List.filter keep module_list in if not !Odoc_html.index_only then self#generate_elements self#generate_for_module keep_list ; (* reinit the lists of elements *) list_values <- Odoc_info.Search.values keep_list ; list_exceptions <- Odoc_info.Search.exceptions keep_list ; list_types <- Odoc_info.Search.types keep_list ; list_attributes <- Odoc_info.Search.attributes keep_list ; list_methods <- Odoc_info.Search.methods keep_list ; list_classes <- Odoc_info.Search.classes keep_list ; list_class_types <- Odoc_info.Search.class_types keep_list ; list_modules <- Odoc_info.Search.modules keep_list ; list_module_types <- Odoc_info.Search.module_types keep_list ; try self#generate_index keep_list; self#generate_values_index keep_list ; self#generate_exceptions_index keep_list ; self#generate_types_index keep_list ; self#generate_attributes_index keep_list ; self#generate_methods_index keep_list ; self#generate_classes_index keep_list ; self#generate_class_types_index keep_list ; self#generate_modules_index keep_list ; self#generate_module_types_index keep_list ; with Failure s -> prerr_endline s ; incr Odoc_info.errors method private html_of_plugin_developer_guide _t = "Consult the Plugin Development Guide for additional details.
\n" method private html_of_ignore _t = "" method private html_of_modify t = match t with | [] -> Odoc_info.warning "Found an empty @modify tag"; "" | Raw s :: l -> let time, explanation = try let idx = String.index s ' ' in String.sub s 0 idx, ":" ^ String.sub s idx (String.length s - idx) with Not_found -> s, "" in let text = Bold [ Raw "Change in "; Raw time ] :: Raw explanation :: l in let buf = Buffer.create 7 in self#html_of_text buf text; Buffer.add_string buf "
\n"; Buffer.contents buf | _ :: _ -> assert false method private html_of_call t = match t with | [] -> Odoc_info.warning "Found an empty @call tag"; "" | l -> let buf = Buffer.create 97 in Buffer.add_string buf "Access it by "; self#html_of_text buf l; Buffer.add_string buf "\n"; Buffer.contents buf (* Write the subtitle (eg. "Frama-C Kernel" after the main title instead of before, for users that use many tabs in their browser *) method inner_title s = match self#title with "" -> "" | t -> self#escape s ^ " - " ^ t initializer tag_functions <- ("modify", self#html_of_modify) :: ("ignore", self#html_of_ignore) :: ("call", self#html_of_call) :: ("plugin", self#html_of_plugin_developer_guide) :: tag_functions end end let () = Odoc_args.extend_html_generator (module Generator: Odoc_gen.Html_functor); Odoc_args.add_option ("-docpath", Arg.Set_string doc_path, "Frama-C documentation directory"); Odoc_args.add_option ("-stdlib", Arg.String (add_libfiles true), "Standard library files"); Odoc_args.add_option ("-stdlib-path", Arg.String (add_libfiles false), "Standard library files") frama-c-Fluorine-20130601/doc/README0000644000175000017500000000105412155630365015430 0ustar mehdimehdiThis is the main source of documentation for the Frama-C distribution. The manuals directory contains the following manuals * acsl is the reference manual of the specification manual * acsl-implementation is a copy of the ACSL reference manual with some implementation-specific remarks. In particular, it explains which features are not currently supported by Frama-C * user-manal describes the use of frama-c * plugin-development-guide provides information needed to develop a Frama-C plugin * the other manuals document specific plug-ins frama-c-Fluorine-20130601/configure0000755000175000017500000104142212155634043015713 0ustar mehdimehdi#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 test \$(( 1 + 1 )) = 2 || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME= PACKAGE_TARNAME= PACKAGE_VERSION= PACKAGE_STRING= PACKAGE_BUGREPORT= PACKAGE_URL= ac_unique_file="src/kernel" # Factoring default headers for most tests. ac_includes_default="\ #include #ifdef HAVE_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef STDC_HEADERS # include # include #else # ifdef HAVE_STDLIB_H # include # endif #endif #ifdef HAVE_STRING_H # if !defined STDC_HEADERS && defined HAVE_MEMORY_H # include # endif # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif" ac_subst_vars='LTLIBOBJS LIBOBJS LABLGTK_PATH EXTERNAL_PLUGINS FC_MCPP FRAMAC_DEFAULT_CPP LOCAL_MACHDEP CYCLES_PER_USEC UNDERSCORE_NAME THREAD_IS_KEYWORD HAVE_BUILTIN_VA_LIST HAVE_PTRDIFF_H HAVE_WCHAR_H HAVE_STDLIB_H EXE OCAML_ANNOT_OPTION OCAMLWIN32 OCAMLLIB OCAMLVERSION OCAMLBEST OCAMLGRAPH_HOME OCAMLGRAPH_LOCAL OCAMLGRAPH_INCLUDE ZARITH_PATH HAS_ZARITH VERBOSEMAKE HAS_USABLE_NATIVE_DYNLINK USABLE_NATIVE_DYNLINK HAS_NATIVE_DYNLINK NATIVE_DYNLINK DOT HAS_DOT HAS_GNOMECANVAS GNOMECANVAS HAS_GTKSOURCEVIEW GTKSOURCEVIEW HAS_LABLGTK LABLGTK COQC DYNAMIC_WP ENABLE_WP DYNAMIC_SECURITY_SLICING ENABLE_SECURITY_SLICING DYNAMIC_REPORT ENABLE_REPORT DYNAMIC_OBFUSCATOR ENABLE_OBFUSCATOR LTLTOBA HAS_LTLTOBA DYNAMIC_AORAI ENABLE_AORAI DYNAMIC_VALUE_ANALYSIS ENABLE_VALUE_ANALYSIS DYNAMIC_USERS ENABLE_USERS DYNAMIC_SYNTACTIC_CALLGRAPH ENABLE_SYNTACTIC_CALLGRAPH DYNAMIC_SPARECODE ENABLE_SPARECODE DYNAMIC_SLICING ENABLE_SLICING DYNAMIC_SEMANTIC_CALLGRAPH ENABLE_SEMANTIC_CALLGRAPH DYNAMIC_SCOPE ENABLE_SCOPE DYNAMIC_RTE_ANNOTATION ENABLE_RTE_ANNOTATION DYNAMIC_POSTDOMINATORS ENABLE_POSTDOMINATORS DYNAMIC_PDG ENABLE_PDG DYNAMIC_OCCURRENCE ENABLE_OCCURRENCE DYNAMIC_METRICS ENABLE_METRICS DYNAMIC_INOUT ENABLE_INOUT DYNAMIC_IMPACT ENABLE_IMPACT DYNAMIC_GUI ENABLE_GUI DYNAMIC_FROM_ANALYSIS ENABLE_FROM_ANALYSIS DYNAMIC_SEMANTIC_CONSTANT_FOLDING ENABLE_SEMANTIC_CONSTANT_FOLDING EGREP GREP CPP OBJEXT EXEEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC OCAMLFIND OTAGS OCAMLCP OCAMLMKTOP OCAMLDOCOPT OCAMLDOC OCAMLYACC OCAMLLEXDOTOPT OCAMLLEX OCAMLDEPDOTOPT OCAMLDEP OCAMLOPTDOTOPT OCAMLCDOTOPT OCAMLOPT OCAMLC MAKE FRAMAC_VERSION 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_verbosemake enable_unsupported_ocaml enable_zarith enable_mcpp with_cpp with_all_static with_no_plugin enable_semantic_constant_folding enable_from_analysis enable_gui enable_impact enable_inout enable_metrics enable_occurrence enable_pdg enable_postdominators enable_rte_annotation enable_scope enable_semantic_callgraph enable_slicing enable_sparecode enable_syntactic_callgraph enable_users enable_value_analysis enable_external enable_aorai with_aorai_static enable_obfuscator with_obfuscator_static enable_report with_report_static enable_security_slicing with_security_slicing_static enable_wp with_wp_static enable_wpcoq ' ac_precious_vars='build_alias host_alias target_alias CC CFLAGS LDFLAGS LIBS CPPFLAGS CPP' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures this package to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then cat <<\_ACEOF 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-verbosemake verbose makefile commands --enable-unsupported-ocaml attempt to compile even against unsupported ocaml version --enable-zarith= use ZArith library --enable-mcpp use Frama-C's mcpp --enable-semantic_constant_folding support for constant propagation plugin (default: yes) --enable-from_analysis support for from analysis (default: yes) --enable-gui support for gui (default: yes) --enable-impact support for impact plugin (default: yes) --enable-inout support for inout analysis (default: yes) --enable-metrics support for metrics analysis (default: yes) --enable-occurrence support for occurrence analysis (default: yes) --enable-pdg support for pdg plugin (default: yes) --enable-postdominators support for postdominators plugin (default: yes) --enable-rte_annotation support for runtime error annotation (default: yes) --enable-scope support for scope plugin (default: yes) --enable-semantic_callgraph support for semantic callgraph (default: yes) --enable-slicing support for slicing plugin (default: yes) --enable-sparecode support for sparecode plugin (default: yes) --enable-syntactic_callgraph support for callgraph plugin (default: yes) --enable-users support for users analysis (default: yes) --enable-value_analysis support for value analysis (default: yes) --enable-external=plugin allows to compile directly from Frama-C kernel some external plug-ins. --enable-aorai support for Aorai plug-in (default: yes) --enable-obfuscator support for Obfuscator plug-in (default: yes) --enable-report support for report plug-in (default: yes) --enable-security_slicing support for Security_slicing plug-in (default: yes) --enable-wp WP plug-in (default: yes) --enable-wpcoq Wp precompiled coq libraries (default: yes) Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-cpp customize defaut preprocessor for Frama-C --with-all-static link all plug-ins statically (default: no) --with-no-plugin disable all plug-ins (default: no) --with-aorai-static link aorai statically (default: no) --with-obfuscator-static link obfuscator statically (default: no) --with-report-static link report statically (default: no) --with-security_slicing-static link security_slicing statically (default: no) --with-wp-static link wp statically (default: no) Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to the package provider. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for guested configure. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF configure generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## # ac_fn_c_try_compile LINENO # -------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_compile # ac_fn_c_try_cpp LINENO # ---------------------- # Try to preprocess conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_cpp () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } > conftest.i && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_cpp # ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists, giving a warning if it cannot be compiled using # the include files in INCLUDES and setting the cache variable VAR # accordingly. ac_fn_c_check_header_mongrel () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if eval \${$3+:} false; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 $as_echo_n "checking $2 usability... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_header_compiler=yes else ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 $as_echo_n "checking $2 presence... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include <$2> _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : ac_header_preproc=yes else ac_header_preproc=no fi rm -f conftest.err conftest.i conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( yes:no: ) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ;; no:yes:* ) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=\$ac_header_compiler" fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_mongrel # ac_fn_c_try_run LINENO # ---------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. Assumes # that executables *can* be run. ac_fn_c_try_run () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then : ac_retval=0 else $as_echo "$as_me: program exited with status $ac_status" >&5 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=$ac_status fi rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_run # ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists and can be compiled using the include files in # INCLUDES, setting the cache variable VAR accordingly. ac_fn_c_check_header_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$3=yes" else eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_compile # ac_fn_c_check_type LINENO TYPE VAR INCLUDES # ------------------------------------------- # Tests whether TYPE exists after having included INCLUDES, setting cache # variable VAR accordingly. ac_fn_c_check_type () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=no" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { if (sizeof ($2)) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { if (sizeof (($2))) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else eval "$3=yes" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_type # ac_fn_c_try_link LINENO # ----------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_link () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest$ac_exeext if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || test -x conftest$ac_exeext }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would # interfere with the next link command; also delete a directory that is # left behind by Apple's compiler. We do this before executing the actions. rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_link cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## # AC_ARG_WITH(frama-c, # AC_HELP_STRING([Frama-C executable name (default is 'frama-c')]), # [FRAMA_C=$withval], # [FRAMA_C=frama-c]) # AC_ARG_WITH(frama-c-gui, # AC_HELP_STRING([Frama-C executable name (default is 'frama-c')]), # [FRAMA_C_GUI=$withval], # [FRAMA_C_GUI=frama-c-gui]) 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 } FRAMAC_VERSION=`cat VERSION` # export CYGWIN=nobinmode ########################## # Check for Make version # ########################## new_section "configure make" # Extract the first word of "make", so it can be a program name with args. set dummy make; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_MAKE+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$MAKE"; then ac_cv_prog_MAKE="$MAKE" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_MAKE="make" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi MAKE=$ac_cv_prog_MAKE if test -n "$MAKE"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MAKE" >&5 $as_echo "$MAKE" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi MAKE_DISTRIB=`sh -c "$MAKE -v | sed -n -e 's/\(.*\) Make.*$/\1/p'"` MAKE_MAJOR=`sh -c "$MAKE -v | sed -n -f bin/sed_get_make_major"` MAKE_MINOR=`sh -c "$MAKE -v | sed -n -f bin/sed_get_make_minor"` echo $ECHO_N "make version is $MAKE_DISTRIB Make $MAKE_MAJOR.$MAKE_MINOR: $ECHO_C" if test "$MAKE_DISTRIB" != GNU -o "$MAKE_MAJOR" -lt 3 -o "$MAKE_MINOR" -lt 81; then echo "${ECHO_T}" as_fn_error $? "unsupported version; GNU Make version 3.81 or higher is required." "$LINENO" 5; else echo "${ECHO_T}Good!" fi # verbosemake feature # Check whether --enable-verbosemake was given. if test "${enable_verbosemake+set}" = set; then : enableval=$enable_verbosemake; VERBOSEMAKE=$enableval else VERBOSEMAKE=no fi if test "$VERBOSEMAKE" = yes ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: Make will be verbose." >&5 $as_echo "Make will be verbose." >&6; } fi ############################# # Check for Ocaml compilers # ############################# # Specifically allow 3.10.0 UNSUPPORTED_OCAML=no # Check whether --enable-unsupported-ocaml was given. if test "${enable_unsupported_ocaml+set}" = set; then : enableval=$enable_unsupported_ocaml; UNSUPPORTED_OCAML=$enableval else UNSUPPORTED_OCAML=no fi new_section "configure ocaml compilers" # we first look for ocamlc in the path; if not present, we fail # Extract the first word of "ocamlc", so it can be a program name with args. set dummy ocamlc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLC"; then ac_cv_prog_OCAMLC="$OCAMLC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLC="ocamlc" $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_OCAMLC" && ac_cv_prog_OCAMLC="no" fi fi OCAMLC=$ac_cv_prog_OCAMLC if test -n "$OCAMLC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLC" >&5 $as_echo "$OCAMLC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLC" = no ; then as_fn_error $? "Cannot find ocamlc." "$LINENO" 5 fi OCAML_ANNOT_OPTION="-dtypes" # Let user shoot himself in the foot if he so wishes warn_or_die () { if test "$UNSUPPORTED_OCAML" = "yes"; then echo "Compile at your own risks"; else echo "If you want to compile Frama-C with this version, use the \ --enable-unsupported-ocaml option of configure"; exit 2; fi } # we extract Ocaml version number and library path # "sed -n" is the posix version of "sed --quiet" OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` echo $ECHO_N "OCaml version is $OCAMLVERSION: $ECHO_C" case $OCAMLVERSION in 3.12.1*) echo "${ECHO_T}good!"; OCAML_ANNOT_OPTION="-annot";; 3.0*) echo "${ECHO_T}Incompatible version! Use at least OCaml 3.12.1."; exit 2;; 3.10*) echo "${ECHO_T}Incompatible version! Use at least OCaml 3.12.1."; exit 2;; 3.11*) echo "${ECHO_T}Incompatible version! Use at least OCaml 3.12.1."; exit 2;; 3.12.0*) echo "${ECHO_T}Incompatible version! Use at least OCaml 3.12.1."; exit 2;; 4.*) echo "${ECHO_T}good!"; OCAML_ANNOT_OPTION="-annot";; *) echo "${ECHO_T}Incompatible version!"; exit 2;; esac # Ocaml library path OCAMLLIB=`$OCAMLC -where | tr -d '\\r'` echo "ocaml library path is $OCAMLLIB" # then we look for ocamlopt; if not present, we issue a warning # if the version or the stdlib directory is not the same, we also discard it # we set OCAMLBEST to "opt" or "byte", whether ocamlopt is available or not # Extract the first word of "ocamlopt", so it can be a program name with args. set dummy ocamlopt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLOPT"; then ac_cv_prog_OCAMLOPT="$OCAMLOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLOPT="ocamlopt" $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_OCAMLOPT" && ac_cv_prog_OCAMLOPT="no" fi fi OCAMLOPT=$ac_cv_prog_OCAMLOPT if test -n "$OCAMLOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLOPT" >&5 $as_echo "$OCAMLOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi OCAMLBEST=byte if test "$OCAMLOPT" = no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Cannot find ocamlopt; bytecode compilation only." >&5 $as_echo "$as_me: WARNING: Cannot find ocamlopt; bytecode compilation only." >&2;} else { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlopt version and standard library" >&5 $as_echo_n "checking ocamlopt version and standard library... " >&6; } TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p'` if test "$TMPVERSION" != "$OCAMLVERSION" \ -o `$OCAMLOPT -where | tr -d '\\r'` != "$OCAMLLIB"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlopt discarded." >&5 $as_echo "differs from ocamlc; ocamlopt discarded." >&6; } OCAMLOPT=no else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } OCAMLBEST=opt fi fi if test "$OCAMLBEST" = "opt"; then LIB_SUFFIX=cmxa OBJ_SUFFIX=cmx; else LIB_SUFFIX=cma OBJ_SUFFIX=cmo; fi # checking for ocamlc.opt # Extract the first word of "ocamlc.opt", so it can be a program name with args. set dummy ocamlc.opt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLCDOTOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLCDOTOPT"; then ac_cv_prog_OCAMLCDOTOPT="$OCAMLCDOTOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLCDOTOPT="ocamlc.opt" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLCDOTOPT" && ac_cv_prog_OCAMLCDOTOPT="no" fi fi OCAMLCDOTOPT=$ac_cv_prog_OCAMLCDOTOPT if test -n "$OCAMLCDOTOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLCDOTOPT" >&5 $as_echo "$OCAMLCDOTOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLCDOTOPT" != no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlc.opt version and standard library" >&5 $as_echo_n "checking ocamlc.opt version and standard library... " >&6; } TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVERSION" != "$OCAMLVERSION" \ -o `$OCAMLCDOTOPT -where | tr -d '\\r'` != "$OCAMLLIB"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlc.opt discarded." >&5 $as_echo "differs from ocamlc; ocamlc.opt discarded." >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } OCAMLC=$OCAMLCDOTOPT fi fi # checking for ocamlopt.opt if test "$OCAMLOPT" != no ; then # Extract the first word of "ocamlopt.opt", so it can be a program name with args. set dummy ocamlopt.opt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLOPTDOTOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLOPTDOTOPT"; then ac_cv_prog_OCAMLOPTDOTOPT="$OCAMLOPTDOTOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLOPTDOTOPT="ocamlopt.opt" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLOPTDOTOPT" && ac_cv_prog_OCAMLOPTDOTOPT="no" fi fi OCAMLOPTDOTOPT=$ac_cv_prog_OCAMLOPTDOTOPT if test -n "$OCAMLOPTDOTOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLOPTDOTOPT" >&5 $as_echo "$OCAMLOPTDOTOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLOPTDOTOPT" != no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlc.opt version and standard library" >&5 $as_echo_n "checking ocamlc.opt version and standard library... " >&6; } TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVER" != "$OCAMLVERSION" \ -o `$OCAMLOPTDOTOPT -where | tr -d '\\r'` != "$OCAMLLIB"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlopt.opt discarded." >&5 $as_echo "differs from ocamlc; ocamlopt.opt discarded." >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } OCAMLOPT=$OCAMLOPTDOTOPT fi fi fi ############################################## # Check for other mandatory tools/libraries # ############################################## new_section "configure mandatory tools and libraries" # ocamldep # Extract the first word of "ocamldep", so it can be a program name with args. set dummy ocamldep; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLDEP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLDEP"; then ac_cv_prog_OCAMLDEP="$OCAMLDEP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLDEP="ocamldep" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLDEP" && ac_cv_prog_OCAMLDEP="no" fi fi OCAMLDEP=$ac_cv_prog_OCAMLDEP if test -n "$OCAMLDEP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDEP" >&5 $as_echo "$OCAMLDEP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLDEP" = no ; then as_fn_error $? "Cannot find ocamldep." "$LINENO" 5 else # Extract the first word of "ocamldep.opt", so it can be a program name with args. set dummy ocamldep.opt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLDEPDOTOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLDEPDOTOPT"; then ac_cv_prog_OCAMLDEPDOTOPT="$OCAMLDEPDOTOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLDEPDOTOPT="ocamldep.opt" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLDEPDOTOPT" && ac_cv_prog_OCAMLDEPDOTOPT="no" fi fi OCAMLDEPDOTOPT=$ac_cv_prog_OCAMLDEPDOTOPT if test -n "$OCAMLDEPDOTOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDEPDOTOPT" >&5 $as_echo "$OCAMLDEPDOTOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLDEPDOTOPT" != no ; then OCAMLDEP=$OCAMLDEPDOTOPT fi fi # ocamllex # Extract the first word of "ocamllex", so it can be a program name with args. set dummy ocamllex; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLLEX+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLLEX"; then ac_cv_prog_OCAMLLEX="$OCAMLLEX" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLLEX="ocamllex" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLLEX" && ac_cv_prog_OCAMLLEX="no" fi fi OCAMLLEX=$ac_cv_prog_OCAMLLEX if test -n "$OCAMLLEX"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLLEX" >&5 $as_echo "$OCAMLLEX" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLLEX" = no ; then as_fn_error $? "Cannot find ocamllex." "$LINENO" 5 else # Extract the first word of "ocamllex.opt", so it can be a program name with args. set dummy ocamllex.opt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLLEXDOTOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLLEXDOTOPT"; then ac_cv_prog_OCAMLLEXDOTOPT="$OCAMLLEXDOTOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLLEXDOTOPT="ocamllex.opt" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLLEXDOTOPT" && ac_cv_prog_OCAMLLEXDOTOPT="no" fi fi OCAMLLEXDOTOPT=$ac_cv_prog_OCAMLLEXDOTOPT if test -n "$OCAMLLEXDOTOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLLEXDOTOPT" >&5 $as_echo "$OCAMLLEXDOTOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLLEXDOTOPT" != no ; then OCAMLLEX=$OCAMLLEXDOTOPT fi fi # ocamlyacc # Extract the first word of "ocamlyacc", so it can be a program name with args. set dummy ocamlyacc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLYACC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLYACC"; then ac_cv_prog_OCAMLYACC="$OCAMLYACC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLYACC="ocamlyacc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLYACC" && ac_cv_prog_OCAMLYACC="no" fi fi OCAMLYACC=$ac_cv_prog_OCAMLYACC if test -n "$OCAMLYACC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLYACC" >&5 $as_echo "$OCAMLYACC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLYACC" = no ; then as_fn_error $? "Cannot find ocamlyacc." "$LINENO" 5 fi ############## # ocamlgraph # ############## OCAMLGRAPH_LOCAL="" OCAMLGRAPH_HOME=$OCAMLLIB/ocamlgraph OCAMLGRAPH_EXISTS=no OCAMLGRAPH_INCLUDE= # check if any ocamlgraph is installed in the right place as_ac_File=`$as_echo "ac_cv_file_$OCAMLGRAPH_HOME/graph.$OBJ_SUFFIX" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLGRAPH_HOME/graph.$OBJ_SUFFIX" >&5 $as_echo_n "checking for $OCAMLGRAPH_HOME/graph.$OBJ_SUFFIX... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLGRAPH_HOME/graph.$OBJ_SUFFIX"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : OCAMLGRAPH_EXISTS="yes" OCAMLGRAPH_INCLUDE="-I +ocamlgraph" fi ocamlgraph_error() { { $as_echo "$as_me:${as_lineno-$LINENO}: OcamlGraph $OCAMLGRAPH_VERSION is incompatible with Frama-C." >&5 $as_echo "$as_me: OcamlGraph $OCAMLGRAPH_VERSION is incompatible with Frama-C." >&6;} OCAMLGRAPH_EXISTS=no OCAMLGRAPH_INCLUDE= } # if any, check if it is a compatible version if test "$OCAMLGRAPH_EXISTS" = "yes"; then test_ocamlgraph_version='print_string Graph.Version.version;;' echo $test_ocamlgraph_version > test_ocamlgraph.ml if ocamlc -o test_ocamlgraph $OCAMLGRAPH_INCLUDE graph.cmo \ test_ocamlgraph.ml 2> /dev/null; \ then OCAMLGRAPH_VERSION=`./test_ocamlgraph` case $OCAMLGRAPH_VERSION in 1.8.1) ocamlgraph_error;; 1.8.2) ocamlgraph_error;; 1.8.3) { $as_echo "$as_me:${as_lineno-$LINENO}: OcamlGraph $OCAMLGRAPH_VERSION found: great!" >&5 $as_echo "$as_me: OcamlGraph $OCAMLGRAPH_VERSION found: great!" >&6;};; 1.8.*) { $as_echo "$as_me:${as_lineno-$LINENO}: OcamlGraph $OCAMLGRAPH_VERSION > 1.8.2 found: should be compatible!" >&5 $as_echo "$as_me: OcamlGraph $OCAMLGRAPH_VERSION > 1.8.2 found: should be compatible!" >&6;};; *) ocamlgraph_error;; esac else ocamlgraph_error fi rm -f test_ocamlgraph test_ocamlgraph.ml test_ocamlgraph.cm* fi # revert back to local version of ocamlgraph if test "$OCAMLGRAPH_EXISTS" = "no"; then { $as_echo "$as_me:${as_lineno-$LINENO}: switching to OcamlGraph provided by Frama-C" >&5 $as_echo "$as_me: switching to OcamlGraph provided by Frama-C" >&6;} OCAMLGRAPH_LOCAL=ocamlgraph OCAMLGRAPH_HOME= as_ac_File=`$as_echo "ac_cv_file_$OCAMLGRAPH_LOCAL" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLGRAPH_LOCAL" >&5 $as_echo_n "checking for $OCAMLGRAPH_LOCAL... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLGRAPH_LOCAL"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : OCAMLGRAPH_EXISTS=yes fi if test "$OCAMLGRAPH_EXISTS" = "no"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ocamlgraph.tar.gz" >&5 $as_echo_n "checking for ocamlgraph.tar.gz... " >&6; } if ${ac_cv_file_ocamlgraph_tar_gz+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "ocamlgraph.tar.gz"; then ac_cv_file_ocamlgraph_tar_gz=yes else ac_cv_file_ocamlgraph_tar_gz=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_ocamlgraph_tar_gz" >&5 $as_echo "$ac_cv_file_ocamlgraph_tar_gz" >&6; } if test "x$ac_cv_file_ocamlgraph_tar_gz" = xyes; then : OCAMLGRAPH_EXISTS=yes fi if test "$OCAMLGRAPH_EXISTS" = "yes"; then # ocamlgraph.tar.gz exists, but no directory ocamlgraph { $as_echo "$as_me:${as_lineno-$LINENO}: unarchiving ocamlgraph.tar.gz" >&5 $as_echo "$as_me: unarchiving ocamlgraph.tar.gz" >&6;} tar zxf ocamlgraph.tar.gz else # neither directory ocamlgraph, nor ocamlgraph.tar.gz exists # broken distrib indeed as_fn_error $? "cannot find OcamlGraph in the current directory. Quite strange: would your Frama-C distribution be corrupted? Anyway: 1. download the latest version from http://ocamlgraph.lri.fr/download 2. install it by './configure && make && make install' 3. rerun ./configure here" "$LINENO" 5 fi else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ocamlgraph.tar.gz" >&5 $as_echo_n "checking for ocamlgraph.tar.gz... " >&6; } if ${ac_cv_file_ocamlgraph_tar_gz+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "ocamlgraph.tar.gz"; then ac_cv_file_ocamlgraph_tar_gz=yes else ac_cv_file_ocamlgraph_tar_gz=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_ocamlgraph_tar_gz" >&5 $as_echo "$ac_cv_file_ocamlgraph_tar_gz" >&6; } if test "x$ac_cv_file_ocamlgraph_tar_gz" = xyes; then : OCAMLGRAPH_TAR=yes fi if test "$OCAMLGRAPH_TAR" = "yes"; then # both directory ocamlgraph and ocamlgraph.tar.gz exist at the same time # untar only if the tar is newer than the directory if test ocamlgraph.tar.gz -nt ocamlgraph; then { $as_echo "$as_me:${as_lineno-$LINENO}: find a newer OcamlGraph version: OcamlGraph updated!" >&5 $as_echo "$as_me: find a newer OcamlGraph version: OcamlGraph updated!" >&6;} rm -rf ocamlgraph tar zxf ocamlgraph.tar.gz fi fi fi # Anyway reconfigure OcamlGraph while reconfiguring Frama-C { $as_echo "$as_me:${as_lineno-$LINENO}: configuring ocamlgraph..." >&5 $as_echo "$as_me: configuring ocamlgraph..." >&6;} (cd $OCAMLGRAPH_LOCAL && ./configure > /dev/null) fi ################################################# # Check for other (optional) tools/libraries # ################################################# new_section "configure optional tools and libraries" # Extract the first word of "ocamldoc", so it can be a program name with args. set dummy ocamldoc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLDOC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLDOC"; then ac_cv_prog_OCAMLDOC="$OCAMLDOC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLDOC="ocamldoc" $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_OCAMLDOC" && ac_cv_prog_OCAMLDOC="no" fi fi OCAMLDOC=$ac_cv_prog_OCAMLDOC if test -n "$OCAMLDOC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDOC" >&5 $as_echo "$OCAMLDOC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLDOC" = no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: ocamldoc discarded not present" >&5 $as_echo "ocamldoc discarded not present" >&6; } else # Extract the first word of "ocamldoc.opt", so it can be a program name with args. set dummy ocamldoc.opt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLDOCOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLDOCOPT"; then ac_cv_prog_OCAMLDOCOPT="$OCAMLDOCOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLDOCOPT="ocamldoc.opt" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLDOCOPT" && ac_cv_prog_OCAMLDOCOPT="no" fi fi OCAMLDOCOPT=$ac_cv_prog_OCAMLDOCOPT if test -n "$OCAMLDOCOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDOCOPT" >&5 $as_echo "$OCAMLDOCOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Strange quantic segfault with native ocamldoc in version 4.00.0 if test "$OCAMLDOCOPT" != no -a "$OCAMLVERSION" != 4.00.0; then OCAMLDOC=$OCAMLDOCOPT; fi fi # Extract the first word of "ocamlmktop", so it can be a program name with args. set dummy ocamlmktop; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLMKTOP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLMKTOP"; then ac_cv_prog_OCAMLMKTOP="$OCAMLMKTOP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLMKTOP="ocamlmktop" $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_OCAMLMKTOP" && ac_cv_prog_OCAMLMKTOP="no" fi fi OCAMLMKTOP=$ac_cv_prog_OCAMLMKTOP if test -n "$OCAMLMKTOP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLMKTOP" >&5 $as_echo "$OCAMLMKTOP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLMKTOP" = no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: Cannot find ocamlmktop: toplevels cannot be built." >&5 $as_echo "Cannot find ocamlmktop: toplevels cannot be built." >&6; } fi # ocamlcp # Extract the first word of "ocamlcp", so it can be a program name with args. set dummy ocamlcp; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLCP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLCP"; then ac_cv_prog_OCAMLCP="$OCAMLCP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLCP="ocamlcp" $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_OCAMLCP" && ac_cv_prog_OCAMLCP="no" fi fi OCAMLCP=$ac_cv_prog_OCAMLCP if test -n "$OCAMLCP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLCP" >&5 $as_echo "$OCAMLCP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLCP" = no ; then as_fn_error $? "Cannot find ocamlcp." "$LINENO" 5 fi # Extract the first word of "otags", so it can be a program name with args. set dummy otags; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OTAGS+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OTAGS"; then ac_cv_prog_OTAGS="$OTAGS" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OTAGS="otags" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OTAGS=$ac_cv_prog_OTAGS if test -n "$OTAGS"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OTAGS" >&5 $as_echo "$OTAGS" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "ocamlfind", so it can be a program name with args. set dummy ocamlfind; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLFIND+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLFIND"; then ac_cv_prog_OCAMLFIND="$OCAMLFIND" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLFIND="ocamlfind" $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_OCAMLFIND" && ac_cv_prog_OCAMLFIND="no" fi fi OCAMLFIND=$ac_cv_prog_OCAMLFIND if test -n "$OCAMLFIND"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLFIND" >&5 $as_echo "$OCAMLFIND" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLFIND" = "no" ; then echo "No ocamlfind detected" else OCAMLLIB_BY_FINDLIB=`ocamlfind query stdlib | tr -d '\\r'` if test "$OCAMLLIB_BY_FINDLIB" = "$OCAMLLIB" ; then echo "OCamlfind detected and enabled" else echo "OCamlfind detected but disabled. Standard libraries differ." OCAMLFIND=no fi fi # zarith ######## # Check whether --enable-zarith was given. if test "${enable_zarith+set}" = set; then : enableval=$enable_zarith; ZARITH_PATH=$enableval fi if test -z "$ZARITH_PATH"; then # standard installation procedure of zarith diverges according to # ocamlfind installation (see zarith's README) if test "$OCAMLFIND" = no ; then ZARITH_PATH=$OCAMLLIB else ZARITH_PATH=`ocamlfind printconf destdir | tr -d '\\r\\n'`/zarith fi as_ac_File=`$as_echo "ac_cv_file_$ZARITH_PATH/zarith.$LIB_SUFFIX" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ZARITH_PATH/zarith.$LIB_SUFFIX" >&5 $as_echo_n "checking for $ZARITH_PATH/zarith.$LIB_SUFFIX... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$ZARITH_PATH/zarith.$LIB_SUFFIX"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : HAS_ZARITH=yes else HAS_ZARITH=no fi if test "$HAS_ZARITH" = "no"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Zarith not found: will use the default less efficient library instead" >&5 $as_echo "$as_me: WARNING: Zarith not found: will use the default less efficient library instead" >&2;} fi else as_ac_File=`$as_echo "ac_cv_file_$ZARITH_PATH/zarith.$LIB_SUFFIX" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ZARITH_PATH/zarith.$LIB_SUFFIX" >&5 $as_echo_n "checking for $ZARITH_PATH/zarith.$LIB_SUFFIX... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$ZARITH_PATH/zarith.$LIB_SUFFIX"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : HAS_ZARITH=yes else HAS_ZARITH=no fi if test "$HAS_ZARITH" = "no"; then as_fn_error $? "Zarith: file $ZARITH_PATH/zarith.$LIB_SUFFIX not found." "$LINENO" 5 fi fi ############ # Platform # ############ new_section "configure platform" { $as_echo "$as_me:${as_lineno-$LINENO}: checking platform" >&5 $as_echo_n "checking platform... " >&6; } if echo "let _ = Sys.os_type;;" | ocaml | grep -q Win32; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: Win32" >&5 $as_echo "Win32" >&6; } OCAMLWIN32=yes EXE=.exe else OCAMLWIN32=no if echo "let _ = Sys.os_type;;" | ocaml | grep -q Cygwin; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: Cygwin" >&5 $as_echo "Cygwin" >&6; } EXE=.exe else { $as_echo "$as_me:${as_lineno-$LINENO}: result: Unix" >&5 $as_echo "Unix" >&6; } EXE= fi fi # Local machdep feature (to generate new platforms) if test "$LOCAL_MACHDEP" = yes ; then ac_config_headers="$ac_config_headers config.h" 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 if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" $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 if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" fi fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl.exe do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl.exe do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH See \`config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 $as_echo_n "checking whether the C compiler works... " >&6; } ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { { ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. # So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an `-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else ac_file='' fi if test -z "$ac_file"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables See \`config.log' for more details" "$LINENO" 5; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 $as_echo_n "checking for C compiler default output file name... " >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 $as_echo "$ac_file" >&6; } ac_exeext=$ac_cv_exeext rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 $as_echo_n "checking for suffix of executables... " >&6; } if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest conftest$ac_cv_exeext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 $as_echo "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { FILE *f = fopen ("conftest.out", "w"); return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF ac_clean_files="$ac_clean_files conftest.out" # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 $as_echo_n "checking whether we are cross compiling... " >&6; } if test "$cross_compiling" != yes; then { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if { ac_try='./conftest$ac_cv_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details" "$LINENO" 5; } fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 $as_echo "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; } if ${ac_cv_objext+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 $as_echo "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } if ${ac_cv_c_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_compiler_gnu=yes else ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 $as_echo "$ac_cv_c_compiler_gnu" >&6; } if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } if ${ac_cv_prog_cc_g+:} false; then : $as_echo_n "(cached) " >&6 else ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes else CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 $as_echo "$ac_cv_prog_cc_g" >&6; } if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } if ${ac_cv_prog_cc_c89+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include struct stat; /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) 'x' int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int main () { return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c89=$ac_arg fi rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac if test "x$ac_cv_prog_cc_c89" != xno; then : fi 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 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 { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 $as_echo_n "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if ${ac_cv_prog_CPP+:} false; then : $as_echo_n "(cached) " >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 $as_echo "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details" "$LINENO" 5; } fi 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 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; } if ${ac_cv_path_GREP+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$GREP"; then ac_path_GREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in grep ggrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_GREP" || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in *GNU*) ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'GREP' >> "conftest.nl" "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_GREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_GREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_GREP"; then as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_GREP=$GREP fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 $as_echo "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 $as_echo_n "checking for egrep... " >&6; } if ${ac_cv_path_EGREP+:} false; then : $as_echo_n "(cached) " >&6 else if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 then ac_cv_path_EGREP="$GREP -E" else if test -z "$EGREP"; then ac_path_EGREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in egrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_EGREP" || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP case `"$ac_path_EGREP" --version 2>&1` in *GNU*) ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'EGREP' >> "conftest.nl" "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_EGREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_EGREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_EGREP"; then as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_EGREP=$EGREP fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 $as_echo "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if ${ac_cv_header_stdc+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdc=yes else ac_cv_header_stdc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : : else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) return 2; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : else ac_cv_header_stdc=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then $as_echo "#define STDC_HEADERS 1" >>confdefs.h fi # On IRIX 5.3, sys/types and inttypes.h are conflicting. for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default " if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in stdlib.h do : ac_fn_c_check_header_mongrel "$LINENO" "stdlib.h" "ac_cv_header_stdlib_h" "$ac_includes_default" if test "x$ac_cv_header_stdlib_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STDLIB_H 1 _ACEOF fi done for ac_header in wchar.h do : ac_fn_c_check_header_mongrel "$LINENO" "wchar.h" "ac_cv_header_wchar_h" "$ac_includes_default" if test "x$ac_cv_header_wchar_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_WCHAR_H 1 _ACEOF fi done # Find out the true definitions of some integer types # checkIntegerype(size_t) will echo "int" or "long" checkIntegerType() { fn="testtype.c" fo="testtype.o" for t in "int" "unsigned int" "long" "unsigned long" "short" "unsigned short" "char" "unsigned char" ;do echo "#include " >$fn echo "#include " >>$fn # We define a prototype with one type and the function with # another type. This will result in compilation error # unless the types are really identical echo "$t foo($t x);" >>$fn echo "$1 foo($1 x) { return x;}" >>$fn if gcc -c $fn 2>/dev/null ;then # Found it echo $t rm -f $fn $fo return fi done rm -f $fn $fo } { $as_echo "$as_me:${as_lineno-$LINENO}: checking definition of size_t" >&5 $as_echo_n "checking definition of size_t... " >&6; } TYPE_SIZE_T=`checkIntegerType "size_t"` if test "x$TYPE_SIZE_T" = "x" ;then as_fn_error $? "Cannot find definition of size_t" "$LINENO" 5 fi cat >>confdefs.h <<_ACEOF #define TYPE_SIZE_T "$TYPE_SIZE_T" _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: result: $TYPE_SIZE_T" >&5 $as_echo "$TYPE_SIZE_T" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking definition of wchar_t" >&5 $as_echo_n "checking definition of wchar_t... " >&6; } TYPE_WCHAR_T=`checkIntegerType "wchar_t"` if test "x$TYPE_WCHAR_T" = "x" ;then as_fn_error $? "Cannot find definition of wchar_t" "$LINENO" 5 fi cat >>confdefs.h <<_ACEOF #define TYPE_WCHAR_T "$TYPE_WCHAR_T" _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: result: $TYPE_WCHAR_T" >&5 $as_echo "$TYPE_WCHAR_T" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking definition of ptrdiff_t" >&5 $as_echo_n "checking definition of ptrdiff_t... " >&6; } TYPE_PTRDIFF_T=`checkIntegerType "ptrdiff_t"` if test "x$TYPE_PTRDIFF_T" = "x" ;then as_fn_error $? "Cannot find definition of ptrdiff_t" "$LINENO" 5 fi cat >>confdefs.h <<_ACEOF #define TYPE_PTRDIFF_T "$TYPE_PTRDIFF_T" _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: result: $TYPE_PTRDIFF_T" >&5 $as_echo "$TYPE_PTRDIFF_T" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gcc version" >&5 $as_echo_n "checking for gcc version... " >&6; } ac_fn_c_check_type "$LINENO" "__builtin_va_list" "ac_cv_type___builtin_va_list" "$ac_includes_default" if test "x$ac_cv_type___builtin_va_list" = xyes; then : HAVE_BUILTIN_VA_LIST=true else HAVE_BUILTIN_VA_LIST=false fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking if __thread is a keyword" >&5 $as_echo_n "checking if __thread is a keyword... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main(int __thread) { return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : THREAD_IS_KEYWORD=false else THREAD_IS_KEYWORD=true fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $THREAD_IS_KEYWORD" >&5 $as_echo "$THREAD_IS_KEYWORD" >&6; } # Does gcc add underscores to identifiers to make assembly labels? # (I think MSVC always does) { $as_echo "$as_me:${as_lineno-$LINENO}: checking if gcc adds underscores to assembly labels." >&5 $as_echo_n "checking if gcc adds underscores to assembly labels.... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main() { __asm__("jmp _main"); } _ACEOF if ac_fn_c_try_link "$LINENO"; then : UNDERSCORE_NAME=true else UNDERSCORE_NAME=false fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $UNDERSCORE_NAME" >&5 $as_echo "$UNDERSCORE_NAME" >&6; } fi # local machdep configuration ########################## # Frama-C's mcpp support # ########################## # Check whether --enable-mcpp was given. if test "${enable_mcpp+set}" = set; then : enableval=$enable_mcpp; #' making emacs mode happy FC_MCPP=$enableval else FC_MCPP=no fi if test "$FC_MCPP" = no ; then FRAMAC_DEFAULT_CPP="gcc -C -E -I." ; else new_section "configure Frama-C-mcpp" (cd mcpp ; ./configure --prefix=$prefix --datarootdir=$datarootdir \ --exec_prefix=$exec_prefix --bindir=$bindir --libdir=$datadir/frama-c \ --host=$host --build=$build --mandir=$mandir > /dev/null \ || \ as_fn_error $? "cannot configure Frama-C-mcpp" "$LINENO" 5) FRAMAC_DEFAULT_CPP="frama-c-mcpp$EXE -C -I- -I$datadir/frama-c/libc -I." fi # Specific preprocessor support # Check whether --with-cpp was given. if test "${with_cpp+set}" = set; then : withval=$with_cpp; FRAMAC_DEFAULT_CPP=$withval fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: Default preprocessor is $FRAMAC_DEFAULT_CPP." >&5 $as_echo "Default preprocessor is $FRAMAC_DEFAULT_CPP." >&6; } ################# # Plugin wished # ################# new_section "wished frama-c plug-ins" # Option -with-all-static ####################### # Check whether --with-all-static was given. if test "${with_all_static+set}" = set; then : withval=$with_all_static; IS_ALL_STATIC=$withval fi # Option -with-no-plugin ####################### # Check whether --with-no-plugin was given. if test "${with_no_plugin+set}" = set; then : withval=$with_no_plugin; ONLY_KERNEL=$withval else ONLY_KERNEL=no fi # library declarations ###################### # REQUIRE_LIBRARY: library *must* be present in order to build plugins # USE_LIBRARY: better for plugins if library is present, but not required # HAS_LIBRARY: is the library available? REQUIRE_LABLGTK= USE_LABLGTK= HAS_LABLGTK= REQUIRE_NATIVE_DYNLINK= USE_NATIVE_DYNLINK= HAS_NATIVE_DYNLINK=uncheck # Tool declarations #################### DOT= REQUIRE_DOT= USE_DOT= HAS_DOT= ### Now plugin declarations PLUGINS_FORCE_LIST= ############################################################################### # # #################### # # Plug-in sections # # #################### # # # # For 'internal' developpers: # # Add your own plug-in here # # # ############################################################################### # constant propagation ###################### { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/constant_propagation" >&5 $as_echo_n "checking for src/constant_propagation... " >&6; } if ${ac_cv_file_src_constant_propagation+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/constant_propagation"; then ac_cv_file_src_constant_propagation=yes else ac_cv_file_src_constant_propagation=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_constant_propagation" >&5 $as_echo "$ac_cv_file_src_constant_propagation" >&6; } if test "x$ac_cv_file_src_constant_propagation" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-semantic_constant_folding was given. if test "${enable_semantic_constant_folding+set}" = set; then : enableval=$enable_semantic_constant_folding; 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 $? "semantic_constant_folding is not available" "$LINENO" 5 fi FORCE_SEMANTIC_CONSTANT_FOLDING=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_SEMANTIC_CONSTANT_FOLDING ENABLE_SEMANTIC_CONSTANT_FOLDING=$ENABLE NAME_SEMANTIC_CONSTANT_FOLDING=semantic_constant_folding if test "$default" = "no" -a "$FORCE" = "no"; then INFO_SEMANTIC_CONSTANT_FOLDING=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_SEMANTIC_CONSTANT_FOLDING=no echo "semantic_constant_folding... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) REQUIRE_VALUE_ANALYSIS=$REQUIRE_VALUE_ANALYSIS" "semantic_constant_folding REQUIRED_SEMANTIC_CONSTANT_FOLDING=$REQUIRED_SEMANTIC_CONSTANT_FOLDING" "value_analysis # from ###### { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/from" >&5 $as_echo_n "checking for src/from... " >&6; } if ${ac_cv_file_src_from+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/from"; then ac_cv_file_src_from=yes else ac_cv_file_src_from=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_from" >&5 $as_echo "$ac_cv_file_src_from" >&6; } if test "x$ac_cv_file_src_from" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-from_analysis was given. if test "${enable_from_analysis+set}" = set; then : enableval=$enable_from_analysis; 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 $? "from_analysis is not available" "$LINENO" 5 fi FORCE_FROM_ANALYSIS=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_FROM_ANALYSIS ENABLE_FROM_ANALYSIS=$ENABLE NAME_FROM_ANALYSIS=from_analysis if test "$default" = "no" -a "$FORCE" = "no"; then INFO_FROM_ANALYSIS=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_FROM_ANALYSIS=no echo "from_analysis... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) REQUIRE_VALUE_ANALYSIS=$REQUIRE_VALUE_ANALYSIS" "from_analysis REQUIRED_FROM_ANALYSIS=$REQUIRED_FROM_ANALYSIS" "value_analysis REQUIRE_SEMANTIC_CALLGRAPH=$REQUIRE_SEMANTIC_CALLGRAPH" "from_analysis REQUIRED_FROM_ANALYSIS=$REQUIRED_FROM_ANALYSIS" "semantic_callgraph # gui ##### { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/gui" >&5 $as_echo_n "checking for src/gui... " >&6; } if ${ac_cv_file_src_gui+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/gui"; then ac_cv_file_src_gui=yes else ac_cv_file_src_gui=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_gui" >&5 $as_echo "$ac_cv_file_src_gui" >&6; } if test "x$ac_cv_file_src_gui" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-gui was given. if test "${enable_gui+set}" = set; then : enableval=$enable_gui; 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 $? "gui is not available" "$LINENO" 5 fi FORCE_GUI=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_GUI ENABLE_GUI=$ENABLE NAME_GUI=gui if test "$default" = "no" -a "$FORCE" = "no"; then INFO_GUI=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_GUI=no echo "gui... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) REQUIRE_LABLGTK=$REQUIRE_LABLGTK" "gui REQUIRE_GNOMECANVAS=$REQUIRE_GNOMECANVAS" "gui USE_DOT=$USE_DOT" "gui # impact ######## { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/impact" >&5 $as_echo_n "checking for src/impact... " >&6; } if ${ac_cv_file_src_impact+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/impact"; then ac_cv_file_src_impact=yes else ac_cv_file_src_impact=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_impact" >&5 $as_echo "$ac_cv_file_src_impact" >&6; } if test "x$ac_cv_file_src_impact" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-impact was given. if test "${enable_impact+set}" = set; then : enableval=$enable_impact; 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 $? "impact is not available" "$LINENO" 5 fi FORCE_IMPACT=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_IMPACT ENABLE_IMPACT=$ENABLE NAME_IMPACT=impact if test "$default" = "no" -a "$FORCE" = "no"; then INFO_IMPACT=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_IMPACT=no echo "impact... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) USE_GUI=$USE_GUI" "impact USED_IMPACT=$USED_IMPACT" "gui USE_SLICING=$USE_SLICING" "impact USED_IMPACT=$USED_IMPACT" "slicing REQUIRE_PDG=$REQUIRE_PDG" "impact REQUIRED_IMPACT=$REQUIRED_IMPACT" "pdg REQUIRE_VALUE_ANALYSIS=$REQUIRE_VALUE_ANALYSIS" "impact REQUIRED_IMPACT=$REQUIRED_IMPACT" "value_analysis REQUIRE_INOUT=$REQUIRE_INOUT" "impact REQUIRED_IMPACT=$REQUIRED_IMPACT" "inout # inout ####### { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/inout" >&5 $as_echo_n "checking for src/inout... " >&6; } if ${ac_cv_file_src_inout+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/inout"; then ac_cv_file_src_inout=yes else ac_cv_file_src_inout=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_inout" >&5 $as_echo "$ac_cv_file_src_inout" >&6; } if test "x$ac_cv_file_src_inout" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-inout was given. if test "${enable_inout+set}" = set; then : enableval=$enable_inout; 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 $? "inout is not available" "$LINENO" 5 fi FORCE_INOUT=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_INOUT ENABLE_INOUT=$ENABLE NAME_INOUT=inout if test "$default" = "no" -a "$FORCE" = "no"; then INFO_INOUT=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_INOUT=no echo "inout... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) REQUIRE_FROM_ANALYSIS=$REQUIRE_FROM_ANALYSIS" "inout REQUIRED_INOUT=$REQUIRED_INOUT" "from_analysis REQUIRE_VALUE_ANALYSIS=$REQUIRE_VALUE_ANALYSIS" "inout REQUIRED_INOUT=$REQUIRED_INOUT" "value_analysis REQUIRE_SEMANTIC_CALLGRAPH=$REQUIRE_SEMANTIC_CALLGRAPH" "inout REQUIRED_INOUT=$REQUIRED_INOUT" "semantic_callgraph # metrics ######### { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/metrics" >&5 $as_echo_n "checking for src/metrics... " >&6; } if ${ac_cv_file_src_metrics+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/metrics"; then ac_cv_file_src_metrics=yes else ac_cv_file_src_metrics=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_metrics" >&5 $as_echo "$ac_cv_file_src_metrics" >&6; } if test "x$ac_cv_file_src_metrics" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-metrics was given. if test "${enable_metrics+set}" = set; then : enableval=$enable_metrics; 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 $? "metrics is not available" "$LINENO" 5 fi FORCE_METRICS=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_METRICS ENABLE_METRICS=$ENABLE NAME_METRICS=metrics if test "$default" = "no" -a "$FORCE" = "no"; then INFO_METRICS=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_METRICS=no echo "metrics... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) USE_VALUE_ANALYSIS=$USE_VALUE_ANALYSIS" "metrics USED_METRICS=$USED_METRICS" "value_analysis USE_GUI=$USE_GUI" "metrics USED_METRICS=$USED_METRICS" "gui # occurrence ############ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/occurrence" >&5 $as_echo_n "checking for src/occurrence... " >&6; } if ${ac_cv_file_src_occurrence+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/occurrence"; then ac_cv_file_src_occurrence=yes else ac_cv_file_src_occurrence=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_occurrence" >&5 $as_echo "$ac_cv_file_src_occurrence" >&6; } if test "x$ac_cv_file_src_occurrence" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-occurrence was given. if test "${enable_occurrence+set}" = set; then : enableval=$enable_occurrence; 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 $? "occurrence is not available" "$LINENO" 5 fi FORCE_OCCURRENCE=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_OCCURRENCE ENABLE_OCCURRENCE=$ENABLE NAME_OCCURRENCE=occurrence if test "$default" = "no" -a "$FORCE" = "no"; then INFO_OCCURRENCE=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_OCCURRENCE=no echo "occurrence... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) USE_GUI=$USE_GUI" "occurrence USED_OCCURRENCE=$USED_OCCURRENCE" "gui REQUIRE_VALUE_ANALYSIS=$REQUIRE_VALUE_ANALYSIS" "occurrence REQUIRED_OCCURRENCE=$REQUIRED_OCCURRENCE" "value_analysis # pdg ##### { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/pdg" >&5 $as_echo_n "checking for src/pdg... " >&6; } if ${ac_cv_file_src_pdg+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/pdg"; then ac_cv_file_src_pdg=yes else ac_cv_file_src_pdg=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_pdg" >&5 $as_echo "$ac_cv_file_src_pdg" >&6; } if test "x$ac_cv_file_src_pdg" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-pdg was given. if test "${enable_pdg+set}" = set; then : enableval=$enable_pdg; 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 $? "pdg is not available" "$LINENO" 5 fi FORCE_PDG=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_PDG ENABLE_PDG=$ENABLE NAME_PDG=pdg if test "$default" = "no" -a "$FORCE" = "no"; then INFO_PDG=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_PDG=no echo "pdg... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) REQUIRE_FROM_ANALYSIS=$REQUIRE_FROM_ANALYSIS" "pdg REQUIRED_PDG=$REQUIRED_PDG" "from_analysis REQUIRE_VALUE_ANALYSIS=$REQUIRE_VALUE_ANALYSIS" "pdg REQUIRED_PDG=$REQUIRED_PDG" "value_analysis # postdominators ################ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/postdominators" >&5 $as_echo_n "checking for src/postdominators... " >&6; } if ${ac_cv_file_src_postdominators+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/postdominators"; then ac_cv_file_src_postdominators=yes else ac_cv_file_src_postdominators=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_postdominators" >&5 $as_echo "$ac_cv_file_src_postdominators" >&6; } if test "x$ac_cv_file_src_postdominators" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-postdominators was given. if test "${enable_postdominators+set}" = set; then : enableval=$enable_postdominators; 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 $? "postdominators is not available" "$LINENO" 5 fi FORCE_POSTDOMINATORS=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_POSTDOMINATORS ENABLE_POSTDOMINATORS=$ENABLE NAME_POSTDOMINATORS=postdominators if test "$default" = "no" -a "$FORCE" = "no"; then INFO_POSTDOMINATORS=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_POSTDOMINATORS=no echo "postdominators... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) # rte ##### { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/rte" >&5 $as_echo_n "checking for src/rte... " >&6; } if ${ac_cv_file_src_rte+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/rte"; then ac_cv_file_src_rte=yes else ac_cv_file_src_rte=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_rte" >&5 $as_echo "$ac_cv_file_src_rte" >&6; } if test "x$ac_cv_file_src_rte" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-rte_annotation was given. if test "${enable_rte_annotation+set}" = set; then : enableval=$enable_rte_annotation; 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 $? "rte_annotation is not available" "$LINENO" 5 fi FORCE_RTE_ANNOTATION=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_RTE_ANNOTATION ENABLE_RTE_ANNOTATION=$ENABLE NAME_RTE_ANNOTATION=rte_annotation if test "$default" = "no" -a "$FORCE" = "no"; then INFO_RTE_ANNOTATION=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_RTE_ANNOTATION=no echo "rte_annotation... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) # scope ############ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/scope" >&5 $as_echo_n "checking for src/scope... " >&6; } if ${ac_cv_file_src_scope+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/scope"; then ac_cv_file_src_scope=yes else ac_cv_file_src_scope=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_scope" >&5 $as_echo "$ac_cv_file_src_scope" >&6; } if test "x$ac_cv_file_src_scope" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-scope was given. if test "${enable_scope+set}" = set; then : enableval=$enable_scope; 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 $? "scope is not available" "$LINENO" 5 fi FORCE_SCOPE=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_SCOPE ENABLE_SCOPE=$ENABLE NAME_SCOPE=scope if test "$default" = "no" -a "$FORCE" = "no"; then INFO_SCOPE=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_SCOPE=no echo "scope... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) REQUIRE_POSTDOMINATORS=$REQUIRE_POSTDOMINATORS" "scope REQUIRED_SCOPE=$REQUIRED_SCOPE" "postdominators REQUIRE_VALUE_ANALYSIS=$REQUIRE_VALUE_ANALYSIS" "scope REQUIRED_SCOPE=$REQUIRED_SCOPE" "value_analysis REQUIRE_FROM_ANALYSIS=$REQUIRE_FROM_ANALYSIS" "scope REQUIRED_SCOPE=$REQUIRED_SCOPE" "from_analysis REQUIRE_PDG=$REQUIRE_PDG" "scope REQUIRED_SCOPE=$REQUIRED_SCOPE" "pdg USE_GUI=$USE_GUI" "scope USED_SCOPE=$USED_SCOPE" "gui # semantic callgraph #################### { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/semantic_callgraph" >&5 $as_echo_n "checking for src/semantic_callgraph... " >&6; } if ${ac_cv_file_src_semantic_callgraph+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/semantic_callgraph"; then ac_cv_file_src_semantic_callgraph=yes else ac_cv_file_src_semantic_callgraph=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_semantic_callgraph" >&5 $as_echo "$ac_cv_file_src_semantic_callgraph" >&6; } if test "x$ac_cv_file_src_semantic_callgraph" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-semantic_callgraph was given. if test "${enable_semantic_callgraph+set}" = set; then : enableval=$enable_semantic_callgraph; 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 $? "semantic_callgraph is not available" "$LINENO" 5 fi FORCE_SEMANTIC_CALLGRAPH=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_SEMANTIC_CALLGRAPH ENABLE_SEMANTIC_CALLGRAPH=$ENABLE NAME_SEMANTIC_CALLGRAPH=semantic_callgraph if test "$default" = "no" -a "$FORCE" = "no"; then INFO_SEMANTIC_CALLGRAPH=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_SEMANTIC_CALLGRAPH=no echo "semantic_callgraph... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) REQUIRE_VALUE_ANALYSIS=$REQUIRE_VALUE_ANALYSIS" "semantic_callgraph REQUIRED_SEMANTIC_CALLGRAPH=$REQUIRED_SEMANTIC_CALLGRAPH" "value_analysis REQUIRE_USERS=$REQUIRE_USERS" "semantic_callgraph REQUIRED_SEMANTIC_CALLGRAPH=$REQUIRED_SEMANTIC_CALLGRAPH" "users # slicing ######### { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/slicing" >&5 $as_echo_n "checking for src/slicing... " >&6; } if ${ac_cv_file_src_slicing+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/slicing"; then ac_cv_file_src_slicing=yes else ac_cv_file_src_slicing=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_slicing" >&5 $as_echo "$ac_cv_file_src_slicing" >&6; } if test "x$ac_cv_file_src_slicing" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-slicing was given. if test "${enable_slicing+set}" = set; then : enableval=$enable_slicing; 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 $? "slicing is not available" "$LINENO" 5 fi FORCE_SLICING=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_SLICING ENABLE_SLICING=$ENABLE NAME_SLICING=slicing if test "$default" = "no" -a "$FORCE" = "no"; then INFO_SLICING=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_SLICING=no echo "slicing... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) REQUIRE_FROM_ANALYSIS=$REQUIRE_FROM_ANALYSIS" "slicing REQUIRED_SLICING=$REQUIRED_SLICING" "from_analysis REQUIRE_PDG=$REQUIRE_PDG" "slicing REQUIRED_SLICING=$REQUIRED_SLICING" "pdg REQUIRE_VALUE_ANALYSIS=$REQUIRE_VALUE_ANALYSIS" "slicing REQUIRED_SLICING=$REQUIRED_SLICING" "value_analysis USE_GUI=$USE_GUI" "slicing USED_SLICING=$USED_SLICING" "gui # spare code ############ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/sparecode" >&5 $as_echo_n "checking for src/sparecode... " >&6; } if ${ac_cv_file_src_sparecode+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/sparecode"; then ac_cv_file_src_sparecode=yes else ac_cv_file_src_sparecode=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_sparecode" >&5 $as_echo "$ac_cv_file_src_sparecode" >&6; } if test "x$ac_cv_file_src_sparecode" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-sparecode was given. if test "${enable_sparecode+set}" = set; then : enableval=$enable_sparecode; 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 $? "sparecode is not available" "$LINENO" 5 fi FORCE_SPARECODE=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_SPARECODE ENABLE_SPARECODE=$ENABLE NAME_SPARECODE=sparecode if test "$default" = "no" -a "$FORCE" = "no"; then INFO_SPARECODE=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_SPARECODE=no echo "sparecode... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) REQUIRE_PDG=$REQUIRE_PDG" "sparecode REQUIRED_SPARECODE=$REQUIRED_SPARECODE" "pdg REQUIRE_VALUE_ANALYSIS=$REQUIRE_VALUE_ANALYSIS" "sparecode REQUIRED_SPARECODE=$REQUIRED_SPARECODE" "value_analysis # syntactic callgraph ##################### { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/syntactic_callgraph" >&5 $as_echo_n "checking for src/syntactic_callgraph... " >&6; } if ${ac_cv_file_src_syntactic_callgraph+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/syntactic_callgraph"; then ac_cv_file_src_syntactic_callgraph=yes else ac_cv_file_src_syntactic_callgraph=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_syntactic_callgraph" >&5 $as_echo "$ac_cv_file_src_syntactic_callgraph" >&6; } if test "x$ac_cv_file_src_syntactic_callgraph" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-syntactic_callgraph was given. if test "${enable_syntactic_callgraph+set}" = set; then : enableval=$enable_syntactic_callgraph; 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 $? "syntactic_callgraph is not available" "$LINENO" 5 fi FORCE_SYNTACTIC_CALLGRAPH=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_SYNTACTIC_CALLGRAPH ENABLE_SYNTACTIC_CALLGRAPH=$ENABLE NAME_SYNTACTIC_CALLGRAPH=syntactic_callgraph if test "$default" = "no" -a "$FORCE" = "no"; then INFO_SYNTACTIC_CALLGRAPH=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_SYNTACTIC_CALLGRAPH=no echo "syntactic_callgraph... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) USE_DOT=$USE_DOT" "syntactic_callgraph USE_GUI=$USE_GUI" "syntactic_callgraph USED_SYNTACTIC_CALLGRAPH=$USED_SYNTACTIC_CALLGRAPH" "gui # users ####### { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/users" >&5 $as_echo_n "checking for src/users... " >&6; } if ${ac_cv_file_src_users+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/users"; then ac_cv_file_src_users=yes else ac_cv_file_src_users=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_users" >&5 $as_echo "$ac_cv_file_src_users" >&6; } if test "x$ac_cv_file_src_users" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-users was given. if test "${enable_users+set}" = set; then : enableval=$enable_users; 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 $? "users is not available" "$LINENO" 5 fi FORCE_USERS=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_USERS ENABLE_USERS=$ENABLE NAME_USERS=users if test "$default" = "no" -a "$FORCE" = "no"; then INFO_USERS=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_USERS=no echo "users... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) REQUIRE_VALUE_ANALYSIS=$REQUIRE_VALUE_ANALYSIS" "users REQUIRED_USERS=$REQUIRED_USERS" "value_analysis # value ####### { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/value" >&5 $as_echo_n "checking for src/value... " >&6; } if ${ac_cv_file_src_value+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/value"; then ac_cv_file_src_value=yes else ac_cv_file_src_value=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_value" >&5 $as_echo "$ac_cv_file_src_value" >&6; } if test "x$ac_cv_file_src_value" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-value_analysis was given. if test "${enable_value_analysis+set}" = set; then : enableval=$enable_value_analysis; 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 $? "value_analysis is not available" "$LINENO" 5 fi FORCE_VALUE_ANALYSIS=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_VALUE_ANALYSIS ENABLE_VALUE_ANALYSIS=$ENABLE NAME_VALUE_ANALYSIS=value_analysis if test "$default" = "no" -a "$FORCE" = "no"; then INFO_VALUE_ANALYSIS=" (not available by default)" fi # Dynamic plug-ins configuration # static plug-in DYNAMIC_VALUE_ANALYSIS=no echo "value_analysis... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) USE_GUI=$USE_GUI" "value_analysis USED_VALUE_ANALYSIS=$USED_VALUE_ANALYSIS" "gui USE_SCOPE=$USE_SCOPE" "value_analysis USED_VALUE_ANALYSIS=$USED_VALUE_ANALYSIS" "scope #################### # External plugins # #################### EXTRA_EXTERNAL_PLUGINS= # Check whether --enable-external was given. if test "${enable_external+set}" = set; then : enableval=$enable_external; if test -d $enableval; then { $as_echo "$as_me:${as_lineno-$LINENO}: external plug-in $enableval found." >&5 $as_echo "$as_me: external plug-in $enableval found." >&6;} EXTRA_EXTERNAL_PLUGINS="$EXTRA_EXTERNAL_PLUGINS $enableval" olddir=`pwd` cd $enableval; if test -x ./configure; then new_section "configure plug-in $enableval" ./configure --prefix=$prefix --datarootdir=$datarootdir \ --exec_prefix=$exec_prefix --bindir=$bindir --libdir=$datadir/frama-c \ --host=$host --build=$build --mandir=$mandir \ || \ as_fn_error $? "cannot configure requested external plugin in $enableval" "$LINENO" 5 fi; cd $olddir else as_fn_error $? "--enable-external expects an existing directory as argument." "$LINENO" 5 fi fi ########################################################################## # # # This file is part of Aorai plug-in of Frama-C. # # # # Copyright (C) 2007-2013 # # CEA (Commissariat a l'nergie atomique et aux nergies # # alternatives) # # INRIA (Institut National de Recherche en Informatique et en # # Automatique) # # INSA (Institut National des Sciences Appliquees) # # # # 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). # # # ########################################################################## { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/aorai/Makefile.in" >&5 $as_echo_n "checking for src/aorai/Makefile.in... " >&6; } if ${ac_cv_file_src_aorai_Makefile_in+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/aorai/Makefile.in"; then ac_cv_file_src_aorai_Makefile_in=yes else ac_cv_file_src_aorai_Makefile_in=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_aorai_Makefile_in" >&5 $as_echo "$ac_cv_file_src_aorai_Makefile_in" >&6; } if test "x$ac_cv_file_src_aorai_Makefile_in" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-aorai was given. if test "${enable_aorai+set}" = set; then : enableval=$enable_aorai; 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 $? "aorai is not available" "$LINENO" 5 fi FORCE_AORAI=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_AORAI ENABLE_AORAI=$ENABLE NAME_AORAI=aorai if test "$default" = "no" -a "$FORCE" = "no"; then INFO_AORAI=" (not available by default)" fi # Dynamic plug-ins configuration # Check whether --with-aorai-static was given. if test "${with_aorai_static+set}" = set; then : withval=$with_aorai_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_AORAI=$is_static if test "$is_static" != "yes"; then USE_NATIVE_DYNLINK="${USE_NATIVE_DYNLINK} aorai" DYNAMIC_AORAI=yes else DYNAMIC_AORAI=no fi echo "aorai... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) if test "$ENABLE_AORAI" != "no"; then USE_LTLTOBA=$USE_LTLTOBA" "aorai # ltl2ba library for file in ltl2ba; do HAS_LTLTOBA= # 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 ${ac_cv_prog_HAS_LTLTOBA+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$HAS_LTLTOBA"; then ac_cv_prog_HAS_LTLTOBA="$HAS_LTLTOBA" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_HAS_LTLTOBA="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_LTLTOBA" && ac_cv_prog_HAS_LTLTOBA="no" fi fi HAS_LTLTOBA=$ac_cv_prog_HAS_LTLTOBA if test -n "$HAS_LTLTOBA"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $HAS_LTLTOBA" >&5 $as_echo "$HAS_LTLTOBA" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$HAS_LTLTOBA" = "yes"; then SELECTED_VAR=$file break; fi done fi ac_config_files="$ac_config_files src/aorai/Makefile" if test "$ENABLE_AORAI" != "no"; then EXTERNAL_PLUGINS="${EXTERNAL_PLUGINS} src/aorai"; fi ########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/obfuscator/Makefile.in" >&5 $as_echo_n "checking for src/obfuscator/Makefile.in... " >&6; } if ${ac_cv_file_src_obfuscator_Makefile_in+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/obfuscator/Makefile.in"; then ac_cv_file_src_obfuscator_Makefile_in=yes else ac_cv_file_src_obfuscator_Makefile_in=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_obfuscator_Makefile_in" >&5 $as_echo "$ac_cv_file_src_obfuscator_Makefile_in" >&6; } if test "x$ac_cv_file_src_obfuscator_Makefile_in" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-obfuscator was given. if test "${enable_obfuscator+set}" = set; then : enableval=$enable_obfuscator; 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 $? "obfuscator is not available" "$LINENO" 5 fi FORCE_OBFUSCATOR=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_OBFUSCATOR ENABLE_OBFUSCATOR=$ENABLE NAME_OBFUSCATOR=obfuscator if test "$default" = "no" -a "$FORCE" = "no"; then INFO_OBFUSCATOR=" (not available by default)" fi # Dynamic plug-ins configuration # Check whether --with-obfuscator-static was given. if test "${with_obfuscator_static+set}" = set; then : withval=$with_obfuscator_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_OBFUSCATOR=$is_static if test "$is_static" != "yes"; then USE_NATIVE_DYNLINK="${USE_NATIVE_DYNLINK} obfuscator" DYNAMIC_OBFUSCATOR=yes else DYNAMIC_OBFUSCATOR=no fi echo "obfuscator... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) ac_config_files="$ac_config_files src/obfuscator/Makefile" if test "$ENABLE_OBFUSCATOR" != "no"; then EXTERNAL_PLUGINS="${EXTERNAL_PLUGINS} src/obfuscator"; fi ########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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 # ######################################## { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/report/Makefile.in" >&5 $as_echo_n "checking for src/report/Makefile.in... " >&6; } if ${ac_cv_file_src_report_Makefile_in+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/report/Makefile.in"; then ac_cv_file_src_report_Makefile_in=yes else ac_cv_file_src_report_Makefile_in=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_report_Makefile_in" >&5 $as_echo "$ac_cv_file_src_report_Makefile_in" >&6; } if test "x$ac_cv_file_src_report_Makefile_in" = xyes; 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 src/report/Makefile" if test "$ENABLE_REPORT" != "no"; then EXTERNAL_PLUGINS="${EXTERNAL_PLUGINS} src/report"; fi ########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/security_slicing/Makefile.in" >&5 $as_echo_n "checking for src/security_slicing/Makefile.in... " >&6; } if ${ac_cv_file_src_security_slicing_Makefile_in+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/security_slicing/Makefile.in"; then ac_cv_file_src_security_slicing_Makefile_in=yes else ac_cv_file_src_security_slicing_Makefile_in=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_security_slicing_Makefile_in" >&5 $as_echo "$ac_cv_file_src_security_slicing_Makefile_in" >&6; } if test "x$ac_cv_file_src_security_slicing_Makefile_in" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-security_slicing was given. if test "${enable_security_slicing+set}" = set; then : enableval=$enable_security_slicing; 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 $? "security_slicing is not available" "$LINENO" 5 fi FORCE_SECURITY_SLICING=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_SECURITY_SLICING ENABLE_SECURITY_SLICING=$ENABLE NAME_SECURITY_SLICING=security_slicing if test "$default" = "no" -a "$FORCE" = "no"; then INFO_SECURITY_SLICING=" (not available by default)" fi # Dynamic plug-ins configuration # Check whether --with-security_slicing-static was given. if test "${with_security_slicing_static+set}" = set; then : withval=$with_security_slicing_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_SECURITY_SLICING=$is_static if test "$is_static" != "yes"; then USE_NATIVE_DYNLINK="${USE_NATIVE_DYNLINK} security_slicing" DYNAMIC_SECURITY_SLICING=yes else DYNAMIC_SECURITY_SLICING=no fi echo "security_slicing... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) if test "$ENABLE_SECURITY_SLICING" != "no"; then REQUIRE_SLICING=$REQUIRE_SLICING" "security_slicing REQUIRED_SECURITY_SLICING=$REQUIRED_SECURITY_SLICING" "slicing REQUIRE_VALUE_ANALYSIS=$REQUIRE_VALUE_ANALYSIS" "security_slicing REQUIRED_SECURITY_SLICING=$REQUIRED_SECURITY_SLICING" "value_analysis REQUIRE_PDG=$REQUIRE_PDG" "security_slicing REQUIRED_SECURITY_SLICING=$REQUIRED_SECURITY_SLICING" "pdg REQUIRE_GUI=$REQUIRE_GUI" "security_slicing REQUIRED_SECURITY_SLICING=$REQUIRED_SECURITY_SLICING" "gui fi ac_config_files="$ac_config_files src/security_slicing/Makefile" if test "$ENABLE_SECURITY_SLICING" != "no"; then EXTERNAL_PLUGINS="${EXTERNAL_PLUGINS} src/security_slicing"; fi ########################################################################## # # # This file is part of WP plug-in of Frama-C. # # # # Copyright (C) 2007-2013 # # CEA (Commissariat a l'energie atomique et aux energies # # 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). # # # ########################################################################## { $as_echo "$as_me:${as_lineno-$LINENO}: checking for src/wp/Makefile.in" >&5 $as_echo_n "checking for src/wp/Makefile.in... " >&6; } if ${ac_cv_file_src_wp_Makefile_in+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "src/wp/Makefile.in"; then ac_cv_file_src_wp_Makefile_in=yes else ac_cv_file_src_wp_Makefile_in=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_src_wp_Makefile_in" >&5 $as_echo "$ac_cv_file_src_wp_Makefile_in" >&6; } if test "x$ac_cv_file_src_wp_Makefile_in" = xyes; 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]) # Check whether --enable-wpcoq was given. if test "${enable_wpcoq+set}" = set; then : enableval=$enable_wpcoq; WPCOQ=$enableval else WPCOQ=yes fi 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 if test "$WPCOQ" = "yes" ; then ## coq # Extract the first word of "coqc", so it can be a program name with args. set dummy coqc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_COQC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$COQC"; then ac_cv_prog_COQC="$COQC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_COQC="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_COQC" && ac_cv_prog_COQC="no" fi fi COQC=$ac_cv_prog_COQC if test -n "$COQC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $COQC" >&5 $as_echo "$COQC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$COQC" = "yes" ; then COQVERSION=`coqc -v | sed -n -e 's|.*version* *\([^ ]*\) .*$|\1|p' ` case $COQVERSION in 8.4*|trunk) { $as_echo "$as_me:${as_lineno-$LINENO}: result: coqc version $COQVERSION found" >&5 $as_echo "coqc version $COQVERSION found" >&6; } ;; *) { $as_echo "$as_me:${as_lineno-$LINENO}: result: wp needs coq 8.4" >&5 $as_echo "wp needs coq 8.4" >&6; } COQC="no" ;; esac else { $as_echo "$as_me:${as_lineno-$LINENO}: rerun configure to make wp using coq 8.4" >&5 $as_echo "$as_me: rerun configure to make wp using coq 8.4" >&6;} fi else COQC="no" fi fi ac_config_files="$ac_config_files src/wp/Makefile" if test "$ENABLE_WP" != "no"; then EXTERNAL_PLUGINS="${EXTERNAL_PLUGINS} src/wp"; fi ##################################################### # Check for tools/libraries requirements of plugins # ##################################################### new_section "configure tools and libraries used by some plug-ins" # lablgtk2 ########## REQUIRE_LABLGTK="$REQUIRE_LABLGTK$REQUIRE_GNOMECANVAS" USE_LABLGTK="$USE_LABLGTK$USE_GNOMECANVAS" if test "$OCAMLFIND" = "no" ; then echo "No Ocamlfind. Using +lablgtk2." LABLGTK_PATH=+lablgtk2 LABLGTKPATH_FOR_CONFIGURE=$OCAMLLIB/lablgtk2 else LABLGTK_PATH=`ocamlfind query lablgtk2 | tr -d '\\r\\n'` if test "$LABLGTK_PATH" = "" -o "$LABLGTK_PATH" -ef "$OCAMLLIB/lablgtk2" ; then echo "Ocamlfind -> using +lablgtk2.($LABLGTK_PATH,$OCAMLLIB/lablgtk2)" LABLGTK_PATH=+lablgtk2 LABLGTKPATH_FOR_CONFIGURE=$OCAMLLIB/lablgtk2 else echo "Ocamlfind -> using $LABLGTK_PATH" LABLGTKPATH_FOR_CONFIGURE=$LABLGTK_PATH fi fi # No need to check the same thing multiple times. # [JS 2009/06/02] sh tests and m4 variables do not mix well together. # It works by chance but it is not robust enough. # Should be rewritten HAS_LABLGTK=no if test "$HAS_LABLGTK" != "yes"; then as_ac_File=`$as_echo "ac_cv_file_$LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX" >&5 $as_echo_n "checking for $LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for $LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX existence when cross compiling" "$LINENO" 5 if test -r "$LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : HAS_LABLGTK=yes else HAS_LABLGTK=no fi if test "$HAS_LABLGTK" = "yes"; then SELECTED_LABLGTK=$LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX fi fi LABLGTK=$SELECTED_LABLGTK if test "$HAS_LABLGTK" = "yes"; then # Gtksourceview ############### REQUIRE_GTKSOURCEVIEW= USE_GTKSOURCEVIEW= HAS_GTKSOURCEVIEW= FORCE_GTKSOURCEVIEW="yes" if test "$FORCE_GTKSOURCEVIEW" = "yes"; then REQUIRE_GTKSOURCEVIEW="$REQUIRE_LABLGTK" USE_GTKSOURCEVIEW="$USE_LABLGTK" else if test "$has" = "yes"; then USE_GTKSOURCEVIEW="$REQUIRE_LABLGTK$USE_LABLGTK" fi fi # No need to check the same thing multiple times. # [JS 2009/06/02] sh tests and m4 variables do not mix well together. # It works by chance but it is not robust enough. # Should be rewritten HAS_GTKSOURCEVIEW=no if test "$HAS_GTKSOURCEVIEW" != "yes"; then as_ac_File=`$as_echo "ac_cv_file_$LABLGTKPATH_FOR_CONFIGURE/lablgtksourceview2.$LIB_SUFFIX" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $LABLGTKPATH_FOR_CONFIGURE/lablgtksourceview2.$LIB_SUFFIX" >&5 $as_echo_n "checking for $LABLGTKPATH_FOR_CONFIGURE/lablgtksourceview2.$LIB_SUFFIX... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for $LABLGTKPATH_FOR_CONFIGURE/lablgtksourceview2.$LIB_SUFFIX existence when cross compiling" "$LINENO" 5 if test -r "$LABLGTKPATH_FOR_CONFIGURE/lablgtksourceview2.$LIB_SUFFIX"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : HAS_GTKSOURCEVIEW=yes else HAS_GTKSOURCEVIEW=no fi if test "$HAS_GTKSOURCEVIEW" = "yes"; then SELECTED_GTKSOURCEVIEW=$LABLGTKPATH_FOR_CONFIGURE/lablgtksourceview2.$LIB_SUFFIX fi fi GTKSOURCEVIEW=$SELECTED_GTKSOURCEVIEW # Gnomecanvas ############# # No need to check the same thing multiple times. # [JS 2009/06/02] sh tests and m4 variables do not mix well together. # It works by chance but it is not robust enough. # Should be rewritten HAS_GNOMECANVAS=no if test "$HAS_GNOMECANVAS" != "yes"; then as_ac_File=`$as_echo "ac_cv_file_$LABLGTKPATH_FOR_CONFIGURE/lablgnomecanvas.$LIB_SUFFIX" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $LABLGTKPATH_FOR_CONFIGURE/lablgnomecanvas.$LIB_SUFFIX" >&5 $as_echo_n "checking for $LABLGTKPATH_FOR_CONFIGURE/lablgnomecanvas.$LIB_SUFFIX... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for $LABLGTKPATH_FOR_CONFIGURE/lablgnomecanvas.$LIB_SUFFIX existence when cross compiling" "$LINENO" 5 if test -r "$LABLGTKPATH_FOR_CONFIGURE/lablgnomecanvas.$LIB_SUFFIX"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : HAS_GNOMECANVAS=yes else HAS_GNOMECANVAS=no fi if test "$HAS_GNOMECANVAS" = "yes"; then SELECTED_GNOMECANVAS=$LABLGTKPATH_FOR_CONFIGURE/lablgnomecanvas.$LIB_SUFFIX fi fi GNOMECANVAS=$SELECTED_GNOMECANVAS fi # $HAS_LABLGTK=yes # dot and xdot tools #################### for file in dot; do HAS_DOT= # 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 ${ac_cv_prog_HAS_DOT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$HAS_DOT"; then ac_cv_prog_HAS_DOT="$HAS_DOT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_HAS_DOT="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_DOT" && ac_cv_prog_HAS_DOT="no" fi fi HAS_DOT=$ac_cv_prog_HAS_DOT if test -n "$HAS_DOT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $HAS_DOT" >&5 $as_echo "$HAS_DOT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$HAS_DOT" = "yes"; then SELECTED_VAR=$file break; fi done # Native dynlink ################ # No need to check the same thing multiple times. # [JS 2009/06/02] sh tests and m4 variables do not mix well together. # It works by chance but it is not robust enough. # Should be rewritten HAS_NATIVE_DYNLINK=no if test "$HAS_NATIVE_DYNLINK" != "yes"; then as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/dynlink.cmxa" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/dynlink.cmxa" >&5 $as_echo_n "checking for $OCAMLLIB/dynlink.cmxa... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for $OCAMLLIB/dynlink.cmxa existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/dynlink.cmxa"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : HAS_NATIVE_DYNLINK=yes else HAS_NATIVE_DYNLINK=no fi if test "$HAS_NATIVE_DYNLINK" = "yes"; then SELECTED_NATIVE_DYNLINK=$OCAMLLIB/dynlink.cmxa fi fi NATIVE_DYNLINK=$SELECTED_NATIVE_DYNLINK # Checking some other things which cannot be done too early ########################################################### # Usable native dynlink # Checking internal invariant if test "$HAS_NATIVE_DYNLINK" = "uncheck"; then as_fn_error $? "Internal error with check of native dynlink. Please report." "$LINENO" 5 fi HAS_USABLE_NATIVE_DYNLINK=no if test "$HAS_NATIVE_DYNLINK" != "no" ; then echo "let f x y = Dynlink.loadfile \"foo\"; ignore (Dynlink.is_native); abs_float (x -. y)" > test_dynlink.ml if ($OCAMLOPT -shared -linkall -o test_dynlink.cmxs test_dynlink.ml) \ 2> /dev/null ; \ then HAS_USABLE_NATIVE_DYNLINK=yes { $as_echo "$as_me:${as_lineno-$LINENO}: result: native dynlink works fine. Great." >&5 $as_echo "native dynlink works fine. Great." >&6; } else REQUIRE_USABLE_NATIVE_DYNLINK=$REQUIRE_NATIVE_DYNLINK USE_USABLE_NATIVE_DYNLINK=$USE_NATIVE_DYNLINK HAS_USABLE_NATIVE_DYNLINK=no # we know that dynlink does not work: # configure a dummy library "dynlink" in order to # configure plug-ins depending on dynlink in a proper way # No need to check the same thing multiple times. # [JS 2009/06/02] sh tests and m4 variables do not mix well together. # It works by chance but it is not robust enough. # Should be rewritten HAS_USABLE_NATIVE_DYNLINK=no if test "$HAS_USABLE_NATIVE_DYNLINK" != "yes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dynlink" >&5 $as_echo_n "checking for dynlink... " >&6; } if ${ac_cv_file_dynlink+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for dynlink existence when cross compiling" "$LINENO" 5 if test -r "dynlink"; then ac_cv_file_dynlink=yes else ac_cv_file_dynlink=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_dynlink" >&5 $as_echo "$ac_cv_file_dynlink" >&6; } if test "x$ac_cv_file_dynlink" = xyes; then : HAS_USABLE_NATIVE_DYNLINK=yes else HAS_USABLE_NATIVE_DYNLINK=no fi if test "$HAS_USABLE_NATIVE_DYNLINK" = "yes"; then SELECTED_USABLE_NATIVE_DYNLINK=dynlink fi fi USABLE_NATIVE_DYNLINK=$SELECTED_USABLE_NATIVE_DYNLINK fi rm -f test_dynlink.* fi ######################## # Plug-in dependencies # ######################## new_section "checking for plug-in dependencies" if test -n "$REQUIRE_LTLTOBA" -o -n "$USE_LTLTOBA" -o "$no" = "yes"; then if test "$HAS_LTLTOBA" = "no"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: ltl2ba not found." >&5 $as_echo "$as_me: WARNING: ltl2ba not found." >&2;} reason="ltl2ba missing" for p in $REQUIRE_LTLTOBA; 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\ ltl2ba\)" { $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_LTLTOBA; 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\ ltl2ba\)" { $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 LTLTOBA=ltl2ba fi fi if test -n "$REQUIRE_LABLGTK" -o -n "$USE_LABLGTK" -o "$no" = "yes"; then if test "$HAS_LABLGTK" = "no"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX not found." >&5 $as_echo "$as_me: WARNING: $LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX not found." >&2;} reason="$LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX missing" for p in $REQUIRE_LABLGTK; 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\ $LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX\)" { $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_LABLGTK; 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\ $LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX\)" { $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 fi fi if test -n "$REQUIRE_GTKSOURCEVIEW" -o -n "$USE_GTKSOURCEVIEW" -o "$no" = "yes"; then if test "$HAS_GTKSOURCEVIEW" = "no"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: lablgtksourceview2.$LIB_SUFFIX not found" >&5 $as_echo "$as_me: WARNING: lablgtksourceview2.$LIB_SUFFIX not found" >&2;} reason="$LABLGTKPATH_FOR_CONFIGURE/lablgtksourceview2.$LIB_SUFFIX missing" for p in $REQUIRE_GTKSOURCEVIEW; 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\ $LABLGTKPATH_FOR_CONFIGURE/lablgtksourceview2.$LIB_SUFFIX\)" { $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_GTKSOURCEVIEW; 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\ $LABLGTKPATH_FOR_CONFIGURE/lablgtksourceview2.$LIB_SUFFIX\)" { $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 fi fi if test -n "$REQUIRE_GNOMECANVAS" -o -n "$USE_GNOMECANVAS" -o "$no" = "yes"; then if test "$HAS_GNOMECANVAS" = "no"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: lablgnomecanvas.$LIB_SUFFIX not found" >&5 $as_echo "$as_me: WARNING: lablgnomecanvas.$LIB_SUFFIX not found" >&2;} reason="$LABLGTKPATH_FOR_CONFIGURE/lablgnomecanvas.$LIB_SUFFIX missing" for p in $REQUIRE_GNOMECANVAS; 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\ $LABLGTKPATH_FOR_CONFIGURE/lablgnomecanvas.$LIB_SUFFIX\)" { $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_GNOMECANVAS; 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\ $LABLGTKPATH_FOR_CONFIGURE/lablgnomecanvas.$LIB_SUFFIX\)" { $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 fi fi if test -n "$REQUIRE_DOT" -o -n "$USE_DOT" -o "$no" = "yes"; then if test "$HAS_DOT" = "no"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: dot not found: you should install GraphViz" >&5 $as_echo "$as_me: WARNING: dot not found: you should install GraphViz" >&2;} reason="dot missing" for p in $REQUIRE_DOT; 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\ dot\)" { $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_DOT; 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\ dot\)" { $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 DOT=dot fi fi if test -n "$REQUIRE_NATIVE_DYNLINK" -o -n "$USE_NATIVE_DYNLINK" -o "$no" = "yes"; then if test "$HAS_NATIVE_DYNLINK" = "no"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: native dynlink unavailable (ocaml 3.11 or higher required)" >&5 $as_echo "$as_me: WARNING: native dynlink unavailable (ocaml 3.11 or higher required)" >&2;} reason="$OCAMLLIB/dynlink.cmxa missing" # compile statically all dynamic plug-ins # except contrary instructions USE_NATIVE_DYNLINK=""; for plugin in SEMANTIC_CONSTANT_FOLDING FROM_ANALYSIS GUI IMPACT INOUT METRICS OCCURRENCE PDG POSTDOMINATORS RTE_ANNOTATION SCOPE SEMANTIC_CALLGRAPH SLICING SPARECODE SYNTACTIC_CALLGRAPH USERS VALUE_ANALYSIS AORAI OBFUSCATOR REPORT SECURITY_SLICING WP; do n=NAME_$plugin d=DYNAMIC_$plugin s=STATIC_$plugin eval np=\$$n eval dp=\$$d eval sp=\$$s if test "$dp" = "yes"; then if test "$sp" = "no"; then # force to be dynamic USE_NATIVE_DYNLINK="${USE_NATIVE_DYNLINK} $np"; else eval STATIC_$plugin=yes; eval DYNAMIC_$plugin=no; fi fi done for p in $REQUIRE_NATIVE_DYNLINK; 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\ $OCAMLLIB/dynlink.cmxa\)" { $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_NATIVE_DYNLINK; 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\ $OCAMLLIB/dynlink.cmxa\)" { $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 fi fi if test -n "$REQUIRE_USABLE_NATIVE_DYNLINK" -o -n "$USE_USABLE_NATIVE_DYNLINK" -o "$no" = "yes"; then if test "$HAS_USABLE_NATIVE_DYNLINK" = "no"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: native dynlink unsupported on this platform" >&5 $as_echo "$as_me: WARNING: native dynlink unsupported on this platform" >&2;} reason="dynlink missing" # compile statically all dynamic plug-ins # except contrary instructions USE_NATIVE_DYNLINK=""; for plugin in SEMANTIC_CONSTANT_FOLDING FROM_ANALYSIS GUI IMPACT INOUT METRICS OCCURRENCE PDG POSTDOMINATORS RTE_ANNOTATION SCOPE SEMANTIC_CALLGRAPH SLICING SPARECODE SYNTACTIC_CALLGRAPH USERS VALUE_ANALYSIS AORAI OBFUSCATOR REPORT SECURITY_SLICING WP; do n=NAME_$plugin d=DYNAMIC_$plugin s=STATIC_$plugin eval np=\$$n eval dp=\$$d eval sp=\$$s if test "$dp" = "yes"; then if test "$sp" = "no"; then # force to be dynamic USE_NATIVE_DYNLINK="${USE_NATIVE_DYNLINK} $np"; else eval STATIC_$plugin=yes; eval DYNAMIC_$plugin=no; fi fi done for p in $REQUIRE_USABLE_NATIVE_DYNLINK; 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\ dynlink\)" { $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_USABLE_NATIVE_DYNLINK; 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\ dynlink\)" { $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 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 ############################ # Substitutions to perform # ############################ EXTERNAL_PLUGINS="${EXTERNAL_PLUGINS} ${EXTRA_EXTERNAL_PLUGINS}" # m4_foreach_w is not supported in some old autoconf versions. # Sadly AC_FOREACH is deprecated now... ################################################ # Finally create the Makefile from Makefile.in # ################################################ new_section "creating makefile" ac_config_files="$ac_config_files share/Makefile.config" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' DEFS=-DHAVE_CONFIG_H ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac case $ac_config_headers in *" "*) set x $ac_config_headers; shift; ac_config_headers=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" config_headers="$ac_config_headers" _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 --header=FILE[:TEMPLATE] instantiate the configuration header FILE Configuration files: $config_files Configuration headers: $config_headers Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append CONFIG_HEADERS " '$ac_optarg'" ac_need_defaults=false;; --he | --h) # Conflict between --help and --header as_fn_error $? "ambiguous option: \`$1' Try \`$0 --help' for more information.";; --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 "config.h") CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;; "src/aorai/Makefile") CONFIG_FILES="$CONFIG_FILES src/aorai/Makefile" ;; "src/obfuscator/Makefile") CONFIG_FILES="$CONFIG_FILES src/obfuscator/Makefile" ;; "src/report/Makefile") CONFIG_FILES="$CONFIG_FILES src/report/Makefile" ;; "src/security_slicing/Makefile") CONFIG_FILES="$CONFIG_FILES src/security_slicing/Makefile" ;; "src/wp/Makefile") CONFIG_FILES="$CONFIG_FILES src/wp/Makefile" ;; "share/Makefile.config") CONFIG_FILES="$CONFIG_FILES share/Makefile.config" ;; *) 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 test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. # This happens for instance with `./config.status Makefile'. if test -n "$CONFIG_HEADERS"; then cat >"$ac_tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF # Transform confdefs.h into an awk script `defines.awk', embedded as # here-document in config.status, that substitutes the proper values into # config.h.in to produce config.h. # Create a delimiter string that does not exist in confdefs.h, to ease # handling of long lines. ac_delim='%!_!# ' for ac_last_try in false false :; do ac_tt=`sed -n "/$ac_delim/p" confdefs.h` if test -z "$ac_tt"; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done # For the awk script, D is an array of macro values keyed by name, # likewise P contains macro parameters if any. Preserve backslash # newline sequences. ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* sed -n ' s/.\{148\}/&'"$ac_delim"'/g t rset :rset s/^[ ]*#[ ]*define[ ][ ]*/ / t def d :def s/\\$// t bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3"/p s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p d :bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3\\\\\\n"\\/p t cont s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p t cont d :cont n s/.\{148\}/&'"$ac_delim"'/g t clear :clear s/\\$// t bsnlc s/["\\]/\\&/g; s/^/"/; s/$/"/p d :bsnlc s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p b cont ' >$CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 for (key in D) D_is_set[key] = 1 FS = "" } /^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { line = \$ 0 split(line, arg, " ") if (arg[1] == "#") { defundef = arg[2] mac1 = arg[3] } else { defundef = substr(arg[1], 2) mac1 = arg[2] } split(mac1, mac2, "(") #) macro = mac2[1] prefix = substr(line, 1, index(line, defundef) - 1) if (D_is_set[macro]) { # Preserve the white space surrounding the "#". print prefix "define", macro P[macro] D[macro] next } else { # Replace #undef with comments. This is necessary, for example, # in the case of _POSIX_SOURCE, which is predefined and required # on some systems where configure will not decide to define it. if (defundef == "undef") { print "/*", prefix defundef, macro, "*/" next } } } { print } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 fi # test -n "$CONFIG_HEADERS" eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; :H) # # CONFIG_HEADER # if test x"$ac_file" != x-; then { $as_echo "/* $configure_input */" \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" } >"$ac_tmp/config.h" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 $as_echo "$as_me: $ac_file is unchanged" >&6;} else rm -f "$ac_file" mv "$ac_tmp/config.h" "$ac_file" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 fi else $as_echo "/* $configure_input */" \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ || as_fn_error $? "could not create -" "$LINENO" 5 fi ;; esac case $ac_file$ac_mode in "src/aorai/Makefile":F) chmod -w src/aorai/Makefile ;; "src/obfuscator/Makefile":F) chmod -w src/obfuscator/Makefile ;; "src/report/Makefile":F) chmod -w src/report/Makefile ;; "src/security_slicing/Makefile":F) chmod -w src/security_slicing/Makefile ;; "src/wp/Makefile":F) chmod -w src/wp/Makefile ;; "share/Makefile.config":F) chmod a-w share/Makefile.config ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi ########### # Summary # ########### new_section "summary: plug-ins available" for plugin in SEMANTIC_CONSTANT_FOLDING FROM_ANALYSIS GUI IMPACT INOUT METRICS OCCURRENCE PDG POSTDOMINATORS RTE_ANNOTATION SCOPE SEMANTIC_CALLGRAPH SLICING SPARECODE SYNTACTIC_CALLGRAPH USERS VALUE_ANALYSIS AORAI OBFUSCATOR REPORT SECURITY_SLICING WP; do n=NAME_$plugin e=ENABLE_$plugin d=DYNAMIC_$plugin s=STATIC_$plugin i=INFO_$plugin eval nv=\$$n eval ev=\$$e eval dv=\$$d eval sv=\$$s eval iv=\$$i if test "$ev" = "no"; then res=$ev; elif test "$dv" = "yes"; then res="$ev, dynamic"; elif test "$sv" = "yes"; then res="$ev, static"; else res=$ev; fi { $as_echo "$as_me:${as_lineno-$LINENO}: $nv: $res$iv" >&5 $as_echo "$as_me: $nv: $res$iv" >&6;} done if test "$EXTRA_EXTERNAL_PLUGINS" != ""; then new_section "summary: requested external plugins" fi for plugin in $EXTRA_EXTERNAL_PLUGINS; do { $as_echo "$as_me:${as_lineno-$LINENO}: $plugin" >&5 $as_echo "$as_me: $plugin" >&6;} done frama-c-Fluorine-20130601/.force-reconfigure0000644000175000017500000000000212155630370017374 0ustar mehdimehdi2 frama-c-Fluorine-20130601/share/0000755000175000017500000000000012155634040015077 5ustar mehdimehdiframa-c-Fluorine-20130601/share/builtin.h0000644000175000017500000000657612155630244016736 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2012 */ /* 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). */ /* */ /**************************************************************************/ /* $Id: builtin.h,v 1.17 2008-11-21 09:19:53 uid527 Exp $ */ #ifndef Frama_C_BUILTIN #define Frama_C_BUILTIN #include "libc.h" extern int Frama_C_entropy_source; /*@ ensures (\result == a) || (\result == b); assigns \result \from a, b, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; */ int Frama_C_nondet(int a, int b); /*@ ensures (\result == a) || (\result == b); assigns \result \from a, b, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; */ void *Frama_C_nondet_ptr(void *a, void *b); /*@ requires min <= max; ensures min <= \result <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; */ int Frama_C_interval(int min, int max); /*@ requires min <= max; ensures min <= \result <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; */ float Frama_C_float_interval(float min, float max); /*@ requires min <= max; ensures min <= \result <= max; assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; */ double Frama_C_double_interval(double min, double max); /*@ assigns ((char*)dest)[0..n-1] \from ((char*)src)[0..n-1]; assigns \result \from dest; */ void* Frama_C_memcpy(char *dest, const char *src, unsigned long n); /*@ assigns \result \from ((char*)s1)[0..n-1], ((char*)s2)[0..n-1]; */ int Frama_C_memcmp(const char *s1, const char *s2, size_t n); /*@ assigns \result \from src; */ size_t Frama_C_strlen(const char *src); /*@ assigns \empty; */ void Frama_C_abort(void) __attribute__ ((noreturn)); void Frama_C_show_each_warning(const char*); size_t Frama_C_offset(const void*); #endif frama-c-Fluorine-20130601/share/fluctuat.h0000644000175000017500000000355412155630244017110 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2012 */ /* 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). */ /* */ /**************************************************************************/ // Fluctuat emulation layer to be used with -imacros fluctuat.h #define __BUILTIN_DAED_LIMIT(lv,min,max) lv=Frama_C_float_interval(min,max) #define __BUILTIN_DAED_DBETWEEN(min,max) Frama_C_float_interval(min,max) #define __BUILTIN_DAED_IBETWEEN(min,max) Frama_C_interval(min,max) frama-c-Fluorine-20130601/share/feedback/0000755000175000017500000000000012155634040016623 5ustar mehdimehdiframa-c-Fluorine-20130601/share/feedback/switch-on.png0000644000175000017500000000637212155630241021253 0ustar mehdimehdiPNG  IHDRH J>p pHYs   IDAThYdGV'{s76cch{ƃixGg/o#^xF8B4 bfd0/CnRUUUވ8<ܼYm7E#FϚ|!, "?ݻ v ! )%Dk{c=;|xm_80C}/\9jbHgEUq^83gWh@lmm}.pI#_z:'Gƀ3#٬{Kף,)Z>|o~Gܻ0p/9&in 1;8[-ߌ&1c$iEH5jjEQd1eI^ #A@$ei⽯#^(0y+گ`{wjw?$V#}18E0r4b &Z=Gg Bx,Z$h 9w1cě:o!%ypT).=so#ksr)zB:BL9XqOlzTop~eyFDY>c[M `C c Y斌2Ɛ9n6 z;Rp1CRE˔HpvJ5uhvfhg3z]lZg*,j1҂Q4BD3WO?'>dݻwq9w"T VX~}ԇn6-~t[mD@ij`e%ιڤCL"TJա,(i$!PDM^dز/rd]8Xq=a <`ww/r9,[ZguYc{6Ʉ~}tZl풵-IES tv-99l6#3P>AX4tu8}s\z ]&9y˲6߯"ш]lll`g}}@|7nE66`'<ւK򼍈.]ϲ@Th6QQpx(`bZE$ F@HPUV0+"9y1>{Ӿ=-˒,c)UU1ϱֵ N<ϗa5m0oڥkRDX>'W|fccSy*@4lj K)QdBwB… 8._7 iIENDB`frama-c-Fluorine-20130601/share/feedback/valid_but_dead.png0000644000175000017500000000307212155630241022260 0ustar mehdimehdiPNG  IHDRa;iCCPICC ProfilexKhP)B%>ЊPi֑q"4sgM31HAZ*BPp BkQq"B7R&L*V/$rUScE4`λɮvxUA5R'}V>PeIƊmKbyo5.Fl[%Wɼdc(&;F'AA^ `36jr2NdhdeQnM<%iF~YƕkE/+ Z_5+-Ϥ?vlSCs=0sTuTeܢea+ 79Z|U ps_.?g"np)9]3;6vG+nhnR.Os'ܢH7c*pZ{{"焷{tD3ɍ{sO7Tw鳭8Ej"u`G<$xŃ2o?ڗ Ӟ{N2~q4#h;Fѿ^/4T<#QqefY(˚mBa^AO^Y.c_/{4C\OLMd<ٵH&|s/>z~q6\ k`Ҳ䍐.XlAQbyyYD6BnFA w+NzlG0Ml@MsX|&VS'*&dEB\·%VgftJ`PA44vj\m㈳` @g7aܨ7a7v;CΞ\u~(T*@UUE3w$I:\<._êh4vsW^=appPa{JrܽǷwAN1ypsO$\̫;S;o2/QYDL$f^" b``@cme_g'[&ټ/]j[IENDB`frama-c-Fluorine-20130601/share/feedback/invalid_under_hyp.png0000644000175000017500000000307212155630241023035 0ustar mehdimehdiPNG  IHDRa;iCCPICC ProfilexKhP)B%>ЊPi֑q"4sgM31HAZ*BPp BkQq"B7R&L*V/$rUScE4`λɮvxUA5R'}V>PeIƊmKbyo5.Fl[%Wɼdc(&;F'AA^ `36jr2NdhdeQnM<%iF~YƕkE/+ Z_5+-Ϥ?vlSCs=0sTuTeܢea+ 79Z|U ps_.?g"np)9]3;6vG+nhnR.Os'ܢH7c*pZ{{"焷{tD3ɍ{sO7Tw鳭8Ej"u`G<$xŃ2o?ڗ Ӟ{N2~q4#h;Fѿ^/4T<#QqefY(˚mBa^AO^Y.c_/{4C\OLMd<ٵH&|s/>z~q6\ k`Ҳ䍐.*4ˬR1>G#X:;s~=Moijr:? 4/!wK)Grvfդbf#A$#;'2a~Sz 4uKN۵ غml8yX; >=GfTws![BKsy6,?\/D'9MQR[|&n}mS RCx:їQ-DE`ug]2~Yk4,G{'zh `X:iP959E 3 :^@9-'da{^` @7tLN0tO./~?*j F/Udw[̂fFߚUFdU0 $#[5Æi B/Rb$ˆ\G Xrԍσ&%8>/C3x2H*P1^v4 0Js]U+ÇUIM5dvXGprIYBכo4Ua%G7n8b]AZYY>LM180`$Yk֥.m/ڜϱI|vff:6f4CAɉIENDB`frama-c-Fluorine-20130601/share/feedback/surely_valid.png0000644000175000017500000000306012155630241022031 0ustar mehdimehdiPNG  IHDRa;iCCPICC ProfilexKhP)B%>ЊPi֑q"4sgM31HAZ*BPp BkQq"B7R&L*V/$rUScE4`λɮvxUA5R'}V>PeIƊmKbyo5.Fl[%Wɼdc(&;F'AA^ `36jr2NdhdeQnM<%iF~YƕkE/+ Z_5+-Ϥ?vlSCs=0sTuTeܢea+ 79Z|U ps_.?g"np)9]3;6vG+nhnR.Os'ܢH7c*pZ{{"焷{tD3ɍ{sO7Tw鳭8Ej"u`G<$xŃ2o?ڗ Ӟ{N2~q4#h;Fѿ^/4T<#QqefY(˚mBa^AO^Y.c_/{4C\OLMd<ٵH&|s/>z~q6\ k`Ҳ䍐.ЊPi֑q"4sgM31HAZ*BPp BkQq"B7R&L*V/$rUScE4`λɮvxUA5R'}V>PeIƊmKbyo5.Fl[%Wɼdc(&;F'AA^ `36jr2NdhdeQnM<%iF~YƕkE/+ Z_5+-Ϥ?vlSCs=0sTuTeܢea+ 79Z|U ps_.?g"np)9]3;6vG+nhnR.Os'ܢH7c*pZ{{"焷{tD3ɍ{sO7Tw鳭8Ej"u`G<$xŃ2o?ڗ Ӟ{N2~q4#h;Fѿ^/4T<#QqefY(˚mBa^AO^Y.c_/{4C\OLMd<ٵH&|s/>z~q6\ k`Ҳ䍐.d %Q$lVF۝k}+FTEFRtIv%QF@04fN)/@`JU6TYȤ ddb"AR.DASA`¾+ Ȓu%'aG *FVb¢L!iIA<[KV p $PغIа,I<-8)rIFI-UM+pIENDB`frama-c-Fluorine-20130601/share/feedback/surely_invalid.png0000644000175000017500000000302312155630241022357 0ustar mehdimehdiPNG  IHDRa;iCCPICC ProfilexKhP)B%>ЊPi֑q"4sgM31HAZ*BPp BkQq"B7R&L*V/$rUScE4`λɮvxUA5R'}V>PeIƊmKbyo5.Fl[%Wɼdc(&;F'AA^ `36jr2NdhdeQnM<%iF~YƕkE/+ Z_5+-Ϥ?vlSCs=0sTuTeܢea+ 79Z|U ps_.?g"np)9]3;6vG+nhnR.Os'ܢH7c*pZ{{"焷{tD3ɍ{sO7Tw鳭8Ej"u`G<$xŃ2o?ڗ Ӟ{N2~q4#h;Fѿ^/4T<#QqefY(˚mBa^AO^Y.c_/{4C\OLMd<ٵH&|s/>z~q6\ k`Ҳ䍐.f\LkhVp&1:8hoJҍ d º0 V{z*Sf&&XR0tAq_oC//?? hBIENDB`frama-c-Fluorine-20130601/share/feedback/switch-off.png0000644000175000017500000000652412155630241021410 0ustar mehdimehdiPNG  IHDRH J>p pHYs   IDAThۏ%Uk]ӧ/s{zۉMb'DQ rd" 53g3;TG]THvjXhRfL8̟9/,,-EU4 EQyhckkWrŃNB)n-^W?x9qN)aNGՏQ)7,`g;ޔh7B؉P>1yA@Ps4SUUw_S#t:kz)]F]\p>8**Z^7$ KX'-89"ieTQrN}r 0F`d éSv|psg<_"+epR—#@ޑNEa4~QLǼ_e}X6Xb"#abA<4ߓdK`rV8gFJ%. N ]$2wi6C %+eE*eAd xVoW>"9g)mޑIspf"6&4MCJdjTQk8I,L%$WhІXaa&D'.K . k}11^nkxHN V8>СO7 TA. /PXIQt1spޫ]|Y= .c(>e!H(E)J4{)J~mNRWgG1+x(PrYфHds(M;֒66 ! iY2 |Hg$Nkkk\~Γe8(Q_BCҥHgC 9q8 8X½#^yhAi|3!m8mI'O"ִjhl {ʢ$u e:>tN3^?UUd29w@Bƈ Eӭ)fP!ƈU%7o%8eum'jEn #됓u 5w _<êr%zZ"Nw5_ .-?Z8j6f:$)KO aٰB5{d5**t4֑r@c+ۺIHi•:˛-pyB J^@&Jq8)H]H)a=ی'> "]KU 𫿎 -h)Zx/HJ)|tD"ዂfҲX-Y)8$z?m;>\| ?"̢tP* t4E ׆>$ۺɷ~6d&W.&-DRBDI@+$Cd4$t0hBkB7~^ˤd8r tRL%T>JEG,'K"YdP (c (B񑧞  U~1HcUE(i\3ACr,XڶE MtNHEJ::c7)Q Ĵ'O֙3~&Td"o[/ٗ~BghiۀΝN)xU.˒7ng},ǹ[, *,-,s5B,f*{'LP4PZY9S ^/hh)ғa9szm ԰?#;^e`#/0OI EQ͛lll? ={ d:>`_"c3㵝CN&-PNZ\Ap B< d ӊO#BԒ5j@F$<8ʼn {Y=Y=]6z_&:UXLGPY$sE5 m>lll|=bg`r`]rJ-*zI ]A܆xNSNk;^%G.Ҷ- ] amnګF$B섭ʧfS?HfDUO:+zM*Bp||qeF ;J-9L-s_kinmeʺh|BUXxuItl$'m3N9gƳ|Uuh^LxF8qUQ,t]ݻwb4SW\y̎,!ScY$'P3(Oz;ד-gmˈEQncfm93TיEj<& M>19g`0@DX\\dqqe?s v?!??{wW E2IENDB`frama-c-Fluorine-20130601/share/feedback/considered_valid.png0000644000175000017500000000312212155630241022624 0ustar mehdimehdiPNG  IHDRa;iCCPICC ProfilexKhP)B%>ЊPi֑q"4sgM31HAZ*BPp BkQq"B7R&L*V/$rUScE4`λɮvxUA5R'}V>PeIƊmKbyo5.Fl[%Wɼdc(&;F'AA^ `36jr2NdhdeQnM<%iF~YƕkE/+ Z_5+-Ϥ?vlSCs=0sTuTeܢea+ 79Z|U ps_.?g"np)9]3;6vG+nhnR.Os'ܢH7c*pZ{{"焷{tD3ɍ{sO7Tw鳭8Ej"u`G<$xŃ2o?ڗ Ӟ{N2~q4#h;Fѿ^/4T<#QqefY(˚mBa^AO^Y.c_/{4C\OLMd<ٵH&|s/>z~q6\ k`Ҳ䍐.@2}ibuԶ(g<ǖ3<1'9~.+g+n]E7Ktn&>3FR78umG)Yd:r`r7D0t4#OےCߊ4HO2ndDZBۋEZ\;+wɅu(Rji2,BhAUDEu@]U*0U lRjrZ0M)ĨBTB{KsSi VqLUm%;y"GmAj&1uM ]DjC=bI;5T$+޼l.mOL=,⫊4,js]itj[#7+iHqg/.PW~cp3ReRu<?^˭=T|#y&rLЊPi֑q"4sgM31HAZ*BPp BkQq"B7R&L*V/$rUScE4`λɮvxUA5R'}V>PeIƊmKbyo5.Fl[%Wɼdc(&;F'AA^ `36jr2NdhdeQnM<%iF~YƕkE/+ Z_5+-Ϥ?vlSCs=0sTuTeܢea+ 79Z|U ps_.?g"np)9]3;6vG+nhnR.Os'ܢH7c*pZ{{"焷{tD3ɍ{sO7Tw鳭8Ej"u`G<$xŃ2o?ڗ Ӟ{N2~q4#h;Fѿ^/4T<#QqefY(˚mBa^AO^Y.c_/{4C\OLMd<ٵH&|s/>z~q6\ k`Ҳ䍐.9<<P$`?5@I* 4H\\\=@H$b06 VEp\[ZE;/b*= 0,H_IENDB`frama-c-Fluorine-20130601/share/feedback/invalid_but_dead.png0000644000175000017500000000306312155630241022607 0ustar mehdimehdiPNG  IHDRa;iCCPICC ProfilexKhP)B%>ЊPi֑q"4sgM31HAZ*BPp BkQq"B7R&L*V/$rUScE4`λɮvxUA5R'}V>PeIƊmKbyo5.Fl[%Wɼdc(&;F'AA^ `36jr2NdhdeQnM<%iF~YƕkE/+ Z_5+-Ϥ?vlSCs=0sTuTeܢea+ 79Z|U ps_.?g"np)9]3;6vG+nhnR.Os'ܢH7c*pZ{{"焷{tD3ɍ{sO7Tw鳭8Ej"u`G<$xŃ2o?ڗ Ӟ{N2~q4#h;Fѿ^/4T<#QqefY(˚mBa^AO^Y.c_/{4C\OLMd<ٵH&|s/>z~q6\ k`Ҳ䍐.:hxO^@ww7JIR)s umhH{}|Hb8994KoS6 Ap}m 6 (k @+++n)llߏQI]_PV[Ae7E6u 2z5:2r94"I)bYyA +2T #ȺC,HuJ |_AΆ0] Hׇ@[v`X`XT]%dx\}F?NHX'~$Wc*b`dd|٥ΏEج.ЊPi֑q"4sgM31HAZ*BPp BkQq"B7R&L*V/$rUScE4`λɮvxUA5R'}V>PeIƊmKbyo5.Fl[%Wɼdc(&;F'AA^ `36jr2NdhdeQnM<%iF~YƕkE/+ Z_5+-Ϥ?vlSCs=0sTuTeܢea+ 79Z|U ps_.?g"np)9]3;6vG+nhnR.Os'ܢH7c*pZ{{"焷{tD3ɍ{sO7Tw鳭8Ej"u`G<$xŃ2o?ڗ Ӟ{N2~q4#h;Fѿ^/4T<#QqefY(˚mBa^AO^Y.c_/{4C\OLMd<ٵH&|s/>z~q6\ k`Ҳ䍐.{CpJM+Na"9>/SoӰ9DvY3؍GH˱ %Z^TlyIENDB`frama-c-Fluorine-20130601/share/feedback/never_tried.png0000644000175000017500000000276412155630241021647 0ustar mehdimehdiPNG  IHDRa;iCCPICC ProfilexKhP)B%>ЊPi֑q"4sgM31HAZ*BPp BkQq"B7R&L*V/$rUScE4`λɮvxUA5R'}V>PeIƊmKbyo5.Fl[%Wɼdc(&;F'AA^ `36jr2NdhdeQnM<%iF~YƕkE/+ Z_5+-Ϥ?vlSCs=0sTuTeܢea+ 79Z|U ps_.?g"np)9]3;6vG+nhnR.Os'ܢH7c*pZ{{"焷{tD3ɍ{sO7Tw鳭8Ej"u`G<$xŃ2o?ڗ Ӟ{N2~q4#h;Fѿ^/4T<#QqefY(˚mBa^AO^Y.c_/{4C\OLMd<ٵH&|s/>z~q6\ k`Ҳ䍐.<7}elQW:s1eȓWYHpr[%P_ >y{\ÞYԞM°F"x"2Hl%l4ᢻ[e2o~޼Kzp klċqss 1F@b旨ry>LGsh{{ݵ1<ÀnnQK? bCo@:jnxX/_6L~ ٨Cb7QpϒFI`6E҂!y Q [,(!ʻ+DЊPi֑q"4sgM31HAZ*BPp BkQq"B7R&L*V/$rUScE4`λɮvxUA5R'}V>PeIƊmKbyo5.Fl[%Wɼdc(&;F'AA^ `36jr2NdhdeQnM<%iF~YƕkE/+ Z_5+-Ϥ?vlSCs=0sTuTeܢea+ 79Z|U ps_.?g"np)9]3;6vG+nhnR.Os'ܢH7c*pZ{{"焷{tD3ɍ{sO7Tw鳭8Ej"u`G<$xŃ2o?ڗ Ӟ{N2~q4#h;Fѿ^/4T<#QqefY(˚mBa^AO^Y.c_/{4C\OLMd<ٵH&|s/>z~q6\ k`Ҳ䍐.wmmmH$bn4<;;x ]>֊>< B@oo uo[|7.tk8J2"199q/?1S.iAgD.X"a&Q(T*i)i{K=PUH~b)i殹(9|>VVVfY}u -v!ql8CaA@Bj%C22 LÃU:lFRA.;%_b 4 ^!l"ְa <,˂aj9mا$py8MS. K%e%/`{yNF@L z"IENDB`frama-c-Fluorine-20130601/share/libc/0000755000175000017500000000000012155634040016010 5ustar mehdimehdiframa-c-Fluorine-20130601/share/libc/__fc_define_stat.h0000644000175000017500000000520512155630243021417 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_STAT_H #define __FC_DEFINE_STAT_H #include "__fc_define_ino_t.h" #include "__fc_define_uid_and_gid.h" #include "__fc_define_time_t.h" #include "__fc_define_blkcnt_t.h" #include "__fc_define_blksize_t.h" #include "__fc_define_dev_t.h" #include "__fc_define_mode_t.h" #include "__fc_define_nlink_t.h" #include "__fc_define_off_t.h" #define __statfs_word unsigned int struct statfs { __statfs_word f_type; __statfs_word f_bsize; __statfs_word f_blocks; __statfs_word f_bfree; __statfs_word f_bavail; __statfs_word f_files; __statfs_word f_ffree; __statfs_word f_fsid; __statfs_word f_namelen; __statfs_word f_frsize; __statfs_word f_flags; __statfs_word f_spare[4]; }; struct stat { dev_t st_dev; ino_t st_ino; mode_t st_mode; nlink_t st_nlink; uid_t st_uid; gid_t st_gid; dev_t st_rdev; off_t st_size; time_t st_atime; time_t st_mtime; time_t st_ctime; blksize_t st_blksize; blkcnt_t st_blocks; char * __fc_real_data; int __fc_real_data_max_size; }; #endif frama-c-Fluorine-20130601/share/libc/assert.h0000644000175000017500000000360112155630243017463 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_ASSERT #define __FC_ASSERT /*@ terminates \false; assigns \nothing; */ void __FC_assert(const char* file,int line,const char*expr); #endif #undef assert #ifdef NDEBUG #define assert(ignore) ((void)0) #else #define assert(e) ((e)?(void)0:__FC_assert(__FILE__,__LINE__,#e)) #endif frama-c-Fluorine-20130601/share/libc/features.h0000644000175000017500000000321712155630243020003 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_FEATURES_H #define __FC_FEATURES_H #endif frama-c-Fluorine-20130601/share/libc/inttypes.c0000644000175000017500000000220012155630243020026 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "inttypes.h" intmax_t imaxabs(intmax_t c) { if (c>0) return c; else return (-c); } imaxdiv_t imaxdiv(intmax_t numer, intmax_t denom){ imaxdiv_t r; r.quot=numer/denom; r.rem=numer%denom; return r; }; frama-c-Fluorine-20130601/share/libc/getopt.h0000644000175000017500000000321212155630243017462 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_GETOPT_H #define __FC_GETOPT_H #endif frama-c-Fluorine-20130601/share/libc/iso646.c0000644000175000017500000000166712155630243017221 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* Empty on purpose */ frama-c-Fluorine-20130601/share/libc/pthread.c0000644000175000017500000000166512155630243017614 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "pthread.h" frama-c-Fluorine-20130601/share/libc/arpa/0000755000175000017500000000000012155634040016733 5ustar mehdimehdiframa-c-Fluorine-20130601/share/libc/arpa/inet.h0000644000175000017500000000467312155630242020055 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef FC_ARPA_INET #define FC_ARPA_INET #include "../inttypes.h" #include "../netinet/in.h" /*@ assigns \result \from arg ; */ uint32_t htonl(uint32_t arg); /*@ assigns \result \from arg ; */ uint16_t htons(uint16_t arg); /*@ assigns \result \from arg ; */ uint32_t ntohl(uint32_t arg); /*@ assigns \result \from arg ; */ uint16_t ntohs(uint16_t arg); /*@ assigns \result \from arg ; */ in_addr_t inet_addr(const char * arg); /*@ assigns \result \from arg ; */ char *inet_ntoa(struct in_addr arg); /*@ assigns \result \from dst,af,((char*)src)[0..]; assigns dst[0..size] \from af,((char*)src)[0..] ; */ const char *inet_ntop(int af, const void *src, char *dst, socklen_t size); /*@ assigns \result \from af,src[..]; assigns ((char*)dst)[0..] \from af,src[0..] ; */ int inet_pton(int af, const char *src, void *dst); #endif frama-c-Fluorine-20130601/share/libc/arpa/inet.c0000644000175000017500000000166212155630242020043 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "inet.h" frama-c-Fluorine-20130601/share/libc/wctype.h0000644000175000017500000000325312155630243017500 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* ISO C: 7.26 */ #ifndef __FC_REG_TEST #error "Frama-C: unsupported wctype.h" #endif frama-c-Fluorine-20130601/share/libc/unistd.c0000644000175000017500000000166412155630243017472 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "unistd.h" frama-c-Fluorine-20130601/share/libc/netdb.c0000644000175000017500000000166412155630243017260 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "netdb.h" frama-c-Fluorine-20130601/share/libc/__fc_define_timespec.h0000644000175000017500000000332012155630243022251 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_TIMESPEC #define __FC_DEFINE_TIMESPEC struct timespec { long tv_sec; long tv_nsec; }; #endif frama-c-Fluorine-20130601/share/libc/__fc_define_blksize_t.h0000644000175000017500000000327112155630243022433 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_BLKSIZE_T #define __FC_DEFINE_BLKSIZE_T typedef unsigned int blksize_t; #endif frama-c-Fluorine-20130601/share/libc/signal.c0000644000175000017500000000170712155630243017437 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* ISO C: 7.14 */ #include "signal.h" frama-c-Fluorine-20130601/share/libc/iconv.c0000644000175000017500000000166312155630243017301 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "iconv.h" frama-c-Fluorine-20130601/share/libc/signal.h0000644000175000017500000001007012155630243017435 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_SIGNAL #define __FC_SIGNAL /* ISO C: 7.14 */ #include "__fc_define_pid_t.h" #include "__fc_define_uid_and_gid.h" /* TODO: put sig_atomic_t in machdep */ typedef volatile int sig_atomic_t; typedef void (*__fc_sighandler_t) (int); #define SIG_DFL ((__fc_sighandler_t)0) /* default signal handling */ #define SIG_IGN ((__fc_sighandler_t)1) /* ignore signal */ #define SIG_ERR ((__fc_sighandler_t)-1) /* error return from signal */ #define SIG_BLOCK 0 #define SIG_UNBLOCK 1 #define SIG_SETMASK 2 #define SIGHUP 1 #define SIGINT 2 #define SIGQUIT 3 #define SIGILL 4 #define SIGTRAP 5 #define SIGABRT 6 #define SIGIOT 6 #define SIGBUS 7 #define SIGFPE 8 #define SIGKILL 9 #define SIGUSR1 10 #define SIGSEGV 11 #define SIGUSR2 12 #define SIGPIPE 13 #define SIGALRM 14 #define SIGTERM 15 #define SIGSTKFLT 16 #define SIGCHLD 17 #define SIGCONT 18 #define SIGSTOP 19 #define SIGTSTP 20 #define SIGTTIN 21 #define SIGTTOU 22 #define SIGURG 23 #define SIGXCPU 24 #define SIGXFSZ 25 #define SIGVTALRM 26 #define SIGPROF 27 #define SIGWINCH 28 #define SIGIO 29 #define SIGPOLL SIGIO /* #define SIGLOST 29 */ #define SIGPWR 30 #define SIGSYS 31 #define SIGUNUSED 31 #define SA_NOCLDSTOP 0x00000001 #define SA_NOCLDWAIT 0x00000002 #define SA_SIGINFO 0x00000004 #define SA_ONSTACK 0x08000000 #define SA_RESTART 0x10000000 #define SA_NODEFER 0x40000000 #define SA_RESETHAND 0x80000000 #define SA_NOMASK SA_NODEFER #define SA_ONESHOT SA_RESETHAND /*@ assigns \nothing; */ void (*signal(int sig, void (*func)(int)))(int); /*@ assigns \nothing; ensures \false; */ int raise(int sig); #include "__fc_define_sigset_t.h" union sigval { int sival_int; void *sival_ptr; }; typedef struct { int si_signo; int si_code; union sigval si_value; int si_errno; pid_t si_pid; uid_t si_uid; void *si_addr; int si_status; int si_band; } siginfo_t; struct sigaction { void (*sa_handler)(int); void (*sa_sigaction)(int, siginfo_t *, void *); sigset_t sa_mask; int sa_flags; }; int sigemptyset(sigset_t *set); int sigfillset(sigset_t *set); int sigaddset(sigset_t *set, int signum); int sigdelset(sigset_t *set, int signum); int sigismember(const sigset_t *set, int signum); int sigaction(int signum, const struct sigaction *act, struct sigaction *oldact); int sigprocmask(int how, const sigset_t *set, sigset_t *oldset); int kill(pid_t pid, int sig); #endif frama-c-Fluorine-20130601/share/libc/tgmath.h0000644000175000017500000000325312155630243017451 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* ISO C: 7.22 */ #ifndef __FC_REG_TEST #error "Frama-C: unsupported tgmath.h" #endif frama-c-Fluorine-20130601/share/libc/__fc_define_sockaddr.h0000644000175000017500000000350112155630243022233 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_SOCKADDR #define __FC_DEFINE_SOCKADDR #include "__fc_define_sa_family_t.h" struct sockaddr { sa_family_t sa_family; /* address family, AF_xxx */ char sa_data[14]; /* 14 bytes of protocol address */ }; #endif frama-c-Fluorine-20130601/share/libc/setjmp.c0000644000175000017500000000202312155630243017454 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "setjmp.h" #include "__fc_builtin.h" void longjmp(jmp_buf env, int val) { Frama_C_abort(); return; } frama-c-Fluorine-20130601/share/libc/uchar.c0000644000175000017500000000166312155630243017265 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "uchar.h" frama-c-Fluorine-20130601/share/libc/stdlib.h0000644000175000017500000001777012155630243017457 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* ISO C: 7.20 */ #ifndef __FC_STDLIB #define __FC_STDLIB #include "__fc_define_size_t.h" #include "__fc_define_wchar_t.h" #include "__fc_define_restrict.h" typedef struct __fc_div_t { int quot; /* Quotient. */ int rem; /* Remainder. */ } div_t; typedef struct __fc_ldiv_t { long int quot; /* Quotient. */ long int rem; /* Remainder. */ } ldiv_t; typedef struct __fc_lldiv_t { long long int quot; /* Quotient. */ long long int rem; /* Remainder. */ } lldiv_t; #include "__fc_define_null.h" /* These could be customizable */ #define EXIT_FAILURE (-1) #define EXIT_SUCCESS 0 #include "limits.h" #define RAND_MAX __FC_RAND_MAX #define MB_CUR_MAX __FC_MB_CUR_MAX /*@ assigns \result \from nptr[..] ; */ double atof(const char *nptr); /*@ assigns \result \from nptr[..] ; */ int atoi(const char *nptr); /*@ assigns \result \from nptr[..] ; */ long int atol(const char *nptr); /*@ assigns \result \from nptr[..] ; */ long long int atoll(const char *nptr); /* See ISO C: 7.20.1.3 to complete these specifications */ /*@ assigns \result \from nptr[..] ; */ double strtod(const char * restrict nptr, char ** restrict endptr); /*@ assigns \result \from nptr[..] ; */ float strtof(const char * restrict nptr, char ** restrict endptr); /*@ assigns \result \from nptr[..] ; */ long double strtold(const char * restrict nptr, char ** restrict endptr); /* TODO: See ISO C 7.20.1.4 to complete these specifications */ /*@ assigns \result \from nptr[..] ; */ long int strtol( const char * restrict nptr, char ** restrict endptr, int base); /*@ assigns \result \from nptr[..] ; */ long long int strtoll( const char * restrict nptr, char ** restrict endptr, int base); /*@ assigns \result \from nptr[..] ; */ unsigned long int strtoul( const char * restrict nptr, char ** restrict endptr, int base); /*@ assigns \result \from nptr[..] ; */ unsigned long long int strtoull( const char * restrict nptr, char ** restrict endptr, int base); int __fc_random_counter __attribute__((unused)); const unsigned long __fc_rand_max = __FC_RAND_MAX; /* ISO C: 7.20.2 */ /*@ assigns \result \from __fc_random_counter ; @ assigns __fc_random_counter ; @ ensures 0 <= \result <= __fc_rand_max ; */ int rand(void); /*@ assigns __fc_random_counter \from seed ; */ void srand(unsigned int seed); /* ISO C: 7.20.3.1 */ void *calloc(size_t nmemb, size_t size); /*@ ghost extern int __fc_heap_status; */ /*@ axiomatic dynamic_allocation { @ predicate is_allocable(size_t n) // Can a block of n bytes be allocated? @ reads __fc_heap_status; @ } */ /*@ allocates \result; @ assigns __fc_heap_status \from size, __fc_heap_status; @ assigns \result \from size, __fc_heap_status; @ behavior allocation: @ assumes is_allocable(size); @ assigns __fc_heap_status \from size, __fc_heap_status; @ assigns \result \from size, __fc_heap_status; @ ensures \fresh(\result,size); @ behavior no_allocation: @ assumes !is_allocable(size); @ assigns \result \from \nothing; @ allocates \nothing; @ ensures \result==\null; @ complete behaviors; @ disjoint behaviors; @*/ void *malloc(size_t size); /*@ frees p; @ assigns __fc_heap_status \from __fc_heap_status; @ behavior deallocation: @ assumes p!=\null; @ requires \freeable(p); @ assigns __fc_heap_status \from __fc_heap_status; @ ensures \allocable(p); @ behavior no_deallocation: @ assumes p==\null; @ assigns \nothing; @ frees \nothing; @ complete behaviors; @ disjoint behaviors; @*/ void free(void *p); #ifdef FRAMA_C_MALLOC_POSITION #define __FRAMA_C_STRINGIFY(x) #x #define __FRAMA_C_XSTRINGIFY(x) __FRAMA_C_STRINGIFY(x) #define FRAMA_C_LOCALIZE_WARNING (" file " __FILE__ " line " __FRAMA_C_XSTRINGIFY(__LINE__)) #define malloc(x) (__Frama_C_malloc_at_pos(x,__FILE__ "_function_" __func__ "_line_" __FRAMA_C_XSTRINGIFY(__LINE__))) #define free(x) (__Frama_C_free_at_pos(x,FRAMA_C_LOCALIZE_WARNING)) void *__Frama_C_malloc_at_pos(size_t size,const char* file); void __Frama_C_free_at_pos(void* ptr,const char* pos); #endif void *realloc(void *ptr, size_t size); /* ISO C: 7.20.4 */ /*@ assigns \nothing; @ ensures \false; */ void abort(void); /*@ assigns \result \from \nothing ;*/ int atexit(void (*func)(void)); /*@ assigns \result \from \nothing ;*/ int at_quick_exit(void (*func)(void)); /*@ assigns \nothing; ensures \false; */ void exit(int status); /*@ assigns \nothing; ensures \false; */ void _Exit(int status); /*@ assigns \nothing ; ensures \result == \null || \valid(\result) ; */ char *getenv(const char *name); /*@ assigns \nothing; ensures \false; */ void quick_exit(int status); /*@ assigns \result \from string[..]; */ int system(const char *string); /* ISO C: 7.20.5 */ /* TODO: use one of the well known specification with high order compare :-) */ /*@ assigns ((char*)\result)[..] \from ((char*)key)[..], ((char*)base)[..], nmemb, size, *compar; */ void *bsearch(const void *key, const void *base, size_t nmemb, size_t size, int (*compar)(const void *, const void *)); /*@ assigns ((char*)base)[..] \from ((char*)base)[..], nmemb, size, *compar ; */ void qsort(void *base, size_t nmemb, size_t size, int (*compar)(const void *, const void *)); /* ISO C: 7.20.6 */ /*@ assigns \result \from j ; */ int abs(int j); /*@ assigns \result \from j ; */ long int labs(long int j); /*@ assigns \result \from j ; */ long long int llabs(long long int j); /*@ assigns \result \from numer,denom ; */ div_t div(int numer, int denom); /*@ assigns \result \from numer,denom ; */ ldiv_t ldiv(long int numer, long int denom); /*@ assigns \result \from numer,denom ; */ lldiv_t lldiv(long long int numer, long long int denom); /* ISO C: 7.20.7 */ /*@ assigns \result \from s[0..], n ;*/ int mblen(const char *s, size_t n); /*@ assigns \result, pwc[0..n-1] \from s[0..n-1], n ; */ int mbtowc(wchar_t * restrict pwc, const char * restrict s, size_t n); /*@ assigns \result, s[0..] \from wc ; */ int wctomb(char *s, wchar_t wc); /* ISO C: 7.20.8 */ /*@ assigns \result, pwcs[0..n-1] \from s[0..n-1], n ; */ size_t mbstowcs(wchar_t * restrict pwcs, const char * restrict s, size_t n); /*@ assigns \result, s[0..n-1] \from pwcs[0..n-1] , n ; */ size_t wcstombs(char * restrict s, const wchar_t * restrict pwcs, size_t n); #endif frama-c-Fluorine-20130601/share/libc/termios.h0000644000175000017500000001164012155630243017646 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* POSIX header */ /* c_iflag bits */ #ifndef _TERMIOS_H #define _TERMIOS_H #include "__fc_define_pid_t.h" #define IGNBRK 0000001 #define BRKINT 0000002 #define IGNPAR 0000004 #define PARMRK 0000010 #define INPCK 0000020 #define ISTRIP 0000040 #define INLCR 0000100 #define IGNCR 0000200 #define ICRNL 0000400 #define IUCLC 0001000 #define IXON 0002000 #define IXANY 0004000 #define IXOFF 0010000 #define IMAXBEL 0020000 #define IUTF8 0040000 /* c_oflag bits */ #define OPOST 0000001 #define OLCUC 0000002 #define ONLCR 0000004 #define OCRNL 0000010 #define ONOCR 0000020 #define ONLRET 0000040 #define OFILL 0000100 #define OFDEL 0000200 #define VTDLY 0040000 #define VT0 0000000 #define VT1 0040000 /* c_cflag bit meaning */ #define B0 0000000 /* hang up */ #define B50 0000001 #define B75 0000002 #define B110 0000003 #define B134 0000004 #define B150 0000005 #define B200 0000006 #define B300 0000007 #define B600 0000010 #define B1200 0000011 #define B1800 0000012 #define B2400 0000013 #define B4800 0000014 #define B9600 0000015 #define B19200 0000016 #define B38400 0000017 #define CSIZE 0000060 #define CS5 0000000 #define CS6 0000020 #define CS7 0000040 #define CS8 0000060 #define CSTOPB 0000100 #define CREAD 0000200 #define PARENB 0000400 #define PARODD 0001000 #define HUPCL 0002000 #define CLOCAL 0004000 #define B57600 0010001 #define B115200 0010002 #define B230400 0010003 #define B460800 0010004 #define B500000 0010005 #define B576000 0010006 #define B921600 0010007 #define B1000000 0010010 #define B1152000 0010011 #define B1500000 0010012 #define B2000000 0010013 #define B2500000 0010014 #define B3000000 0010015 #define B3500000 0010016 #define B4000000 0010017 #define __MAX_BAUD B4000000 /* c_lflag bits */ #define ISIG 0000001 #define ICANON 0000002 #define ECHO 0000010 #define ECHOE 0000020 #define ECHOK 0000040 #define ECHONL 0000100 #define NOFLSH 0000200 #define TOSTOP 0000400 #define IEXTEN 0001000 /* tcflow() and TCXONC use these */ #define TCOOFF 0 #define TCOON 1 #define TCIOFF 2 #define TCION 3 /* tcflush() and TCFLSH use these */ #define TCIFLUSH 0 #define TCOFLUSH 1 #define TCIOFLUSH 2 /* tcsetattr uses these */ #define TCSANOW 0 #define TCSADRAIN 1 #define TCSAFLUSH 2 typedef unsigned int tcflag_t; typedef unsigned char cc_t; typedef unsigned int speed_t; // cc_c characters #define NCCS 32 #define VINTR 0 #define VQUIT 1 #define VERASE 2 #define VKILL 3 #define VEOF 4 #define VTIME 5 #define VMIN 6 #define VSWTC 7 #define VSTART 8 #define VSTOP 9 #define VSUSP 10 #define VEOL 11 #define VREPRINT 12 #define VDISCARD 13 #define VWERASE 14 #define VLNEXT 15 #define VEOL2 16 struct termios { tcflag_t c_iflag; /* input specific flags (bitmask) */ tcflag_t c_oflag; /* output specific flags (bitmask) */ tcflag_t c_cflag; /* control flags (bitmask) */ tcflag_t c_lflag; /* local flags (bitmask) */ cc_t c_cc[NCCS]; /* special characters */ }; speed_t cfgetispeed(const struct termios *); speed_t cfgetospeed(const struct termios *); int cfsetispeed(struct termios *, speed_t); int cfsetospeed(struct termios *, speed_t); int tcdrain(int); int tcflow(int, int); int tcflush(int, int); int tcgetattr(int, struct termios *); pid_t tcgetsid(int); int tcsendbreak(int, int); int tcsetattr(int, int, struct termios *); #endif frama-c-Fluorine-20130601/share/libc/stdint.h0000644000175000017500000000772312155630243017500 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* ISO C: 7.18 */ #ifndef __FC_STDINT #define __FC_STDINT #include "__fc_machdep.h" /* ISO C: 7.18.1.1 */ #ifdef __INT8_T typedef __INT8_T int8_t; #endif #ifdef __UINT8_T typedef __UINT8_T uint8_t; #endif #ifdef __INT16_T typedef __INT16_T int16_t; #endif #ifdef __UINT16_T typedef __UINT16_T uint16_t; #endif #ifdef __INT32_T typedef __INT32_T int32_t; #endif #ifdef __UINT32_T typedef __UINT32_T uint32_t; #endif #ifdef __INT64_T typedef __INT64_T int64_t; #endif #ifdef __UINT64_T typedef __UINT64_T uint64_t; #endif /* ISO C: 7.18.1.2 */ typedef __INT_LEAST8_T int_least8_t; typedef __UINT_LEAST8_T uint_least8_t; typedef __INT_LEAST16_T int_least16_t; typedef __UINT_LEAST16_T uint_least16_t; typedef __INT_LEAST32_T int_least32_t; typedef __UINT_LEAST32_T uint_least32_t; typedef __INT_LEAST64_T int_least64_t; typedef __UINT_LEAST64_T uint_least64_t; /* ISO C: 7.18.1.3 */ typedef __INT_FAST8_T int_fast8_t; typedef __UINT_FAST8_T uint_fast8_t; typedef __INT_FAST16_T int_fast16_t; typedef __UINT_FAST16_T uint_fast16_t; typedef __INT_FAST32_T int_fast32_t; typedef __UINT_FAST32_T uint_fast32_t; typedef __INT_FAST64_T int_fast64_t; typedef __UINT_FAST64_T uint_fast64_t; /* ISO C: 7.18.1.4 */ #include "__fc_define_intptr_t.h" #ifdef __UINTPTR_T typedef __UINTPTR_T uintptr_t; #endif /* ISO C: 7.18.1.5 */ typedef __INT_MAX_T intmax_t; typedef __UINT_MAX_T uintmax_t; /* ISO C: 7.18.2.1 */ #define INT8_MIN (-128) #define INT8_MAX 127 #define UINT8_MAX 255 #define INT16_MIN (-32768) #define INT16_MAX 32767 #define UINT16_MAX 65535 #define INT32_MIN (-INT32_MAX - 1) #define INT32_MAX 2147483647 #define UINT32_MAX 4294967295U #define INT64_MIN (-INT64_MAX -1LL) #define INT64_MAX 9223372036854775807LL #define UINT64_MAX 18446744073709551615ULL /* ISO C: 7.18.2.3-5 : TODO */ /* ISO C: 7.18.3 */ #define PTRDIFF_MIN __FC_PTRDIFF_MIN #define PTRDIFF_MAX __FC_PTRDIFF_MAX #define SIG_ATOMIC_MIN __FC_SIG_ATOMIC_MIN #define SIG_ATOMIC_MAX __FC_SIG_ATOMIC_MAX #define SIZE_MAX __FC_SIZE_MAX #define WCHAR_MIN __FC_WCHAR_MIN #define WCHAR_MAX __FC_WCHAR_MAX #define WINT_MIN __FC_WINT_MIN #define WINT_MAX __FC_WINT_MAX /* ISO C: 7.18.4 */ #define INT8_C(c) c #define UINT8_C(c) c #define INT16_C(c) c #define UINT16_C(c) c #define INT32_C(c) (c ## L) #define UINT32_C(c) (c ## UL) #define INT64_C(c) (c ## LL) #define UINT64_C(c) (c ## ULL) #define INTMAX_C(c) (c ## LL) #define UINTMAX_C(c) (c ## ULL) #endif frama-c-Fluorine-20130601/share/libc/string.c0000644000175000017500000000643012155630243017466 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "string.h" #ifdef __FC_USE_BUILTIN__ #include "__fc_builtin.h" void* memcpy(void* region1, const void* region2, size_t n) { if (n > 0) Frama_C_memcpy(region1, region2, n); return region1; } #else void* memcpy(void* region1, const void* region2, size_t n) { const char* first = (const char*)region2; const char* last = ((const char*)region2) + n; char* result = (char*)region1; char* dest = result; while (first != last) *dest++ = *first++; return result; } #endif void* memset (void* dest, int val, size_t len) { unsigned char *ptr = (unsigned char*)dest; while (len-- > 0) *ptr++ = val; return dest; } int strcmp(const char *s1, const char *s2) { while (*s1 == *s2++) if (*s1++ == '\0') return (0); return (*(unsigned char *)s1 - *(unsigned char *)--s2); } char* strcat(char *s1, const char *s2) { char *os1 = s1; while (*s1++) ; --s1; while (*s1++ = *s2++) ; return (os1); } char* strcpy(char *s1, const char *s2) { char *os1 = s1; while (*s1++ = *s2++) ; return (os1); } /* * Copy s2 to s1, truncating or null-padding to always copy n bytes * return s1 */ char * strncpy(char *s1, const char *s2, size_t n) { char *os1 = s1; n++; while ((--n != 0) && ((*s1++ = *s2++) != '\0')) ; if (n != 0) while (--n != 0) *s1++ = '\0'; return (os1); } /* * Compare strings (at most n bytes) * returns: s1>s2; >0 s1==s2; 0 s1 \forall ℤ i; 0 <= i < n ==> s1[i] == s2[i]; @ @ } @*/ /*@ axiomatic MemChr { @ logic 𝔹 memchr{L}(char *s, ℤ c, ℤ n); @ // reads s[0..n - 1]; @ // Returns [true] iff array [s] contains character [c] @ @ axiom memchr_def{L}: @ \forall char *s; \forall ℤ c; \forall ℤ n; @ memchr(s,c,n) <==> \exists int i; 0 <= i < n && s[i] == c; @ } @*/ /*@ axiomatic MemSet { @ logic 𝔹 memset{L}(char *s, ℤ c, ℤ n); @ // reads s[0..n - 1]; @ // Returns [true] iff array [s] contains only character [c] @ @ axiom memset_def{L}: @ \forall char *s; \forall ℤ c; \forall ℤ n; @ memset(s,c,n) <==> \forall ℤ i; 0 <= i < n ==> s[i] == c; @ } @*/ /*@ axiomatic StrLen { @ logic ℤ strlen{L}(char *s); @ // reads s[0..]; @ @ axiom strlen_pos_or_null{L}: @ \forall char* s; \forall ℤ i; @ (0 <= i @ && (\forall ℤ j; 0 <= j < i ==> s[j] != '\0') @ && s[i] == '\0') ==> strlen(s) == i; @ @ axiom strlen_neg{L}: @ \forall char* s; @ (\forall ℤ i; 0 <= i ==> s[i] != '\0') @ ==> strlen(s) < 0; @ @ axiom strlen_before_null{L}: @ \forall char* s; \forall ℤ i; 0 <= i < strlen(s) ==> s[i] != '\0'; @ @ axiom strlen_at_null{L}: @ \forall char* s; 0 <= strlen(s) ==> s[strlen(s)] == '\0'; @ @ axiom strlen_not_zero{L}: @ \forall char* s; \forall ℤ i; @ 0 <= i <= strlen(s) && s[i] != '\0' ==> i < strlen(s); @ @ axiom strlen_zero{L}: @ \forall char* s; \forall ℤ i; @ 0 <= i <= strlen(s) && s[i] == '\0' ==> i == strlen(s); @ @ axiom strlen_sup{L}: @ \forall char* s; \forall ℤ i; @ 0 <= i && s[i] == '\0' ==> 0 <= strlen(s) <= i; @ @ axiom strlen_shift{L}: @ \forall char* s; \forall ℤ i; @ 0 <= i <= strlen(s) ==> strlen(s + i) == strlen(s) - i; @ @ axiom strlen_create{L}: @ \forall char* s; \forall ℤ i; @ 0 <= i && s[i] == '\0' ==> 0 <= strlen(s) <= i; @ @ axiom strlen_create_shift{L}: @ \forall char* s; \forall ℤ i; \forall ℤ k; @ 0 <= k <= i && s[i] == '\0' ==> 0 <= strlen(s+k) <= i - k; @ @ axiom memcmp_strlen_left{L}: @ \forall char *s1, *s2; \forall ℤ n; @ memcmp(s1,s2,n) == 0 && strlen(s1) < n ==> strlen(s1) == strlen(s2); @ @ axiom memcmp_strlen_right{L}: @ \forall char *s1, *s2; \forall ℤ n; @ memcmp(s1,s2,n) == 0 && strlen(s2) < n ==> strlen(s1) == strlen(s2); @ @ axiom memcmp_strlen_shift_left{L}: @ \forall char *s1, *s2; \forall ℤ k, n; @ memcmp(s1,s2 + k,n) == 0 && 0 <= k && strlen(s1) < n ==> @ 0 <= strlen(s2) <= k + strlen(s1); @ @ axiom memcmp_strlen_shift_right{L}: @ \forall char *s1, *s2; \forall ℤ k, n; @ memcmp(s1 + k,s2,n) == 0 && 0 <= k && strlen(s2) < n ==> @ 0 <= strlen(s1) <= k + strlen(s2); @ } @*/ /*@ axiomatic StrCmp { @ logic ℤ strcmp{L}(char *s1, char *s2); @ // reads s1[0..strlen(s1)], s2[0..strlen(s2)]; @ @ axiom strcmp_zero{L}: @ \forall char *s1, *s2; @ strcmp(s1,s2) == 0 <==> @ (strlen(s1) == strlen(s2) @ && \forall ℤ i; 0 <= i <= strlen(s1) ==> s1[i] == s2[i]); @ } @*/ /*@ axiomatic StrNCmp { @ logic ℤ strncmp{L}(char *s1, char *s2, ℤ n); @ // reads s1[0..n-1], s2[0..n-1]; @ @ axiom strncmp_zero{L}: @ \forall char *s1, *s2; \forall ℤ n; @ strncmp(s1,s2,n) == 0 <==> @ (strlen(s1) < n && strcmp(s1,s2) == 0 @ || \forall ℤ i; 0 <= i < n ==> s1[i] == s2[i]); @ } @*/ /*@ axiomatic StrChr { @ logic 𝔹 strchr{L}(char *s, ℤ c); @ // reads s[0..strlen(s)]; @ // Returns [true] iff string [s] contains character [c] @ @ axiom strchr_def{L}: @ \forall char *s; \forall ℤ c; @ strchr(s,c) <==> \exists ℤ i; 0 <= i <= strlen(s) && s[i] == c; @ } @*/ /*@ axiomatic WcsLen { @ logic ℤ wcslen{L}(wchar_t *s); @ // reads s[0..]; @ @ axiom wcslen_pos_or_null{L}: @ \forall wchar_t* s; \forall ℤ i; @ (0 <= i @ && (\forall ℤ j; 0 <= j < i ==> s[j] != L'\0') @ && s[i] == L'\0') ==> wcslen(s) == i; @ @ axiom wcslen_neg{L}: @ \forall wchar_t* s; @ (\forall ℤ i; 0 <= i ==> s[i] != L'\0') @ ==> wcslen(s) < 0; @ @ axiom wcslen_before_null{L}: @ \forall wchar_t* s; \forall int i; 0 <= i < wcslen(s) ==> s[i] != L'\0'; @ @ axiom wcslen_at_null{L}: @ \forall wchar_t* s; 0 <= wcslen(s) ==> s[wcslen(s)] == L'\0'; @ @ axiom wcslen_not_zero{L}: @ \forall wchar_t* s; \forall int i; @ 0 <= i <= wcslen(s) && s[i] != L'\0' ==> i < wcslen(s); @ @ axiom wcslen_zero{L}: @ \forall wchar_t* s; \forall int i; @ 0 <= i <= wcslen(s) && s[i] == L'\0' ==> i == wcslen(s); @ @ axiom wcslen_sup{L}: @ \forall wchar_t* s; \forall int i; @ 0 <= i && s[i] == L'\0' ==> 0 <= wcslen(s) <= i; @ @ axiom wcslen_shift{L}: @ \forall wchar_t* s; \forall int i; @ 0 <= i <= wcslen(s) ==> wcslen(s+i) == wcslen(s)-i; @ @ axiom wcslen_create{L}: @ \forall wchar_t* s; \forall int i; @ 0 <= i && s[i] == L'\0' ==> 0 <= wcslen(s) <= i; @ @ axiom wcslen_create_shift{L}: @ \forall wchar_t* s; \forall int i; \forall int k; @ 0 <= k <= i && s[i] == L'\0' ==> 0 <= wcslen(s+k) <= i - k; @ } @*/ /*@ axiomatic WcsCmp { @ logic ℤ wcscmp{L}(wchar_t *s1, wchar_t *s2); @ // reads s1[0..wcslen(s1)], s2[0..wcslen(s2)]; @ @ axiom wcscmp_zero{L}: @ \forall wchar_t *s1, *s2; @ wcscmp(s1,s2) == 0 <==> @ (wcslen(s1) == wcslen(s2) @ && \forall ℤ i; 0 <= i <= wcslen(s1) ==> s1[i] == s2[i]); @ } @*/ /*@ axiomatic WcsNCmp { @ logic ℤ wcsncmp{L}(wchar_t *s1, wchar_t *s2, ℤ n); @ // reads s1[0..n-1], s2[0..n-1]; @ @ axiom wcsncmp_zero{L}: @ \forall wchar_t *s1, *s2; \forall ℤ n; @ wcsncmp(s1,s2,n) == 0 <==> @ (wcslen(s1) < n && wcscmp(s1,s2) == 0 @ || \forall ℤ i; 0 <= i < n ==> s1[i] == s2[i]); @ } @*/ /*@ logic ℤ minimum(ℤ i, ℤ j) = i < j ? i : j; @ logic ℤ maximum(ℤ i, ℤ j) = i < j ? j : i; @*/ /*@ predicate valid_string{L}(char *s) = @ 0 <= strlen(s) && \valid(s+(0..strlen(s))); @ @ predicate valid_string_or_null{L}(char *s) = @ s == \null || valid_string(s); @ @ predicate valid_wstring{L}(wchar_t *s) = @ 0 <= wcslen(s) && \valid(s+(0..wcslen(s))); @ @ predicate valid_wstring_or_null{L}(wchar_t *s) = @ s == \null || valid_wstring(s); @*/ #define FRAMA_C_PTR __declspec(valid) #define FRAMA_C_ARRAY(n) __declspec(valid_range(0,n)) #define FRAMA_C_STRING __declspec(valid_string) #define FRAMA_C_STRING_OR_NULL __declspec(valid_string_or_null) #define FRAMA_C_WSTRING __declspec(valid_wstring) #define FRAMA_C_WSTRING_OR_NULL __declspec(valid_wstring_or_null) #endif frama-c-Fluorine-20130601/share/libc/dlfcn.c0000644000175000017500000000166512155630243017253 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "dlfcn.h" frama-c-Fluorine-20130601/share/libc/syslog.h0000644000175000017500000001247212155630243017510 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_SYSLOG_H #define __FC_SYSLOG_H #include "__fc_define_null.h" typedef struct _code { const char *c_name; int c_val; } CODE; #define LOG_PID 0x01 /* log the pid with each message */ #define LOG_CONS 0x02 /* log on the console if errors in sending */ #define LOG_ODELAY 0x04 /* delay open until first syslog() (default) */ #define LOG_NDELAY 0x08 /* don't delay open */ #define LOG_NOWAIT 0x10 /* don't wait for console forks: DEPRECATED */ #define LOG_PERROR 0x20 /* log to stderr as well */ #define LOG_KERN (0<<3) /* kernel messages */ #define LOG_USER (1<<3) /* random user-level messages */ #define LOG_MAIL (2<<3) /* mail system */ #define LOG_DAEMON (3<<3) /* system daemons */ #define LOG_AUTH (4<<3) /* security/authorization messages */ #define LOG_SYSLOG (5<<3) /* messages generated internally by syslogd */ #define LOG_LPR (6<<3) /* line printer subsystem */ #define LOG_NEWS (7<<3) /* network news subsystem */ #define LOG_UUCP (8<<3) /* UUCP subsystem */ #define LOG_CRON (9<<3) /* clock daemon */ #define LOG_AUTHPRIV (10<<3) /* security/authorization messages (private) */ #define LOG_FTP (11<<3) /* ftp daemon */ /* other codes through 15 reserved for system use */ #define LOG_LOCAL0 (16<<3) /* reserved for local use */ #define LOG_LOCAL1 (17<<3) /* reserved for local use */ #define LOG_LOCAL2 (18<<3) /* reserved for local use */ #define LOG_LOCAL3 (19<<3) /* reserved for local use */ #define LOG_LOCAL4 (20<<3) /* reserved for local use */ #define LOG_LOCAL5 (21<<3) /* reserved for local use */ #define LOG_LOCAL6 (22<<3) /* reserved for local use */ #define LOG_LOCAL7 (23<<3) /* reserved for local use */ #define LOG_NFACILITIES 24 /* current number of facilities */ #define LOG_FACMASK 0x03f8 /* mask to extract facility part */ /* facility of pri */ #define LOG_FAC(p) (((p) & LOG_FACMASK) >> 3) #define LOG_PRIMASK 0x07 #define LOG_PRI(p) ((p) & LOG_PRIMASK) #define LOG_MAKEPRI(fac, pri) (((fac) << 3) | (pri)) #define INTERNAL_NOPRI 0x10 /* the "no priority" priority */ /* mark "facility" */ #define INTERNAL_MARK LOG_MAKEPRI(LOG_NFACILITIES, 0) CODE facilitynames[] = { { "auth", LOG_AUTH }, { "authpriv", LOG_AUTHPRIV }, { "cron", LOG_CRON }, { "daemon", LOG_DAEMON }, { "ftp", LOG_FTP }, { "kern", LOG_KERN }, { "lpr", LOG_LPR }, { "mail", LOG_MAIL }, { "mark", INTERNAL_MARK }, /* INTERNAL */ { "news", LOG_NEWS }, { "security", LOG_AUTH }, /* DEPRECATED */ { "syslog", LOG_SYSLOG }, { "user", LOG_USER }, { "uucp", LOG_UUCP }, { "local0", LOG_LOCAL0 }, { "local1", LOG_LOCAL1 }, { "local2", LOG_LOCAL2 }, { "local3", LOG_LOCAL3 }, { "local4", LOG_LOCAL4 }, { "local5", LOG_LOCAL5 }, { "local6", LOG_LOCAL6 }, { "local7", LOG_LOCAL7 }, { NULL, -1 } }; #define LOG_MASK(pri) (1 << (pri)) /* mask for one priority */ #define LOG_UPTO(pri) ((1 << ((pri)+1)) - 1) /* all priorities through pri */ #define LOG_EMERG 0 #define LOG_ALERT 1 #define LOG_CRIT 2 #define LOG_ERR 3 #define LOG_WARNING 4 #define LOG_NOTICE 5 #define LOG_INFO 6 #define LOG_DEBUG 7 CODE prioritynames[] = { { "alert", LOG_ALERT }, { "crit", LOG_CRIT }, { "debug", LOG_DEBUG }, { "emerg", LOG_EMERG }, { "err", LOG_ERR }, { "error", LOG_ERR }, /* DEPRECATED */ { "info", LOG_INFO }, { "none", INTERNAL_NOPRI }, /* INTERNAL */ { "notice", LOG_NOTICE }, { "panic", LOG_EMERG }, /* DEPRECATED */ { "warn", LOG_WARNING }, /* DEPRECATED */ { "warning", LOG_WARNING }, { NULL, -1 } }; /*@ assigns \nothing ; */ void closelog(void); /*@ assigns \nothing ; */ void openlog(const char *, int, int); /*@ assigns \nothing ; */ int setlogmask(int); /*@ assigns \nothing ; */ void syslog(int, const char *, ...); #endif frama-c-Fluorine-20130601/share/libc/linux/0000755000175000017500000000000012155634040017147 5ustar mehdimehdiframa-c-Fluorine-20130601/share/libc/linux/fs.c0000644000175000017500000000166112155630243017730 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "fs.h" frama-c-Fluorine-20130601/share/libc/linux/if_addr.h0000644000175000017500000000322712155630243020715 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_LINUX_IF_ADDR_H #define __FC_LINUX_IF_ADDR_H #endif frama-c-Fluorine-20130601/share/libc/linux/netlink.h0000644000175000017500000000323112155630243020764 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_LINUX_NETLINK_H #define __FC_LINUX_NETLINK_H #endif frama-c-Fluorine-20130601/share/libc/linux/if_netlink.h0000644000175000017500000000322712155630243021447 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_IF_NETLINK_H #define __FC_IF_NETLINK_H #endif frama-c-Fluorine-20130601/share/libc/linux/netlink.c0000644000175000017500000000166512155630243020770 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "netlink.h" frama-c-Fluorine-20130601/share/libc/linux/rtnetlink.c0000644000175000017500000000166712155630243021340 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "rtnetlink.h" frama-c-Fluorine-20130601/share/libc/linux/rtnetlink.h0000644000175000017500000000323512155630243021336 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_LINUX_RTNETLINK_H #define __FC_LINUX_RTNETLINK_H #endif frama-c-Fluorine-20130601/share/libc/linux/fs.h0000644000175000017500000000323112155630243017730 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_LINUX_FS_H #define __FC_LINUX_FS_H /* TODO */ #endif frama-c-Fluorine-20130601/share/libc/linux/if_netlink.c0000644000175000017500000000167012155630243021442 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "if_netlink.h" frama-c-Fluorine-20130601/share/libc/linux/if_addr.c0000644000175000017500000000166512155630243020714 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "if_addr.h" frama-c-Fluorine-20130601/share/libc/__fc_define_time_t.h0000644000175000017500000000325312155630243021726 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_TIME_T #define __FC_DEFINE_TIME_T typedef long int time_t; #endif frama-c-Fluorine-20130601/share/libc/string.h0000644000175000017500000002157712155630243017504 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_STRING_H_ #define __FC_STRING_H_ #include "__fc_string_axiomatic.h" #include "stddef.h" #include "limits.h" #include "__fc_define_restrict.h" // Query memory /*@ requires \valid(((char*)s1)+(0..n - 1)); @ requires \valid(((char*)s2)+(0..n - 1)); @ assigns \result \from ((char*)s1)[0.. n-1], ((char*)s2)[0.. n-1]; @ ensures \result == memcmp((char*)s1,(char*)s2,n); @*/ extern int memcmp (const void *s1, const void *s2, size_t n); /*@ requires \valid(((char*)s)+(0..n - 1)); @ assigns \result \from s, c, ((char*)s)[0..n-1]; @ behavior found: @ assumes memchr((char*)s,c,n); @ ensures \base_addr(\result) == \base_addr(s); @ ensures *(char*)\result == c; @ behavior not_found: @ assumes ! memchr((char*)s,c,n); @ ensures \result == \null; @*/ extern void *memchr(const void *s, int c, size_t n); // Copy memory /*@ requires \valid(((char*)dest)+(0..n - 1)); @ requires \valid(((char*)src)+(0..n - 1)); @ requires \separated(((char *)dest)+(0..n-1),((char *)src)+(0..n-1)); @ assigns ((char*)dest)[0..n - 1] \from ((char*)src)[0..n-1]; @ assigns \result \from dest; @ ensures memcmp((char*)dest,(char*)src,n) == 0; @ ensures \result == dest; @*/ extern void *memcpy(void *restrict dest, const void *restrict src, size_t n); /*@ requires \valid(((char*)dest)+(0..n - 1)) @ && \valid(((char*)src)+(0..n - 1)); @ assigns ((char*)dest)[0..n - 1] \from ((char*)src)[0..n-1]; @ assigns \result \from dest; @ ensures memcmp((char*)dest,(char*)src,n) == 0; @ ensures \result == dest; @*/ extern void *memmove(void *dest, const void *src, size_t n); // Set memory /*@ requires \valid(((char*)s)+(0..n - 1)); @ assigns ((char*)s)[0..n - 1] \from c; @ assigns \result \from s; @ ensures memset((char*)s,c,n); @ ensures \result == s; @*/ extern void *memset(void *s, int c, size_t n); // Query strings /*@ requires valid_string(s); @ assigns \result \from s[0..]; @ ensures \result == strlen(s); @*/ extern size_t strlen (const char *s); /*@ requires valid_string(s1); @ requires valid_string(s2); @ assigns \result \from s1[0..], s2[0..]; @ ensures \result == strcmp(s1,s2); @*/ extern int strcmp (const char *s1, const char *s2); /*@ requires valid_string(s1); @ requires valid_string(s2); @ assigns \result \from s1[0 .. n-1], s2[0 ..n-1]; @ ensures \result == strncmp(s1,s2,n); @*/ extern int strncmp (const char *s1, const char *s2, size_t n); /*@ requires valid_string(s1) && valid_string(s2); @ assigns \nothing; @*/ extern int strcoll (const char *s1, const char *s2); /*@ requires valid_string(s); @ assigns \result \from s, s[0..],c; @ behavior found: @ assumes strchr(s,c); @ ensures *\result == c; @ ensures \base_addr(\result) == \base_addr(s); @ ensures s <= \result < s + strlen(s); @ ensures valid_string(\result); @ ensures \forall char* p; s<=p<\result ==> *p != c; @ behavior not_found: @ assumes ! strchr(s,c); @ ensures \result == \null; @ behavior default: @ ensures \result == \null || \base_addr(\result) == \base_addr(s); @*/ extern char *strchr(const char *s, int c); /*@ requires valid_string(s); @ assigns \result \from s, s[0..],c; @ behavior found: @ assumes strchr(s,c); @ ensures *\result == c; @ ensures \base_addr(\result) == \base_addr(s); @ ensures valid_string(\result); @ behavior not_found: @ assumes ! strchr(s,c); @ ensures \result == \null; @ behavior default: @ ensures \result == \null || \base_addr(\result) == \base_addr(s); @*/ extern char *strrchr(const char *s, int c); /*@ requires valid_string(s) && valid_string(reject); @ assigns \nothing; @ ensures 0 <= \result <= strlen(s); @*/ extern size_t strcspn(const char *s, const char *reject); /*@ requires valid_string(s) && valid_string(accept); @ assigns \nothing; @ ensures 0 <= \result <= strlen(s); @*/ extern size_t strspn(const char *s, const char *accept); /*@ requires valid_string(s) && valid_string(accept); @ assigns \nothing; @ ensures \result == 0 || \base_addr(\result) == \base_addr(s); @*/ extern char *strpbrk(const char *s, const char *accept); /*@ requires valid_string(haystack) && valid_string(needle); @ assigns \nothing; @ ensures \result == 0 @ || (\base_addr(\result) == \base_addr(haystack) @ && memcmp(\result,needle,strlen(needle)) == 0); @*/ extern char *strstr(const char *haystack, const char *needle); /*@ requires (valid_string(s) || s == \null) && valid_string(delim); @ assigns \nothing; @*/ extern char *strtok(char *restrict s, const char *restrict delim); /*@ requires \valid(stringp) && valid_string(*stringp) && valid_string(delim); @ assigns *stringp \from delim[..], *stringp[..]; @ assigns \result \from delim[..], *stringp[..]; @*/ extern char *strsep (char **stringp, const char *delim); /*@ assigns \result \from errnum; @ ensures valid_string(\result); @*/ extern char *strerror(int errnum); // Copy strings /*@ requires \valid(dest+(0..strlen(src))); @ requires valid_string(src); @ assigns dest[0..strlen(src)] \from src[0..strlen(src)]; @ assigns \result \from dest; @ ensures strcmp(dest,src) == 0; @ ensures \result == dest; @*/ extern char *strcpy(char *restrict dest, const char *restrict src); /*@ requires \valid(dest+(0..n - 1)) && valid_string(src); @ assigns dest[0..n - 1]; @ ensures \result == dest; @ behavior complete: @ assumes strlen(src) < n; @ assigns dest[0..n - 1]; @ ensures strcmp(dest,src) == 0; @ behavior partial: @ assumes n <= strlen(src); @ assigns dest[0..n - 1]; @ ensures memcmp(dest,src,n) == 0; @*/ extern char *strncpy(char *restrict dest, const char *restrict src, size_t n); /*@ requires \valid(dest+(0..strlen(dest) + strlen(src))); @ requires valid_string(src); @ requires valid_string(dest); @ assigns dest[strlen(dest)..strlen(dest) + strlen(src)] @ \from src[0..strlen(src)]; @ ensures strlen(dest) == \old(strlen(dest) + strlen(src)); @ assigns \result \from dest; @ ensures \result == dest; @*/ extern char *strcat(char *restrict dest, const char *restrict src); /*@ requires \valid(dest+(0..n)); @ requires valid_string(src); @ requires valid_string(dest); @ assigns dest[strlen(dest) .. strlen(dest) + n] \from src[0..n]; @ ensures \result == dest; @ behavior complete: @ assumes strlen(src) <= n; @ assigns dest[strlen(dest)..strlen(dest) + strlen(src)] @ \from src[0..strlen(src)]; @ ensures strlen(dest) == \old(strlen(dest) + strlen(src)); @ behavior partial: @ assumes n < strlen(src); @ ensures strlen(dest) == \old(strlen(dest)) + n; @*/ extern char *strncat(char *restrict dest, const char *restrict src, size_t n); /*@ requires \valid(dest+(0..n - 1)) && valid_string(src); @ assigns dest[0..n - 1]; @*/ extern size_t strxfrm (char *restrict dest, const char *restrict src, size_t n); // Allocate strings /*@ requires valid_string(s); @ assigns \nothing; @ ensures \valid(\result+(0..strlen(s))) && strcmp(\result,s) == 0; @*/ extern char *strdup (const char *s); /*@ requires valid_string(s); @ assigns \nothing; @ ensures \valid(\result+(0..minimum(strlen(s),n))) @ && valid_string(\result) && strlen(\result) <= n @ && strncmp(\result,s,n) == 0; @*/ extern char *strndup (const char *s, size_t n); #endif /* _STRING_H_ */ frama-c-Fluorine-20130601/share/libc/fc_runtime.c0000644000175000017500000000264612155630243020320 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "__fc_builtin.h" #include "assert.c" #include "complex.c" #include "ctype.c" #include "errno.c" #include "fenv.c" #include "float.c" #include "inttypes.c" #include "iso646.c" #include "limits.c" #include "locale.c" #include "math.c" #include "setjmp.c" #include "stdbool.c" #include "stddef.c" #include "signal.c" #include "stdarg.c" #include "stdint.c" #include "stdio.c" #include "stdlib.c" #include "string.c" #include "tgmath.c" #include "time.c" #include "uchar.c" #include "wchar.c" #include "wctype.c" frama-c-Fluorine-20130601/share/libc/termios.c0000644000175000017500000000166512155630243017647 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "termios.h" frama-c-Fluorine-20130601/share/libc/nl_types.c0000644000175000017500000000166612155630243020023 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "nl_types.h" frama-c-Fluorine-20130601/share/libc/errno.h0000644000175000017500000001246612155630243017320 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* ISO C: 7.5 */ #ifndef __FC_ERRNO #define __FC_ERRNO #include "__fc_machdep.h" /* Mandatory */ #define EDOM __FC_EDOM #define EILSEQ __FC_EILSEQ #define ERANGE __FC_ERANGE /* Implementation defined by POSIX and GNU Linux */ #define E2BIG __FC_E2BIG #define EACCES __FC_EACCES #define EADDRINUSE __FC_EADDRINUSE #define EADDRNOTAVAIL __FC_EADDRNOTAVAIL #define EAFNOSUPPORT __FC_EAFNOSUPPORT #define EAGAIN __FC_EAGAIN #define EALREADY __FC_EALREADY #define EBADE __FC_EBADE #define EBADF __FC_EBADF #define EBADFD __FC_EBADFD #define EBADMSG __FC_EBADMSG #define EBADR __FC_EBADR #define EBADRQC __FC_EBADRQC #define EBADSLT __FC_EBADSLT #define EBUSY __FC_EBUSY #define ECANCELED __FC_ECANCELED #define ECHILD __FC_ECHILD #define ECHRNG __FC_ECHRNG #define ECOMM __FC_ECOMM #define ECONNABORTED __FC_ECONNABORTED #define ECONNREFUSED __FC_ECONNREFUSED #define ECONNRESET __FC_ECONNRESET #define EDEADLK __FC_EDEADLK #define EDEADLOCK __FC_EDEADLOCK #define EDESTADDRREQ __FC_EDESTADDRREQ #define EDQUOT __FC_EDQUOT #define EEXIST __FC_EEXIST #define EFAULT __FC_EFAULT #define EFBIG __FC_EFBIG #define EHOSTDOWN __FC_EHOSTDOWN #define EHOSTUNREACH __FC_EHOSTUNREACH #define EIDRM __FC_EIDRM #define EINPROGRESS __FC_EINPROGRESS #define EINTR __FC_EINTR #define EINVAL __FC_EINVAL #define EIO __FC_EIO #define EISCONN __FC_EISCONN #define EISDIR __FC_EISDIR #define EISNAM __FC_EISNAM #define EKEYEXPIRED __FC_EKEYEXPIRED #define EKEYREJECTED __FC_EKEYREJECTED #define EKEYREVOKED __FC_EKEYREVOKED #define EL2HLT __FC_EL2HLT #define EL2NSYNC __FC_EL2NSYNC #define EL3HLT __FC_EL3HLT #define EL3RST __FC_EL3RST #define ELIBACC __FC_ELIBACC #define ELIBBAD __FC_ELIBBAD #define ELIBMAX __FC_ELIBMAX #define ELIBSCN __FC_ELIBSCN #define ELIBEXEC __FC_ELIBEXEC #define ELOOP __FC_ELOOP #define EMEDIUMTYPE __FC_EMEDIUMTYPE #define EMFILE __FC_EMFILE #define EMLINK __FC_EMLINK #define EMSGSIZE __FC_EMSGSIZE #define EMULTIHOP __FC_EMULTIHOP #define ENAMETOOLONG __FC_ENAMETOOLONG #define ENETDOWN __FC_ENETDOWN #define ENETRESET __FC_ENETRESET #define ENETUNREACH __FC_ENETUNREACH #define ENFILE __FC_ENFILE #define ENOBUFS __FC_ENOBUFS #define ENODATA __FC_ENODATA #define ENODEV __FC_ENODEV #define ENOENT __FC_ENOENT #define ENOEXEC __FC_ENOEXEC #define ENOKEY __FC_ENOKEY #define ENOLCK __FC_ENOLCK #define ENOLINK __FC_ENOLINK #define ENOMEDIUM __FC_ENOMEDIUM #define ENOMEM __FC_ENOMEM #define ENOMSG __FC_ENOMSG #define ENONET __FC_ENONET #define ENOPKG __FC_ENOPKG #define ENOPROTOOPT __FC_ENOPROTOOPT #define ENOSPC __FC_ENOSPC #define ENOSR __FC_ENOSR #define ENOSTR __FC_ENOSTR #define ENOSYS __FC_ENOSYS #define ENOTBLK __FC_ENOTBLK #define ENOTCONN __FC_ENOTCONN #define ENOTDIR __FC_ENOTDIR #define ENOTEMPTY __FC_ENOTEMPTY #define ENOTSOCK __FC_ENOTSOCK #define ENOTSUP __FC_ENOTSUP #define ENOTTY __FC_ENOTTY #define ENOTUNIQ __FC_ENOTUNIQ #define ENXIO __FC_ENXIO #define EOPNOTSUPP __FC_EOPNOTSUPP #define EOVERFLOW __FC_EOVERFLOW #define EPERM __FC_EPERM #define EPFNOSUPPORT __FC_EPFNOSUPPORT #define EPIPE __FC_EPIPE #define EPROTO __FC_EPROTO #define EPROTONOSUPPORT __FC_EPROTONOSUPPORT #define EPROTOTYPE __FC_EPROTOTYPE #define EREMCHG __FC_EREMCHG #define EREMOTE __FC_EREMOTE #define EREMOTEIO __FC_EREMOTEIO #define ERESTART __FC_ERESTART #define EROFS __FC_EROFS #define ESHUTDOWN __FC_ESHUTDOWN #define ESPIPE __FC_ESPIPE #define ESOCKTNOSUPPORT __FC_ESOCKTNOSUPPORT #define ESRCH __FC_ESRCH #define ESTALE __FC_ESTALE #define ESTRPIPE __FC_ESTRPIPE #define ETIME __FC_ETIME #define ETIMEDOUT __FC_ETIMEDOUT #define ETXTBSY __FC_ETXTBSY #define EUCLEAN __FC_EUCLEAN #define EUNATCH __FC_EUNATCH #define EUSERS __FC_EUSERS #define EWOULDBLOCK __FC_EWOULDBLOCK #define EXDEV __FC_EXDEV #define EXFULL __FC_EXFULL extern int __FC_errno; #define errno __FC_errno #endif frama-c-Fluorine-20130601/share/libc/__fc_define_ssize_t.h0000644000175000017500000000331212155630243022121 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_SSIZE_T #define __FC_DEFINE_SSIZE_T #include "__fc_machdep.h" typedef __SSIZE_T ssize_t; #endif frama-c-Fluorine-20130601/share/libc/pwd.h0000644000175000017500000000424612155630243016762 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_PWD_H__ #define __FC_PWD_H__ #include "__fc_define_uid_and_gid.h" // for size_t #include "stddef.h" struct passwd { char *pw_name; uid_t pw_uid; gid_t pw_gid; char *pw_dir; char *pw_shell; }; struct passwd *getpwnam(const char *); struct passwd *getpwuid(uid_t); int getpwnam_r(const char *, struct passwd *, char *, size_t, struct passwd **); int getpwuid_r(uid_t, struct passwd *, char *, size_t, struct passwd **); void endpwent(void); struct passwd *getpwent(void); void setpwent(void); #endif frama-c-Fluorine-20130601/share/libc/strings.c0000644000175000017500000000166512155630243017656 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "strings.h" frama-c-Fluorine-20130601/share/libc/complex.c0000644000175000017500000000171312155630243017626 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* Complex type Unsupported by Frama-C. */ frama-c-Fluorine-20130601/share/libc/__fc_define_restrict.h0000644000175000017500000000345412155630243022307 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_RESTRICT #define __FC_DEFINE_RESTRICT #ifndef __STDC_VERSION__ #define restrict #else # if __STDC_VERSION__ >= 199901L #define restrict restrict # else #define restrict # endif #endif #endif frama-c-Fluorine-20130601/share/libc/fenv.h0000644000175000017500000000325012155630243017120 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* ISO C: 7.6 */ #ifndef __FC_REG_TEST #error "Frama-C: unsupported fenv.h" #endif frama-c-Fluorine-20130601/share/libc/__fc_define_size_t.h0000644000175000017500000000330612155630243021741 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_SIZE_T #define __FC_DEFINE_SIZE_T #include "__fc_machdep.h" typedef __SIZE_T size_t; #endif frama-c-Fluorine-20130601/share/libc/netdb.h0000644000175000017500000001312612155630243017261 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_NETDB #define __FC_NETDB #include "netinet/in.h" #include "sys/socket.h" #include "inttypes.h" struct hostent { char *h_name; /* Official name of host. */ char **h_aliases; /* Alias list. */ int h_addrtype; /* Host address type. */ int h_length; /* Length of address. */ char **h_addr_list; /* List of addresses from name server. */ }; #define h_addr h_addr_list[0] /* for backward compatibility */ struct netent { char *n_name; /* Official name of network. */ char **n_aliases; /* Alias list. */ int n_addrtype; /* Net address type. */ uint32_t n_net; /* Network number. */ }; struct protoent { char *p_name; /* Official protocol name. */ char **p_aliases; /* Alias list. */ int p_proto; /* Protocol number. */ }; struct servent { char *s_name; /* Official service name. */ char **s_aliases; /* Alias list. */ int s_port; /* Port number. */ char *s_proto; /* Protocol to use. */ }; #define IPPORT_RESERVED 1024 int h_errno; # define HOST_NOT_FOUND 1 # define TRY_AGAIN 2 # define NO_RECOVERY 3 # define NO_DATA 4 struct addrinfo { int ai_flags; /* Input flags. */ int ai_family; /* Protocol family for socket. */ int ai_socktype; /* Socket type. */ int ai_protocol; /* Protocol for socket. */ socklen_t ai_addrlen; /* Length of socket address. */ struct sockaddr *ai_addr; /* Socket address for socket. */ char *ai_canonname; /* Canonical name for service location. */ struct addrinfo *ai_next; /* Pointer to next in list. */ }; # define AI_PASSIVE 0x0001 /* Socket address is intended for `bind'. */ # define AI_CANONNAME 0x0002 /* Request for canonical name. */ # define AI_NUMERICHOST 0x0004 /* Don't use name resolution. */ # define AI_NUMERICSERV 0x0400 /* Don't use name resolution. */ # define AI_V4MAPPED 0x0008 /* IPv4 mapped addresses are acceptable. */ # define AI_ALL 0x0010 /* Return IPv4 mapped and IPv6 addresses. */ # define AI_ADDRCONFIG 0x0020 /* Use configuration of this host to choose returned address type.. */ # define NI_NUMERICHOST 1 /* Don't try to look up hostname. */ # define NI_NUMERICSERV 2 /* Don't convert port number to name. */ # define NI_NOFQDN 4 /* Only return nodename portion. */ # define NI_NAMEREQD 8 /* Don't return numeric addresses. */ # define NI_DGRAM 16 /* Look up UDP service rather than TCP. */ # define NI_NUMERICSCOPE 32 # define EAI_BADFLAGS -1 /* Invalid value for `ai_flags' field. */ # define EAI_NONAME -2 /* NAME or SERVICE is unknown. */ # define EAI_AGAIN -3 /* Temporary failure in name resolution. */ # define EAI_FAIL -4 /* Non-recoverable failure in name res. */ # define EAI_FAMILY -6 /* `ai_family' not supported. */ # define EAI_SOCKTYPE -7 /* `ai_socktype' not supported. */ # define EAI_SERVICE -8 /* SERVICE not supported for `ai_socktype'. */ # define EAI_MEMORY -10 /* Memory allocation failure. */ # define EAI_SYSTEM -11 /* System error returned in `errno'. */ # define EAI_OVERFLOW -12 /* Argument buffer overflow. */ void endhostent(void); void endnetent(void); void endprotoent(void); void endservent(void); void freeaddrinfo(struct addrinfo *); const char *gai_strerror(int); int getaddrinfo(const char *restrict, const char *restrict, const struct addrinfo *restrict, struct addrinfo **restrict); struct hostent *gethostbyaddr(const void *, socklen_t, int); struct hostent *gethostbyname(const char *); struct hostent *gethostent(void); int getnameinfo(const struct sockaddr *restrict, socklen_t, char *restrict, socklen_t, char *restrict, socklen_t, int); struct netent *getnetbyaddr(uint32_t, int); struct netent *getnetbyname(const char *); struct netent *getnetent(void); struct protoent *getprotobyname(const char *); struct protoent *getprotobynumber(int); struct protoent *getprotoent(void); struct servent *getservbyname(const char *, const char *); struct servent *getservbyport(int, const char *); struct servent *getservent(void); void sethostent(int); void setnetent(int); void setprotoent(int); void setservent(int); #endif frama-c-Fluorine-20130601/share/libc/strings.h0000644000175000017500000000374512155630243017664 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_STRINGS_H_ #define __FC_STRINGS_H_ #include "__fc_define_size_t.h" int bcmp(const void *, const void *, size_t); void bcopy(const void *, void *, size_t); void bzero(void *, size_t); int ffs(int); char *index(const char *, int); char *rindex(const char *, int); int strcasecmp(const char *, const char *); int strncasecmp(const char *, const char *, size_t); #endif frama-c-Fluorine-20130601/share/libc/__fc_define_uid_and_gid.h0000644000175000017500000000332512155630243022673 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_UID_AND_GID #define __FC_DEFINE_UID_AND_GID typedef unsigned int gid_t; typedef unsigned int uid_t; #endif frama-c-Fluorine-20130601/share/libc/math.h0000644000175000017500000002476412155630243017130 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* ISO C: 7.12 */ #ifndef __FC_MATH #define __FC_MATH #include "__fc_string_axiomatic.h" #include "errno.h" typedef float float_t; typedef double double_t; #define MATH_ERRNO 1 #define MATH_ERREXCEPT 2 /* The following specifications will set errno. */ #define math_errhandling MATH_ERRNO /*@ behavior normal: assumes \is_finite(x) && \abs(x) <= 1; assigns \nothing; ensures \is_finite(\result) && \result >= 0; behavior edom: assumes \is_infinite(x) || (\is_finite(x) && \abs(x) > 1); assigns __FC_errno; ensures __FC_errno == 1; disjoint behaviors normal, edom; */ double acos(double x); /*@ behavior normal: assumes \is_finite(x) && \abs(x) <= 1; assigns \nothing; ensures \is_finite(\result) && \result >= 0; behavior edom: assumes \is_infinite(x) || (\is_finite(x) && \abs(x) > 1); assigns __FC_errno; ensures __FC_errno == 1; disjoint behaviors normal, edom; */ float acosf(float x); /*@ behavior normal: assumes \is_finite(x) && \abs(x) <= 1; assigns \nothing; ensures \is_finite(\result) && \result >= 0; behavior edom: assumes \is_infinite(x) || (\is_finite(x) && \abs(x) > 1); assigns __FC_errno; ensures __FC_errno == 1; disjoint behaviors normal, edom; */ long double acosl(long double x); /*@ behavior normal: assumes \is_finite(x) && \abs(x) <= 1; assigns \nothing; ensures \is_finite(\result); behavior edom: assumes \is_infinite(x) || (\is_finite(x) && \abs(x) > 1); assigns __FC_errno; ensures __FC_errno == 1; disjoint behaviors normal, edom; */ double asin(double x); /*@ behavior normal: assumes \is_finite(x) && \abs(x) <= 1; assigns \nothing; ensures \is_finite(\result); behavior edom: assumes \is_infinite(x) || (\is_finite(x) && \abs(x) > 1); assigns __FC_errno; ensures __FC_errno == 1; disjoint behaviors normal, edom; */ float asinf(float x); /*@ behavior normal: assumes \is_finite(x) && \abs(x) <= 1; assigns \nothing; ensures \is_finite(\result); behavior edom: assumes \is_infinite(x) || (\is_finite(x) && \abs(x) > 1); assigns __FC_errno; ensures __FC_errno == 1; disjoint behaviors normal, edom; */ long double asinl(long double x); float atanf(float x); double atan(double x); long double atanl(long double x); double atan2(double y, double x); float atan2f(float y, float x); long double atan2l(long double y, long double x); double cos(double x); float cosf(float x); long double cosl(long double x); double sin(double x); float sinf(float x); long double sinl(long double x); double tan(double x); float tanf(float x); long double tanl(long double x); /*@ behavior normal: assumes \is_finite(x) && x >= 1; assigns \nothing; ensures \is_finite(\result) && \result >= 0; behavior infinite: assumes \is_plus_infinity(x); assigns \nothing; ensures \is_plus_infinity(\result); behavior edom: assumes \is_minus_infinity(x) || (\is_finite(x) && x < 1); assigns __FC_errno; ensures __FC_errno == 1; disjoint behaviors normal, infinite, edom; */ double acosh(double x); /*@ behavior normal: assumes \is_finite(x) && x >= 1; assigns \nothing; ensures \is_finite(\result) && \result >= 0; behavior infinite: assumes \is_plus_infinity(x); assigns \nothing; ensures \is_plus_infinity(\result); behavior edom: assumes \is_minus_infinity(x) || (\is_finite(x) && x < 1); assigns __FC_errno; ensures __FC_errno == 1; disjoint behaviors normal, infinite, edom; */ float acoshf(float x); /*@ behavior normal: assumes \is_finite(x) && x >= 1; assigns \nothing; ensures \is_finite(\result) && \result >= 0; behavior infinite: assumes \is_plus_infinity(x); assigns \nothing; ensures \is_plus_infinity(\result); behavior edom: assumes \is_minus_infinity(x) || (\is_finite(x) && x < 1); assigns __FC_errno; ensures __FC_errno == 1; disjoint behaviors normal, infinite, edom; */ long double acoshl(long double x); double asinh(double x); float asinhf(float x); long double asinhl(long double x); double atanh(double x); float atanhf(float x); long double atanhl(long double x); double cosh(double x); float coshf(float x); long double coshl(long double x); double sinh(double x); float sinhf(float x); long double sinhl(long double x); double tanh(double x); float tanhf(float x); long double tanhl(long double x); double exp(double x); float expf(float x); long double expl(long double x); double exp2(double x); float exp2f(float x); long double exp2l(long double x); double expm1(double x); float expm1f(float x); long double expm1l(long double x); double frexp(double value, int *exp); float frexpf(float value, int *exp); long double frexpl(long double value, int *exp); int ilogb(double x); int ilogbf(float x); int ilogbl(long double x); double ldexp(double x, int exp); float ldexpf(float x, int exp); long double ldexpl(long double x, int exp); double log(double x); float logf(float x); long double logl(long double x); double log10(double x); float log10f(float x); long double log10l(long double x); double log1p(double x); float log1pf(float x); long double log1pl(long double x); double log2(double x); float log2f(float x); long double log2l(long double x); double logb(double x); float logbf(float x); long double logbl(long double x); double modf(double value, double *iptr); float modff(float value, float *iptr); long double modfl(long double value, long double *iptr); double scalbn(double x, int n); float scalbnf(float x, int n); long double scalbnl(long double x, int n); double scalbln(double x, long int n); float scalblnf(float x, long int n); long double scalblnl(long double x, long int n); double cbrt(double x); float cbrtf(float x); long double cbrtl(long double x); double fabs(double x); float fabsf(float x); long double fabsl(long double x); double hypot(double x, double y); float hypotf(float x, float y); long double hypotl(long double x, long double y); double pow(double x, double y); float powf(float x, float y); long double powl(long double x, long double y); double sqrt(double x); float sqrtf(float x); long double sqrtl(long double x); double erf(double x); float erff(float x); long double erfl(long double x); double erfc(double x); float erfcf(float x); long double erfcl(long double x); double lgamma(double x); float lgammaf(float x); long double lgammal(long double x); double tgamma(double x); float tgammaf(float x); long double tgammal(long double x); double ceil(double x); float ceilf(float x); long double ceill(long double x); double floor(double x); float floorf(float x); long double floorl(long double x); double nearbyint(double x); float nearbyintf(float x); long double nearbyintl(long double x); double rint(double x); float rintf(float x); long double rintl(long double x); long int lrint(double x); long int lrintf(float x); long int lrintl(long double x); long long int llrint(double x); long long int llrintf(float x); long long int llrintl(long double x); double round(double x); float roundf(float x); long double roundl(long double x); long int lround(double x); long int lroundf(float x); long int lroundl(long double x); long long int llround(double x); long long int llroundf(float x); long long int llroundl(long double x); double trunc(double x); float truncf(float x); long double truncl(long double x); double fmod(double x, double y); float fmodf(float x, float y); long double fmodl(long double x, long double y); double remainder(double x, double y); float remainderf(float x, float y); long double remainderl(long double x, long double y); double remquo(double x, double y, int *quo); float remquof(float x, float y, int *quo); long double remquol(long double x, long double y, int *quo); double copysign(double x, double y); float copysignf(float x, float y); long double copysignl(long double x, long double y); /*@ requires valid_string(tagp); assigns \nothing; ensures \is_NaN(\result); */ double nan(const char *tagp); /*@ requires valid_string(tagp); assigns \nothing; ensures \is_NaN(\result); */ float nanf(const char *tagp); /*@ requires valid_string(tagp); assigns \nothing; ensures \is_NaN(\result); */ long double nanl(const char *tagp); double nextafter(double x, double y); float nextafterf(float x, float y); long double nextafterl(long double x, long double y); double nexttoward(double x, long double y); float nexttowardf(float x, long double y); long double nexttowardl(long double x, long double y); double fdim(double x, double y); float fdimf(float x, float y); long double fdiml(long double x, long double y); double fmax(double x, double y); float fmaxf(float x, float y); long double fmaxl(long double x, long double y); double fmin(double x, double y); float fminf(float x, float y); long double fminl(long double x, long double y); double fma(double x, double y, double z); float fmaf(float x, float y, float z); long double fmal(long double x, long double y, long double z); #endif frama-c-Fluorine-20130601/share/libc/iso646.h0000644000175000017500000000353112155630243017216 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_ISO646 #define __FC_ISO646 /* ISO C: 7.9 */ #define and && #define and_eq &= #define bitand & #define bitor | #define compl ~ #define not ! #define not_eq != #define or || #define or_eq |= #define xor ^ #define xor_eq ^= #endif frama-c-Fluorine-20130601/share/libc/uchar.h0000644000175000017500000000322512155630243017266 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* ISO C: 7.24 */ #ifndef __FC_UCHAR #define __FC_UCHAR #endif frama-c-Fluorine-20130601/share/libc/__fc_builtin.c0000644000175000017500000000404612155630243020575 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* $Id: builtin.c,v 1.16 2008-11-21 09:19:53 uid527 Exp $ */ #include "__fc_builtin.h" int Frama_C_entropy_source; //@ assigns Frama_C_entropy_source \from Frama_C_entropy_source; void Frama_C_update_entropy(void); int Frama_C_nondet(int a, int b) { Frama_C_update_entropy(); return Frama_C_entropy_source ? a : b; } void *Frama_C_nondet_ptr(void *a, void *b) { return (void*) Frama_C_nondet((int)a, (int)b); } int Frama_C_interval(int min, int max) { int r,aux; Frama_C_update_entropy(); aux = Frama_C_entropy_source; if ((aux>=min) && (aux <=max)) r = aux; else r = min; return r; } float Frama_C_float_interval(float min, float max) { Frama_C_update_entropy(); return Frama_C_entropy_source ? min : max; } #if 0 static int ex1, ex2; static int *ex3; static float f; void Frama_C_builtin_examples(void) { /* non-determinist choice between two integers */ ex1 = Frama_C_nondet(17, 42); /* non-determinist choice between two pointers */ ex3 = Frama_C_nondet_ptr(&ex1, &ex2); /* integers interval */ ex2 = Frama_C_interval(17, 42); /* floats interval */ f = Frama_C_float_interval(1.0, 5.0); } #endif frama-c-Fluorine-20130601/share/libc/__fc_define_off_t.h0000644000175000017500000000325512155630243021544 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_OFF_T #define __FC_DEFINE_OFF_T typedef unsigned int off_t; #endif frama-c-Fluorine-20130601/share/libc/grp.c0000644000175000017500000000166212155630243016752 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "grp.h" frama-c-Fluorine-20130601/share/libc/__fc_builtin.h0000644000175000017500000000601312155630243020576 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef Frama_C_BUILTIN #define Frama_C_BUILTIN #include "__fc_define_size_t.h" #include "__fc_builtin_for_normalization.i" extern int Frama_C_entropy_source; /*@ assigns \result \from a, b, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures \result == a || \result == b ; */ int Frama_C_nondet(int a, int b); /*@ assigns \result \from a, b, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures \result == a || \result == b ; */ void *Frama_C_nondet_ptr(void *a, void *b); /*@ assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ int Frama_C_interval(int min, int max); /*@ assigns \result \from min, max, Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; ensures min <= \result <= max ; */ float Frama_C_float_interval(float min, float max); /*@ assigns ((char *)dest)[0..n-1] \from ((char *)src)[0..n-1]; assigns \result \from dest; ensures dest[0..n] == src[0..n]; */ void* Frama_C_memcpy(char *dest, const char *src, unsigned long n); /*@ terminates \false; assigns \empty; ensures \false; */ void Frama_C_abort(void) __attribute__ ((noreturn)); void Frama_C_show_each_warning(const char*, ...); size_t Frama_C_offset(const void*); void *Frama_C_undegenerate(const void*); #endif frama-c-Fluorine-20130601/share/libc/errno.c0000644000175000017500000000171012155630243017301 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "errno.h" int __FC_errno = 0; frama-c-Fluorine-20130601/share/libc/fcntl.c0000644000175000017500000000166312155630243017271 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "fcntl.h" frama-c-Fluorine-20130601/share/libc/locale.c0000644000175000017500000000270612155630243017421 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "locale.h" #include "limits.h" struct lconv __C_locale = {".","","","","","","","","","",CHAR_MAX,CHAR_MAX,CHAR_MAX,CHAR_MAX,CHAR_MAX,CHAR_MAX,CHAR_MAX,CHAR_MAX,CHAR_MAX,CHAR_MAX,CHAR_MAX,CHAR_MAX,CHAR_MAX,CHAR_MAX}; struct lconv *__frama_c_locale=&__C_locale; char*__frama_c_locale_names[1]={"C"}; char *setlocale(int category, const char *locale) { if (*locale == 'C') { __frama_c_locale = &__C_locale; return __frama_c_locale_names[0]; }; return NULL; } struct lconv *localeconv(void) { return __frama_c_locale; } frama-c-Fluorine-20130601/share/libc/stdio.c0000644000175000017500000000230412155630243017276 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "stdio.h" FILE __fc_initial_stdout = {.__fc_stdio_id=1}; FILE * __fc_stdout = &__fc_initial_stdout; FILE __fc_initial_stderr = {.__fc_stdio_id=2}; FILE * __fc_stderr = &__fc_initial_stderr; FILE __fc_initial_stdin = {.__fc_stdio_id=3}; FILE * __fc_stdin = &__fc_initial_stdin; frama-c-Fluorine-20130601/share/libc/unistd.h0000644000175000017500000006764512155630243017512 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_UNISTD #define __FC_UNISTD #include "__fc_define_size_t.h" #include "__fc_define_null.h" #include "__fc_define_ssize_t.h" #include "__fc_define_uid_and_gid.h" #include "__fc_define_off_t.h" #include "__fc_define_pid_t.h" #include "__fc_define_useconds_t.h" #include "__fc_define_intptr_t.h" /* Values for the second argument to access. These may be OR'd together. */ #define R_OK 4 /* Test for read permission. */ #define W_OK 2 /* Test for write permission. */ #define X_OK 1 /* Test for execute permission. */ #define F_OK 0 /* Test for existence. */ /* Standard file descriptors. */ #define STDIN_FILENO 0 /* Standard input. */ #define STDOUT_FILENO 1 /* Standard output. */ #define STDERR_FILENO 2 /* Standard error output. */ #include "__fc_define_seek_macros.h" /* Values for the NAME argument to `pathconf' and `fpathconf'. */ enum { _PC_LINK_MAX, #define _PC_LINK_MAX _PC_LINK_MAX _PC_MAX_CANON, #define _PC_MAX_CANON _PC_MAX_CANON _PC_MAX_INPUT, #define _PC_MAX_INPUT _PC_MAX_INPUT _PC_NAME_MAX, #define _PC_NAME_MAX _PC_NAME_MAX _PC_PATH_MAX, #define _PC_PATH_MAX _PC_PATH_MAX _PC_PIPE_BUF, #define _PC_PIPE_BUF _PC_PIPE_BUF _PC_CHOWN_RESTRICTED, #define _PC_CHOWN_RESTRICTED _PC_CHOWN_RESTRICTED _PC_NO_TRUNC, #define _PC_NO_TRUNC _PC_NO_TRUNC _PC_VDISABLE, #define _PC_VDISABLE _PC_VDISABLE _PC_SYNC_IO, #define _PC_SYNC_IO _PC_SYNC_IO _PC_ASYNC_IO, #define _PC_ASYNC_IO _PC_ASYNC_IO _PC_PRIO_IO, #define _PC_PRIO_IO _PC_PRIO_IO _PC_SOCK_MAXBUF, #define _PC_SOCK_MAXBUF _PC_SOCK_MAXBUF _PC_FILESIZEBITS, #define _PC_FILESIZEBITS _PC_FILESIZEBITS _PC_REC_INCR_XFER_SIZE, #define _PC_REC_INCR_XFER_SIZE _PC_REC_INCR_XFER_SIZE _PC_REC_MAX_XFER_SIZE, #define _PC_REC_MAX_XFER_SIZE _PC_REC_MAX_XFER_SIZE _PC_REC_MIN_XFER_SIZE, #define _PC_REC_MIN_XFER_SIZE _PC_REC_MIN_XFER_SIZE _PC_REC_XFER_ALIGN, #define _PC_REC_XFER_ALIGN _PC_REC_XFER_ALIGN _PC_ALLOC_SIZE_MIN, #define _PC_ALLOC_SIZE_MIN _PC_ALLOC_SIZE_MIN _PC_SYMLINK_MAX, #define _PC_SYMLINK_MAX _PC_SYMLINK_MAX _PC_2_SYMLINKS #define _PC_2_SYMLINKS _PC_2_SYMLINKS }; /* Values for the argument to `sysconf'. */ enum { _SC_ARG_MAX, #define _SC_ARG_MAX _SC_ARG_MAX _SC_CHILD_MAX, #define _SC_CHILD_MAX _SC_CHILD_MAX _SC_CLK_TCK, #define _SC_CLK_TCK _SC_CLK_TCK _SC_NGROUPS_MAX, #define _SC_NGROUPS_MAX _SC_NGROUPS_MAX _SC_OPEN_MAX, #define _SC_OPEN_MAX _SC_OPEN_MAX _SC_STREAM_MAX, #define _SC_STREAM_MAX _SC_STREAM_MAX _SC_TZNAME_MAX, #define _SC_TZNAME_MAX _SC_TZNAME_MAX _SC_JOB_CONTROL, #define _SC_JOB_CONTROL _SC_JOB_CONTROL _SC_SAVED_IDS, #define _SC_SAVED_IDS _SC_SAVED_IDS _SC_REALTIME_SIGNALS, #define _SC_REALTIME_SIGNALS _SC_REALTIME_SIGNALS _SC_PRIORITY_SCHEDULING, #define _SC_PRIORITY_SCHEDULING _SC_PRIORITY_SCHEDULING _SC_TIMERS, #define _SC_TIMERS _SC_TIMERS _SC_ASYNCHRONOUS_IO, #define _SC_ASYNCHRONOUS_IO _SC_ASYNCHRONOUS_IO _SC_PRIORITIZED_IO, #define _SC_PRIORITIZED_IO _SC_PRIORITIZED_IO _SC_SYNCHRONIZED_IO, #define _SC_SYNCHRONIZED_IO _SC_SYNCHRONIZED_IO _SC_FSYNC, #define _SC_FSYNC _SC_FSYNC _SC_MAPPED_FILES, #define _SC_MAPPED_FILES _SC_MAPPED_FILES _SC_MEMLOCK, #define _SC_MEMLOCK _SC_MEMLOCK _SC_MEMLOCK_RANGE, #define _SC_MEMLOCK_RANGE _SC_MEMLOCK_RANGE _SC_MEMORY_PROTECTION, #define _SC_MEMORY_PROTECTION _SC_MEMORY_PROTECTION _SC_MESSAGE_PASSING, #define _SC_MESSAGE_PASSING _SC_MESSAGE_PASSING _SC_SEMAPHORES, #define _SC_SEMAPHORES _SC_SEMAPHORES _SC_SHARED_MEMORY_OBJECTS, #define _SC_SHARED_MEMORY_OBJECTS _SC_SHARED_MEMORY_OBJECTS _SC_AIO_LISTIO_MAX, #define _SC_AIO_LISTIO_MAX _SC_AIO_LISTIO_MAX _SC_AIO_MAX, #define _SC_AIO_MAX _SC_AIO_MAX _SC_AIO_PRIO_DELTA_MAX, #define _SC_AIO_PRIO_DELTA_MAX _SC_AIO_PRIO_DELTA_MAX _SC_DELAYTIMER_MAX, #define _SC_DELAYTIMER_MAX _SC_DELAYTIMER_MAX _SC_MQ_OPEN_MAX, #define _SC_MQ_OPEN_MAX _SC_MQ_OPEN_MAX _SC_MQ_PRIO_MAX, #define _SC_MQ_PRIO_MAX _SC_MQ_PRIO_MAX _SC_VERSION, #define _SC_VERSION _SC_VERSION _SC_PAGESIZE, #define _SC_PAGESIZE _SC_PAGESIZE #define _SC_PAGE_SIZE _SC_PAGESIZE _SC_RTSIG_MAX, #define _SC_RTSIG_MAX _SC_RTSIG_MAX _SC_SEM_NSEMS_MAX, #define _SC_SEM_NSEMS_MAX _SC_SEM_NSEMS_MAX _SC_SEM_VALUE_MAX, #define _SC_SEM_VALUE_MAX _SC_SEM_VALUE_MAX _SC_SIGQUEUE_MAX, #define _SC_SIGQUEUE_MAX _SC_SIGQUEUE_MAX _SC_TIMER_MAX, #define _SC_TIMER_MAX _SC_TIMER_MAX /* Values for the argument to `sysconf' corresponding to _POSIX2_* symbols. */ _SC_BC_BASE_MAX, #define _SC_BC_BASE_MAX _SC_BC_BASE_MAX _SC_BC_DIM_MAX, #define _SC_BC_DIM_MAX _SC_BC_DIM_MAX _SC_BC_SCALE_MAX, #define _SC_BC_SCALE_MAX _SC_BC_SCALE_MAX _SC_BC_STRING_MAX, #define _SC_BC_STRING_MAX _SC_BC_STRING_MAX _SC_COLL_WEIGHTS_MAX, #define _SC_COLL_WEIGHTS_MAX _SC_COLL_WEIGHTS_MAX _SC_EQUIV_CLASS_MAX, #define _SC_EQUIV_CLASS_MAX _SC_EQUIV_CLASS_MAX _SC_EXPR_NEST_MAX, #define _SC_EXPR_NEST_MAX _SC_EXPR_NEST_MAX _SC_LINE_MAX, #define _SC_LINE_MAX _SC_LINE_MAX _SC_RE_DUP_MAX, #define _SC_RE_DUP_MAX _SC_RE_DUP_MAX _SC_CHARCLASS_NAME_MAX, #define _SC_CHARCLASS_NAME_MAX _SC_CHARCLASS_NAME_MAX _SC_2_VERSION, #define _SC_2_VERSION _SC_2_VERSION _SC_2_C_BIND, #define _SC_2_C_BIND _SC_2_C_BIND _SC_2_C_DEV, #define _SC_2_C_DEV _SC_2_C_DEV _SC_2_FORT_DEV, #define _SC_2_FORT_DEV _SC_2_FORT_DEV _SC_2_FORT_RUN, #define _SC_2_FORT_RUN _SC_2_FORT_RUN _SC_2_SW_DEV, #define _SC_2_SW_DEV _SC_2_SW_DEV _SC_2_LOCALEDEF, #define _SC_2_LOCALEDEF _SC_2_LOCALEDEF _SC_PII, #define _SC_PII _SC_PII _SC_PII_XTI, #define _SC_PII_XTI _SC_PII_XTI _SC_PII_SOCKET, #define _SC_PII_SOCKET _SC_PII_SOCKET _SC_PII_INTERNET, #define _SC_PII_INTERNET _SC_PII_INTERNET _SC_PII_OSI, #define _SC_PII_OSI _SC_PII_OSI _SC_POLL, #define _SC_POLL _SC_POLL _SC_SELECT, #define _SC_SELECT _SC_SELECT _SC_UIO_MAXIOV, #define _SC_UIO_MAXIOV _SC_UIO_MAXIOV _SC_IOV_MAX = _SC_UIO_MAXIOV, #define _SC_IOV_MAX _SC_IOV_MAX _SC_PII_INTERNET_STREAM, #define _SC_PII_INTERNET_STREAM _SC_PII_INTERNET_STREAM _SC_PII_INTERNET_DGRAM, #define _SC_PII_INTERNET_DGRAM _SC_PII_INTERNET_DGRAM _SC_PII_OSI_COTS, #define _SC_PII_OSI_COTS _SC_PII_OSI_COTS _SC_PII_OSI_CLTS, #define _SC_PII_OSI_CLTS _SC_PII_OSI_CLTS _SC_PII_OSI_M, #define _SC_PII_OSI_M _SC_PII_OSI_M _SC_T_IOV_MAX, #define _SC_T_IOV_MAX _SC_T_IOV_MAX /* Values according to POSIX 1003.1c (POSIX threads). */ _SC_THREADS, #define _SC_THREADS _SC_THREADS _SC_THREAD_SAFE_FUNCTIONS, #define _SC_THREAD_SAFE_FUNCTIONS _SC_THREAD_SAFE_FUNCTIONS _SC_GETGR_R_SIZE_MAX, #define _SC_GETGR_R_SIZE_MAX _SC_GETGR_R_SIZE_MAX _SC_GETPW_R_SIZE_MAX, #define _SC_GETPW_R_SIZE_MAX _SC_GETPW_R_SIZE_MAX _SC_LOGIN_NAME_MAX, #define _SC_LOGIN_NAME_MAX _SC_LOGIN_NAME_MAX _SC_TTY_NAME_MAX, #define _SC_TTY_NAME_MAX _SC_TTY_NAME_MAX _SC_THREAD_DESTRUCTOR_ITERATIONS, #define _SC_THREAD_DESTRUCTOR_ITERATIONS _SC_THREAD_DESTRUCTOR_ITERATIONS _SC_THREAD_KEYS_MAX, #define _SC_THREAD_KEYS_MAX _SC_THREAD_KEYS_MAX _SC_THREAD_STACK_MIN, #define _SC_THREAD_STACK_MIN _SC_THREAD_STACK_MIN _SC_THREAD_THREADS_MAX, #define _SC_THREAD_THREADS_MAX _SC_THREAD_THREADS_MAX _SC_THREAD_ATTR_STACKADDR, #define _SC_THREAD_ATTR_STACKADDR _SC_THREAD_ATTR_STACKADDR _SC_THREAD_ATTR_STACKSIZE, #define _SC_THREAD_ATTR_STACKSIZE _SC_THREAD_ATTR_STACKSIZE _SC_THREAD_PRIORITY_SCHEDULING, #define _SC_THREAD_PRIORITY_SCHEDULING _SC_THREAD_PRIORITY_SCHEDULING _SC_THREAD_PRIO_INHERIT, #define _SC_THREAD_PRIO_INHERIT _SC_THREAD_PRIO_INHERIT _SC_THREAD_PRIO_PROTECT, #define _SC_THREAD_PRIO_PROTECT _SC_THREAD_PRIO_PROTECT _SC_THREAD_PROCESS_SHARED, #define _SC_THREAD_PROCESS_SHARED _SC_THREAD_PROCESS_SHARED _SC_NPROCESSORS_CONF, #define _SC_NPROCESSORS_CONF _SC_NPROCESSORS_CONF _SC_NPROCESSORS_ONLN, #define _SC_NPROCESSORS_ONLN _SC_NPROCESSORS_ONLN _SC_PHYS_PAGES, #define _SC_PHYS_PAGES _SC_PHYS_PAGES _SC_AVPHYS_PAGES, #define _SC_AVPHYS_PAGES _SC_AVPHYS_PAGES _SC_ATEXIT_MAX, #define _SC_ATEXIT_MAX _SC_ATEXIT_MAX _SC_PASS_MAX, #define _SC_PASS_MAX _SC_PASS_MAX _SC_XOPEN_VERSION, #define _SC_XOPEN_VERSION _SC_XOPEN_VERSION _SC_XOPEN_XCU_VERSION, #define _SC_XOPEN_XCU_VERSION _SC_XOPEN_XCU_VERSION _SC_XOPEN_UNIX, #define _SC_XOPEN_UNIX _SC_XOPEN_UNIX _SC_XOPEN_CRYPT, #define _SC_XOPEN_CRYPT _SC_XOPEN_CRYPT _SC_XOPEN_ENH_I18N, #define _SC_XOPEN_ENH_I18N _SC_XOPEN_ENH_I18N _SC_XOPEN_SHM, #define _SC_XOPEN_SHM _SC_XOPEN_SHM _SC_2_CHAR_TERM, #define _SC_2_CHAR_TERM _SC_2_CHAR_TERM _SC_2_C_VERSION, #define _SC_2_C_VERSION _SC_2_C_VERSION _SC_2_UPE, #define _SC_2_UPE _SC_2_UPE _SC_XOPEN_XPG2, #define _SC_XOPEN_XPG2 _SC_XOPEN_XPG2 _SC_XOPEN_XPG3, #define _SC_XOPEN_XPG3 _SC_XOPEN_XPG3 _SC_XOPEN_XPG4, #define _SC_XOPEN_XPG4 _SC_XOPEN_XPG4 _SC_CHAR_BIT, #define _SC_CHAR_BIT _SC_CHAR_BIT _SC_CHAR_MAX, #define _SC_CHAR_MAX _SC_CHAR_MAX _SC_CHAR_MIN, #define _SC_CHAR_MIN _SC_CHAR_MIN _SC_INT_MAX, #define _SC_INT_MAX _SC_INT_MAX _SC_INT_MIN, #define _SC_INT_MIN _SC_INT_MIN _SC_LONG_BIT, #define _SC_LONG_BIT _SC_LONG_BIT _SC_WORD_BIT, #define _SC_WORD_BIT _SC_WORD_BIT _SC_MB_LEN_MAX, #define _SC_MB_LEN_MAX _SC_MB_LEN_MAX _SC_NZERO, #define _SC_NZERO _SC_NZERO _SC_SSIZE_MAX, #define _SC_SSIZE_MAX _SC_SSIZE_MAX _SC_SCHAR_MAX, #define _SC_SCHAR_MAX _SC_SCHAR_MAX _SC_SCHAR_MIN, #define _SC_SCHAR_MIN _SC_SCHAR_MIN _SC_SHRT_MAX, #define _SC_SHRT_MAX _SC_SHRT_MAX _SC_SHRT_MIN, #define _SC_SHRT_MIN _SC_SHRT_MIN _SC_UCHAR_MAX, #define _SC_UCHAR_MAX _SC_UCHAR_MAX _SC_UINT_MAX, #define _SC_UINT_MAX _SC_UINT_MAX _SC_ULONG_MAX, #define _SC_ULONG_MAX _SC_ULONG_MAX _SC_USHRT_MAX, #define _SC_USHRT_MAX _SC_USHRT_MAX _SC_NL_ARGMAX, #define _SC_NL_ARGMAX _SC_NL_ARGMAX _SC_NL_LANGMAX, #define _SC_NL_LANGMAX _SC_NL_LANGMAX _SC_NL_MSGMAX, #define _SC_NL_MSGMAX _SC_NL_MSGMAX _SC_NL_NMAX, #define _SC_NL_NMAX _SC_NL_NMAX _SC_NL_SETMAX, #define _SC_NL_SETMAX _SC_NL_SETMAX _SC_NL_TEXTMAX, #define _SC_NL_TEXTMAX _SC_NL_TEXTMAX _SC_XBS5_ILP32_OFF32, #define _SC_XBS5_ILP32_OFF32 _SC_XBS5_ILP32_OFF32 _SC_XBS5_ILP32_OFFBIG, #define _SC_XBS5_ILP32_OFFBIG _SC_XBS5_ILP32_OFFBIG _SC_XBS5_LP64_OFF64, #define _SC_XBS5_LP64_OFF64 _SC_XBS5_LP64_OFF64 _SC_XBS5_LPBIG_OFFBIG, #define _SC_XBS5_LPBIG_OFFBIG _SC_XBS5_LPBIG_OFFBIG _SC_XOPEN_LEGACY, #define _SC_XOPEN_LEGACY _SC_XOPEN_LEGACY _SC_XOPEN_REALTIME, #define _SC_XOPEN_REALTIME _SC_XOPEN_REALTIME _SC_XOPEN_REALTIME_THREADS, #define _SC_XOPEN_REALTIME_THREADS _SC_XOPEN_REALTIME_THREADS _SC_ADVISORY_INFO, #define _SC_ADVISORY_INFO _SC_ADVISORY_INFO _SC_BARRIERS, #define _SC_BARRIERS _SC_BARRIERS _SC_BASE, #define _SC_BASE _SC_BASE _SC_C_LANG_SUPPORT, #define _SC_C_LANG_SUPPORT _SC_C_LANG_SUPPORT _SC_C_LANG_SUPPORT_R, #define _SC_C_LANG_SUPPORT_R _SC_C_LANG_SUPPORT_R _SC_CLOCK_SELECTION, #define _SC_CLOCK_SELECTION _SC_CLOCK_SELECTION _SC_CPUTIME, #define _SC_CPUTIME _SC_CPUTIME _SC_THREAD_CPUTIME, #define _SC_THREAD_CPUTIME _SC_THREAD_CPUTIME _SC_DEVICE_IO, #define _SC_DEVICE_IO _SC_DEVICE_IO _SC_DEVICE_SPECIFIC, #define _SC_DEVICE_SPECIFIC _SC_DEVICE_SPECIFIC _SC_DEVICE_SPECIFIC_R, #define _SC_DEVICE_SPECIFIC_R _SC_DEVICE_SPECIFIC_R _SC_FD_MGMT, #define _SC_FD_MGMT _SC_FD_MGMT _SC_FIFO, #define _SC_FIFO _SC_FIFO _SC_PIPE, #define _SC_PIPE _SC_PIPE _SC_FILE_ATTRIBUTES, #define _SC_FILE_ATTRIBUTES _SC_FILE_ATTRIBUTES _SC_FILE_LOCKING, #define _SC_FILE_LOCKING _SC_FILE_LOCKING _SC_FILE_SYSTEM, #define _SC_FILE_SYSTEM _SC_FILE_SYSTEM _SC_MONOTONIC_CLOCK, #define _SC_MONOTONIC_CLOCK _SC_MONOTONIC_CLOCK _SC_MULTI_PROCESS, #define _SC_MULTI_PROCESS _SC_MULTI_PROCESS _SC_SINGLE_PROCESS, #define _SC_SINGLE_PROCESS _SC_SINGLE_PROCESS _SC_NETWORKING, #define _SC_NETWORKING _SC_NETWORKING _SC_READER_WRITER_LOCKS, #define _SC_READER_WRITER_LOCKS _SC_READER_WRITER_LOCKS _SC_SPIN_LOCKS, #define _SC_SPIN_LOCKS _SC_SPIN_LOCKS _SC_REGEXP, #define _SC_REGEXP _SC_REGEXP _SC_REGEX_VERSION, #define _SC_REGEX_VERSION _SC_REGEX_VERSION _SC_SHELL, #define _SC_SHELL _SC_SHELL _SC_SIGNALS, #define _SC_SIGNALS _SC_SIGNALS _SC_SPAWN, #define _SC_SPAWN _SC_SPAWN _SC_SPORADIC_SERVER, #define _SC_SPORADIC_SERVER _SC_SPORADIC_SERVER _SC_THREAD_SPORADIC_SERVER, #define _SC_THREAD_SPORADIC_SERVER _SC_THREAD_SPORADIC_SERVER _SC_SYSTEM_DATABASE, #define _SC_SYSTEM_DATABASE _SC_SYSTEM_DATABASE _SC_SYSTEM_DATABASE_R, #define _SC_SYSTEM_DATABASE_R _SC_SYSTEM_DATABASE_R _SC_TIMEOUTS, #define _SC_TIMEOUTS _SC_TIMEOUTS _SC_TYPED_MEMORY_OBJECTS, #define _SC_TYPED_MEMORY_OBJECTS _SC_TYPED_MEMORY_OBJECTS _SC_USER_GROUPS, #define _SC_USER_GROUPS _SC_USER_GROUPS _SC_USER_GROUPS_R, #define _SC_USER_GROUPS_R _SC_USER_GROUPS_R _SC_2_PBS, #define _SC_2_PBS _SC_2_PBS _SC_2_PBS_ACCOUNTING, #define _SC_2_PBS_ACCOUNTING _SC_2_PBS_ACCOUNTING _SC_2_PBS_LOCATE, #define _SC_2_PBS_LOCATE _SC_2_PBS_LOCATE _SC_2_PBS_MESSAGE, #define _SC_2_PBS_MESSAGE _SC_2_PBS_MESSAGE _SC_2_PBS_TRACK, #define _SC_2_PBS_TRACK _SC_2_PBS_TRACK _SC_SYMLOOP_MAX, #define _SC_SYMLOOP_MAX _SC_SYMLOOP_MAX _SC_STREAMS, #define _SC_STREAMS _SC_STREAMS _SC_2_PBS_CHECKPOINT, #define _SC_2_PBS_CHECKPOINT _SC_2_PBS_CHECKPOINT _SC_V6_ILP32_OFF32, #define _SC_V6_ILP32_OFF32 _SC_V6_ILP32_OFF32 _SC_V6_ILP32_OFFBIG, #define _SC_V6_ILP32_OFFBIG _SC_V6_ILP32_OFFBIG _SC_V6_LP64_OFF64, #define _SC_V6_LP64_OFF64 _SC_V6_LP64_OFF64 _SC_V6_LPBIG_OFFBIG, #define _SC_V6_LPBIG_OFFBIG _SC_V6_LPBIG_OFFBIG _SC_HOST_NAME_MAX, #define _SC_HOST_NAME_MAX _SC_HOST_NAME_MAX _SC_TRACE, #define _SC_TRACE _SC_TRACE _SC_TRACE_EVENT_FILTER, #define _SC_TRACE_EVENT_FILTER _SC_TRACE_EVENT_FILTER _SC_TRACE_INHERIT, #define _SC_TRACE_INHERIT _SC_TRACE_INHERIT _SC_TRACE_LOG, #define _SC_TRACE_LOG _SC_TRACE_LOG _SC_LEVEL1_ICACHE_SIZE, #define _SC_LEVEL1_ICACHE_SIZE _SC_LEVEL1_ICACHE_SIZE _SC_LEVEL1_ICACHE_ASSOC, #define _SC_LEVEL1_ICACHE_ASSOC _SC_LEVEL1_ICACHE_ASSOC _SC_LEVEL1_ICACHE_LINESIZE, #define _SC_LEVEL1_ICACHE_LINESIZE _SC_LEVEL1_ICACHE_LINESIZE _SC_LEVEL1_DCACHE_SIZE, #define _SC_LEVEL1_DCACHE_SIZE _SC_LEVEL1_DCACHE_SIZE _SC_LEVEL1_DCACHE_ASSOC, #define _SC_LEVEL1_DCACHE_ASSOC _SC_LEVEL1_DCACHE_ASSOC _SC_LEVEL1_DCACHE_LINESIZE, #define _SC_LEVEL1_DCACHE_LINESIZE _SC_LEVEL1_DCACHE_LINESIZE _SC_LEVEL2_CACHE_SIZE, #define _SC_LEVEL2_CACHE_SIZE _SC_LEVEL2_CACHE_SIZE _SC_LEVEL2_CACHE_ASSOC, #define _SC_LEVEL2_CACHE_ASSOC _SC_LEVEL2_CACHE_ASSOC _SC_LEVEL2_CACHE_LINESIZE, #define _SC_LEVEL2_CACHE_LINESIZE _SC_LEVEL2_CACHE_LINESIZE _SC_LEVEL3_CACHE_SIZE, #define _SC_LEVEL3_CACHE_SIZE _SC_LEVEL3_CACHE_SIZE _SC_LEVEL3_CACHE_ASSOC, #define _SC_LEVEL3_CACHE_ASSOC _SC_LEVEL3_CACHE_ASSOC _SC_LEVEL3_CACHE_LINESIZE, #define _SC_LEVEL3_CACHE_LINESIZE _SC_LEVEL3_CACHE_LINESIZE _SC_LEVEL4_CACHE_SIZE, #define _SC_LEVEL4_CACHE_SIZE _SC_LEVEL4_CACHE_SIZE _SC_LEVEL4_CACHE_ASSOC, #define _SC_LEVEL4_CACHE_ASSOC _SC_LEVEL4_CACHE_ASSOC _SC_LEVEL4_CACHE_LINESIZE, #define _SC_LEVEL4_CACHE_LINESIZE _SC_LEVEL4_CACHE_LINESIZE /* Leave room here, maybe we need a few more cache levels some day. */ _SC_IPV6 = _SC_LEVEL1_ICACHE_SIZE + 50, #define _SC_IPV6 _SC_IPV6 _SC_RAW_SOCKETS, #define _SC_RAW_SOCKETS _SC_RAW_SOCKETS _SC_V7_ILP32_OFF32, #define _SC_V7_ILP32_OFF32 _SC_V7_ILP32_OFF32 _SC_V7_ILP32_OFFBIG, #define _SC_V7_ILP32_OFFBIG _SC_V7_ILP32_OFFBIG _SC_V7_LP64_OFF64, #define _SC_V7_LP64_OFF64 _SC_V7_LP64_OFF64 _SC_V7_LPBIG_OFFBIG, #define _SC_V7_LPBIG_OFFBIG _SC_V7_LPBIG_OFFBIG _SC_SS_REPL_MAX, #define _SC_SS_REPL_MAX _SC_SS_REPL_MAX _SC_TRACE_EVENT_NAME_MAX, #define _SC_TRACE_EVENT_NAME_MAX _SC_TRACE_EVENT_NAME_MAX _SC_TRACE_NAME_MAX, #define _SC_TRACE_NAME_MAX _SC_TRACE_NAME_MAX _SC_TRACE_SYS_MAX, #define _SC_TRACE_SYS_MAX _SC_TRACE_SYS_MAX _SC_TRACE_USER_EVENT_MAX, #define _SC_TRACE_USER_EVENT_MAX _SC_TRACE_USER_EVENT_MAX _SC_XOPEN_STREAMS, #define _SC_XOPEN_STREAMS _SC_XOPEN_STREAMS _SC_THREAD_ROBUST_PRIO_INHERIT, #define _SC_THREAD_ROBUST_PRIO_INHERIT _SC_THREAD_ROBUST_PRIO_INHERIT _SC_THREAD_ROBUST_PRIO_PROTECT #define _SC_THREAD_ROBUST_PRIO_PROTECT _SC_THREAD_ROBUST_PRIO_PROTECT }; /* Values for the NAME argument to `confstr'. */ enum { _CS_PATH, /* The default search path. */ #define _CS_PATH _CS_PATH _CS_V6_WIDTH_RESTRICTED_ENVS, #define _CS_V6_WIDTH_RESTRICTED_ENVS _CS_V6_WIDTH_RESTRICTED_ENVS #define _CS_POSIX_V6_WIDTH_RESTRICTED_ENVS _CS_V6_WIDTH_RESTRICTED_ENVS _CS_GNU_LIBC_VERSION, #define _CS_GNU_LIBC_VERSION _CS_GNU_LIBC_VERSION _CS_GNU_LIBPTHREAD_VERSION, #define _CS_GNU_LIBPTHREAD_VERSION _CS_GNU_LIBPTHREAD_VERSION _CS_V5_WIDTH_RESTRICTED_ENVS, #define _CS_V5_WIDTH_RESTRICTED_ENVS _CS_V5_WIDTH_RESTRICTED_ENVS #define _CS_POSIX_V5_WIDTH_RESTRICTED_ENVS _CS_V5_WIDTH_RESTRICTED_ENVS _CS_V7_WIDTH_RESTRICTED_ENVS, #define _CS_V7_WIDTH_RESTRICTED_ENVS _CS_V7_WIDTH_RESTRICTED_ENVS #define _CS_POSIX_V7_WIDTH_RESTRICTED_ENVS _CS_V7_WIDTH_RESTRICTED_ENVS _CS_LFS_CFLAGS = 1000, #define _CS_LFS_CFLAGS _CS_LFS_CFLAGS _CS_LFS_LDFLAGS, #define _CS_LFS_LDFLAGS _CS_LFS_LDFLAGS _CS_LFS_LIBS, #define _CS_LFS_LIBS _CS_LFS_LIBS _CS_LFS_LINTFLAGS, #define _CS_LFS_LINTFLAGS _CS_LFS_LINTFLAGS _CS_LFS64_CFLAGS, #define _CS_LFS64_CFLAGS _CS_LFS64_CFLAGS _CS_LFS64_LDFLAGS, #define _CS_LFS64_LDFLAGS _CS_LFS64_LDFLAGS _CS_LFS64_LIBS, #define _CS_LFS64_LIBS _CS_LFS64_LIBS _CS_LFS64_LINTFLAGS, #define _CS_LFS64_LINTFLAGS _CS_LFS64_LINTFLAGS _CS_XBS5_ILP32_OFF32_CFLAGS = 1100, #define _CS_XBS5_ILP32_OFF32_CFLAGS _CS_XBS5_ILP32_OFF32_CFLAGS _CS_XBS5_ILP32_OFF32_LDFLAGS, #define _CS_XBS5_ILP32_OFF32_LDFLAGS _CS_XBS5_ILP32_OFF32_LDFLAGS _CS_XBS5_ILP32_OFF32_LIBS, #define _CS_XBS5_ILP32_OFF32_LIBS _CS_XBS5_ILP32_OFF32_LIBS _CS_XBS5_ILP32_OFF32_LINTFLAGS, #define _CS_XBS5_ILP32_OFF32_LINTFLAGS _CS_XBS5_ILP32_OFF32_LINTFLAGS _CS_XBS5_ILP32_OFFBIG_CFLAGS, #define _CS_XBS5_ILP32_OFFBIG_CFLAGS _CS_XBS5_ILP32_OFFBIG_CFLAGS _CS_XBS5_ILP32_OFFBIG_LDFLAGS, #define _CS_XBS5_ILP32_OFFBIG_LDFLAGS _CS_XBS5_ILP32_OFFBIG_LDFLAGS _CS_XBS5_ILP32_OFFBIG_LIBS, #define _CS_XBS5_ILP32_OFFBIG_LIBS _CS_XBS5_ILP32_OFFBIG_LIBS _CS_XBS5_ILP32_OFFBIG_LINTFLAGS, #define _CS_XBS5_ILP32_OFFBIG_LINTFLAGS _CS_XBS5_ILP32_OFFBIG_LINTFLAGS _CS_XBS5_LP64_OFF64_CFLAGS, #define _CS_XBS5_LP64_OFF64_CFLAGS _CS_XBS5_LP64_OFF64_CFLAGS _CS_XBS5_LP64_OFF64_LDFLAGS, #define _CS_XBS5_LP64_OFF64_LDFLAGS _CS_XBS5_LP64_OFF64_LDFLAGS _CS_XBS5_LP64_OFF64_LIBS, #define _CS_XBS5_LP64_OFF64_LIBS _CS_XBS5_LP64_OFF64_LIBS _CS_XBS5_LP64_OFF64_LINTFLAGS, #define _CS_XBS5_LP64_OFF64_LINTFLAGS _CS_XBS5_LP64_OFF64_LINTFLAGS _CS_XBS5_LPBIG_OFFBIG_CFLAGS, #define _CS_XBS5_LPBIG_OFFBIG_CFLAGS _CS_XBS5_LPBIG_OFFBIG_CFLAGS _CS_XBS5_LPBIG_OFFBIG_LDFLAGS, #define _CS_XBS5_LPBIG_OFFBIG_LDFLAGS _CS_XBS5_LPBIG_OFFBIG_LDFLAGS _CS_XBS5_LPBIG_OFFBIG_LIBS, #define _CS_XBS5_LPBIG_OFFBIG_LIBS _CS_XBS5_LPBIG_OFFBIG_LIBS _CS_XBS5_LPBIG_OFFBIG_LINTFLAGS, #define _CS_XBS5_LPBIG_OFFBIG_LINTFLAGS _CS_XBS5_LPBIG_OFFBIG_LINTFLAGS _CS_POSIX_V6_ILP32_OFF32_CFLAGS, #define _CS_POSIX_V6_ILP32_OFF32_CFLAGS _CS_POSIX_V6_ILP32_OFF32_CFLAGS _CS_POSIX_V6_ILP32_OFF32_LDFLAGS, #define _CS_POSIX_V6_ILP32_OFF32_LDFLAGS _CS_POSIX_V6_ILP32_OFF32_LDFLAGS _CS_POSIX_V6_ILP32_OFF32_LIBS, #define _CS_POSIX_V6_ILP32_OFF32_LIBS _CS_POSIX_V6_ILP32_OFF32_LIBS _CS_POSIX_V6_ILP32_OFF32_LINTFLAGS, #define _CS_POSIX_V6_ILP32_OFF32_LINTFLAGS _CS_POSIX_V6_ILP32_OFF32_LINTFLAGS _CS_POSIX_V6_ILP32_OFFBIG_CFLAGS, #define _CS_POSIX_V6_ILP32_OFFBIG_CFLAGS _CS_POSIX_V6_ILP32_OFFBIG_CFLAGS _CS_POSIX_V6_ILP32_OFFBIG_LDFLAGS, #define _CS_POSIX_V6_ILP32_OFFBIG_LDFLAGS _CS_POSIX_V6_ILP32_OFFBIG_LDFLAGS _CS_POSIX_V6_ILP32_OFFBIG_LIBS, #define _CS_POSIX_V6_ILP32_OFFBIG_LIBS _CS_POSIX_V6_ILP32_OFFBIG_LIBS _CS_POSIX_V6_ILP32_OFFBIG_LINTFLAGS, #define _CS_POSIX_V6_ILP32_OFFBIG_LINTFLAGS _CS_POSIX_V6_ILP32_OFFBIG_LINTFLAGS _CS_POSIX_V6_LP64_OFF64_CFLAGS, #define _CS_POSIX_V6_LP64_OFF64_CFLAGS _CS_POSIX_V6_LP64_OFF64_CFLAGS _CS_POSIX_V6_LP64_OFF64_LDFLAGS, #define _CS_POSIX_V6_LP64_OFF64_LDFLAGS _CS_POSIX_V6_LP64_OFF64_LDFLAGS _CS_POSIX_V6_LP64_OFF64_LIBS, #define _CS_POSIX_V6_LP64_OFF64_LIBS _CS_POSIX_V6_LP64_OFF64_LIBS _CS_POSIX_V6_LP64_OFF64_LINTFLAGS, #define _CS_POSIX_V6_LP64_OFF64_LINTFLAGS _CS_POSIX_V6_LP64_OFF64_LINTFLAGS _CS_POSIX_V6_LPBIG_OFFBIG_CFLAGS, #define _CS_POSIX_V6_LPBIG_OFFBIG_CFLAGS _CS_POSIX_V6_LPBIG_OFFBIG_CFLAGS _CS_POSIX_V6_LPBIG_OFFBIG_LDFLAGS, #define _CS_POSIX_V6_LPBIG_OFFBIG_LDFLAGS _CS_POSIX_V6_LPBIG_OFFBIG_LDFLAGS _CS_POSIX_V6_LPBIG_OFFBIG_LIBS, #define _CS_POSIX_V6_LPBIG_OFFBIG_LIBS _CS_POSIX_V6_LPBIG_OFFBIG_LIBS _CS_POSIX_V6_LPBIG_OFFBIG_LINTFLAGS, #define _CS_POSIX_V6_LPBIG_OFFBIG_LINTFLAGS _CS_POSIX_V6_LPBIG_OFFBIG_LINTFLAGS _CS_POSIX_V7_ILP32_OFF32_CFLAGS, #define _CS_POSIX_V7_ILP32_OFF32_CFLAGS _CS_POSIX_V7_ILP32_OFF32_CFLAGS _CS_POSIX_V7_ILP32_OFF32_LDFLAGS, #define _CS_POSIX_V7_ILP32_OFF32_LDFLAGS _CS_POSIX_V7_ILP32_OFF32_LDFLAGS _CS_POSIX_V7_ILP32_OFF32_LIBS, #define _CS_POSIX_V7_ILP32_OFF32_LIBS _CS_POSIX_V7_ILP32_OFF32_LIBS _CS_POSIX_V7_ILP32_OFF32_LINTFLAGS, #define _CS_POSIX_V7_ILP32_OFF32_LINTFLAGS _CS_POSIX_V7_ILP32_OFF32_LINTFLAGS _CS_POSIX_V7_ILP32_OFFBIG_CFLAGS, #define _CS_POSIX_V7_ILP32_OFFBIG_CFLAGS _CS_POSIX_V7_ILP32_OFFBIG_CFLAGS _CS_POSIX_V7_ILP32_OFFBIG_LDFLAGS, #define _CS_POSIX_V7_ILP32_OFFBIG_LDFLAGS _CS_POSIX_V7_ILP32_OFFBIG_LDFLAGS _CS_POSIX_V7_ILP32_OFFBIG_LIBS, #define _CS_POSIX_V7_ILP32_OFFBIG_LIBS _CS_POSIX_V7_ILP32_OFFBIG_LIBS _CS_POSIX_V7_ILP32_OFFBIG_LINTFLAGS, #define _CS_POSIX_V7_ILP32_OFFBIG_LINTFLAGS _CS_POSIX_V7_ILP32_OFFBIG_LINTFLAGS _CS_POSIX_V7_LP64_OFF64_CFLAGS, #define _CS_POSIX_V7_LP64_OFF64_CFLAGS _CS_POSIX_V7_LP64_OFF64_CFLAGS _CS_POSIX_V7_LP64_OFF64_LDFLAGS, #define _CS_POSIX_V7_LP64_OFF64_LDFLAGS _CS_POSIX_V7_LP64_OFF64_LDFLAGS _CS_POSIX_V7_LP64_OFF64_LIBS, #define _CS_POSIX_V7_LP64_OFF64_LIBS _CS_POSIX_V7_LP64_OFF64_LIBS _CS_POSIX_V7_LP64_OFF64_LINTFLAGS, #define _CS_POSIX_V7_LP64_OFF64_LINTFLAGS _CS_POSIX_V7_LP64_OFF64_LINTFLAGS _CS_POSIX_V7_LPBIG_OFFBIG_CFLAGS, #define _CS_POSIX_V7_LPBIG_OFFBIG_CFLAGS _CS_POSIX_V7_LPBIG_OFFBIG_CFLAGS _CS_POSIX_V7_LPBIG_OFFBIG_LDFLAGS, #define _CS_POSIX_V7_LPBIG_OFFBIG_LDFLAGS _CS_POSIX_V7_LPBIG_OFFBIG_LDFLAGS _CS_POSIX_V7_LPBIG_OFFBIG_LIBS, #define _CS_POSIX_V7_LPBIG_OFFBIG_LIBS _CS_POSIX_V7_LPBIG_OFFBIG_LIBS _CS_POSIX_V7_LPBIG_OFFBIG_LINTFLAGS, #define _CS_POSIX_V7_LPBIG_OFFBIG_LINTFLAGS _CS_POSIX_V7_LPBIG_OFFBIG_LINTFLAGS _CS_V6_ENV, #define _CS_V6_ENV _CS_V6_ENV _CS_V7_ENV #define _CS_V7_ENV _CS_V7_ENV }; int access(const char *, int); unsigned int alarm(unsigned int); int brk(void *); int chdir(const char *path); int chroot(const char *path); int chown(const char *, uid_t, gid_t); int close(int); size_t confstr(int, char *, size_t); char *crypt(const char *, const char *); char *ctermid(char *); char *cuserid(char *s); int dup(int); int dup2(int, int); void encrypt(char[64], int); int execl(const char *, const char *, ...); int execle(const char *, const char *, ...); int execlp(const char *, const char *, ...); int execv(const char *, char *const []); int execve(const char *, char *const [], char *const []); int execvp(const char *, char *const []); void _exit(int); int fchown(int, uid_t, gid_t); int fchdir(int); int fdatasync(int); pid_t fork(void); long int fpathconf(int, int); int fsync(int); int ftruncate(int, off_t); char *getcwd(char *, size_t); int getdtablesize(void); gid_t getegid(void); uid_t geteuid(void); gid_t getgid(void); int getgroups(int, gid_t []); long gethostid(void); int gethostname(char *, size_t); char *getlogin(void); int getlogin_r(char *, size_t); extern char *optarg; extern int optind, opterr, optopt; /*@ assigns \result \from argc, *argv[0..argc],options[0..]; */ int getopt(int argc, char * const argv[], const char *options); int getpagesize(void); char *getpass(const char *); pid_t getpgid(pid_t); pid_t getpgrp(void); pid_t getpid(void); pid_t getppid(void); pid_t getsid(pid_t); uid_t getuid(void); char *getwd(char *); int isatty(int); int lchown(const char *, uid_t, gid_t); int link(const char *, const char *); int lockf(int, int, off_t); off_t lseek(int, off_t, int); int nice(int); long int pathconf(const char *, int); int pause(void); int pipe(int [2]); ssize_t pread(int, void *, size_t, off_t); int pthread_atfork(void (*)(void), void (*)(void), void(*)(void)); ssize_t pwrite(int, const void *, size_t, off_t); ssize_t read(int, void *, size_t); int readlink(const char *, char *, size_t); int rmdir(const char *); void *sbrk(intptr_t); int setegid(gid_t gid); int seteuid(uid_t uid); int setgid(gid_t); int setpgid(pid_t, pid_t); pid_t setpgrp(void); int setregid(gid_t, gid_t); int setreuid(uid_t, uid_t); pid_t setsid(void); int setuid(uid_t uid); unsigned int sleep(unsigned int); void swab(const void *, void *, ssize_t); int symlink(const char *, const char *); void sync(void); long int sysconf(int); pid_t tcgetpgrp(int); int tcsetpgrp(int, pid_t); int truncate(const char *, off_t); char *ttyname(int); int ttyname_r(int, char *, size_t); useconds_t ualarm(useconds_t, useconds_t); int unlink(const char *); int usleep(useconds_t); pid_t vfork(void); ssize_t write(int, const void *, size_t); #endif frama-c-Fluorine-20130601/share/libc/tgmath.c0000644000175000017500000000174512155630243017450 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* ISO C: 7.22 */ //tgmath.h not supported yet //#include "tgmath.h" frama-c-Fluorine-20130601/share/libc/libintl.h0000644000175000017500000000321312155630243017616 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_LIBINTL_H #define __FC_LIBINTL_H #endif frama-c-Fluorine-20130601/share/libc/setjmp.h0000644000175000017500000000350112155630243017463 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_SETJMP #define __FC_SETJMP typedef char jmp_buf[5]; /*@ assigns env[0..5]; */ int setjmp(jmp_buf env); /*@ terminates \false; // Unsupported anyway... assigns \nothing ; */ void longjmp(jmp_buf env, int val); #endif frama-c-Fluorine-20130601/share/libc/complex.h0000644000175000017500000000333412155630243017634 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* ISO C: 7.3 */ #ifndef __FC_COMPLEX #define __FC_COMPLEX #ifndef __FC_REG_TEST #error "Frama-C: unsupported complex.h" #endif #endif frama-c-Fluorine-20130601/share/libc/syslog.c0000644000175000017500000000166412155630243017504 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "syslog.h" frama-c-Fluorine-20130601/share/libc/__fc_define_iovec.h0000644000175000017500000000335212155630243021552 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_IOVEC #define __FC_DEFINE_IOVEC #include "__fc_define_size_t.h" struct iovec { void *iov_base; size_t iov_len; }; #endif frama-c-Fluorine-20130601/share/libc/math.c0000644000175000017500000000241512155630243017110 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* ISO C: 7.12 */ #include "math.h" double Frama_C_exp(double x); double exp(double x){ return Frama_C_exp(x); } double Frama_C_cos(double x); double cos(double x){ return Frama_C_cos(x); } double Frama_C_sin(double x); double sin(double x){ return Frama_C_sin(x); } double fabs(double x){ if(x==0.0) return 0.0; if (x>0.0) return x; return -x; } frama-c-Fluorine-20130601/share/libc/stddef.c0000644000175000017500000000166712155630243017440 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* Empty on purpose */ frama-c-Fluorine-20130601/share/libc/__fc_define_blkcnt_t.h0000644000175000017500000000326712155630243022252 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_BLKCNT_T #define __FC_DEFINE_BLKCNT_T typedef unsigned int blkcnt_t; #endif frama-c-Fluorine-20130601/share/libc/ctype.c0000644000175000017500000000446112155630243017306 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "ctype.h" #include "__fc_builtin.h" #define ISDIGIT(_c) \ ((_c) >= '0' && (_c) <= '9') #define ISXDIGIT(_c) \ (ISDIGIT(_c) || \ ((_c) >= 'a' && (_c) <= 'f') || \ ((_c) >= 'A' && (_c) <= 'F')) // if locale = "C" #define ISLOWER(_c) \ ((_c) >= 'a' && (_c) <= 'z') // if locale = "C" #define ISUPPER(_c) \ ((_c) >= 'A' && (_c) <= 'Z') #define ISALPHA(_c) \ (ISUPPER(_c) || \ ISLOWER(_c)) #define ISALNUM(_c) \ (ISALPHA(_c) || \ ISDIGIT(_c)) // if locale = "C" #define ISSPACE(_c) \ ((_c) == ' ' || \ (_c) == '\f' || \ (_c) == '\n' || \ (_c) == '\r' || \ (_c) == '\t' || \ (_c) == '\v' ) // if locale = "C" #define ISBLANK(_c) \ ((_c) == ' ' || \ (_c) == '\t') int isalnum(int c) { return (ISALNUM(c)); } int isalpha(int c){ return (ISALPHA(c)); } int isblank(int c){ return (ISBLANK(c)||ISSPACE(c)); } int iscntrl(int c) { return (Frama_C_nondet(0,1)); } int isdigit(int c) { return (ISDIGIT(c)); } int isgraph(int c) { return (Frama_C_nondet(0,1)); } int islower(int c) { return (ISLOWER(c)); } int isprint(int c) { return (Frama_C_nondet(0,1)); } int ispunct(int c) { return (Frama_C_nondet(0,1)); } int isspace(int c) { return (ISSPACE(c)); } int isupper(int c) { return (ISUPPER(c)); } int isxdigit(int c) { return (ISXDIGIT(c)); } int tolower(int c) { return (Frama_C_interval(0,255)); } int toupper(int c) { return (Frama_C_interval(0,255)); } frama-c-Fluorine-20130601/share/libc/__fc_define_seek_macros.h0000644000175000017500000000355612155630243022746 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_SEEK_MACROS #define __FC_DEFINE_SEEK_MACROS /* Values for the WHENCE argument to lseek. */ # define SEEK_SET 0 /* Seek from beginning of file. */ # define SEEK_CUR 1 /* Seek from current position. */ # define SEEK_END 2 /* Seek from end of file. */ #endif frama-c-Fluorine-20130601/share/libc/stdlib.c0000644000175000017500000001753712155630243017453 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* ISO C: 7.20 */ #include "stdlib.h" #include "__fc_builtin.h" /* This file is part of the Frama-C framework. It must be included in all files calling malloc of free as it defines macros. 4 different implementation are available: you should define one of these: FRAMA_C_MALLOC_STACK FRAMA_C_MALLOC_HEAP FRAMA_C_MALLOC_CHUNKS FRAMA_C_MALLOC_INDIVIDUAL FRAMA_C_MALLOC_POSITION to select the proper one. */ /* define a safe default if nothing is selected */ #ifndef FRAMA_C_MALLOC_INFINITE #ifndef FRAMA_C_MALLOC_CHUNKS #ifndef FRAMA_C_MALLOC_INDIVIDUAL #ifndef FRAMA_C_MALLOC_POSITION #ifndef FRAMA_C_MALLOC_HEAP #define FRAMA_C_MALLOC_STACK #endif #endif #endif #endif #endif /* Size of mallocable memory in bytes. Some implementations may not limit the memory size. */ #ifndef MEMORY_SIZE # define MEMORY_SIZE (1<<10) #endif #ifdef FRAMA_C_MALLOC_POSITION /* malloc is always safe and may return NULL. free() problems are checked heuristically. Two calls at different lines in a given file return separated zones. Drawback : successive malloc inside a loop are not separated. */ #define FRAMA_C_VALID 1 #define FRAMA_C_FREED 2 void * Frama_C_alloc_infinite(void*base,...); void *__Frama_C_malloc_at_pos(size_t size,const char* file) { static counter = 0; counter++; char *base = Frama_C_alloc_infinite(file); char *tag = Frama_C_alloc_infinite(base); size_t *next_free = Frama_C_alloc_infinite(tag); size_t index = *next_free; if (index+size>=MEMORY_SIZE) return NULL; *next_free += size; tag[index] = FRAMA_C_VALID; return base+index; } void __Frama_C_free_at_pos(void *ptr, const char* pos) { if (ptr==NULL) { Frama_C_show_each_warning(pos); Frama_C_show_each_warning("potential free of NULL"); return;} char *tag = Frama_C_alloc_infinite(ptr); tag += Frama_C_offset(ptr); if (*tag != FRAMA_C_VALID) if (*tag == FRAMA_C_FREED) { Frama_C_show_each_warning (pos); Frama_C_show_each_warning("potential double free"); Frama_C_abort(); } else { Frama_C_show_each_warning(pos); Frama_C_show_each_warning("potential invalid adress"); Frama_C_abort(); } else { *tag = FRAMA_C_FREED;} } #else #ifdef FRAMA_C_MALLOC_HEAP /* malloc is always safe and may return NULL. free() does not check anything. All calls to malloc return offsets inside the same memory zone. Drawback : malloc pointers are not separated. */ char MEMORY[MEMORY_SIZE]; void *malloc(size_t size) { static int next_free = 0; next_free += size; if (next_free>=MEMORY_SIZE) return NULL; return (MEMORY+(next_free-size)); } void free(void*p) { return; } #else #ifdef FRAMA_C_MALLOC_INDIVIDUAL /* This malloc must not be used if the analyzer cannot determine that there is only a finite number of calls to malloc. It checks for out-of-bound accesses to malloc'ed blocks. It does not check free() problems. Each call to malloc is separated from the others. This might create too many different bases. */ void *Frama_C_alloc_size(size_t size); void *malloc(size_t size) { return Frama_C_alloc_size(size); } void free(void*) { return; } #else #ifdef FRAMA_C_MALLOC_CHUNKS #define FRAMA_C_CHUNK_LENGTH 2000 void * Frama_C_alloc_infinite(void*base,...); /* This malloc must not be used if the analyzer cannot determine that there is only a finite number of calls to malloc. It does not check free() problems. Memory is allocated in separated chunks of memory of size CHUNK_LENGTH. */ void *malloc(size_t size) { static char* base= (char*)0; static int next_free = 0; void *addr; if (!base) base=Frama_C_alloc_infinite("MEMORY"); if (next_free >= FRAMA_C_CHUNK_LENGTH) { next_free = 0; base = Frama_C_alloc_infinite(base); } addr = (void*) (base + next_free); next_free += size; return addr; } void free(void*) { return; } #else #ifdef FRAMA_C_MALLOC_INFINITE void * Frama_C_alloc_infinite(void*base,...); /* This malloc must not be used if the analyzer cannot determine that there is only a finite number of calls to malloc. It does not take into account the size and therefore does not checks for out-of-bound accesses to malloc'ed blocks. It does not check free() problems. Each call to malloc is separated from the others. This might create too many different zones. */ void *malloc(size_t size) { static char* const base="M"; #ifdef FRAMA_C_MALLOC_DEBUG CEA_F("Called malloc", base); #endif return base = Frama_C_alloc_infinite(base); } void free(void*) { return; } #else #ifdef FRAMA_C_MALLOC_STACK /* malloc is always safe and may return NULL. free() problems are checked heuristically. Two calls from different call stacks return separated zones. Drawback : successive malloc with the exact same call stack are not separated. */ #define FRAMA_C_VALID 1 #define FRAMA_C_FREED 2 void * Frama_C_alloc_by_stack(size_t size); void * Frama_C_alloc_infinite(void*base,...); void Frama_C_free(void*base); void * Frama_C_alloc_infinite_zero(void*base,...); void *malloc(size_t size) { char *base = Frama_C_alloc_by_stack(MEMORY_SIZE); char *tag = Frama_C_alloc_infinite_zero(base,MEMORY_SIZE); size_t *next_free = Frama_C_alloc_infinite_zero(tag,sizeof(size_t)); size_t index = *next_free; if (index+(unsigned long long)size>(unsigned long long)MEMORY_SIZE) { Frama_C_show_each_malloc("Cannot allocate memory at '", base, "'. Next free is '", *next_free, "' . Required size was '", size,"'."); return NULL;} *next_free += size; tag[index] = FRAMA_C_VALID; return base+index; } void free(void *p) { if (p==NULL) { Frama_C_show_each_warning("potential free of NULL"); return;} char *tag = Frama_C_alloc_infinite(p); tag += Frama_C_offset(p); if (*tag != FRAMA_C_VALID) if (*tag == FRAMA_C_FREED) { Frama_C_show_each_warning("potential double free"); Frama_C_abort(); } else { Frama_C_show_each_warning("potential free of invalid adress"); Frama_C_abort(); } else { *tag = FRAMA_C_FREED; /*Frama_C_free(p,size);*/ } } #else #error Please define one of: FRAMA_C_MALLOC_HEAP FRAMA_C_MALLOC_INFINITE\ FRAMA_C_MALLOC_CHUNKS\ FRAMA_C_MALLOC_INDIVIDUAL\ FRAMA_C_MALLOC_POSITION. #endif // FRAMA_C_MALLOC_STACK #endif // FRAMA_C_MALLOC_INFINITE #endif // FRAMA_C_MALLOC_CHUNKS #endif // FRAMA_C_MALLOC_INDIVIDUAL #endif // FRAMA_C_MALLOC_HEAP #endif // FRAMA_C_MALLOC_POSITION #if 0 void main0(void) { int *x = malloc((sizeof(int))); *x = 12; free(x); free(x); } void main1(void) { int *x; CEA_F(x); free(x); } void main2(void) { int x; CEA_F(x); free(&x); } void main3(void) { free((void*)0); } void main4(void) { int * x = Frama_C_alloc_infinite("toto"); int * y = Frama_C_alloc_infinite("toto"); } int G; void main5(void) { int *x[5]; for(int i=0; i<=4; i++) { x[i] = (int*)malloc(4);} free(x[2]); for(int i=0; i<=4; i++) { *x[i] = i; } } #endif frama-c-Fluorine-20130601/share/libc/__fc_define_fd_set_t.h0000644000175000017500000000374612155630243022243 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_FD_SET_T #define __FC_DEFINE_FD_SET_T typedef struct {char __fc_fd_set;} fd_set; //@ assigns *fdset \from *fdset, fd; void FD_CLR(int fd, fd_set *fdset); //@ assigns \nothing ; int FD_ISSET(int fd, fd_set *fdset); //@ assigns *fdset \from *fdset, fd; void FD_SET(int fd, fd_set *fdset); //@ assigns *fdset \from \nothing; void FD_ZERO(fd_set *fdset); #define FD_SETSIZE 255 #endif frama-c-Fluorine-20130601/share/libc/__fc_define_mode_t.h0000644000175000017500000000527612155630243021723 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_MODE_T #define __FC_DEFINE_MODE_T typedef unsigned int mode_t; /* POSIX symbolic values */ #define S_IFMT (1<<1) #define S_IFBLK (1<<2) #define S_IFCHR (1<<3) #define S_IFIFO (1<<4) #define S_IFREG (1<<5) #define S_IFDIR (1<<6) #define S_IFLNK (1<<7) #define S_IFSOCK (1<<8) #define S_IRWXU (S_IRUSR|S_IWUSR|S_IXUSR) #define S_IRUSR (1<<9) #define S_IWUSR (1<<10) #define S_IXUSR (1<<11) #define S_IRWXG (S_IRGRP|S_IWGRP|S_IXGRP) #define S_IRGRP (1<<12) #define S_IWGRP (1<<13) #define S_IXGRP (1<<14) #define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH) #define S_IROTH (1<<15) #define S_IWOTH (1<<16) #define S_IXOTH (1<<17) #define S_ISUID (1<<18) #define S_ISGID (1<<19) #define S_ISVTX (1<<20) #define S_IEXEC S_IXUSR #define S_IWRITE S_IWUSR #define S_IREAD S_IRUSR #define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) #define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) #define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) #define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) #define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) #define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) #endif frama-c-Fluorine-20130601/share/libc/fenv.c0000644000175000017500000000174112155630243017116 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* ISO C: 7.6 */ // fenv.h not supported yet //#include "fenv.h" frama-c-Fluorine-20130601/share/libc/ctype.h0000644000175000017500000000474312155630243017316 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_CTYPE #define __FC_CTYPE /* ISO C : 7.4.1 */ /*@ assigns \result \from c ; */ int isalnum(int c); /*@ assigns \result \from c ; */ int isalpha(int c); /*@ assigns \result \from c ; */ int isblank(int c); /*@ assigns \result \from c ; */ int iscntrl(int c); /*@ assigns \result \from c ; */ int isdigit(int c); /*@ assigns \result \from c ; */ int isgraph(int c); /*@ assigns \result \from c ; */ int islower(int c); /*@ assigns \result \from c ; */ int isprint(int c); /*@ assigns \result \from c ; */ int ispunct(int c); /*@ assigns \result \from c ; */ int isspace(int c); /*@ assigns \result \from c ; */ int isupper(int c); /*@ assigns \result \from c ; */ int isxdigit(int c); /* ISO C : 7.4.2 */ /*@ assigns \result \from c ; */ int tolower(int c); /*@ assigns \result \from c ; */ int toupper(int c); /* POSIX */ /*@ assigns \result \from c ; */ int isascii(int c); #endif frama-c-Fluorine-20130601/share/libc/__fc_define_intptr_t.h0000644000175000017500000000335112155630243022307 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_INTPTR_T #define __FC_DEFINE_INTPTR_T #include "__fc_machdep.h" #ifdef __INTPTR_T typedef __INTPTR_T intptr_t; #endif #endif frama-c-Fluorine-20130601/share/libc/__fc_define_null.h0000644000175000017500000000326312155630243021420 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_NULL #define __FC_DEFINE_NULL #undef NULL #define NULL ((void*)0) #endif frama-c-Fluorine-20130601/share/libc/__fc_define_nlink_t.h0000644000175000017500000000326312155630243022104 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_NLINK_T #define __FC_DEFINE_NLINK_T typedef unsigned int nlink_t; #endif frama-c-Fluorine-20130601/share/libc/__fc_machdep.h0000644000175000017500000000614212155630243020534 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_MACHDEP #define __FC_MACHDEP #ifndef __FC_MACHDEP_X86_64 #define __FC_MACHDEP_X86_32 #endif #ifdef __FC_MACHDEP_X86_32 #define __FC_FORCE_INCLUDE_MACHDEP__ #include "__fc_machdep_linux_gcc_shared.h" #undef __FC_FORCE_INCLUDE_MACHDEP__ /* Required */ #undef __CHAR_UNSIGNED__ #define __WORDSIZE 32 #define __SIZEOF_SHORT 2 #define __SIZEOF_INT 4 #define __SIZEOF_LONG 4 #define __SIZEOF_LONGLONG 8 #define __CHAR_BIT 8 #define __SIZE_T unsigned int #define __PTRDIFF_T int #define __FC_LONG_MAX 2147483647L #define __FC_ULONG_MAX 4294967295UL /* Optional */ #define __INTPTR_T signed int #define __UINTPTR_T unsigned int /* POSIX */ #define __SSIZE_T int /* stdint.h */ #define __FC_PTRDIFF_MIN __FC_INT_MIN #define __FC_PTRDIFF_MAX __FC_INT_MAX #else #ifdef __FC_MACHDEP_X86_64 #define __FC_FORCE_INCLUDE_MACHDEP__ #include "__fc_machdep_linux_gcc_shared.h" #undef __FC_FORCE_INCLUDE_MACHDEP__ /* Required */ #undef __CHAR_UNSIGNED__ #define __WORDSIZE 64 #define __SIZEOF_SHORT 2 #define __SIZEOF_INT 4 #define __SIZEOF_LONG 8 #define __SIZEOF_LONGLONG 8 #define __CHAR_BIT 8 #define __SIZE_T unsigned long #define __PTRDIFF_T long #define __FC_LONG_MAX 9223372036854775807L #define __FC_ULONG_MAX 18446744073709551615UL /* Optional */ #define __INTPTR_T signed long #define __UINTPTR_T unsigned long /* POSIX */ #define __SSIZE_T signed long /* stdint.h */ #define __FC_PTRDIFF_MIN __FC_LONG_MIN #define __FC_PTRDIFF_MAX __FC_LONG_MAX #else #error Must define __FC_MACHDEP_X86_32 or __FC_MACHDEP_X86_64. #endif #endif #endif frama-c-Fluorine-20130601/share/libc/dirent.c0000644000175000017500000000252612155630243017447 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "dirent.h" #include "string.h" static struct dirent __fc_directories[]= { {1,1,1,1,"foo"}, {2,2,2,2,"bar"}, 0 }; static DIR __fc_opendir_result; DIR *opendir(const char *path){ int dir_id=0; while(__fc_directories[dir_id].d_ino!=0) { if (strcmp(path,__fc_directories[dir_id].d_name)==0) {__fc_opendir_result.__fc_dir_contents = dir_id; return &__fc_opendir_result;} dir_id++; } return NULL; } frama-c-Fluorine-20130601/share/libc/dlfcn.h0000644000175000017500000000351512155630243017254 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DLFCN_H #define __FC_DLFCN_H #define RTLD_LAZY 1 #define RTLD_NOW 2 #define RTLD_GLOBAL 3 #define RTLD_LOCAL 4 void *dlopen(const char *, int); void *dlsym(void *, const char *); int dlclose(void *); char *dlerror(void); #endif frama-c-Fluorine-20130601/share/libc/dirent.h0000644000175000017500000000661612155630243017460 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DIRENT_H #define __FC_DIRENT_H typedef struct __FC_DIR_T { unsigned int __fc_dir_contents; } DIR; #include "__fc_define_ino_t.h" struct dirent { ino_t d_ino; /* inode number */ off_t d_off; /* offset to the next dirent */ unsigned short d_reclen; /* length of this record */ unsigned char d_type; /* type of file; not supported by all file system types */ char d_name[256]; /* filename */ }; int alphasort(const struct dirent **, const struct dirent **); int closedir(DIR *); int dirfd(DIR *); DIR *fdopendir(int); /*@ assigns \result \from path[0..]; */ DIR *opendir(const char *path); /*@ assigns \result \from *DIR; assigns *DIR \from *DIR; */ struct dirent *readdir(DIR *DIR); int readdir_r(DIR * dirp, struct dirent * entry, struct dirent ** result); void rewinddir(DIR *); int scandir(const char *, struct dirent ***, int (*)(const struct dirent *), int (*)(const struct dirent **, const struct dirent **)); void seekdir(DIR *, long); long telldir(DIR *); /* File types for `d_type'. */ enum { DT_UNKNOWN = 0, # define DT_UNKNOWN DT_UNKNOWN DT_FIFO = 1, # define DT_FIFO DT_FIFO DT_CHR = 2, # define DT_CHR DT_CHR DT_DIR = 4, # define DT_DIR DT_DIR DT_BLK = 6, # define DT_BLK DT_BLK DT_REG = 8, # define DT_REG DT_REG DT_LNK = 10, # define DT_LNK DT_LNK DT_SOCK = 12, # define DT_SOCK DT_SOCK DT_WHT = 14 # define DT_WHT DT_WHT }; /* Convert between stat structure types and directory types. */ # define IFTODT(mode) (((mode) & 0170000) >> 12) # define DTTOIF(dirtype) ((dirtype) << 12) #endif frama-c-Fluorine-20130601/share/libc/__fc_define_useconds_t.h0000644000175000017500000000327412155630243022616 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_USECONDS_T #define __FC_DEFINE_USECONDS_T typedef unsigned int useconds_t; #endif frama-c-Fluorine-20130601/share/libc/wchar.c0000644000175000017500000000174412155630243017267 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* ISO C: 7.25 */ //wchar.h not supported yet // #include "wchar.h" frama-c-Fluorine-20130601/share/libc/fcntl.h0000644000175000017500000001137712155630243017301 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_FCNTL #define __FC_FCNTL #include "__fc_define_off_t.h" #include "__fc_define_pid_t.h" #include "__fc_define_mode_t.h" /* For posix fcntl() and `l_type' field of a `struct flock' for lockf(). */ #define F_RDLCK 0 /* Read lock. */ #define F_WRLCK 1 /* Write lock. */ #define F_UNLCK 2 /* Remove lock. */ /* For old implementation of bsd flock(). */ #define F_EXLCK 4 /* or 3 */ #define F_SHLCK 8 /* or 4 */ struct flock { short int l_type; /* Type of lock: F_RDLCK, F_WRLCK, or F_UNLCK. */ short int l_whence; /* Where `l_start' is relative to (like `lseek'). */ off_t l_start; /* Offset where the lock begins. */ off_t l_len; /* Size of the locked area; zero means until EOF. */ pid_t l_pid; /* Process holding the lock. */ }; #define F_DUPFD 1 #define F_GETFD 2 #define F_SETFD 3 #define F_GETFL 4 #define F_SETFL 5 #define F_GETLK 6 #define F_SETLK 7 #define F_SETLKW 8 #define F_GETOWN 9 #define F_SETOWN 10 #define FD_CLOEXEC 1 #include "__fc_define_seek_macros.h" # define AT_FDCWD -100 /* Special value used to indicate the *at functions should use the current working directory. */ # define AT_SYMLINK_NOFOLLOW 0x100 /* Do not follow symbolic links. */ # define AT_REMOVEDIR 0x200 /* Remove directory instead of unlinking file. */ # define AT_SYMLINK_FOLLOW 0x400 /* Follow symbolic links. */ # define AT_NO_AUTOMOUNT 0x800 /* Suppress terminal automount traversal. */ # define AT_EACCESS 0x200 /* Test access permitted for effective IDs, not real IDs. */ #define O_RDONLY 0x0000 /* open for reading only */ #define O_WRONLY 0x0001 /* open for writing only */ #define O_RDWR 0x0002 /* open for reading and writing */ #define O_ACCMODE 0x0003 /* mask for above modes */ #define O_NONBLOCK 0x0004 /* no delay */ #define O_APPEND 0x0008 /* set append mode */ #define O_CREAT 0x0200 /* create if nonexistent */ #define O_TRUNC 0x0400 /* truncate to zero length */ #define O_EXCL 0x0800 /* error if already exists */ #define O_NDELAY O_NONBLOCK #define O_SYNC 04010000 #define O_FSYNC O_SYNC #define O_ASYNC 020000 # define O_DIRECTORY 0200000 /* Must be a directory. */ # define O_NOFOLLOW 0400000 /* Do not follow links. */ # define O_CLOEXEC 02000000 /* Set close_on_exec. */ # define O_DIRECT 040000 /* Direct disk access. */ # define O_NOATIME 01000000 /* Do not set atime. */ /* Advise to `posix_fadvise'. */ # define POSIX_FADV_NORMAL 0 /* No further special treatment. */ # define POSIX_FADV_RANDOM 1 /* Expect random page references. */ # define POSIX_FADV_SEQUENTIAL 2 /* Expect sequential page references. */ # define POSIX_FADV_WILLNEED 3 /* Will need these pages. */ # define POSIX_FADV_DONTNEED 4 /* Don't need these pages. */ # define POSIX_FADV_NOREUSE 5 /* Data will be accessed once. */ /* Defined by POSIX 1003.1; BSD default, but must be distinct from O_RDONLY. */ #define O_NOCTTY 0x8000 /* don't assign controlling terminal */ /*@ assigns \result \from filename[0..], mode ; */ int creat(const char * filename, mode_t mode); int fcntl(int, int, ...); /*@ assigns \result \from filename[0..], mode ; */ int open(const char * filename, int mode, ...); #endif frama-c-Fluorine-20130601/share/libc/limits.c0000644000175000017500000000167012155630243017462 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* Empty on purpose */ frama-c-Fluorine-20130601/share/libc/__fc_define_suseconds_t.h0000644000175000017500000000327412155630243023001 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_SUSECONDS_T #define __FC_DEFINE_SUSECONDS_T typedef signed int suseconds_t; #endif frama-c-Fluorine-20130601/share/libc/__fc_define_ino_t.h0000644000175000017500000000325512155630243021557 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_INO_T #define __FC_DEFINE_INO_T typedef unsigned int ino_t; #endif frama-c-Fluorine-20130601/share/libc/inttypes.h0000644000175000017500000002060112155630243020040 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_INTTYPES #define __FC_INTTYPES /* ISO C: 7.8 */ #include "stdint.h" #include "errno.h" #include "__fc_define_restrict.h" /* ISO C: 7.8.1 */ # if __WORDSIZE == 64 # define __PRI64_PREFIX "l" # define __PRIPTR_PREFIX "l" # else # define __PRI64_PREFIX "ll" # define __PRIPTR_PREFIX # endif /* Macros for printing format specifiers. */ /* Decimal notation. */ # define PRId8 "d" # define PRId16 "d" # define PRId32 "d" # define PRId64 __PRI64_PREFIX "d" # define PRIdLEAST8 "d" # define PRIdLEAST16 "d" # define PRIdLEAST32 "d" # define PRIdLEAST64 __PRI64_PREFIX "d" # define PRIdFAST8 "d" # define PRIdFAST16 __PRIPTR_PREFIX "d" # define PRIdFAST32 __PRIPTR_PREFIX "d" # define PRIdFAST64 __PRI64_PREFIX "d" # define PRIi8 "i" # define PRIi16 "i" # define PRIi32 "i" # define PRIi64 __PRI64_PREFIX "i" # define PRIiLEAST8 "i" # define PRIiLEAST16 "i" # define PRIiLEAST32 "i" # define PRIiLEAST64 __PRI64_PREFIX "i" # define PRIiFAST8 "i" # define PRIiFAST16 __PRIPTR_PREFIX "i" # define PRIiFAST32 __PRIPTR_PREFIX "i" # define PRIiFAST64 __PRI64_PREFIX "i" /* Octal notation. */ # define PRIo8 "o" # define PRIo16 "o" # define PRIo32 "o" # define PRIo64 __PRI64_PREFIX "o" # define PRIoLEAST8 "o" # define PRIoLEAST16 "o" # define PRIoLEAST32 "o" # define PRIoLEAST64 __PRI64_PREFIX "o" # define PRIoFAST8 "o" # define PRIoFAST16 __PRIPTR_PREFIX "o" # define PRIoFAST32 __PRIPTR_PREFIX "o" # define PRIoFAST64 __PRI64_PREFIX "o" /* Unsigned integers. */ # define PRIu8 "u" # define PRIu16 "u" # define PRIu32 "u" # define PRIu64 __PRI64_PREFIX "u" # define PRIuLEAST8 "u" # define PRIuLEAST16 "u" # define PRIuLEAST32 "u" # define PRIuLEAST64 __PRI64_PREFIX "u" # define PRIuFAST8 "u" # define PRIuFAST16 __PRIPTR_PREFIX "u" # define PRIuFAST32 __PRIPTR_PREFIX "u" # define PRIuFAST64 __PRI64_PREFIX "u" /* lowercase hexadecimal notation. */ # define PRIx8 "x" # define PRIx16 "x" # define PRIx32 "x" # define PRIx64 __PRI64_PREFIX "x" # define PRIxLEAST8 "x" # define PRIxLEAST16 "x" # define PRIxLEAST32 "x" # define PRIxLEAST64 __PRI64_PREFIX "x" # define PRIxFAST8 "x" # define PRIxFAST16 __PRIPTR_PREFIX "x" # define PRIxFAST32 __PRIPTR_PREFIX "x" # define PRIxFAST64 __PRI64_PREFIX "x" /* UPPERCASE hexadecimal notation. */ # define PRIX8 "X" # define PRIX16 "X" # define PRIX32 "X" # define PRIX64 __PRI64_PREFIX "X" # define PRIXLEAST8 "X" # define PRIXLEAST16 "X" # define PRIXLEAST32 "X" # define PRIXLEAST64 __PRI64_PREFIX "X" # define PRIXFAST8 "X" # define PRIXFAST16 __PRIPTR_PREFIX "X" # define PRIXFAST32 __PRIPTR_PREFIX "X" # define PRIXFAST64 __PRI64_PREFIX "X" /* Macros for printing `intmax_t' and `uintmax_t'. */ # define PRIdMAX __PRI64_PREFIX "d" # define PRIiMAX __PRI64_PREFIX "i" # define PRIoMAX __PRI64_PREFIX "o" # define PRIuMAX __PRI64_PREFIX "u" # define PRIxMAX __PRI64_PREFIX "x" # define PRIXMAX __PRI64_PREFIX "X" /* Macros for printing `intptr_t' and `uintptr_t'. */ # define PRIdPTR __PRIPTR_PREFIX "d" # define PRIiPTR __PRIPTR_PREFIX "i" # define PRIoPTR __PRIPTR_PREFIX "o" # define PRIuPTR __PRIPTR_PREFIX "u" # define PRIxPTR __PRIPTR_PREFIX "x" # define PRIXPTR __PRIPTR_PREFIX "X" /* Macros for scanning format specifiers. */ /* Signed decimal notation. */ # define SCNd8 "hhd" # define SCNd16 "hd" # define SCNd32 "d" # define SCNd64 __PRI64_PREFIX "d" # define SCNdLEAST8 "hhd" # define SCNdLEAST16 "hd" # define SCNdLEAST32 "d" # define SCNdLEAST64 __PRI64_PREFIX "d" # define SCNdFAST8 "hhd" # define SCNdFAST16 __PRIPTR_PREFIX "d" # define SCNdFAST32 __PRIPTR_PREFIX "d" # define SCNdFAST64 __PRI64_PREFIX "d" /* Signed decimal notation. */ # define SCNi8 "hhi" # define SCNi16 "hi" # define SCNi32 "i" # define SCNi64 __PRI64_PREFIX "i" # define SCNiLEAST8 "hhi" # define SCNiLEAST16 "hi" # define SCNiLEAST32 "i" # define SCNiLEAST64 __PRI64_PREFIX "i" # define SCNiFAST8 "hhi" # define SCNiFAST16 __PRIPTR_PREFIX "i" # define SCNiFAST32 __PRIPTR_PREFIX "i" # define SCNiFAST64 __PRI64_PREFIX "i" /* Unsigned decimal notation. */ # define SCNu8 "hhu" # define SCNu16 "hu" # define SCNu32 "u" # define SCNu64 __PRI64_PREFIX "u" # define SCNuLEAST8 "hhu" # define SCNuLEAST16 "hu" # define SCNuLEAST32 "u" # define SCNuLEAST64 __PRI64_PREFIX "u" # define SCNuFAST8 "hhu" # define SCNuFAST16 __PRIPTR_PREFIX "u" # define SCNuFAST32 __PRIPTR_PREFIX "u" # define SCNuFAST64 __PRI64_PREFIX "u" /* Octal notation. */ # define SCNo8 "hho" # define SCNo16 "ho" # define SCNo32 "o" # define SCNo64 __PRI64_PREFIX "o" # define SCNoLEAST8 "hho" # define SCNoLEAST16 "ho" # define SCNoLEAST32 "o" # define SCNoLEAST64 __PRI64_PREFIX "o" # define SCNoFAST8 "hho" # define SCNoFAST16 __PRIPTR_PREFIX "o" # define SCNoFAST32 __PRIPTR_PREFIX "o" # define SCNoFAST64 __PRI64_PREFIX "o" /* Hexadecimal notation. */ # define SCNx8 "hhx" # define SCNx16 "hx" # define SCNx32 "x" # define SCNx64 __PRI64_PREFIX "x" # define SCNxLEAST8 "hhx" # define SCNxLEAST16 "hx" # define SCNxLEAST32 "x" # define SCNxLEAST64 __PRI64_PREFIX "x" # define SCNxFAST8 "hhx" # define SCNxFAST16 __PRIPTR_PREFIX "x" # define SCNxFAST32 __PRIPTR_PREFIX "x" # define SCNxFAST64 __PRI64_PREFIX "x" /* Macros for scanning `intmax_t' and `uintmax_t'. */ # define SCNdMAX __PRI64_PREFIX "d" # define SCNiMAX __PRI64_PREFIX "i" # define SCNoMAX __PRI64_PREFIX "o" # define SCNuMAX __PRI64_PREFIX "u" # define SCNxMAX __PRI64_PREFIX "x" /* Macros for scaning `intptr_t' and `uintptr_t'. */ # define SCNdPTR __PRIPTR_PREFIX "d" # define SCNiPTR __PRIPTR_PREFIX "i" # define SCNoPTR __PRIPTR_PREFIX "o" # define SCNuPTR __PRIPTR_PREFIX "u" # define SCNxPTR __PRIPTR_PREFIX "x" #if __WORDSIZE == 64 /* We have to define the `uintmax_t' type using `ldiv_t'. */ typedef struct { long int quot; /* Quotient. */ long int rem; /* Remainder. */ } imaxdiv_t; #else /* We have to define the `uintmax_t' type using `lldiv_t'. */ typedef struct { long long int quot; /* Quotient. */ long long int rem; /* Remainder. */ } imaxdiv_t; #endif /* ISO C: 7.8.2 */ /*@ requires (intmax_t)(-c) != c ; assigns \result \from c ; */ intmax_t imaxabs(intmax_t c); /*@ requires denom != 0; assigns \result \from numer, denom ; ensures \result.quot == numer / denom; ensures \result.rem == numer % denom; */ imaxdiv_t imaxdiv(intmax_t numer, intmax_t denom); #include "__fc_define_wchar_t.h" /*@ assigns \result \from nptr[..], base ; assigns endptr[..] \from nptr[..], base ; assigns __FC_errno \from nptr[..], base ; */ intmax_t strtoimax(const char * restrict nptr, char ** restrict endptr, int base); uintmax_t strtoumax(const char * restrict nptr, char ** restrict endptr, int base); intmax_t wcstoimax(const wchar_t * restrict nptr, wchar_t ** restrict endptr, int base); uintmax_t wcstoumax(const wchar_t * restrict nptr, wchar_t ** restrict endptr, int base); #endif frama-c-Fluorine-20130601/share/libc/fc_posix_runtime.c0000644000175000017500000000277412155630243021544 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "fc_runtime.c" #include "dirent.c" #include "fcntl.c" #include "ifaddrs.c" #include "pwd.c" #include "strings.c" #include "syslog.c" #include "termios.c" #include "unistd.c" #include "nl_types.c" #include "netdb.c" #include "grp.c" #include "dlfcn.c" #include "arpa/inet.c" #include "linux/fs.c" #include "net/if.c" #include "netinet/in.c" #include "sys/ioctl.c" #include "sys/param.c" #include "sys/resource.c" #include "sys/select.c" #include "sys/socket.c" #include "sys/time.c" #include "sys/un.c" #include "sys/uio.c" #include "sys/stat.c" #include "sys/types.c" #include "sys/wait.c" frama-c-Fluorine-20130601/share/libc/stddef.h0000644000175000017500000000353412155630243017440 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_STDDEF #define __FC_STDDEF #include "__fc_machdep.h" typedef __PTRDIFF_T ptrdiff_t; #include "__fc_define_size_t.h" #include "__fc_define_wchar_t.h" #include "__fc_define_null.h" #define offsetof(type, member) __builtin_offsetof(type,member) #endif frama-c-Fluorine-20130601/share/libc/__fc_define_dev_t.h0000644000175000017500000000325512155630243021550 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_DEV_T #define __FC_DEFINE_DEV_T typedef unsigned int dev_t; #endif frama-c-Fluorine-20130601/share/libc/__fc_define_wchar_t.h0000644000175000017500000000331112155630243022067 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_WCHAR_T #define __FC_DEFINE_WCHAR_T #include "__fc_machdep.h" typedef __WCHAR_T wchar_t; #endif frama-c-Fluorine-20130601/share/libc/ifaddrs.c0000644000175000017500000000166512155630243017601 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "ifaddrs.h" frama-c-Fluorine-20130601/share/libc/__fc_define_pid_t.h0000644000175000017500000000325612155630243021547 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_PID_T #define __FC_DEFINE_PID_T typedef unsigned int pid_t ; #endif frama-c-Fluorine-20130601/share/libc/stdarg.c0000644000175000017500000000171212155630243017442 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* ISO C: 7.15 */ /* Empty on purpose */ frama-c-Fluorine-20130601/share/libc/float.c0000644000175000017500000000166312155630243017270 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "float.h" frama-c-Fluorine-20130601/share/libc/__fc_define_sigset_t.h0000644000175000017500000000326712155630243022273 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_SIGSET_T #define __FC_DEFINE_SIGSET_T typedef unsigned long sigset_t; #endif frama-c-Fluorine-20130601/share/libc/__fc_define_sa_family_t.h0000644000175000017500000000330312155630243022730 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_SA_FAMILY_T #define __FC_DEFINE_SA_FAMILY_T typedef __UINT_LEAST16_T sa_family_t; #endif frama-c-Fluorine-20130601/share/libc/wchar.h0000644000175000017500000000323112155630243017265 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* ISO C: 7.25 */ #ifndef __FC_WCHAR_H #define __FC_WCHAR_H #endif frama-c-Fluorine-20130601/share/libc/net/0000755000175000017500000000000012155634040016576 5ustar mehdimehdiframa-c-Fluorine-20130601/share/libc/net/if.c0000644000175000017500000000166012155630243017344 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "if.h" frama-c-Fluorine-20130601/share/libc/net/if.h0000644000175000017500000001452312155630243017353 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef FC_NET_IF #define FC_NET_IF struct if_nameidx {unsigned if_index; char *if_name;}; #define IF_NAMESIZE 255 unsigned if_nametoindex(const char * name); char *if_indextoname(unsigned index, char *name); struct if_nameindex *if_nameindex(void); void if_freenameindex(struct if_nameindex *ni); #define IFF_UP 0x1 /* interface is up */ #define IFF_BROADCAST 0x2 /* broadcast address valid */ #define IFF_DEBUG 0x4 /* turn on debugging */ #define IFF_LOOPBACK 0x8 /* is a loopback net */ #define IFF_POINTOPOINT 0x10 /* interface is has p-p link */ #define IFF_NOTRAILERS 0x20 /* avoid use of trailers */ #define IFF_RUNNING 0x40 /* interface RFC2863 OPER_UP */ #define IFF_NOARP 0x80 /* no ARP protocol */ #define IFF_PROMISC 0x100 /* receive all packets */ #define IFF_ALLMULTI 0x200 /* receive all multicast packets*/ #define IFF_MASTER 0x400 /* master of a load balancer */ #define IFF_SLAVE 0x800 /* slave of a load balancer */ #define IFF_MULTICAST 0x1000 /* Supports multicast */ #define IFF_PORTSEL 0x2000 /* can set media type */ #define IFF_AUTOMEDIA 0x4000 /* auto media select active */ #define IFF_DYNAMIC 0x8000 /* dialup device with changing addresses*/ #define IFF_LOWER_UP 0x10000 /* driver signals L1 up */ #define IFF_DORMANT 0x20000 /* driver signals dormant */ #define IFF_ECHO 0x40000 /* echo sent packets */ #define IFF_VOLATILE (IFF_LOOPBACK|IFF_POINTOPOINT|IFF_BROADCAST|IFF_ECHO|\ IFF_MASTER|IFF_SLAVE|IFF_RUNNING|IFF_LOWER_UP|IFF_DORMANT) /* The ifaddr structure contains information about one address of an interface. They are maintained by the different address families, are allocated and attached when an address is set, and are linked together so all addresses for an interface can be located. */ struct ifaddr { struct sockaddr ifa_addr; /* Address of interface. */ union { struct sockaddr ifu_broadaddr; struct sockaddr ifu_dstaddr; } ifa_ifu; struct iface *ifa_ifp; /* Back-pointer to interface. */ struct ifaddr *ifa_next; /* Next address for interface. */ }; #if 0 /* NOTE: Conflicts with file ifaddrs.h */ # define ifa_broadaddr ifa_ifu.ifu_broadaddr /* broadcast address */ # define ifa_dstaddr ifa_ifu.ifu_dstaddr /* other end of link */ #endif /* Device mapping structure. I'd just gone off and designed a beautiful scheme using only loadable modules with arguments for driver options and along come the PCMCIA people 8) Ah well. The get() side of this is good for WDSETUP, and it'll be handy for debugging things. The set side is fine for now and being very small might be worth keeping for clean configuration. */ struct ifmap { unsigned long int mem_start; unsigned long int mem_end; unsigned short int base_addr; unsigned char irq; unsigned char dma; unsigned char port; /* 3 bytes spare */ }; /* Interface request structure used for socket ioctl's. All interface ioctl's must have parameter definitions which begin with ifr_name. The remainder may be interface specific. */ struct ifreq { # define IFHWADDRLEN 6 # define IFNAMSIZ IF_NAMESIZE union { char ifrn_name[IFNAMSIZ]; /* Interface name, e.g. "en0". */ } ifr_ifrn; union { struct sockaddr ifru_addr; struct sockaddr ifru_dstaddr; struct sockaddr ifru_broadaddr; struct sockaddr ifru_netmask; struct sockaddr ifru_hwaddr; short int ifru_flags; int ifru_ivalue; int ifru_mtu; struct ifmap ifru_map; char ifru_slave[IFNAMSIZ]; /* Just fits the size */ char ifru_newname[IFNAMSIZ]; char * ifru_data; } ifr_ifru; }; # define ifr_name ifr_ifrn.ifrn_name /* interface name */ # define ifr_hwaddr ifr_ifru.ifru_hwaddr /* MAC address */ # define ifr_addr ifr_ifru.ifru_addr /* address */ # define ifr_dstaddr ifr_ifru.ifru_dstaddr /* other end of p-p lnk */ # define ifr_broadaddr ifr_ifru.ifru_broadaddr /* broadcast address */ # define ifr_netmask ifr_ifru.ifru_netmask /* interface net mask */ # define ifr_flags ifr_ifru.ifru_flags /* flags */ # define ifr_metric ifr_ifru.ifru_ivalue /* metric */ # define ifr_mtu ifr_ifru.ifru_mtu /* mtu */ # define ifr_map ifr_ifru.ifru_map /* device map */ # define ifr_slave ifr_ifru.ifru_slave /* slave device */ # define ifr_data ifr_ifru.ifru_data /* for use by interface */ # define ifr_ifindex ifr_ifru.ifru_ivalue /* interface index */ # define ifr_bandwidth ifr_ifru.ifru_ivalue /* link bandwidth */ # define ifr_qlen ifr_ifru.ifru_ivalue /* queue length */ # define ifr_newname ifr_ifru.ifru_newname /* New name */ # define _IOT_ifreq _IOT(_IOTS(char),IFNAMSIZ,_IOTS(char),16,0,0) # define _IOT_ifreq_short _IOT(_IOTS(char),IFNAMSIZ,_IOTS(short),1,0,0) # define _IOT_ifreq_int _IOT(_IOTS(char),IFNAMSIZ,_IOTS(int),1,0,0) #endif frama-c-Fluorine-20130601/share/libc/iconv.h0000644000175000017500000000433612155630243017306 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_ICONV #define __FC_ICONV #include "__fc_define_restrict.h" #include "__fc_define_size_t.h" typedef void * iconv_t; extern int __FC_errno; /*@ assigns *outbuf[0 .. *outbytesleft-1] \from *inbuf[0 .. *inbytesleft-1]; assigns __FC_errno ; */ size_t iconv(iconv_t cd, char **restrict inbuf, size_t *restrict inbytesleft, char **restrict outbuf, size_t *restrict outbytesleft); /*@ assigns __FC_errno; ensures \result == 0 || \result == 1 ; */ int iconv_close(iconv_t); /*@ assigns \result \from tocode[..],fromcode[..]; assigns __FC_errno; */ iconv_t iconv_open(const char *tocode, const char *fromcode); #endif frama-c-Fluorine-20130601/share/libc/ifaddrs.h0000644000175000017500000000424112155630243017577 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef FC_IFADDRS #define FC_IFADDRS #include "__fc_define_sockaddr.h" /* Linux header */ struct ifaddrs { struct ifaddrs *ifa_next; char *ifa_name; unsigned int ifa_flags; struct sockaddr *ifa_addr; struct sockaddr *ifa_netmask; struct sockaddr *ifa_dstaddr; void *ifa_data; }; struct ifmaddrs { struct ifmaddrs *ifma_next; struct sockaddr *ifma_name; struct sockaddr *ifma_addr; struct sockaddr *ifma_lladdr; }; int getifaddrs(struct ifaddrs **); void freeifaddrs(struct ifaddrs *); int getifmaddrs(struct ifmaddrs **); void freeifmaddrs(struct ifmaddrs *); #endif frama-c-Fluorine-20130601/share/libc/test.c0000644000175000017500000000256412155630243017143 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #if 0 // #include "assert.h" //#include "complex.h" //#include "ctype.h" #include "errno.h" //#include "fenv.h" //#include "float.h" //#include "inttypes.h" //#include "iso646.h" //#include "limits.h" //#include "locale.h" //#include "math.h" //#include "setjmp.h" //#include "stdbool.h" //#include "stddef.h" //#include "signal.h" //#include "stdarg.h" //#include "stdint.h" #endif #include "stdio.h" int G=17; void main(int x) { FILE * f = fopen("FOO","rwx"); } frama-c-Fluorine-20130601/share/libc/stdint.c0000644000175000017500000000166412155630243017471 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "stdint.h" frama-c-Fluorine-20130601/share/libc/netinet/0000755000175000017500000000000012155634040017456 5ustar mehdimehdiframa-c-Fluorine-20130601/share/libc/netinet/ip_icmp.c0000644000175000017500000000166512155630242021252 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "ip_icmp.c" frama-c-Fluorine-20130601/share/libc/netinet/in_systm.h0000644000175000017500000000322712155630242021500 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_NETINET_SYSTM_H #define __FC_NETINET_SYSTM_H #endif frama-c-Fluorine-20130601/share/libc/netinet/in.h0000644000175000017500000002632012155630242020240 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_NETINET_IN_H__ #define __FC_NETINET_IN_H__ #include "inttypes.h" #include "sys/socket.h" typedef uint16_t in_port_t; typedef uint32_t in_addr_t; struct in_addr { in_addr_t s_addr; }; struct sockaddr_in { sa_family_t sin_family; in_port_t sin_port; struct in_addr sin_addr; }; struct in6_addr { uint8_t s6_addr[16]; }; struct sockaddr_in6 { sa_family_t sin6_family; in_port_t sin6_port; uint32_t sin6_flowinfo; struct in6_addr sin6_addr; uint32_t sin6_scope_id; }; #define INADDR_ANY 0 #define INADDR_BROADCAST 0XFFFFFFFFUL #define IN6ADDR_ANY 0 #define IN6ADDR_BROADCAST 0XFFFFFFFFFFFFFFFFULL const struct in6_addr in6addr_any={{0}}; const struct in6_addr in6addr_loopback= {{0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF, 0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF}} ; struct ipv6_mreq { struct in6_addr ipv6mr_multiaddr; unsigned ipv6mr_interface; }; /* Standard well-defined IP protocols. */ enum { IPPROTO_IP = 0, /* Dummy protocol for TCP. */ #define IPPROTO_IP IPPROTO_IP IPPROTO_HOPOPTS = 0, /* IPv6 Hop-by-Hop options. */ #define IPPROTO_HOPOPTS IPPROTO_HOPOPTS IPPROTO_ICMP = 1, /* Internet Control Message Protocol. */ #define IPPROTO_ICMP IPPROTO_ICMP IPPROTO_IGMP = 2, /* Internet Group Management Protocol. */ #define IPPROTO_IGMP IPPROTO_IGMP IPPROTO_IPIP = 4, /* IPIP tunnels (older KA9Q tunnels use 94). */ #define IPPROTO_IPIP IPPROTO_IPIP IPPROTO_TCP = 6, /* Transmission Control Protocol. */ #define IPPROTO_TCP IPPROTO_TCP IPPROTO_EGP = 8, /* Exterior Gateway Protocol. */ #define IPPROTO_EGP IPPROTO_EGP IPPROTO_PUP = 12, /* PUP protocol. */ #define IPPROTO_PUP IPPROTO_PUP IPPROTO_UDP = 17, /* User Datagram Protocol. */ #define IPPROTO_UDP IPPROTO_UDP IPPROTO_IDP = 22, /* XNS IDP protocol. */ #define IPPROTO_IDP IPPROTO_IDP IPPROTO_TP = 29, /* SO Transport Protocol Class 4. */ #define IPPROTO_TP IPPROTO_TP IPPROTO_DCCP = 33, /* Datagram Congestion Control Protocol. */ #define IPPROTO_DCCP IPPROTO_DCCP IPPROTO_IPV6 = 41, /* IPv6 header. */ #define IPPROTO_IPV6 IPPROTO_IPV6 IPPROTO_ROUTING = 43, /* IPv6 routing header. */ #define IPPROTO_ROUTING IPPROTO_ROUTING IPPROTO_FRAGMENT = 44, /* IPv6 fragmentation header. */ #define IPPROTO_FRAGMENT IPPROTO_FRAGMENT IPPROTO_RSVP = 46, /* Reservation Protocol. */ #define IPPROTO_RSVP IPPROTO_RSVP IPPROTO_GRE = 47, /* General Routing Encapsulation. */ #define IPPROTO_GRE IPPROTO_GRE IPPROTO_ESP = 50, /* encapsulating security payload. */ #define IPPROTO_ESP IPPROTO_ESP IPPROTO_AH = 51, /* authentication header. */ #define IPPROTO_AH IPPROTO_AH IPPROTO_ICMPV6 = 58, /* ICMPv6. */ #define IPPROTO_ICMPV6 IPPROTO_ICMPV6 IPPROTO_NONE = 59, /* IPv6 no next header. */ #define IPPROTO_NONE IPPROTO_NONE IPPROTO_DSTOPTS = 60, /* IPv6 destination options. */ #define IPPROTO_DSTOPTS IPPROTO_DSTOPTS IPPROTO_MTP = 92, /* Multicast Transport Protocol. */ #define IPPROTO_MTP IPPROTO_MTP IPPROTO_ENCAP = 98, /* Encapsulation Header. */ #define IPPROTO_ENCAP IPPROTO_ENCAP IPPROTO_PIM = 103, /* Protocol Independent Multicast. */ #define IPPROTO_PIM IPPROTO_PIM IPPROTO_COMP = 108, /* Compression Header Protocol. */ #define IPPROTO_COMP IPPROTO_COMP IPPROTO_SCTP = 132, /* Stream Control Transmission Protocol. */ #define IPPROTO_SCTP IPPROTO_SCTP IPPROTO_UDPLITE = 136, /* UDP-Lite protocol. */ #define IPPROTO_UDPLITE IPPROTO_UDPLITE IPPROTO_RAW = 255, /* Raw IP packets. */ #define IPPROTO_RAW IPPROTO_RAW IPPROTO_MAX }; /*** originaly from bits/in.h ***/ /* Options for use with `getsockopt' and `setsockopt' at the IP level. The first word in the comment at the right is the data type used; "bool" means a boolean value stored in an `int'. */ #define IP_OPTIONS 4 /* ip_opts; IP per-packet options. */ #define IP_HDRINCL 3 /* int; Header is included with data. */ #define IP_TOS 1 /* int; IP type of service and precedence. */ #define IP_TTL 2 /* int; IP time to live. */ #define IP_RECVOPTS 6 /* bool; Receive all IP options w/datagram. */ /* For BSD compatibility. */ #define IP_RECVRETOPTS IP_RETOPTS /* bool; Receive IP options for response. */ #define IP_RETOPTS 7 /* ip_opts; Set/get IP per-packet options. */ #define IP_MULTICAST_IF 32 /* in_addr; set/get IP multicast i/f */ #define IP_MULTICAST_TTL 33 /* u_char; set/get IP multicast ttl */ #define IP_MULTICAST_LOOP 34 /* i_char; set/get IP multicast loopback */ #define IP_ADD_MEMBERSHIP 35 /* ip_mreq; add an IP group membership */ #define IP_DROP_MEMBERSHIP 36 /* ip_mreq; drop an IP group membership */ #define IP_UNBLOCK_SOURCE 37 /* ip_mreq_source: unblock data from source */ #define IP_BLOCK_SOURCE 38 /* ip_mreq_source: block data from source */ #define IP_ADD_SOURCE_MEMBERSHIP 39 /* ip_mreq_source: join source group */ #define IP_DROP_SOURCE_MEMBERSHIP 40 /* ip_mreq_source: leave source group */ #define IP_MSFILTER 41 #if defined __USE_MISC || defined __USE_GNU # define MCAST_JOIN_GROUP 42 /* group_req: join any-source group */ # define MCAST_BLOCK_SOURCE 43 /* group_source_req: block from given group */ # define MCAST_UNBLOCK_SOURCE 44 /* group_source_req: unblock from given group*/ # define MCAST_LEAVE_GROUP 45 /* group_req: leave any-source group */ # define MCAST_JOIN_SOURCE_GROUP 46 /* group_source_req: join source-spec gr */ # define MCAST_LEAVE_SOURCE_GROUP 47 /* group_source_req: leave source-spec gr*/ # define MCAST_MSFILTER 48 # define MCAST_EXCLUDE 0 # define MCAST_INCLUDE 1 #endif #define IP_ROUTER_ALERT 5 /* bool */ #define IP_PKTINFO 8 /* bool */ #define IP_PKTOPTIONS 9 #define IP_PMTUDISC 10 /* obsolete name? */ #define IP_MTU_DISCOVER 10 /* int; see below */ #define IP_RECVERR 11 /* bool */ #define IP_RECVTTL 12 /* bool */ #define IP_RECVTOS 13 /* bool */ #define IP_MTU 14 /* int */ #define IP_FREEBIND 15 #define IP_IPSEC_POLICY 16 #define IP_XFRM_POLICY 17 #define IP_PASSSEC 18 #define IP_TRANSPARENT 19 /* TProxy original addresses */ #define IP_ORIGDSTADDR 20 #define IP_RECVORIGDSTADDR IP_ORIGDSTADDR #define IP_MINTTL 21 /* IP_MTU_DISCOVER arguments. */ #define IP_PMTUDISC_DONT 0 /* Never send DF frames. */ #define IP_PMTUDISC_WANT 1 /* Use per route hints. */ #define IP_PMTUDISC_DO 2 /* Always DF. */ #define IP_PMTUDISC_PROBE 3 /* Ignore dst pmtu. */ /* To select the IP level. */ #define SOL_IP 0 #define IP_DEFAULT_MULTICAST_TTL 1 #define IP_DEFAULT_MULTICAST_LOOP 1 #define IP_MAX_MEMBERSHIPS 20 #if defined __USE_MISC || defined __USE_GNU /* Structure used to describe IP options for IP_OPTIONS and IP_RETOPTS. The `ip_dst' field is used for the first-hop gateway when using a source route (this gets put into the header proper). */ struct ip_opts { struct in_addr ip_dst; /* First hop; zero without source route. */ char ip_opts[40]; /* Actually variable in size. */ }; /* Like `struct ip_mreq' but including interface specification by index. */ struct ip_mreqn { struct in_addr imr_multiaddr; /* IP multicast address of group */ struct in_addr imr_address; /* local IP address of interface */ int imr_ifindex; /* Interface index */ }; /* Structure used for IP_PKTINFO. */ struct in_pktinfo { int ipi_ifindex; /* Interface index */ struct in_addr ipi_spec_dst; /* Routing destination address */ struct in_addr ipi_addr; /* Header destination address */ }; #endif /* Options for use with `getsockopt' and `setsockopt' at the IPv6 level. The first word in the comment at the right is the data type used; "bool" means a boolean value stored in an `int'. */ #define IPV6_ADDRFORM 1 #define IPV6_2292PKTINFO 2 #define IPV6_2292HOPOPTS 3 #define IPV6_2292DSTOPTS 4 #define IPV6_2292RTHDR 5 #define IPV6_2292PKTOPTIONS 6 #define IPV6_CHECKSUM 7 #define IPV6_2292HOPLIMIT 8 #define SCM_SRCRT IPV6_RXSRCRT #define IPV6_NEXTHOP 9 #define IPV6_AUTHHDR 10 #define IPV6_UNICAST_HOPS 16 #define IPV6_MULTICAST_IF 17 #define IPV6_MULTICAST_HOPS 18 #define IPV6_MULTICAST_LOOP 19 #define IPV6_JOIN_GROUP 20 #define IPV6_LEAVE_GROUP 21 #define IPV6_ROUTER_ALERT 22 #define IPV6_MTU_DISCOVER 23 #define IPV6_MTU 24 #define IPV6_RECVERR 25 #define IPV6_V6ONLY 26 #define IPV6_JOIN_ANYCAST 27 #define IPV6_LEAVE_ANYCAST 28 #define IPV6_IPSEC_POLICY 34 #define IPV6_XFRM_POLICY 35 #define IPV6_RECVPKTINFO 49 #define IPV6_PKTINFO 50 #define IPV6_RECVHOPLIMIT 51 #define IPV6_HOPLIMIT 52 #define IPV6_RECVHOPOPTS 53 #define IPV6_HOPOPTS 54 #define IPV6_RTHDRDSTOPTS 55 #define IPV6_RECVRTHDR 56 #define IPV6_RTHDR 57 #define IPV6_RECVDSTOPTS 58 #define IPV6_DSTOPTS 59 #define IPV6_RECVTCLASS 66 #define IPV6_TCLASS 67 /* Obsolete synonyms for the above. */ #define IPV6_ADD_MEMBERSHIP IPV6_JOIN_GROUP #define IPV6_DROP_MEMBERSHIP IPV6_LEAVE_GROUP #define IPV6_RXHOPOPTS IPV6_HOPOPTS #define IPV6_RXDSTOPTS IPV6_DSTOPTS /* IPV6_MTU_DISCOVER values. */ #define IPV6_PMTUDISC_DONT 0 /* Never send DF frames. */ #define IPV6_PMTUDISC_WANT 1 /* Use per route hints. */ #define IPV6_PMTUDISC_DO 2 /* Always DF. */ #define IPV6_PMTUDISC_PROBE 3 /* Ignore dst pmtu. */ /* Socket level values for IPv6. */ #define SOL_IPV6 41 #define SOL_ICMPV6 58 /* Routing header options for IPv6. */ #define IPV6_RTHDR_LOOSE 0 /* Hop doesn't need to be neighbour. */ #define IPV6_RTHDR_STRICT 1 /* Hop must be a neighbour. */ #define IPV6_RTHDR_TYPE_0 0 /* IPv6 Routing header type 0. */ #endif frama-c-Fluorine-20130601/share/libc/netinet/ip.c0000644000175000017500000000166012155630242020235 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "ip.h" frama-c-Fluorine-20130601/share/libc/netinet/ip.h0000644000175000017500000000322112155630242020235 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_NETINET_IP_H #define __FC_NETINET_IP_H #endif frama-c-Fluorine-20130601/share/libc/netinet/in_systm.c0000644000175000017500000000166612155630242021500 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "in_systm.h" frama-c-Fluorine-20130601/share/libc/netinet/in.c0000644000175000017500000000166012155630242020233 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "in.h" frama-c-Fluorine-20130601/share/libc/netinet/ip_icmp.h0000644000175000017500000000323412155630242021251 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_NETINET_IP_ICMP_H #define __FC_NETINET_IP_ICMP_H #endif frama-c-Fluorine-20130601/share/libc/time.c0000644000175000017500000000166212155630243017120 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "time.h" frama-c-Fluorine-20130601/share/libc/sys/0000755000175000017500000000000012155634040016626 5ustar mehdimehdiframa-c-Fluorine-20130601/share/libc/sys/types.h0000644000175000017500000000427412155630243020153 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_SYS_TYPES_H__ #define __FC_SYS_TYPES_H__ #include "../__fc_machdep.h" #include "../__fc_define_id_t.h" #include "../__fc_define_pid_t.h" #include "../__fc_define_ssize_t.h" #include "../__fc_define_uid_and_gid.h" #include "../__fc_define_time_t.h" #include "../__fc_define_suseconds_t.h" #include "../__fc_define_ino_t.h" #include "../__fc_define_blkcnt_t.h" #include "../__fc_define_blksize_t.h" #include "../__fc_define_dev_t.h" #include "../__fc_define_mode_t.h" #include "../__fc_define_nlink_t.h" #include "../__fc_define_off_t.h" typedef unsigned int u_int; typedef unsigned char u_char; #endif frama-c-Fluorine-20130601/share/libc/sys/uio.h0000644000175000017500000000420612155630243017576 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef FC_UIO #define FC_UIO #include "../__fc_define_ssize_t.h" #include "../__fc_define_size_t.h" #include "../__fc_define_iovec.h" /*@ requires \valid( &iov[0..iovcnt-1] ); // Value cannot yet interpret the precise assigns clause; we use the weaker one as a fallback. //@ assigns { ((char *) iov[i].iov_base)[0..iov[i].iov_len - 1] | integer i; 0 <= i < iovcnt }; @ assigns ((char *) iov[0..iovcnt -1].iov_base)[0..]; */ ssize_t readv(int fd, const struct iovec *iov, int iovcnt); ssize_t writev(int fd, const struct iovec *iov, int iovcnt); #endif frama-c-Fluorine-20130601/share/libc/sys/ioctl.c0000644000175000017500000000166312155630243020113 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "ioctl.h" frama-c-Fluorine-20130601/share/libc/sys/time.h0000644000175000017500000000622412155630243017742 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_SYS_TIME_H__ #define __FC_SYS_TIME_H__ #include "../__fc_define_time_t.h" #include "../__fc_define_suseconds_t.h" #include "../__fc_define_fd_set_t.h" #include "../__fc_define_timespec.h" struct timeval { time_t tv_sec; suseconds_t tv_usec; }; struct timezone { int tz_minuteswest; int tz_dsttime; }; /* Abstract representation of the current time. */ extern volatile int __fc_time; extern int __fc_tz; /*@ assigns \result \from path[0..],times[0..1]; */ int utimes(const char *path, const struct timeval times[2]); /*@ behavior tv_and_tz_null: @ assumes tv == \null && tz == \null; @ assigns \nothing; @ @ behavior tv_not_null: @ assumes tv != \null && tz == \null; @ assigns tv->tv_sec \from __fc_time; @ assigns tv->tv_usec \from __fc_time; @ ensures \initialized(tv); @ @ behavior tz_not_null: @ assumes tv == \null && tz != \null; @ assigns tz[0..] \from __fc_tz; @ ensures \initialized(tz); @ @ behavior tv_and_tz_not_null: @ assumes tv != \null && tz != \null; @ assigns tv->tv_sec \from __fc_time; @ assigns tv->tv_usec \from __fc_time; @ assigns tz[0..] \from __fc_tz; @ ensures \initialized(tv); @ ensures \initialized(tz); @ @ complete behaviors; @ disjoint behaviors; @*/ int gettimeofday(struct timeval *tv, struct timezone *tz); /*@ assigns \result,__fc_time,__fc_tz @ \from tv->tv_sec, tv->tv_usec, @ tz->tz_dsttime, tz->tz_minuteswest; @*/ int settimeofday(const struct timeval *tv, const struct timezone *tz); #endif frama-c-Fluorine-20130601/share/libc/sys/wait.c0000644000175000017500000000166212155630243017744 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "wait.h" frama-c-Fluorine-20130601/share/libc/sys/wait.h0000644000175000017500000000416212155630243017747 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_WAIT_H__ #define __FC_WAIT_H__ #define WNOHANG 0 #define WUNTRACED 1 #define WEXITED 2 #define WSTOPPED 3 #define WCONTINUED 4 #define WNOWAIT 5 #include "../__fc_define_pid_t.h" #include "../__fc_define_uid_and_gid.h" #include "../signal.h" #include "resource.h" typedef enum __FC_IDTYPE_T { P_ALL, P_PID, P_PGID } idtype_t; pid_t wait(int *stat_loc); pid_t wait3(int *, int, struct rusage *); int waitid(idtype_t idt, id_t id, siginfo_t * sig, int options); pid_t waitpid(pid_t pid, int *stat_loc, int options); #endif frama-c-Fluorine-20130601/share/libc/sys/un.h0000644000175000017500000000344312155630243017426 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef FC_UN #define FC_UN #include "../__fc_define_sa_family_t.h" struct sockaddr_un { sa_family_t sun_family; char sun_path[__FC_SOCKADDR_SUN_SUN_PATH]; /* Path name. */ }; #endif frama-c-Fluorine-20130601/share/libc/sys/ioctl.h0000644000175000017500000001206012155630243020111 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef FC_IOCTL #define FC_IOCTL /* Routing table calls. */ #define SIOCADDRT 0x890B /* add routing table entry */ #define SIOCDELRT 0x890C /* delete routing table entry */ #define SIOCRTMSG 0x890D /* call to routing system */ /* Socket configuration controls. */ #define SIOCGIFNAME 0x8910 /* get iface name */ #define SIOCSIFLINK 0x8911 /* set iface channel */ #define SIOCGIFCONF 0x8912 /* get iface list */ #define SIOCGIFFLAGS 0x8913 /* get flags */ #define SIOCSIFFLAGS 0x8914 /* set flags */ #define SIOCGIFADDR 0x8915 /* get PA address */ #define SIOCSIFADDR 0x8916 /* set PA address */ #define SIOCGIFDSTADDR 0x8917 /* get remote PA address */ #define SIOCSIFDSTADDR 0x8918 /* set remote PA address */ #define SIOCGIFBRDADDR 0x8919 /* get broadcast PA address */ #define SIOCSIFBRDADDR 0x891a /* set broadcast PA address */ #define SIOCGIFNETMASK 0x891b /* get network PA mask */ #define SIOCSIFNETMASK 0x891c /* set network PA mask */ #define SIOCGIFMETRIC 0x891d /* get metric */ #define SIOCSIFMETRIC 0x891e /* set metric */ #define SIOCGIFMEM 0x891f /* get memory address (BSD) */ #define SIOCSIFMEM 0x8920 /* set memory address (BSD) */ #define SIOCGIFMTU 0x8921 /* get MTU size */ #define SIOCSIFMTU 0x8922 /* set MTU size */ #define SIOCSIFNAME 0x8923 /* set interface name */ #define SIOCSIFHWADDR 0x8924 /* set hardware address */ #define SIOCGIFENCAP 0x8925 /* get/set encapsulations */ #define SIOCSIFENCAP 0x8926 #define SIOCGIFHWADDR 0x8927 /* Get hardware address */ #define SIOCGIFSLAVE 0x8929 /* Driver slaving support */ #define SIOCSIFSLAVE 0x8930 #define SIOCADDMULTI 0x8931 /* Multicast address lists */ #define SIOCDELMULTI 0x8932 #define SIOCGIFINDEX 0x8933 /* name -> if_index mapping */ #define SIOGIFINDEX SIOCGIFINDEX /* misprint compatibility :-) */ #define SIOCSIFPFLAGS 0x8934 /* set/get extended flags set */ #define SIOCGIFPFLAGS 0x8935 #define SIOCDIFADDR 0x8936 /* delete PA address */ #define SIOCSIFHWBROADCAST 0x8937 /* set hardware broadcast addr */ #define SIOCGIFCOUNT 0x8938 /* get number of devices */ #define SIOCGIFBR 0x8940 /* Bridging support */ #define SIOCSIFBR 0x8941 /* Set bridging options */ #define SIOCGIFTXQLEN 0x8942 /* Get the tx queue length */ #define SIOCSIFTXQLEN 0x8943 /* Set the tx queue length */ /* ARP cache control calls. */ /* 0x8950 - 0x8952 * obsolete calls, don't re-use */ #define SIOCDARP 0x8953 /* delete ARP table entry */ #define SIOCGARP 0x8954 /* get ARP table entry */ #define SIOCSARP 0x8955 /* set ARP table entry */ /* RARP cache control calls. */ #define SIOCDRARP 0x8960 /* delete RARP table entry */ #define SIOCGRARP 0x8961 /* get RARP table entry */ #define SIOCSRARP 0x8962 /* set RARP table entry */ /* Driver configuration calls */ #define SIOCGIFMAP 0x8970 /* Get device parameters */ #define SIOCSIFMAP 0x8971 /* Set device parameters */ /* DLCI configuration calls */ #define SIOCADDDLCI 0x8980 /* Create new DLCI device */ #define SIOCDELDLCI 0x8981 /* Delete DLCI device */ /* Device private ioctl calls. */ /* These 16 ioctls are available to devices via the do_ioctl() device vector. Each device should include this file and redefine these names as their own. Because these are device dependent it is a good idea _NOT_ to issue them to random objects and hope. */ #define SIOCDEVPRIVATE 0x89F0 /* to 89FF */ /* * These 16 ioctl calls are protocol private */ #define SIOCPROTOPRIVATE 0x89E0 /* to 89EF */ #endif frama-c-Fluorine-20130601/share/libc/sys/param.h0000644000175000017500000000337412155630243020107 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_SYS_PARAM_H__ #define __FC_SYS_PARAM_H__ /* Only deprecated programs use this header. Add whatever is needed for this program to compile. */ #endif frama-c-Fluorine-20130601/share/libc/sys/resource.c0000644000175000017500000000166612155630243020633 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "resource.h" frama-c-Fluorine-20130601/share/libc/sys/socket.c0000644000175000017500000000166412155630243020272 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "socket.h" frama-c-Fluorine-20130601/share/libc/sys/select.h0000644000175000017500000000436212155630243020264 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_SYS_SELECT_H__ #define __FC_SYS_SELECT_H__ #include "../__fc_define_time_t.h" #include "../__fc_define_suseconds_t.h" #include "../__fc_define_fd_set_t.h" #include "../__fc_define_sigset_t.h" #include "time.h" /* assigns \result \from nfds, *readfds, *writefds,*errorfds,*timeout,*sigmask; */ int pselect(int nfds, fd_set * readfds, fd_set * writefds, fd_set * errorfds, const struct timespec * timeout, const sigset_t * sigmask); /* assigns \result \from nfds, *readfds, *writefds,*errorfds,*timeout ;*/ int select(int nfds, fd_set * readfds, fd_set * writefds, fd_set * errorfds, struct timeval * timeout); #endif frama-c-Fluorine-20130601/share/libc/sys/socket.h0000644000175000017500000001607112155630243020275 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_SOCKET_H__ #define __FC_SOCKET_H__ #include "__fc_machdep.h" typedef __UINT_LEAST32_T socklen_t; #include "../__fc_define_sa_family_t.h" #include "../__fc_define_sockaddr.h" /* Not POSIX compliant but seems needed for some functions... */ #include "__fc_define_ssize_t.h" struct sockaddr_storage { sa_family_t ss_family; }; #include "__fc_define_iovec.h" struct cmsghdr { socklen_t cmsg_len; int cmsg_level; int cmsg_type; }; #define SCM_RIGHTS 0 struct msghdr { void *msg_name; socklen_t msg_namelen; struct iovec *msg_iov; int msg_iovlen; void *msg_control; socklen_t msg_controllen; int msg_flags; }; /* Socket types. */ #define SOCK_STREAM 1 /* stream (connection) socket */ #define SOCK_DGRAM 2 /* datagram (conn.less) socket */ #define SOCK_RAW 3 /* raw socket */ #define SOCK_RDM 4 /* reliably-delivered message */ #define SOCK_SEQPACKET 5 /* sequential packet socket */ /* Supported address families. */ /* * Address families. */ #define AF_UNSPEC 0 /* unspecified */ #define AF_UNIX 1 /* local to host (pipes, portals) */ #define AF_LOCAL 1 /* POSIX name for AF_UNIX */ #define AF_INET 2 /* internetwork: UDP, TCP, etc. */ #define AF_IMPLINK 3 /* arpanet imp addresses */ #define AF_PUP 4 /* pup protocols: e.g. BSP */ #define AF_CHAOS 5 /* mit CHAOS protocols */ #define AF_NS 6 /* XEROX NS protocols */ #define AF_ISO 7 /* ISO protocols */ #define AF_OSI AF_ISO /* OSI is ISO */ #define AF_ECMA 8 /* european computer manufacturers */ #define AF_DATAKIT 9 /* datakit protocols */ #define AF_CCITT 10 /* CCITT protocols, X.25 etc */ #define AF_SNA 11 /* IBM SNA */ #define AF_DECnet 12 /* DECnet */ #define AF_DLI 13 /* Direct data link interface */ #define AF_LAT 14 /* LAT */ #define AF_HYLINK 15 /* NSC Hyperchannel */ #define AF_APPLETALK 16 /* AppleTalk */ #define AF_NETBIOS 17 /* NetBios-style addresses */ #define AF_MAX 32 /* * Protocol families, same as address families for now. */ #define PF_UNSPEC AF_UNSPEC #define PF_UNIX AF_UNIX #define PF_LOCAL AF_LOCAL #define PF_INET AF_INET #define PF_IMPLINK AF_IMPLINK #define PF_PUP AF_PUP #define PF_CHAOS AF_CHAOS #define PF_NS AF_NS #define PF_ISO AF_ISO #define PF_OSI AF_OSI #define PF_ECMA AF_ECMA #define PF_DATAKIT AF_DATAKIT #define PF_CCITT AF_CCITT #define PF_SNA AF_SNA #define PF_DECnet AF_DECnet #define PF_DLI AF_DLI #define PF_LAT AF_LAT #define PF_HYLINK AF_HYLINK #define PF_APPLETALK AF_APPLETALK #define PF_NETBIOS AF_NETBIOS #define PF_MAX AF_MAX #define SOL_SOCKET 0xffff /* options for socket level */ #define SO_DEBUG 0x0001 /* turn on debugging info recording */ #define SO_ACCEPTCONN 0x0002 /* socket has had listen() */ #define SO_REUSEADDR 0x0004 /* allow local address reuse */ #define SO_KEEPALIVE 0x0008 /* keep connections alive */ #define SO_DONTROUTE 0x0010 /* just use interface addresses */ #define SO_BROADCAST 0x0020 /* permit sending of broadcast msgs */ #define SO_USELOOPBACK 0x0040 /* bypass hardware when possible */ #define SO_LINGER 0x0080 /* linger on close if data present */ #define SO_OOBINLINE 0x0100 /* leave received OOB data in line */ #define SO_DONTLINGER (unsigned int)(~SO_LINGER) #define SO_PEERCRED 0x0200 /* same as getpeereid */ #define SO_ERROR 0x1000 #define SOMAXCONN 0xFF int accept(int, struct sockaddr *, socklen_t *); int bind(int, const struct sockaddr *, socklen_t); int connect(int, const struct sockaddr *, socklen_t); int getpeername(int, struct sockaddr *, socklen_t *); int getsockname(int, struct sockaddr *, socklen_t *); int getsockopt(int, int, int, void *, socklen_t *); int listen(int, int); ssize_t recv(int, void *, size_t, int); ssize_t recvfrom(int, void *, size_t, int, struct sockaddr *, socklen_t *); /*@ requires \valid(&((char *)hdr->msg_control)[0..hdr->msg_controllen-1]); @ requires \valid(&(hdr->msg_iov[0..hdr->msg_iovlen-1])); @ assigns ((char *) hdr->msg_iov[0..hdr->msg_iovlen-1].iov_base)[0..]; @ assigns ((char *) hdr->msg_control)[0..]; @ assigns hdr->msg_controllen; @ assigns hdr->msg_flags; */ ssize_t recvmsg(int sockfd, struct msghdr *hdr, int flags); ssize_t send(int, const void *, size_t, int); ssize_t sendmsg(int, const struct msghdr *, int); ssize_t sendto(int, const void *, size_t, int, const struct sockaddr *, socklen_t); int setsockopt(int, int, int, const void *, socklen_t); int shutdown(int, int); int socket(int, int, int); int sockatmark(int); /* Represents the creation of new file descriptors for sockets. */ extern int __fc_socket_counter; /*@ requires \valid(&socket_vector[0..1]); @ assigns __fc_socket_counter, socket_vector[0..1] \from __fc_socket_counter; @ ensures \initialized(&socket_vector[0..1]); @*/ int socketpair(int domain, int type, int protocol, int socket_vector[2]); #endif frama-c-Fluorine-20130601/share/libc/sys/types.c0000644000175000017500000000166312155630243020145 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "types.h" frama-c-Fluorine-20130601/share/libc/sys/uio.c0000644000175000017500000000166112155630243017573 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "uio.h" frama-c-Fluorine-20130601/share/libc/sys/select.c0000644000175000017500000000166412155630243020261 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "select.h" frama-c-Fluorine-20130601/share/libc/sys/un.c0000644000175000017500000000166012155630243017420 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "un.h" frama-c-Fluorine-20130601/share/libc/sys/stat.c0000644000175000017500000000166212155630243017753 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "stat.h" frama-c-Fluorine-20130601/share/libc/sys/param.c0000644000175000017500000000166312155630243020101 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "param.h" frama-c-Fluorine-20130601/share/libc/sys/time.c0000644000175000017500000000166212155630243017736 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "time.h" frama-c-Fluorine-20130601/share/libc/sys/stat.h0000644000175000017500000000376112155630243017762 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_SYS_STAT_H #define __FC_SYS_STAT_H #include "../__fc_define_stat.h" int chmod(const char *, mode_t); int fchmod(int, mode_t); int fstat(int, struct stat *); int lstat(const char *, struct stat *); int mkdir(const char *, mode_t); int mkfifo(const char *, mode_t); int mknod(const char *, mode_t, dev_t); int stat(const char *, struct stat *); mode_t umask(mode_t); #endif frama-c-Fluorine-20130601/share/libc/sys/resource.h0000644000175000017500000000547512155630243020642 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_SYS_RESOURCE_H__ #define __FC_SYS_RESOURCE_H__ #include "time.h" #include "../__fc_define_id_t.h" #define PRIO_PROCESS 0 #define PRIO_PGRP 1 #define PRIO_USER 2 typedef unsigned long rlim_t; struct rlimit { rlim_t rlim_cur; rlim_t rlim_max; }; struct rusage { struct timeval ru_utime; struct timeval ru_stime; }; #define RLIM_INFINITY 0xFFFFFFFFul #define RLIM_SAVED_MAX RLIM_INFINITY #define RLIM_SAVED_CUR RLIM_INFINITY #define RUSAGE_SELF 0 #define RUSAGE_CHILDREN 1 #define RLIMIT_CORE 0 #define RLIMIT_CPU 1 #define RLIMIT_DATA 2 #define RLIMIT_FSIZE 3 #define RLIMIT_NOFILE 4 #define RLIMIT_STACK 5 #define RLIMIT_AS 6 /*@ assigns \result \from which,who; */ int getpriority(int which, id_t who); /*@ assigns \result \from which,who,prio; */ int setpriority(int which, id_t who, int prio); /*@ assigns \result \from r; @ assigns rl->rlim_cur \from r; @ assigns rl->rlim_max \from r; */ int getrlimit(int r, struct rlimit *rl); /*@ assigns \result \from r; @ assigns ru->ru_utime \from r; @ assigns ru->ru_stime \from r; */ int getrusage(int r, struct rusage *ru); /*@ assigns \result \from r,rl->rlim_cur,rl->rlim_max; */ int setrlimit(int r, const struct rlimit * rl); #endif frama-c-Fluorine-20130601/share/libc/float.h0000644000175000017500000000522312155630243017271 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* ISO C: 7.7 */ #ifndef __FC_FLOAT #define __FC_FLOAT /* Note: Values for long double are only valid for x86 extended format. Some black magic will be needed if some other format (or none) is supposed to be provided. */ #define FLT_RADIX 2 #define FLT_MANT_DIG 24 #define DBL_MANT_DIG 53 #define LDBL_MANT_DIG 64 #define FLT_DIG 6 #define DBL_DIG 15 #define LDBL_DIG 18 #define FLT_MIN_EXP -125 #define DBL_MIN_EXP -1021 #define LDBL_MIN_EXP -16381 #define FLT_MIN_10_EXP -37 #define DBL_MIN_10_EXP -307 #define LDBL_MIN_10_EXP -4931 #define FLT_MAX_EXP 128 #define DBL_MAX_EXP 1024 #define LDBL_MAX_EXP 16384 #define FLT_MAX_10_EXP 38 #define DBL_MAX_10_EXP 308 #define LDBL_MAX_10_EXP 4932 #define FLT_MAX 0x1.fffffep+127 #define DBL_MAX 0x1.fffffffffffffp+1023 #define LDBL_MAX 0x1.fffffffffffffffep+16383 #define FLT_EPSILON 0x1p-23 #define DBL_EPSILON 0x1p-52 #define LDBL_EPSILON 0x1p-63 #define FLT_MIN 0x1p-126 #define DBL_MIN 0x1p-1022 #define LDBL_MIN 0x1p-16382 #define FLT_ROUNDS -1 #define FLT_EVAL_METHOD -1 #endif frama-c-Fluorine-20130601/share/libc/stdbool.c0000644000175000017500000000167012155630243017627 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* Empty on purpose */ frama-c-Fluorine-20130601/share/libc/nl_types.h0000644000175000017500000000355012155630243020022 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_NL_TYPES #define __FC_NL_TYPES typedef unsigned long nl_catd; typedef unsigned long nl_item; #define NL_SETD 0 #define NL_CAT_LOCALE 1 int catclose(nl_catd); char *catgets(nl_catd, int, int, const char *); nl_catd catopen(const char *, int); #endif frama-c-Fluorine-20130601/share/libc/stdio.h0000644000175000017500000002211412155630243017304 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* ISO C: 7.19 */ #ifndef __FC_STDIO #define __FC_STDIO #include "__fc_machdep.h" #include "stdarg.h" #include "errno.h" #include "__fc_define_stat.h" #include "__fc_define_size_t.h" #include "__fc_define_restrict.h" struct __fc_pos_t { unsigned long __fc_stdio_position; }; typedef struct __fc_pos_t fpos_t; struct __fc_FILE { unsigned int __fc_stdio_id; unsigned int __fc_maxsz; unsigned int __fc_writepos; unsigned int __fc_readpos; int __fc_is_a_socket; int mode; // O_RDONLY 1 | O_RDWR 2 | O_WRONLY 3 struct stat* __fc_inode; }; typedef struct __fc_FILE FILE; #include "__fc_define_null.h" #define _IOFBF 0 #define _IOLBF 1 #define _IONBF 2 #define BUFSIZ __FC_BUFSIZ #define EOF __FC_EOF #define FOPEN_MAX __FC_FOPEN_MAX #define FILENAME_MAX __FC_FILENAME_MAX #define L_tmpnam __FC_L_tmpnam #include "__fc_define_seek_macros.h" #define TMP_MAX __FC_TMP_MAX extern FILE * __fc_stderr; #define stderr (__fc_stderr) extern FILE * __fc_stdin; #define stdin (__fc_stdin) extern FILE * __fc_stdout; #define stdout (__fc_stdout) /*@ assigns \nothing; */ int remove(const char *filename); /*@ assigns \nothing; */ int rename(const char *old, const char *new); /*@ assigns \nothing; ensures \result==\null || (\valid(\result) && \fresh(\result,sizeof(FILE))) ; */ FILE *tmpfile(void); /*@ assigns \result \from s[..]; assigns s[..] \from \nothing; // TODO: more precise behaviors from ISO C 7.19.4.4 */ char *tmpnam(char *s); /*@ assigns *stream \from \nothing; ensures \result == 0 || \result == (-1); // -1 expanded manually to EOF // TODO: more precise behaviors from ISO C 7.19.4.1 */ int fclose(FILE *stream); /*@ assigns *stream \from \nothing; ensures \result == 0 || \result == (-1); // -1 expanded manually from EOF // TODO: more precise behaviors from ISO C 7.19.5.2 */ int fflush(FILE *stream); /*@ assigns \result \from filename[..],mode[..]; ensures \result==\null || (\valid(\result) && \fresh(\result,sizeof(FILE))) ; */ FILE *fopen(const char * restrict filename, const char * restrict mode); /*@ assigns \result \from fildes,mode[..]; ensures \result==\null || (\valid(\result) && \fresh(\result,sizeof(FILE))); */ FILE *fdopen(int fildes, const char *mode); /*@ assigns *stream; ensures \result==\null || \result==stream ; */ FILE *freopen(const char * restrict filename, const char * restrict mode, FILE * restrict stream); /*@ assigns *stream \from buf; */ void setbuf(FILE * restrict stream, char * restrict buf); /*@ assigns *stream \from buf,mode,size; */ int setvbuf(FILE * restrict stream, char * restrict buf, int mode, size_t size); /*@ assigns *stream; */ int fprintf(FILE * restrict stream, const char * restrict format, ...); /*@ assigns *stream; // unsupported... */ int fscanf(FILE * restrict stream, const char * restrict format, ...); // TODO: \from ... /*@ assigns *__fc_stdout \from format[..]; */ int printf(const char * restrict format, ...); /*@ assigns *__fc_stdin; // unsupported... */ int scanf(const char * restrict format, ...); /*@ assigns s[0..n]; // unsupported... */ int snprintf(char * restrict s, size_t n, const char * restrict format, ...); /*@ assigns s[0..]; // unsupported... */ int sprintf(char * restrict s, const char * restrict format, ...); /*@ assigns \nothing ; */ int sscanf(const char * restrict s, const char * restrict format, ...); /*@ assigns *stream \from format[..], arg; */ int vfprintf(FILE * restrict stream, const char * restrict format, va_list arg); /*@ assigns *stream \from format[..], *stream; // TODO: assign arg too. */ int vfscanf(FILE * restrict stream, const char * restrict format, va_list arg); /*@ assigns *__fc_stdout \from arg; */ int vprintf(const char * restrict format, va_list arg); /*@ assigns *__fc_stdin \from format[..]; // TODO: assign arg too. */ int vscanf(const char * restrict format, va_list arg); /*@ assigns s[0..n] \from format[..], arg; */ int vsnprintf(char * restrict s, size_t n, const char * restrict format, va_list arg); /*@ assigns s[0..] \from format[..], arg; */ int vsprintf(char * restrict s, const char * restrict format, va_list arg); /* @ TODO: assigns arg ; */ int vsscanf(const char * restrict s, const char * restrict format, va_list arg); /*@ assigns *stream; */ int fgetc(FILE *stream); /*@ assigns s[0..n],*stream \from *stream; assigns \result \from s,n,*stream; ensures \result == \null || \result==s; */ char *fgets(char * restrict s, int n, FILE * restrict stream); /*@ assigns *stream ; */ int fputc(int c, FILE *stream); /*@ assigns *stream \from s[..]; */ int fputs(const char * restrict s, FILE * restrict stream); /*@ assigns \result,*stream \from *stream; */ int getc(FILE *stream); /*@ assigns \result \from *__fc_stdin ; */ int getchar(void); /*@ assigns s[..] \from *__fc_stdin ; ensures \result == s || \result == \null; */ char *gets(char *s); /*@ assigns *stream \from c; */ int putc(int c, FILE *stream); /*@ assigns *__fc_stdout \from c; */ int putchar(int c); /*@ assigns *__fc_stdout \from s[..]; */ int puts(const char *s); /*@ assigns *stream \from c; */ int ungetc(int c, FILE *stream); /*@ assigns ((char*)ptr)[0..(nmemb*size)] \from *stream; */ size_t fread(void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream); /*@ assigns *stream \from ((char*)ptr)[0..(nmemb*size)]; */ size_t fwrite(const void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream); /*@ assigns *pos \from *stream ; */ int fgetpos(FILE * restrict stream, fpos_t * restrict pos); /*@ assigns *stream \from offset, whence ; assigns __FC_errno ; */ int fseek(FILE *stream, long int offset, int whence); /*@ assigns *stream \from *pos; */ int fsetpos(FILE *stream, const fpos_t *pos); /*@ assigns \result, __FC_errno \from *stream ;*/ long int ftell(FILE *stream); /*@ assigns *stream \from \nothing; */ void rewind(FILE *stream); /*@ assigns *stream \from \nothing; */ void clearerr(FILE *stream); /*@ assigns \result \from *stream ;*/ int feof(FILE *stream); /*@ assigns \result \from *stream ;*/ int fileno(FILE *stream); /*@ assigns *stream \from \nothing ;*/ void flockfile(FILE *stream); /*@ assigns *stream \from \nothing ;*/ void funlockfile(FILE *stream); /*@ assigns \result,*stream \from \nothing ;*/ int ftrylockfile(FILE *stream); /*@ assigns \result \from *stream ;*/ int ferror(FILE *stream); /*@ assigns __fc_stdout \from __FC_errno, s[..]; */ void perror(const char *s); /*@ assigns \result,*stream \from *stream; */ int getc_unlocked(FILE *stream); /*@ assigns \result \from *__fc_stdin ; */ int getchar_unlocked(void); /*@ assigns *stream \from c; */ int putc_unlocked(int c, FILE *stream); /*@ assigns *__fc_stdout \from c; */ int putchar_unlocked(int c); /*@ assigns *stream \from \nothing; */ void clearerr_unlocked(FILE *stream); /*@ assigns \result \from *stream ;*/ int feof_unlocked(FILE *stream); /*@ assigns \result \from *stream ;*/ int ferror_unlocked(FILE *stream); /*@ assigns \result \from *stream ;*/ int fileno_unlocked(FILE *stream); int fflush_unlocked(FILE *stream); int fgetc_unlocked(FILE *stream); int fputc_unlocked(int c, FILE *stream); size_t fread_unlocked(void *ptr, size_t size, size_t n, FILE *stream); size_t fwrite_unlocked(const void *ptr, size_t size, size_t n, FILE *stream); char *fgets_unlocked(char *s, int n, FILE *stream); int fputs_unlocked(const char *s, FILE *stream); #define IOV_MAX 1024 #endif frama-c-Fluorine-20130601/share/libc/grp.h0000644000175000017500000000420012155630243016746 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_GRP_H #define __FC_GRP_H #include "__fc_define_uid_and_gid.h" #include "__fc_define_size_t.h" struct group { char *gr_name; gid_t gr_gid; char **gr_mem; }; struct group *getgrgid(gid_t); struct group *getgrnam(const char *); int getgrgid_r(gid_t, struct group *, char *, size_t, struct group **); int getgrnam_r(const char *, struct group *, char *, size_t , struct group **); struct group *getgrent(void); void endgrent(void); void setgrent(void); /* BSD function */ int initgroups (const char *user, gid_t group); #endif frama-c-Fluorine-20130601/share/libc/__fc_machdep_linux_gcc_shared.h0000644000175000017500000001626312155630243024122 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_FORCE_INCLUDE_MACHDEP__ #error "This file shall not be directly included" #endif /* This file contains common machine specific values between Linux/GCC x86 and AMD64.*/ #ifndef __FC_MACHDEP_LINUX_SHARED #define __FC_MACHDEP_LINUX_SHARED /* Optional */ #define __INT8_T signed char #define __UINT8_T unsigned char #define __INT16_T signed short #define __UINT16_T unsigned short #define __INT32_T signed int #define __UINT32_T unsigned int #define __INT64_T signed long long #define __UINT64_T unsigned long long /* Required */ #define __INT_LEAST8_T signed char #define __UINT_LEAST8_T unsigned char #define __INT_LEAST16_T signed short #define __UINT_LEAST16_T unsigned short #define __INT_LEAST32_T signed int #define __UINT_LEAST32_T unsigned int #define __INT_LEAST64_T signed long long #define __UINT_LEAST64_T unsigned long long /* Required */ #define __INT_FAST8_T signed char #define __UINT_FAST8_T unsigned char #define __INT_FAST16_T signed int #define __UINT_FAST16_T unsigned int #define __INT_FAST32_T signed int #define __UINT_FAST32_T unsigned int #define __INT_FAST64_T signed long long #define __UINT_FAST64_T unsigned long long /* Required */ #define __INT_MAX_T signed long long #define __UINT_MAX_T unsigned long long /* min and max values as specified in limits.h */ #define __FC_SCHAR_MIN (-128) #define __FC_SCHAR_MAX 127 #define __FC_UCHAR_MAX 255 #define __FC_SHRT_MIN (-32768) #define __FC_SHRT_MAX 32767 #define __FC_USHRT_MAX 65535 #define __FC_INT_MIN (-INT_MAX - 1) #define __FC_INT_MAX 2147483647 #define __FC_UINT_MAX 4294967295U #define __FC_LONG_MIN (-LONG_MAX -1L) #define __FC_LLONG_MIN (-LLONG_MAX -1LL) #define __FC_LLONG_MAX 9223372036854775807LL #define __FC_ULLONG_MAX 18446744073709551615ULL /* Unused at this time */ #define __FC_umax(n) ((uint##n##_t)(-1)) #define __FC_smin(n) (2*(-(1ll << (sizeof(int##n##_t)*__CHAR_BIT - 2)))) #define __FC_smax(n) ((1ll<<(sizeof(int##n##_t)*__CHAR_BIT - 2))-1+(1ll<<(sizeof(int##n##_t)*__CHAR_BIT - 2))) /* stdint.h */ /* NB: in signal.h, sig_atomic_t is hardwired to int. */ #define __FC_SIG_ATOMIC_MIN __FC_INT_MIN #define __FC_SIG_ATOMIC_MAX __FC_INT_MAX #define __FC_SIZE_MAX __FC_UINT_MAX #define __FC_WCHAR_MIN __FC_INT_MIN #define __FC_WCHAR_MAX __FC_INT_MAX // To be defined in coordination with wchar.h which is currently unsupported #define __WCHAR_T int #define __FC_WINT_MIN __FC_INT_MIN #define __FC_WINT_MAX __FC_INT_MAX /* stdio.h */ #define __FC_BUFSIZ 8192 #define __FC_EOF (-1) #define __FC_FOPEN_MAX 512 #define __FC_FILENAME_MAX 2048 #define __FC_L_tmpnam 2048 #define __FC_TMP_MAX 0xFFFFFFFF /* stdlib.h */ #define __FC_RAND_MAX 32767 #define __FC_MB_CUR_MAX ((size_t)16) /* errno.h */ #define __FC_EDOM 1 #define __FC_EILSEQ 2 #define __FC_ERANGE 3 #define __FC_E2BIG 4 #define __FC_EACCES 5 #define __FC_EADDRINUSE 6 #define __FC_EADDRNOTAVAIL 7 #define __FC_EAFNOSUPPORT 8 #define __FC_EAGAIN 9 #define __FC_EALREADY 10 #define __FC_EBADE 11 #define __FC_EBADF 12 #define __FC_EBADFD 13 #define __FC_EBADMSG 14 #define __FC_EBADR 15 #define __FC_EBADRQC 16 #define __FC_EBADSLT 17 #define __FC_EBUSY 18 #define __FC_ECANCELED 19 #define __FC_ECHILD 20 #define __FC_ECHRNG 21 #define __FC_ECOMM 22 #define __FC_ECONNABORTED 23 #define __FC_ECONNREFUSED 24 #define __FC_ECONNRESET 25 #define __FC_EDEADLK 26 #define __FC_EDEADLOCK 27 #define __FC_EDESTADDRREQ 28 #define __FC_EDQUOT 29 #define __FC_EEXIST 30 #define __FC_EFAULT 31 #define __FC_EFBIG 32 #define __FC_EHOSTDOWN 33 #define __FC_EHOSTUNREACH 34 #define __FC_EIDRM 35 #define __FC_EINPROGRESS 36 #define __FC_EINTR 37 #define __FC_EINVAL 38 #define __FC_EIO 39 #define __FC_EISCONN 40 #define __FC_EISDIR 41 #define __FC_EISNAM 42 #define __FC_EKEYEXPIRED 43 #define __FC_EKEYREJECTED 44 #define __FC_EKEYREVOKED 45 #define __FC_EL2HLT 46 #define __FC_EL2NSYNC 47 #define __FC_EL3HLT 48 #define __FC_EL3RST 49 #define __FC_ELIBACC 50 #define __FC_ELIBBAD 51 #define __FC_ELIBMAX 52 #define __FC_ELIBSCN 53 #define __FC_ELIBEXEC 54 #define __FC_ELOOP 55 #define __FC_EMEDIUMTYPE 56 #define __FC_EMFILE 57 #define __FC_EMLINK 58 #define __FC_EMSGSIZE 59 #define __FC_EMULTIHOP 60 #define __FC_ENAMETOOLONG 61 #define __FC_ENETDOWN 62 #define __FC_ENETRESET 63 #define __FC_ENETUNREACH 64 #define __FC_ENFILE 65 #define __FC_ENOBUFS 66 #define __FC_ENODATA 67 #define __FC_ENODEV 68 #define __FC_ENOENT 69 #define __FC_ENOEXEC 70 #define __FC_ENOKEY 71 #define __FC_ENOLCK 72 #define __FC_ENOLINK 73 #define __FC_ENOMEDIUM 74 #define __FC_ENOMEM 75 #define __FC_ENOMSG 76 #define __FC_ENONET 77 #define __FC_ENOPKG 78 #define __FC_ENOPROTOOPT 79 #define __FC_ENOSPC 80 #define __FC_ENOSR 81 #define __FC_ENOSTR 82 #define __FC_ENOSYS 83 #define __FC_ENOTBLK 84 #define __FC_ENOTCONN 85 #define __FC_ENOTDIR 86 #define __FC_ENOTEMPTY 87 #define __FC_ENOTSOCK 88 #define __FC_ENOTSUP 89 #define __FC_ENOTTY 90 #define __FC_ENOTUNIQ 91 #define __FC_ENXIO 92 #define __FC_EOPNOTSUPP 93 #define __FC_EOVERFLOW 94 #define __FC_EPERM 95 #define __FC_EPFNOSUPPORT 96 #define __FC_EPIPE 97 #define __FC_EPROTO 98 #define __FC_EPROTONOSUPPORT 99 #define __FC_EPROTOTYPE 100 #define __FC_EREMCHG 101 #define __FC_EREMOTE 102 #define __FC_EREMOTEIO 103 #define __FC_ERESTART 104 #define __FC_EROFS 105 #define __FC_ESHUTDOWN 106 #define __FC_ESPIPE 107 #define __FC_ESOCKTNOSUPPORT 108 #define __FC_ESRCH 109 #define __FC_ESTALE 110 #define __FC_ESTRPIPE 111 #define __FC_ETIME 112 #define __FC_ETIMEDOUT 113 #define __FC_ETXTBSY 114 #define __FC_EUCLEAN 115 #define __FC_EUNATCH 116 #define __FC_EUSERS 117 #define __FC_EWOULDBLOCK 118 #define __FC_EXDEV 119 #define __FC_EXFULL 120 /* sys/un.h */ #define __FC_SOCKADDR_SUN_SUN_PATH 108 #endif frama-c-Fluorine-20130601/share/libc/assert.c0000644000175000017500000000226412155630243017462 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "__fc_builtin.h" #include "assert.h" __attribute__ ((__noreturn__)) void __FC_abort (void) { Frama_C_abort (); } void __FC_assert(const char* file,int line,const char*expr) { Frama_C_show_each_warning("Assertion may fail",file,line,expr); Frama_C_abort (); } frama-c-Fluorine-20130601/share/libc/byteswap.h0000644000175000017500000001252012155630243020020 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* Copyright (C) 1997 Free Software Foundation, Inc. This file is part of the GNU C Library. The GNU C Library is free software; 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; either version 2.1 of the License, or (at your option) any later version. The GNU C Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with the GNU C Library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. */ #ifndef _BYTESWAP_H #define _BYTESWAP_H 1 /* Get the machine specific, optimized definitions. */ //#include /* Swap bytes in 16 bit value. */ #define __bswap_constant_16(x) \ ((((x) >> 8) & 0xff) | (((x) & 0xff) << 8)) /* This is better than nothing. */ # define __bswap_16(x) \ (__extension__ \ ({ register unsigned short int __x = (x); __bswap_constant_16 (__x); })) /* Swap bytes in 32 bit value. */ #define __bswap_constant_32(x) \ ((((x) & 0xff000000) >> 24) | (((x) & 0x00ff0000) >> 8) | \ (((x) & 0x0000ff00) << 8) | (((x) & 0x000000ff) << 24)) # define __bswap_32(x) \ (__extension__ \ ({ register unsigned int __x = (x); __bswap_constant_32 (__x); })) /* Swap bytes in 64 bit value. */ # define __bswap_constant_64(x) \ ((((x) & 0xff00000000000000ull) >> 56) \ | (((x) & 0x00ff000000000000ull) >> 40) \ | (((x) & 0x0000ff0000000000ull) >> 24) \ | (((x) & 0x000000ff00000000ull) >> 8) \ | (((x) & 0x00000000ff000000ull) << 8) \ | (((x) & 0x0000000000ff0000ull) << 24) \ | (((x) & 0x000000000000ff00ull) << 40) \ | (((x) & 0x00000000000000ffull) << 56)) # define __bswap_64(x) \ (__extension__ \ ({ union { __extension__ unsigned long long int __ll; \ unsigned int __l[2]; } __w, __r; \ if (__builtin_constant_p (x)) \ __r.__ll = __bswap_constant_64 (x); \ else \ { \ __w.__ll = (x); \ __r.__l[0] = __bswap_32 (__w.__l[1]); \ __r.__l[1] = __bswap_32 (__w.__l[0]); \ } \ __r.__ll; })) /* The following definitions must all be macros since otherwise some of the possible optimizations are not possible. */ /* Return a value with all bytes in the 16 bit argument swapped. */ #define bswap_16(x) __bswap_16 (x) /* Return a value with all bytes in the 32 bit argument swapped. */ #define bswap_32(x) __bswap_32 (x) #if defined __GNUC__ && __GNUC__ >= 2 /* Return a value with all bytes in the 64 bit argument swapped. */ # define bswap_64(x) __bswap_64 (x) #endif #endif /* byteswap.h */ frama-c-Fluorine-20130601/share/libc/locale.h0000644000175000017500000001177312155630243017432 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_LOCALE #define __FC_LOCALE /* Structure giving information about numeric and monetary notation. */ struct lconv { /* Numeric (non-monetary) information. */ char *decimal_point; /* Decimal point character. */ char *thousands_sep; /* Thousands separator. */ /* Each element is the number of digits in each group; elements with higher indices are farther left. An element with value CHAR_MAX means that no further grouping is done. An element with value 0 means that the previous element is used for all groups farther left. */ char *grouping; /* Monetary information. */ /* First three chars are a currency symbol from ISO 4217. Fourth char is the separator. Fifth char is '\0'. */ char *int_curr_symbol; char *currency_symbol; /* Local currency symbol. */ char *mon_decimal_point; /* Decimal point character. */ char *mon_thousands_sep; /* Thousands separator. */ char *mon_grouping; /* Like `grouping' element (above). */ char *positive_sign; /* Sign for positive values. */ char *negative_sign; /* Sign for negative values. */ char int_frac_digits; /* Int'l fractional digits. */ char frac_digits; /* Local fractional digits. */ /* 1 if currency_symbol precedes a positive value, 0 if succeeds. */ char p_cs_precedes; /* 1 iff a space separates currency_symbol from a positive value. */ char p_sep_by_space; /* 1 if currency_symbol precedes a negative value, 0 if succeeds. */ char n_cs_precedes; /* 1 iff a space separates currency_symbol from a negative value. */ char n_sep_by_space; /* Positive and negative sign positions: 0 Parentheses surround the quantity and currency_symbol. 1 The sign string precedes the quantity and currency_symbol. 2 The sign string follows the quantity and currency_symbol. 3 The sign string immediately precedes the currency_symbol. 4 The sign string immediately follows the currency_symbol. */ char p_sign_posn; char n_sign_posn; /* 1 if int_curr_symbol precedes a positive value, 0 if succeeds. */ char int_p_cs_precedes; /* 1 iff a space separates int_curr_symbol from a positive value. */ char int_p_sep_by_space; /* 1 if int_curr_symbol precedes a negative value, 0 if succeeds. */ char int_n_cs_precedes; /* 1 iff a space separates int_curr_symbol from a negative value. */ char int_n_sep_by_space; /* Positive and negative sign positions: 0 Parentheses surround the quantity and int_curr_symbol. 1 The sign string precedes the quantity and int_curr_symbol. 2 The sign string follows the quantity and int_curr_symbol. 3 The sign string immediately precedes the int_curr_symbol. 4 The sign string immediately follows the int_curr_symbol. */ char int_p_sign_posn; char int_n_sign_posn; }; #include "__fc_define_null.h" #define LC_ALL 0 #define LC_COLLATE 1 #define LC_CTYPE 2 #define LC_MONETARY 3 #define LC_NUMERIC 4 #define LC_TIME 5 extern struct lconv* __frama_c_locale; extern char*__frama_c_locale_names[]; /*@ requires \valid(locale); assigns __frama_c_locale \from category, locale[..]; assigns \result \from __frama_c_locale,category, locale[..]; ensures \result==\null || (\valid(\result) && \exists ℤ i ; \result == __frama_c_locale_names[i]) ; */ extern char *setlocale(int category, const char *locale); /*@ assigns \nothing; ensures \result == __frama_c_locale; */ extern struct lconv *localeconv(void); #endif frama-c-Fluorine-20130601/share/libc/pwd.c0000644000175000017500000000166112155630243016753 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ #include "pwd.h" frama-c-Fluorine-20130601/share/libc/stdbool.h0000644000175000017500000000334012155630243017630 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_STDBOOL #define __FC_STDBOOL #define bool _Bool #define true 1 #define false 0 #define __bool_true_false_are_defined 1 #endif frama-c-Fluorine-20130601/share/libc/wctype.c0000644000175000017500000000174612155630243017500 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat à l'énergie atomique et aux énergies */ /* alternatives) */ /* */ /* All rights reserved. */ /* Contact CEA LIST for licensing. */ /* */ /**************************************************************************/ /* ISO C: 7.26 */ // wctype.h not supported yet //#include "wctype.h" frama-c-Fluorine-20130601/share/libc/__fc_builtin_for_normalization.i0000644000175000017500000000502012155630243024410 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ // Functions used internally by the normalization phase. // This file is systematically included by Frama-C's kernel. // FC's code normalization can use some of the functions declared here. // If you add something here, be sure to use the FC_BUILTIN attribute, // that will ensure that the builtin is printed iff it is actually used // in the normalized code. /*@ requires \valid(dest+(0..n-1)); assigns dest[0..n-1] \from \nothing; ensures \forall integer i; 0<= i < n ==> dest[i] == 0; */ void Frama_C_bzero(unsigned char* dest, unsigned long n) __attribute__((FC_BUILTIN)) ; /*@ requires \valid(dest+(0..(size*n-1))); requires n >= 1; assigns dest[size..(size*n -1)] \from dest[0..size-1]; ensures \forall integer i,j; 0<=i dest[i+j*size] == dest[i]; */ void Frama_C_copy_block(unsigned char* dest, unsigned long size, unsigned long n) __attribute__((FC_BUILTIN)) ; frama-c-Fluorine-20130601/share/libc/__fc_define_id_t.h0000644000175000017500000000325212155630243021363 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_DEFINE_ID_T #define __FC_DEFINE_ID_T typedef unsigned int id_t; #endif frama-c-Fluorine-20130601/share/libc/glob.h0000644000175000017500000000634112155630243017111 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifndef __FC_GLOB_H #define __FC_GLOB_H #include "__fc_machdep.h" #define GLOB_ERR (1 << 0)/* Return on read errors. */ #define GLOB_MARK (1 << 1)/* Append a slash to each name. */ #define GLOB_NOSORT (1 << 2)/* Don't sort the names. */ #define GLOB_DOOFFS (1 << 3)/* Insert PGLOB->gl_offs NULLs. */ #define GLOB_NOCHECK (1 << 4)/* If nothing matches, return the pattern. */ #define GLOB_APPEND (1 << 5)/* Append to results of a previous call. */ #define GLOB_NOESCAPE (1 << 6)/* Backslashes don't quote metacharacters. */ #define GLOB_PERIOD (1 << 7)/* Leading `.' can be matched by metachars. */ #define GLOB_NOSPACE 1 /* Ran out of memory. */ #define GLOB_ABORTED 2 /* Read error. */ #define GLOB_NOMATCH 3 /* No matches found. */ #define GLOB_NOSYS 4 /* Not implemented. */ typedef struct { __SIZE_T gl_pathc; /* Count of paths matched by the pattern. */ char **gl_pathv; /* List of matched pathnames. */ __SIZE_T gl_offs; /* Slots to reserve in `gl_pathv'. */ int gl_flags; /* Set to FLAGS, maybe | GLOB_MAGCHAR. */ /* If the GLOB_ALTDIRFUNC flag is set, the following functions are used instead of the normal file access functions. */ void (*gl_closedir) (void *); #ifdef __USE_GNU struct dirent *(*gl_readdir) (void *); #else void *(*gl_readdir) (void *); #endif void *(*gl_opendir) (__const char *); #ifdef __USE_GNU int (*gl_lstat) (__const char *__restrict, struct stat *__restrict); int (*gl_stat) (__const char *__restrict, struct stat *__restrict); #else int (*gl_lstat) (__const char *__restrict, void *__restrict); int (*gl_stat) (__const char *__restrict, void *__restrict); #endif } glob_t; #endif frama-c-Fluorine-20130601/share/unmark.png0000644000175000017500000000172412155630244017110 0ustar mehdimehdiPNG  IHDRa;iCCPICC ProfilexKhP)B%>ЊPi֑q"4sgM31HAZ*BPp BkQq"B7R&L*V/$rUScE4`λɮvxUA5R'}V>PeIƊmKbyo5.Fl[%Wɼdc(&;F'AA^ `36jr2NdhdeQnM<%iF~YƕkE/+ Z_5+-Ϥ?vlSCs=0sTuTeܢea+ 79Z|U ps_.?g"np)9]3;6vG+nhnR.Os'ܢH7c*pZ{{"焷{tD3ɍ{sO7Tw鳭8Ej"u`G<$xŃ2o?ڗ Ӟ{N2~q4#h;Fѿ^/4T<#QqefY(˚mBa^AO^Y.c_/{4C\OLMd<ٵH&|s/>z~q6\ k`Ҳ䍐.&\xGIBQ(bC4,Hq6,IENDB`frama-c-Fluorine-20130601/share/math.h0000644000175000017500000000327312155630244016210 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2012 */ /* 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). */ /* */ /**************************************************************************/ /* $Id: math.h,v 1.7 2008-06-26 07:46:00 uid568 Exp $ */ double cos (double x); double sqrt (double x); frama-c-Fluorine-20130601/share/frama-c.WIN32.rc0000644000175000017500000000346712155630244017550 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## # Default font for all widgets The first exisiting font is used. style "general" { font_name = "Sans" } widget "*" style "general" # Style for widgets displaying source code. style "monospace" { font_name = "Sans" } widget "*source" style "monospace" frama-c-Fluorine-20130601/share/builtin.c0000644000175000017500000000550212155630244016715 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2012 */ /* 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). */ /* */ /**************************************************************************/ /* $Id: builtin.c,v 1.16 2008-11-21 09:19:53 uid527 Exp $ */ int Frama_C_entropy_source; //@ assigns Frama_C_entropy_source \from Frama_C_entropy_source; void Frama_C_update_entropy(void); int Frama_C_nondet(int a, int b) { Frama_C_update_entropy(); return Frama_C_entropy_source ? a : b; } void *Frama_C_nondet_ptr(void *a, void *b) { return (void*) Frama_C_nondet((int)a, (int)b); } int Frama_C_interval(int min, int max) { int r,aux; Frama_C_update_entropy(); aux = Frama_C_entropy_source; if ((aux>=min) && (aux <=max)) r = aux; else r = min; return r; } float Frama_C_float_interval(float min, float max) { Frama_C_update_entropy(); return Frama_C_entropy_source ? min : max; } double Frama_C_double_interval(double min, double max) { Frama_C_update_entropy(); return Frama_C_entropy_source ? min : max; } #if 0 static int ex1, ex2; static int *ex3; static float f; void Frama_C_builtin_examples(void) { /* non-determinist choice between two integers */ ex1 = Frama_C_nondet(17, 42); /* non-determinist choice between two pointers */ ex3 = Frama_C_nondet_ptr(&ex1, &ex2); /* integers interval */ ex2 = Frama_C_interval(17, 42); /* floats interval */ f = Frama_C_float_interval(1.0, 5.0); } #endif frama-c-Fluorine-20130601/share/frama-c.Unix.rc0000644000175000017500000000450712155630244017665 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## # Default font for all widgets The first exisiting font is used. style "general 1" { font_name = "DejaVu Sans" } style "general 2" { font_name = "Lucida Sans Unicode" } style "general 3" { font_name = "Sans" } widget "*" style "general 3" widget "*" style "general 2" widget "*" style "general 1" # Style for widgets displaying source code. The first exisiting font is used. style "monospace 1" { font_name = "Menlo" } style "monospace 2" { font_name = "DejaVu Sans Mono" } style "monospace 3" { font_name = "Lucida Sans Mono Unicode" } style "monospace 4" { font_name = "Monospace" } widget "*source" style "monospace 4" widget "*source" style "monospace 3" widget "*source" style "monospace 2" #widget "*source" style "monospace 1" frama-c-Fluorine-20130601/share/libc.h0000644000175000017500000000415112155630244016164 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2012 */ /* 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). */ /* */ /**************************************************************************/ #ifndef FRAMA_C_LIBC_H_ #define FRAMA_C_LIBC_H_ #include "machine.h" void* memcpy(void* region1, const void* region2, size_t n); void* memset (void* dest, int val, size_t len); int strcmp(const char *s1, const char *s2); char* strcat(char *s1, const char *s2); char* strcpy(char *s1, const char *s2); char* strncpy(char *s1, const char *s2, size_t n); int strncmp(const char *s1, const char *s2, size_t n); size_t strlen(const char *s); int memcmp(const void *s1, const void *s2, size_t n); int atoi(const char *p); #endif frama-c-Fluorine-20130601/share/Makefile.config.in0000644000175000017500000001244412155630244020417 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## ########################################################################## # # # Define variables from configure. # # These variables may be redefined later. # # # ########################################################################## ####################### # Working directories # ####################### FRAMAC_TOP_SRCDIR ?= @abs_top_srcdir@ ###################### # Installation paths # ###################### DESTDIR ?= prefix ?=@prefix@ exec_prefix ?=@exec_prefix@ datarootdir ?=@datarootdir@ datadir ?=@datadir@ BINDIR ?="$(DESTDIR)@bindir@" LIBDIR ?="$(DESTDIR)@libdir@" DATADIR ?="$(DESTDIR)@datarootdir@" MANDIR ?="$(DESTDIR)@mandir@" FRAMAC_LIBDIR ?=$(LIBDIR)/frama-c FRAMAC_PLUGINDIR ?=$(FRAMAC_LIBDIR)/plugins FRAMAC_DATADIR ?=$(DATADIR)/frama-c EMACS_DATADIR ?=$(DATADIR)/emacs/site-lisp FRAMAC_DEFAULT_CPP ?=@FRAMAC_DEFAULT_CPP@ FC_MCPP ?=@FC_MCPP@ ############### # Ocaml stuff # ############### # compilers and others executables OCAMLC ?=@OCAMLC@ OCAMLOPT ?=@OCAMLOPT@ OCAMLDEP ?=@OCAMLDEP@ -slash OCAMLLEX ?=@OCAMLLEX@ OCAMLYACC ?=@OCAMLYACC@ OCAMLMKTOP ?=@OCAMLMKTOP@ OCAMLDOC ?=@OCAMLDOC@ OCAMLCP ?=@OCAMLCP@ # others ocaml stuffs # either -annot or -dtypes OCAML_ANNOT_OPTION ?=@OCAML_ANNOT_OPTION@ # ocaml stdlib path OCAMLLIB ?=@OCAMLLIB@ # either opt or byte OCAMLBEST ?=@OCAMLBEST@ OCAMLVERSION ?=@OCAMLVERSION@ NATIVE_DYNLINK ?=@HAS_NATIVE_DYNLINK@ USABLE_NATIVE_DYNLINK ?=@HAS_USABLE_NATIVE_DYNLINK@ OCAMLWIN32 ?=@OCAMLWIN32@ ############# # Libraries # ############# # ocamlgraph OCAMLGRAPH_INCLUDE?=@OCAMLGRAPH_INCLUDE@ # ocamlgraph compilation directive OCAMLGRAPH_LOCAL ?=@OCAMLGRAPH_LOCAL@ OCAMLGRAPH_HOME ?=@OCAMLGRAPH_HOME@ # lablgtk HAS_LABLGTK ?=@HAS_LABLGTK@ HAS_LABLGTK_CUSTOM_MODEL ?=@HAS_LABLGTK@ LABLGTK_PATH ?=@LABLGTK_PATH@ # lablgtksourceview HAS_GTKSOURCEVIEW ?=@HAS_GTKSOURCEVIEW@ # lablgnomecanvas HAS_GNOMECANVAS ?=@HAS_GNOMECANVAS@ # zarith HAS_ZARITH ?=@HAS_ZARITH@ ZARITH_PATH ?=@ZARITH_PATH@ ########################## # Miscellaneous commands # ########################## OTAGS ?=@OTAGS@ DOT ?=@DOT@ HAS_DOT ?=@HAS_DOT@ HEADACHE ?= headache -c $(FRAMAC_SRC)/headers/headache_config.txt ########################### # Miscellaneous variables # ########################### VERBOSEMAKE ?=@VERBOSEMAKE@ LOCAL_MACHDEP ?=@LOCAL_MACHDEP@ EXE ?=@EXE@ # Required by Cil UNDERSCORE_NAME ?=@UNDERSCORE_NAME@ HAVE_BUILTIN_VA_LIST ?=@HAVE_BUILTIN_VA_LIST@ THREAD_IS_KEYWORD ?=@THREAD_IS_KEYWORD@ ########################## # Variables for plug-ins # ########################## EXTERNAL_PLUGINS ?=@EXTERNAL_PLUGINS@ # Integrated plugins ENABLE_FROM_ANALYSIS ?=@ENABLE_FROM_ANALYSIS@ ENABLE_GUI ?=@ENABLE_GUI@ ENABLE_IMPACT ?=@ENABLE_IMPACT@ ENABLE_INOUT ?=@ENABLE_INOUT@ ENABLE_METRICS ?=@ENABLE_METRICS@ ENABLE_OCCURRENCE ?=@ENABLE_OCCURRENCE@ ENABLE_PDG ?=@ENABLE_PDG@ ENABLE_POSTDOMINATORS ?=@ENABLE_POSTDOMINATORS@ ENABLE_REPORT ?=@ENABLE_REPORT@ ENABLE_RTE_ANNOTATION ?=@ENABLE_RTE_ANNOTATION@ ENABLE_SCOPE ?=@ENABLE_SCOPE@ ENABLE_SEMANTIC_CALLGRAPH ?=@ENABLE_SEMANTIC_CALLGRAPH@ ENABLE_SEMANTIC_CONSTANT_FOLDING ?=@ENABLE_SEMANTIC_CONSTANT_FOLDING@ ENABLE_SLICING ?=@ENABLE_SLICING@ ENABLE_SPARECODE ?=@ENABLE_SPARECODE@ ENABLE_SYNTACTIC_CALLGRAPH ?=@ENABLE_SYNTACTIC_CALLGRAPH@ ENABLE_USERS ?=@ENABLE_USERS@ ENABLE_VALUE_ANALYSIS ?=@ENABLE_VALUE_ANALYSIS@ frama-c-Fluorine-20130601/share/Makefile.dynamic0000644000175000017500000002252412155630244020171 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## PLUGIN_ENABLE ?=yes PLUGIN_DIR ?=. FRAMAC_SRC ?=$(PLUGIN_DIR)/../.. FRAMAC_MAKE ?=no ifndef MAKECONFIG_DIR MAKECONFIG_DIR :=$(FRAMAC_SHARE) endif ifndef PLUGIN_DYNAMIC PLUGIN_DYNAMIC :=yes endif ifeq ($(NATIVE_DYNLINK),no) USABLE_NATIVE_DYNLINK ?=no endif #Do not generate documentation for this. PLUGIN_UNDOC:=$(PLUGIN_UNDOC) ptests_local_config.ml ifeq ($(FRAMAC_MAKE),yes) PLUGIN_RESET :=yes .PHONY: $(PLUGIN_DIR)/TESTS $(PLUGIN_NAME)_TESTS $(PLUGIN_NAME)_TESTS: $(PLUGIN_DIR)/TESTS $(PLUGIN_DIR)/TESTS: $(call external_make, $(dir $@), tests) else PLUGIN_RESET :=no include $(MAKECONFIG_DIR)/Makefile.common include $(MAKECONFIG_DIR)/Makefile.dynamic_config #special goal for use by frama-c's main Makefile. run_tests: ifndef PLUGIN_NO_DEFAULT_TEST ifndef PLUGIN_NO_TEST true else false endif # PLUGIN_NO_TEST else false endif #PLUGIN_NO_DEFAULT_TEST ifeq ($(PLUGIN_ENABLE),no) tests:: doc:: else .PHONY: plugin-doc/$(PLUGIN_NAME) ifneq ($(FRAMAC_INTERNAL),yes) plugin-doc/$(PLUGIN_NAME): if test ! -e $(DOC_DIR)/kernel-doc.ocamldoc; then \ echo "Frama-C kernel was not installed with code documentation \ support. Cannot compile API documentation. To install it, run 'make doc \ install-doc-code' in Frama-C's main directory"; \ exit 1; \ fi $(MKDIR) $($(@:plugin-doc/%=%_DOC_DIR)) else ifeq ($(FRAMAC_MAKE),yes) plugin-doc/$(PLUGIN_NAME): : else plugin-doc/$(PLUGIN_NAME): $(MKDIR) $($(@:plugin-doc/%=%_DOC_DIR)) endif endif doc:: plugin-doc/$(PLUGIN_NAME) $(PLUGIN_NAME)_DOC clean-doc:: $(PLUGIN_DIR)/$(PLUGIN_NAME)_CLEAN_DOC ifneq ($(FRAMAC_MAKE),yes) install-doc-code:: $(PLUGIN_NAME)_INSTALL_DOC endif $(PLUGIN_NAME)_INSTALL_DOC: plugin-doc/$(PLUGIN_NAME) $(PRINT_CP) $(patsubst %_INSTALL_DOC,%,$@) Documentation $(MKDIR) $(FRAMAC_SHARE)/doc/code/$(@:%_INSTALL_DOC=%) $(CP) $(patsubst %,"%", \ $(wildcard $($(@:%_INSTALL_DOC=%_DOC_DIR))/*.css \ $($(@:%_INSTALL_DOC=%_DOC_DIR))/*.html \ $($(@:%_INSTALL_DOC=%_DOC_DIR))/*.png)) \ $(FRAMAC_SHARE)/doc/code/$(@:%_INSTALL_DOC=%) ifndef PLUGIN_INTERNAL_TEST ifndef PLUGIN_NO_TEST PTESTS_DEP=$(PLUGIN_DIR)/Makefile ifeq ($(FRAMAC_INTERNAL),yes) $(PLUGIN_DIR)/ptests_local_config.cmo: BFLAGS=-I $(FRAMAC_SRC)/ptests -g $(PLUGIN_DIR)/ptests_local_config.cmo: $(FRAMAC_SRC)/bin/ptests.byte PTESTS_DEP+=$(FRAMAC_SHARE)/Makefile.dynamic \ $(FRAMAC_SHARE)/Makefile.dynamic_config else $(PLUGIN_DIR)/ptests_local_config.cmo: BFLAGS=$(FRAMAC_INCLUDES) endif #FRAMAC_INTERNAL $(PLUGIN_DIR)/ptests_local_config.ml: $(PTESTS_DEP) $(PRINT_MAKING) $@ $(CHMOD_RW) $@ $(ECHO) \ "Ptests_config.default_suites:= [" $(PLUGIN_TESTS_DIRS:%='"%";') "];;" > $@ if test "$(USABLE_NATIVE_DYNLINK)" = "yes" \ -o "$(FRAMAC_INTERNAL)" = "yes"; then \ $(ECHO) \ "Ptests_config.toplevel_path :=\"$(FRAMAC_OPT)\";;" >> $@; \ else \ $(ECHO) "Ptests_config.toplevel_path :=" >> $@; \ $(ECHO) " Filename.concat Filename.current_dir_name" >> $@; \ $(ECHO) " \"frama-c-$(PLUGIN_NAME).$(OCAMLBEST)$(EXE)\";;" >> $@; \ fi $(ECHO) \ "Ptests_config.framac_share :=\"$(FRAMAC_SHARE)\";;" >> $@ $(ECHO) \ "Ptests_config.framac_plugin :=\"$(PLUGIN_LIB_DIR)\";;" >> $@ $(ECHO) \ "Ptests_config.framac_plugin_gui :=\"$(PLUGIN_GUI_LIB_DIR)\";;" >> $@ $(ECHO) \ "Ptests_config.framac_lib :=\"$(FRAMAC_LIB)\";;" >> $@ $(CHMOD_RO) $@ $(PLUGIN_NAME)_PTESTS_OPTS:=$(PLUGIN_PTESTS_OPTS) .PHONY: plugin-test/$(PLUGIN_NAME) plugin-test/$(PLUGIN_NAME): $(TARGETS) $(TARGETS_GUI) \ $(PLUGIN_DIR)/ptests_local_config.cmo $(PRINT) TESTING PLUG-IN $(notdir $@) cd $($(notdir $@)_DIR) && \ time -p $(PTESTS) $(PTESTS_OPTS) $($(notdir $@)_PTESTS_OPTS) tests:: plugin-test/$(PLUGIN_NAME) else tests:: endif #PLUGIN_NO_TEST else tests:: endif #PLUGIN_INTERNAL_TEST endif #PLUGIN_ENABLE endif #FRAMAC_MAKE PLUGIN_LIB_DIR ?= $(PLUGIN_DIR) PLUGIN_GUI_LIB_DIR ?= $(PLUGIN_DIR)/gui PLUGIN_INSTALL_DIR ?=$(DESTDIR)$(FRAMAC_PLUGINDIR) PLUGIN_FLAGS:=$(FLAGS) $(DEBUG) $(FRAMAC_INCLUDES) $(OCAMLGRAPH_INCLUDE) PLUGIN_BFLAGS:=$(PLUGIN_FLAGS) $(PLUGIN_BFLAGS) PLUGIN_OFLAGS:=$(PLUGIN_FLAGS) $(PLUGIN_OFLAGS) ifeq ($(FRAMAC_INTERNAL),yes) PLUGIN_DEPFLAGS:=$(PLUGIN_DEPFLAGS) ifneq ($(FRAMAC_MAKE),yes) PLUGIN_DOC_DIR:=$(PLUGIN_DIR)/doc/code endif else PLUGIN_DEPFLAGS:=$(FRAMAC_INCLUDES) $(PLUGIN_DEPFLAGS) PLUGIN_DOC_DIR:=$(PLUGIN_DIR)/doc/code endif PLUGIN_DOCFLAGS:=$(FRAMAC_INCLUDES) $(PLUGIN_DOCFLAGS) include $(MAKECONFIG_DIR)/Makefile.plugin TARGETS := $(TARGET_CMI) $(TARGET_CMO) $(TARGET_CMA) $(TARGET_CMXS) TARGETS_GUI := $(TARGET_GUI_CMI) $(TARGET_GUI_CMO) $(TARGET_GUI_CMX) $(TARGET_GUI_CMXS) TARGETS_BYTE:= $(TARGET_CMI) $(TARGET_CMO) $(TARGET_CMA) TARGETS_OPT:=$(TARGET_CMI) $(TARGET_CMX) $(TARGET_CMXS) include $(MAKECONFIG_DIR)/Makefile.kernel byte:: $(TARGETS_BYTE) opt:: $(TARGETS_OPT) gui:: $(TARGETS_GUI) # do not define additional targets if you come from the Frama-C Makefile ifneq ($(FRAMAC_MAKE),yes) ########## # Zarith # ########## ifeq ($(HAS_ZARITH),yes) ZARITH_INCLUDES= -I $(ZARITH_PATH) endif $(PLUGIN_DIR)/frama-c-$(PLUGIN_NAME).byte$(EXE): $(TARGET_CMO) $(PRINT_LINKING) $@ $(OCAMLC) $(PLUGIN_LINK_BFLAGS) $(DYN_BLINKFLAGS) $(ZARITH_INCLUDES) \ -o $@ $(DYN_BYTE_LIBS) $(DYN_GEN_BYTE_LIBS) \ $(patsubst %boot.cmo, $(PLUGIN_EXTRA_BYTE) $(TARGET_CMO) %boot.cmo, \ $(DYN_ALL_BATCH_CMO)) $(PLUGIN_DIR)/frama-c-$(PLUGIN_NAME).opt$(EXE): $(TARGET_CMX) $(PRINT_LINKING) $@ $(OCAMLOPT) $(PLUGIN_LINK_OFLAGS) $(DYN_OLINKFLAGS) $(ZARITH_INCLUDES) \ -o $@ $(DYN_OPT_LIBS) $(DYN_GEN_OPT_LIBS) \ $(patsubst %boot.cmx, $(PLUGIN_EXTRA_OPT) $(TARGET_CMX) %boot.cmx, \ $(DYN_ALL_BATCH_CMX)) static.byte:: $(PLUGIN_DIR)/frama-c-$(PLUGIN_NAME).byte$(EXE) static.opt:: $(PLUGIN_DIR)/frama-c-$(PLUGIN_NAME).opt$(EXE) static:: $(PLUGIN_DIR)/frama-c-$(PLUGIN_NAME).byte$(EXE) \ $(PLUGIN_DIR)/frama-c-$(PLUGIN_NAME).$(OCAMLBEST)$(EXE) .PHONY: tests all install uninstall clean depend $(PLUGIN_NAME)_CLEAN_DYNAMIC clean:: $(PLUGIN_NAME)_CLEAN_DYNAMIC $(PLUGIN_NAME)_CLEAN_DYNAMIC: $(RM) $($(patsubst %_CLEAN_DYNAMIC,%_DIR,$@))/ptests_local_config.ml $(RM) frama-c-$($(patsubst %_CLEAN_DYNAMIC,,$@)) \ frama-c-$($(patsubst %_CLEAN_DYNAMIC,,$@)).byte ifneq ($(FRAMAC_MAKE),yes) dist-clean distclean: $(PLUGIN_DIR)/$(PLUGIN_NAME)_DIST_CLEAN endif ifeq ($(USABLE_NATIVE_DYNLINK),no) STATIC=static else STATIC= endif all:: $(PLUGIN_DIR)/.depend byte $(OCAMLBEST) gui $(STATIC) ifneq ($(PLUGIN_ENABLE),no) install:: $(PRINT_CP) $(PLUGIN_INSTALL_DIR) $(MKDIR) $(PLUGIN_INSTALL_DIR) $(CP) $(TARGETS) $(PLUGIN_INSTALL_DIR) $(PRINT_CP) $(BINDIR) if [ -f frama-c-$(PLUGIN_NAME).byte$(EXE) ]; then \ $(CP) frama-c-$(PLUGIN_NAME).byte$(EXE) $(BINDIR); \ fi if [ -f frama-c-$(PLUGIN_NAME).$(OCAMLBEST)$(EXE) ]; then \ $(CP) frama-c-$(PLUGIN_NAME).$(OCAMLBEST)$(EXE) \ $(BINDIR)/frama-c-$(PLUGIN_NAME)$(EXE); \ fi ifeq ($(HAS_GUI),yes) $(PRINT_CP) $(PLUGIN_INSTALL_DIR)/gui $(MKDIR) $(PLUGIN_INSTALL_DIR)/gui $(CP) $(TARGETS_GUI) $(PLUGIN_INSTALL_DIR)/gui endif uninstall:: $(PRINT_RM) installed $(PLUGIN_NAME) libraries $(RM) $(PLUGIN_INSTALL_DIR)/$(PLUGIN_NAME).* $(PRINT_RM) installed $(PLUGIN_NAME) binaries $(RM) $(BINDIR)/frama-c-$(PLUGIN_NAME).opt$(EXE) \ $(BINDIR)/frama-c-$(PLUGIN_NAME).byte$(EXE) ifeq ($(HAS_GUI),yes) $(PRINT_RM) installed $(PLUGIN_NAME)/gui $(RM) $(PLUGIN_INSTALL_DIR)/gui/$(PLUGIN_NAME).* endif endif # PLUGIN_ENABLE <> no clean:: $(PLUGIN_DIR)/$(PLUGIN_NAME)_CLEAN; $(PLUGIN_DIR)/.depend: $(PLUGIN_DIR)/$(PLUGIN_NAME)_DEP depend:: $(PLUGIN_DIR)/$(PLUGIN_NAME)_DEP_REDO .PRECIOUS: $(PLUGIN_DIR)/.depend include $(PLUGIN_DIR)/.depend endif # FRAMAC_MAKE <> yes PLUGIN_PTESTS_OPTS:= ############################################################################### # Local Variables: # mode: makefile # End: frama-c-Fluorine-20130601/share/math.c0000644000175000017500000000357012155630244016203 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2012 */ /* 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). */ /* */ /**************************************************************************/ /*@ assigns \result \from x; */ double Frama_C_cos(double x); /*@ assigns \result \from x; */ double Frama_C_sqrt(double x); /*@ assigns \result \from x; */ double cos(double x) { return Frama_C_cos(x); } /*@ assigns \result \from x; */ double sqrt(double x) { return Frama_C_sqrt(x); } frama-c-Fluorine-20130601/share/frama-c.ico0000644000175000017500000026024612155630244017115 0ustar mehdimehdihF@@ (B  G (~X(  G#I$K&L(M*O+P-R1U9\?`Qox~               (@ &U >*DR⏱ZMd`G{I}ffeDyCxCxCxCxCxCxCxyTCxCxCxmRCxCxCxCxCxCxCxCxCxCxCxCxCxCxCxJ}gTCxCxwp {\Bw4mlK~Sc7o[cG{4m4m4m4m4m4m4m;ry5m4m4m4m`Fz4m4m4m4m4mK}SSS6o4m4m4m4m4mmK}q:q4mGzK}4mR-aDw5l6mp6l:om5lM~g6m5l5l5l5l5l5l5lEwk5l5l5l5laGy5l5l5l5l5lI{RRQ7n5l5l5l5l;qi5l^Hz5l6l7n5l5l@vתQztd5lQonHz6mons[5l5l5l5l5l5l9o}8n5lUqxFx5l5l5l5l5l`qqo9o5l5l5l5lt5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5meN5m5m;qN5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mqUr6n5m5m5m5m5m5m5m iO4m5nG{L~6o4m4m4m4m4m4m4m4m4m4m4m4m4m4m4m4mte5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mWL~5m5m5m5m5m5m5m5m6nkBv5m5m5mj8;rSool7m_ooN~6m6m6m6m6m6m6mbY6m]oocGyoK|Y]FxoooBu9ojr^6mFyt6m6m6m6m6m6m6m6m@ug6m6m6m6mi8CH;r5mDxd6n5m6nq7o5m5m5m5m5m5m5m5mu?t5m6nQW6n5mq5mSS5m7oq7o5mJ|\7nAv5m5mxs;qke8o9ppvjGz6m@t{7m6m6m6m6m6m6m6m@ug6m6m6m6mj8t8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p9q9q:qwUpqX9sF|psT>wmpn\9setgx:u:u:u:u:u:uMvH@z>xgp_G~ztm@z;vdq];vg}nT;vPoWxrA{yz?{D~z]C}>z=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=ym8C>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>{@|E{]D~?|>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>z>zn8D?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|@}B~G{^FA}?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|o8E@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}A~BG|_GB~@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}n8FA~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~BCH}_GBA~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~o8FAAAAAAAAAAAAAAAAAAABDI}`HCBAAAAAAAAAAAAAAAAAAAAAAAo8HCCCCCCCCCCCCCCCCCDDEFK~cJEEDDCCCCCCCCCCCCCCCCCCCCCp8IDDDDDDDDDDDDDDDDEEFGJOdMIHGFFEDDDDDDDDDDDDDDDDDDDp8IDDDDDDDDDDDDDDDDEGHKNQhQMLJIGEDDDDDDDDDDDDDDDDDDDq8KFFFFFFFFFFFFFFFFGJIGFFFFFFFFFFFFFFFFFFFr8LGGGGGGGGGGGGGGGGHIZ^`cwb_^^\IHGGGGGGGGGGGGGGGGGGGs8MIIIIIIIIIIIIIIIIJJKLNRhQNMLKJJIIIIIIIIIIIIIIIIIIIs8NIIIIIIIIIIIIIIIIIJJKMQgPLKJJJIIIIIIIIIIIIIIIIIIIIs8PKKKKKKKKKKKKKKKKKKKLNQiQMLKKKKKKKKKKKKKKKKKKKKKKKt8QLLLLLLLLLLLLLLLLLLLLMQtiQMLLLLLLLLLLLLLLLLLLLLLLLLu8QMMMMMMMMMMMMMMMMMMMMOSbkSOMMMMMMMMMMMMMMMMMMMMMMMMv8RNNNNNNNNNNNNNNNNNNNNPSZkTPNNNNNNNNNNNNNNNNNNNNNNNNv8TPPPPPPPPPPPPPPPPPPPPPTZlUQPPPPPPPPPPPPPPPPPPPPPPPPw8UQQQQQQQQQQQQQQQQQQQQRTZmWSRTUUTRRQQQQQQQQQQQQQQQQQw8WRRRRRRRRRRRRRRRRRRRRSUZvYVWZhiZVTSRRRRRRRRRRRRRRRRx8WSSSSSSSSSSSSSSSSSSSSSUXc[X[\VTSSSSSSSSSSSSSSSSy8YUUUUUUUUUUUUUUUUUUUUUVX^][d[VUUUUUUUUUUUUUUUUy8[WWWWWWWWWWWWWWWWWWWWWWY\_]`\XWWWWWWWWWWWWWWWWz8aXXXXXXXXXXXXXXXXXXXXXXY[`b_`^ZXXXXXXXXXXXXXXXX(VpZZZZZZZZZZZZZZZZZZZZZZ[\_c}bbeii^\ZZZZZZZZZZZZZZZZ%\\\\\\\\\\\\\\\\\\\\\\\]^`gkla^]\\\\\\\\\\\\\\\^i]]]]]]]]]]]]]]]]]]]]]]]^`be{ca^]]]]]]]]]]]]]]]]Oc_______________________`abdeeedca``_______________p6raaaaaaaaaaaaaaaaaaaaaaaabbccccbaaaaaaaaaaaaaaaab ~zzzzzzzzzzzzzzzzzzzzzz{{{{{zzzzzzzzzzzzzzzW>DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD4 ??( @ dkkkkkkkrqkkkkkkkkkkc%YYVP]:r:r:r:rZ:rOAw:r:rH|J};r:r:r[OKafBvZXK}_?t5m5m9pU=s`s5m5m5m6mH{5mM|@ufDxbJ|5m5m5mM=sXZZNK}fGzVQ7oX5m5m5m?tM~5mN=|s6n>t;r6n6n6n6nEy6nO |;r8o8o8o8o8o8o8o9p:q=s\J|=s:q9p8o8o8o8o8o8o8o8o8oO|;t9s8r9r9s8r9r8r9s8r;s\H}9r8r8r8r8r8r8r9s8r8r8r8rP}I~lS]R]sH}bI~]zS:t:sWc\PRbM:s:sM~0}C{bLkKHcJhB{UgXz>z>z>z>z>z>z>z>z?{`L>z>z>z>z>z>z>z>z>z>z>z>zT~B~?|?|?|?|?|?|?|?|?|A}aN@|?|?|?|?|?|?|?|?|?|?|?|V~DA~A~A~A~A~A~A~A~A~CcPBA~A~A~A~A~A~A~A~A~A~A~VFCCCCCCCCEGfTGEDCCCCCCCCCXGEEEEEEEFgGEEEEEEEEEYJHHHHHHHILQo]QQIHHHHHHHHH\LJJJJJJJJJLiXKKJJJJJJJJJJ]NMMMMMMMMMM\ZMMMMMMMMMMMM`QOOOOOOOOOOV]PPPOOOOOOOOOaTRRRRRRRRRRVdTY[TRRRRRRRRdWUUUUUUUUUUX]eVUUUUUUUes[WWWWWWWWWWXf`qXWWWWWWWj n[[[[[[[[[[[]|t_[[[[[[[[_^^^^^^^^^^_`gb_^^^^^^^c mllllllllllmnnmllllllp!%%%%%%%%%%%%%%%%%%%%( $%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%)%%%5qurb5%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%$ Z]Y C̥ըR 79B cԞj_UNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNY{NNNNNNNbfNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNte{;kչ{J|5m5m5mI{o}yg>s5m5mJ|mnnnne6n5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mfDx5m5m5m5m5m5m5m>tV5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mXux]9p5m5m5m5mGzQ5mAvd٩TsrN5m5mO~iq|>s5mM~r}ssk7n5m5m5m5m5m5m5m5m5m5m5m5m5m5m:qn5m5m5m5m5m5m5m5m>tV5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mYzqf5m5m5m5m6n|x7n5m5m=tqyVzT5m5m5m5m6m|x9p5m5mI{e5m5m5mh{5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mGz[5m5m5m5m5m5m5m5m>tV5m5m5m5m5m5m5m5m5m5m5mGzabbbbb_9p5m5m5m5m5m5m5m5m5m5m6nzr8o5m`Ey5m5m5m5mI{OtV5m5m5m5m5m5m5m5m5m5m5m\}Dx5m5m5m5m5m5m5m5m5m5m?t\5m5mGzT5m5m5m5m5m5m5m5m5m5m5m5mZ` 8oAvT5m5m5m5m8oo5m5m5m>sk5m5m5mhV5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mSN5m5m5m5m5m5m5m5m>tV5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mGzM5m5m8o_5m5m5m5m5m5m5m5m5m5m5m5m5mi/kBxH{_iYXDx5m5mbkRYvJ}5m5mStkRkH{5m5m5m5m5m5m5m5m5m5m5m5m5mFy[5m5m5m5m7nUYY^V5m5m5m5m5m5m5m5m5m5m5mL~iiiiiigt5m5m5m5m5m5m7n)--j5mqh5m5m7oa|Q5m5m:qu|YzDx5m5m5m5m5m5m5m5m5m5m5m5m5m9pm5m5m5m5mCwV5m5m5m5m5m5m5m5m5m5m5mVwxxxxxtAv5m5m5m5m5m5m5m5m5m5m@uV5m5mAvY5m5m5m5mo~Bv5m5m5m5m5m5m5mT<```X?u5m7oGz\?t>s6n5m5m5m5ms5m;qGz6n5m5m5m5m5m5m5m5m5m5m5m5m5m5m5meCw5m5m5m5m;q?t?t?t?t9p5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m6nj5m5mUM~5m5m5m5m5m8o5m5m5m5m5m5m5m5m5m 5m5m5m5mpzadkP5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m@ug5m5m5m5m5m5mEyeN5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mag\~x6n5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mgשa5m5m5m5mDxf{~uK}5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mc{5m5m5m5m5m5mO^5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m8ojzDx5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mK~4+S5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m6n9p5m5m5m5m5m5m6m7o6n5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m;qDx6n5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m=sL/K~5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m`=Cy5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mn>Cx5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mp>Cx5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mp>Cx5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mp>Cx5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mp>Cx5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mYFz5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m6m^Au5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m=s\H{5m5m5m5m5m5m5m5mp>Cx5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mOX5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m8o}q5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mwU5m5m5m5m5m5m5m5mp>Cx5m5mCwH{H{H{H{H{Av5m5m9pGzH{H{H{H{?t5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5ms}:q5m5m8oGzH{H{H{H{Gz;q5m;rGzH{=s5m5mEyGz:p5m;qGzH{H{H{H{Gz8o5m5m5m7oJ|XO;r5m5m5m5m^J|5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mExP5m5m5m5m5m5m5m5m5mp>Cx5mBv8o5m_z5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mK}_5m5m5m]h5mku5mU^5mj[5m5m;q}a5m5m5mCx5m5mJ|M~_XM~Fz5m5mt5m?tryBv5m6mtu6n5m?tM~M~zqM~L};q5m5m[L~?tNa^5m5m5m5mj8o5m5m5m5m5m5m5m5m5m5m5m5m5m5m5m5mGzM~5m5m5m5m5m5m5m5m5mp+`6>Dx6m6m6m6mPFy6m6m6m6m6m6mnt6m6m6m6m6m6m6m6m6m6m6m6m6m6m6m6m6m6mm8n6m6m6m6m6m6mkx6m6m6m6m6mlv6m6m6mqq6m6m6m6m6mxk6m6m6m6m6md6m6m6m6m6m6m6m6m6m]Ex6m6m6m6m6m6m6m6m6m6m6m6m6m6m6m6m[J{6m6m6m6m6m6m6m6m6mp`#>Dx6m6m6m6mPFy6m6m6m6m6m6mnt6m6m6m6m6m6m6m6m6m6m6m6m6m6m6m6m6m6mvx6m6m6m7m7n7n7nky7n7n7n7n7nmw7n7n7nrr7n7n7n7n7nxl7m6m6m6m6md6m6m6m6m6m6m6m6m6mTO6m6m6m6m6m6m6m6m6m6m6m6m6m6m6mK|9o6m6m6m6m6m6m6m6m6mp`#>Dx6m6m6m6mPFy6m6m6m6m6m6mnt6m6m6m6m6m6m6m6m6m6m6m6m6m6m6m6m6m6mm7n7n7n7n8n8n8nly8o8o8o8o8onN~8o:p|i8o8n8n8n8nyl7n7n7n6m6md6m6m6m6m6m6m6m6m6m]Fx6m6m6m6m6m6m6m6m6m6m6m6m6m6m6m6m^J{6m6m6m6m6m6m6m6m6mp`#>Dx6m6mU~Fy6m6m6m6mN~}yDy6n6nEydee@u6n6n6n6nAvc{}ee`7o6n6n6n6n6n6n6n6n6n6n6n6n6n6nK}_8o9p:q:qXiidDy6n6n6n6n>t?u6n6n6n6n6n6n6nc}Cw;rCwBw6n6n6n6n6n6n6n6n6n6n6n6n6n6n7ns>s:q;rt?u@uAvBvBwBwBwBwAvAv@u?t>t>s=s@uEy@u;q:q9p8o7oe6n6n6n6n6n6n6n6n^M~6n6n6n6n6n6n6n6n6n6n6n6n6n6n6n6n6nDxV6n6n6n6n6n6n6n6n6np]9>Dy6n6n6n6nv6n6n6n6n6n6n6n@u}7o6n6n6n6n6n6n6n6n6n6n6n6n6n7oN[]gghtjklnooooonmlkjji}fT9p8p7oWr6n6n6n6n6n6n6n9p~t6n6n6n6n6n6n6n6n6n6n6n6n6n6n6n6n6n6n6ns[6n6n6n6n6n6n6n6np6`>Ey7n7n7n7nY_7n7n7n7n7n7n7n7n;qN\UDw7n7n7n7n7n7n7n7n7n7n7n7n7n7n8o9o^M~:q9p8o8o7n7n7n7n7n7n7n7n8n`Cw7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n:pUDw7n7n7n7n7n7n7n7np>Ey7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n8o9o9p:qn:p9p8o8o7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7n7np>Ez7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o8p8p9p:q;rt?u@vBwEyH{mGzDxBw@u?u>t=sEz7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o7o8p9p9q:q;rt=sFz8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o8o9o9p:p:p;q;qtAuDxH{mGzCw@u>s=rF{8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p9p9q9q:q:q:r;r=t?uCxH{lFzBw?uF|8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q9q9r9r:r:su;s:s9r9r9r9q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8qp>F|8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q9r9r:ruBxG|lEzAw=u;s:r9r9q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8q8qp>F}8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r9s:s;t>vByG|lE{@x=v;t9s9r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8r8rp>G}9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r:r;su;t:s9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9r9rp>G~9s9sRTbm^K9s9s9s9s>wUjj]E{9s9s9sMdiWP^\@x9s9sAyYliYAy9s9sD{^`acgizF|Ay>v;u:t9s9s9s9s9s9s=v[^^^^^R9sCz]^X9s9sV^P9s9s9sOdmbM:s9s9s9s9s9s9s9s9s9s9s9sS^R9s@x,>G~9sAxzV9s9s9sh}O9sP{T9s9su{D{9s^\Ay>v;u:t9s9s9s9s9s9sL{9sZ?wG}j9s9sR|e9s9s9s9s9s9s9s9s9s9sCzF|MX >H~:s=u^By:s@w|:s:s>vf:s;tI}ZAx:sl@w:sCykM:s:sJY:sH:u:uH:u:uUzhU;v:u:u@y`:u:u:u:u:u:u:uPtK:u:uMS:u:u:u:u:u:u:u;uxoq>H;u;uoP@xRub;u=wOhKKH~;u;u;u;uMNC{@xfC{;u?xZ^KKE|;u;u;u;uByMuE|IYC{@x=wwJeC{;u;u;u;u`oE|D{wv;u;uG~xzKKJ>w;u;u;u;u;u;u;u;u;u;u;u;uD|x^d>H;v;vJf;vaM;v;v;v}g;v;vnAz;v;v;vzE}ITC|@y=xH;v;v;v@yS`TQ@z;vB{ZnWWS=w;v;v;vAzP\]I;v;v;vF~bfWWP;v;v;v;vKXYXE}I~HC|@y=xx;v;v;v;vLWAzZ]E};v;vx;v>Iy=xIz=yIz=yJ=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y>y?z@{C}FKpIEB|?{>z=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=yp>J=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y>y?z@{C}FKpIEB|?{>z=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=yp>J=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y>y?z@{C}FKpIEB|?{>z=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=y=yp>K>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{?{@|A}DGLpJFC~@}?|>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{p>K>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{?{@|A}DGLpJFC~@}?|>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{>{p>L?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{@{A|B}EHMqKGD~A}@|?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{?{p>L?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|@|A}B~EHMqKGDA~@}?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|?|p>M@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}A}A~CFINrLHEBA~@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}p>M@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}A}A~CFINrLHEBA~@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}@}p>M@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~A~ACFINrLHEBA@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~@~p>NA~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~B~BDGJOsMIFCBA~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~p>NAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABCDGJOsMIFDBBAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAp>OBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBCDEHKPtNJGECCBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBp>OBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBCCCDFHLPtOJGEDCCBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBp>OCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCDDDEFGIMQtPLIFEEDDDDDCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCp>OCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCDDDEEFFHJNRuQMIGFFEEEDDDDCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCp>PDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDEEEFGGHIJMPTvSOLJIHGGGFFFEEDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDp>PDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDEEFGHIIJLNQUwTPMKJIIIHHGFFEEDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDp>QEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEFFGHIJKLMNPSWyVRPNMLLKKJIHGFFEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEp>RFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFGGHIIHGGFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFp>RFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFGGHIJHHGFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFp>SGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGHHIJgnopqrtvyxusrqppponlJIHHGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGp>SGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGHHIJJKLMNPRUXzWTQONNMMLKKJIHHGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGp>THHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHIIJJKLLNOQTXzWSPONMMLLKKJIIHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHp>THHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHIIJJKKLNPSWyVROMLKKKJJJIIIHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHp>UIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIJJJKKLMPSWyVROMLKKJJJJJIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIp>VJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJKKKLNPSXzVROMLKKKKKJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJp>VJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJKKLMOSWyVROMKKJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJp>VKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKLLNPSXzWSPMLLKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKp>VKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKLLNPSXzWROMLKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKp>WLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLMMOQTX{XSPNMLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLp>XMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMNNOQUY|XTQONMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMp>XMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMNOQTX|XTQONMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMp>YNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNOPRUYw|YURPONNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNp>ZOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOPQSUY`}ZVSQPPOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOp>ZOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOPQRUY]}ZVSQPPPPPPPPPPPOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOp>[PPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPQRSUY]~[WTRQQQQQRRRRRQQQPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPp>[PPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPQQSUX\~[XUSRQRRRSSSSSRRQQPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPp>\QQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQRSUX\\YVTSSTTUVWWVVUTSRRQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQp>]RRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRSTVX\b^ZWUUUVWYZ[[ZYXVUTSSRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRp>]RRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRSTUX[_^ZWVVVXZ\~`[YWUTSRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRp>]SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSTTVX[^_[YWXY[h\YWVTTSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSp>^TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTUVXZ^l`]ZYY[^q\ZWVUTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTp>^TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTUVWY]`a][ZZ\m^[XVUUTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTp>_UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUVVWY\`xb_\[\]`\ZXVVUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUp>`VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVWXY\_bd`^\]^xb^[YWWVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVp>aWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWXXZ[^ahb_^^_cb_\ZXXWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWp8dXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXYZ[^`cca__`b~c_\ZYYXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXj$kYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYZZ[]`bheba``bdic`][ZZYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY[VrZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ[\]_adodbbabdfhj|b`]\[ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZcBǁZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ[[\]_bdecbbbcefhida_][[ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZrv\[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[\\]_abdedccdefgnb`^]\\[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[9o\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\]^^`acehfwcb`^]]\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\be^]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]^^__abcdfgdba`_^^]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]ک5x^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^__``abcdeglddcba`__^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^jem_______________________________________________```abccdeeeeeeeeddcbaa``________________________________e l````````````````````````````````````````````````aaabccddddddddccbbaaa````````````````````````````````eөuaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaabbbccddddddcccbbbaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaalש3jaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaabbbbbbcccbbbbbaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaae"ZПwgbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbcccccccccbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbdsr eͩwRg{lX-?frama-c-Fluorine-20130601/share/acsl.el0000644000175000017500000001662612155630244016360 0ustar mehdimehdi;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; This file is part of Frama-C. ; ; ; ; Copyright (C) 2008-2011 ; ; Pierre Roux ; ; ; ; Copyright (C) 2009-2013 ; ; CEA LIST ; ; ; ; 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). ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; How to install: ;; copy the following in your .emacs file ;; ;; (setq load-path (cons "/directory/in/which/you/put/the/file/acsl.el" load-path)) ;; (autoload 'acsl-mode "acsl" "Major mode for editing ACSL code" t) ;; ;; uncomment this if you want to automatically load ACSL mode with ;; ;; each C file ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq auto-mode-alist (append '(("\\.[chi]" . acsl-mode)) auto-mode-alist)) ;; you can then load the mode in emacs with M-x acsl-mode ;; TODO: ;; - font-lock for ghost code ;; code (defun acsl-keymap-init () "Init keymap" (define-key acsl-mode-map "\C-c\C-j" 'acsl-jessie-gui)) ;; font-lock (defconst acsl-keywords '("assert" "assigns" "assumes" "allocates" "axiom" "axiomatic" "behavior" "behaviors" "breaks" "case" "char" "complete" "continues" "decreases" "disjoint" "double" "else" "ensures" "enum" "exits" "float" "for" "frees" "if" "inductive" "int" "integer" "invariant" "global" "label" "lemma" "logic" "long" "loop" "pragma" "predicate" "reads" "real" "requires" "returns" "short" "signed" "sizeof" "slice" "impact" "struct" "terminates" "type" "union" "unsigned" "variant" "void" ) "List of ACSL keywords to highlight.") (defun acsl-in-acsl-annot () "If we are in a C comment beginning with @." (and (nth 4 (syntax-ppss)) (eq (char-after (+ (nth 8 (syntax-ppss)) 2)) ?@))) (defvar acsl-font-lock-keywords (let ((pre-match-form (lambda () (goto-char (match-beginning 0)) (match-end 0))) (find-annot (lambda (limit) ;; skip comments (if (and (looking-at "//") (acsl-in-acsl-annot)) (re-search-forward "\n" limit 'e)) (while (and (not (acsl-in-acsl-annot)) (< (point) limit)) (re-search-forward "/[*/]" limit 'e)) (if (>= (point) limit) nil (let ((b (save-excursion (re-search-backward "/[*/]" (- (point) 2) t) (point)))) (re-search-forward "[*/]/\\|\n" limit 'e) (re-search-backward "//" (- (point) 2) t) ; don't recolor comments (set-match-data (list b (point) (nth 2 (match-data t)))) t))))) (list `(,find-annot (0 font-lock-type-face t) (,(concat (regexp-opt acsl-keywords 'words) "\\|?\\|&&\\|||\\|!=?\\|\\^\\^") (,pre-match-form) nil (0 font-lock-keyword-face t)) ("\\(\\?\\)[^:]*\\(:\\)" (,pre-match-form) nil (1 font-lock-keyword-face t) (2 font-lock-keyword-face t)) ("\\(axiom\\|behavior\\|case\\|inductive\\|predicate\\|l\\(ogic\\|emma\\)\\)\\>[ \t\n@]*\\([a-zA-Z_][a-zA-Z_0-9]*\\)" (,pre-match-form) nil (3 font-lock-function-name-face t)) ("\\\\\\(at\\|e\\(mpty\\|xists\\)\\|f\\(alse\\|orall\\)\\|old\\|result\\|true\\|valid\\(_range\\|_index\\)?\\)" (,pre-match-form) nil (0 font-lock-constant-face t))))) "Default highlighting for ACSL mode") (defun acsl-font-lock-init () "Initialize font-lock for ACSL." (add-hook 'c-mode-hook (lambda () (font-lock-add-keywords nil acsl-font-lock-keywords)))) ;; custom variables (require 'custom) (defcustom acsl-jessie-gui-prog-name "frama-c -jessie" "Frama-C/Jessie executable name." :group 'acsl :type 'string) (defcustom acsl-jessie-int-model "exact" "Jessie int model." :group 'acsl :type '(choice (const :tag "Exact" "exact") (const :tag "Bounded" "bounded") (const :tag "Modulo" "modulo"))) (defun acsl-jessie-gui () "Generate VCs and show them in a GUI" (interactive) (compile (concat acsl-jessie-gui-prog-name " -jessie-int-model " acsl-jessie-int-model " " (buffer-file-name)))) ;; menu (require 'easymenu) (defun acsl-menu-init () (easy-menu-define acsl-menu (list acsl-mode-map) "ACSL Mode Menu." '("ACSL" ["Customize ACSL mode" (customize-group 'acsl) t] "---" ["Jessie GUI" acsl-jessie-gui t] )) (easy-menu-add acsl-menu)) ;; indent (defun acsl-indent-command (&optional arg) "Indent ACSL code (quite basic yet)." (interactive "*") (c-indent-line) (when (and (acsl-in-acsl-annot) (< (nth 8 (syntax-ppss)) (line-beginning-position))) ; not the first line of an annot (which don't need to be indented) (save-excursion (back-to-indentation) (if (not (eq (char-after) ?@)) (insert "@") (goto-char (+ (point) 1))) (if (not (looking-at "*/")) ; to avoid indenting last lines of annotation of the form "@*/" (thanks Yannick) (let ((current (save-excursion (skip-chars-forward " \t@"))) (expected (save-excursion (let ((cc (current-column))) (forward-line -1) (move-to-column cc)) (skip-chars-forward " \t@")))) (if (save-excursion (skip-chars-backward " \t\n@") (memq (char-before) '(?: ?=))) (setq expected (+ expected 2))) (if (save-excursion (skip-chars-forward " \t@") (looking-at "\\<\\(axiom\\|behavior\\|predicate\\|l\\(ogic\\|emma\\)\\|inductive\\)\\>")) (setq expected (save-excursion (goto-char (+ (nth 8 (syntax-ppss)) 3)) (skip-chars-forward " \t@")))) (if (< current expected) (insert-char ? (- expected current))) (if (> current expected) (kill-forward-chars (- current expected)))))) (if (eq (char-after) ?@) (skip-chars-forward " \t@")))) (defun acsl-indent-init () (setq indent-line-function 'acsl-indent-command) ;; maybe not the best solution for C code but still works (setq indent-region-function nil)) ;; main function for the mode (define-derived-mode acsl-mode c-mode "ACSL" "Major mode for C annoted with ACSL." (acsl-font-lock-init) (acsl-keymap-init) (acsl-indent-init) (acsl-menu-init)) (provide 'acsl-mode) frama-c-Fluorine-20130601/share/machine.h0000644000175000017500000000533012155630244016657 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2012 */ /* 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). */ /* */ /**************************************************************************/ #include "libc/__fc_machdep.h" #ifdef FRAMA_C_LYNX typedef unsigned int size_t; typedef int ssize_t; typedef void FILE; typedef long time_t; struct tm { int tm_sec; int tm_min; int tm_hour; int tm_mday; int tm_mon; int tm_year; int tm_wday; int tm_yday; int tm_isdst; }; typedef struct fsynch { int w_count; int mut_owner; unsigned int id; int owncnt; } fsynch_struct; typedef struct __iobuf { char *_ptr; int _cnt; char *_base; short _flag; char _nobuf; /* One-character buffer used for _UNBUF */ char _unused; int _fd; long _mark; /* position relative to start of file of _base */ int _bufsize; /* buffer size for this file */ fsynch_struct lock; /* Guards against concurrent access */ } FILE; #else // This is the default for regression tests typedef __SIZE_T size_t; typedef __SSIZE_T ssize_t; //typedef FILE; typedef long time_t; #ifdef FRAMA_CXX struct tm; struct FRAMA_C_IO_FILE; #else struct tm { int tm_sec; int tm_min; int tm_hour; int tm_mday; int tm_mon; int tm_year; int tm_wday; int tm_yday; int tm_isdst; }; struct FRAMA_C_IO_FILE { char *content; }; #endif typedef struct FRAMA_C_IO_FILE FILE; #endif frama-c-Fluorine-20130601/share/libc.c0000644000175000017500000001523212155630244016161 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2012 */ /* 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). */ /* */ /**************************************************************************/ #include "libc.h" #ifndef FRAMA_C_MEMCPY #include "builtin.h" void* memcpy(void* region1, const void* region2, size_t n) { if (n > 0) Frama_C_memcpy(region1, region2, n); return region1; } #else void* memcpy(void* region1, const void* region2, size_t n) { const char* first = (const char*)region2; const char* last = ((const char*)region2) + n; char* dest = (char*)region1; while (first != last) { *dest = *first; dest++; first++; } return region1; } #endif void* memset (void* dest, int val, size_t len) { unsigned char *ptr = (unsigned char*)dest; while (len-- > 0) *ptr++ = val; return dest; } int strcmp(const char *s1, const char *s2) { if (s1 == s2) return (0); while (*s1 == *s2++) if (*s1++ == '\0') return (0); return (*(unsigned char *)s1 - *(unsigned char *)--s2); } char* strcat(char *s1, const char *s2) { char *os1 = s1; while (*s1++) ; --s1; while (*s1++ = *s2++) ; return (os1); } char* strcpy(char *s1, const char *s2) { char *os1 = s1; while (*s1++ = *s2++) ; return (os1); } /* * Copy s2 to s1, truncating or null-padding to always copy n bytes * return s1 */ char * strncpy(char *s1, const char *s2, size_t n) { char *os1 = s1; n++; while ((--n != 0) && ((*s1++ = *s2++) != '\0')) ; if (n != 0) while (--n != 0) *s1++ = '\0'; return (os1); } /* * Compare strings (at most n bytes) * returns: s1>s2; >0 s1==s2; 0 s1= '0' && (_c) <= '9') #define ISXDIGIT(_c) \ (ISDIGIT(_c) || \ ((_c) >= 'a' && (_c) <= 'f') || \ ((_c) >= 'A' && (_c) <= 'F')) #define ISLOWER(_c) \ ((_c) >= 'a' && (_c) <= 'z') #define ISUPPER(_c) \ ((_c) >= 'A' && (_c) <= 'Z') #define ISALPHA(_c) \ (ISUPPER(_c) || \ ISLOWER(_c)) #define ISALNUM(_c) \ (ISALPHA(_c) || \ ISDIGIT(_c)) #define ISSPACE(_c) \ ((_c) == ' ' || \ (_c) == '\t' || \ (_c) == '\r' || \ (_c) == '\n') static int isdigit(int c) { return (ISDIGIT(c)); } static int isxdigit(int c) { return (ISXDIGIT(c)); } static int islower(int c) { return (ISLOWER(c)); } static int isupper(int c) { return (ISUPPER(c)); } static int isalpha(int c) { return (ISALPHA(c)); } static int isalnum(int c) { return (ISALNUM(c)); } static int isspace(int c) { return (ISSPACE(c)); } int atoi(const char *p) { int n; int c, neg = 0; unsigned char *up = (unsigned char *)p; if (!isdigit(c = *up)) { while (isspace(c)) c = *++up; switch (c) { case '-': neg++; /* FALLTHROUGH */ case '+': c = *++up; } if (!isdigit(c)) return (0); } for (n = '0' - c; isdigit(c = *++up); ) { n *= 10; /* two steps to avoid unnecessary overflow */ n += '0' - c; /* accum neg to avoid surprises at MAX */ } return (neg ? n : -n); } char * strchr (s, c) const char *s; int c; { do { if (*s == c) { return (char*)s; } } while (*s++); return (0); } char * strrchr (s, c) const char *s; int c; { char *rtnval = 0; do { if (*s == c) rtnval = (char*) s; } while (*s++); return (rtnval); } char * strstr (s1, s2) char *s1, *s2; { char *p = s1; int len = strlen (s2); for (; (p = strchr (p, *s2)) != 0; p++) { if (strncmp (p, s2, len) == 0) { return (p); } } return (0); } char * getenv(const char * c) { return (char*)0; } volatile int any; int my_errno = 0; int *_errno() { return &my_errno; } #if 0 int fprintf(FILE *restrict stream, const char *restrict format, ...) { return any; } #endif int printf(const char *restrict format, ...) { return any; } int sprintf(char *restrict s, const char *restrict format, ...) { int i; for (i = 0; format[i] != '\0'; i++) { s[i] = format[i]; } /* boucle qui copie le format vers s */ return any; } int snprintf (char *restrict s, size_t size, const char *restrict fmt, ...) { int i; for (i = 0; i < size && fmt[i] != '\0'; i++) s[i] = fmt[i]; return any; } /*@ ensures \valid(t2); assigns *t2; */ int localtime_r (struct tm *t2, const time_t t); int toupper (int c) { if ((c >= 'a') && (c <= 'z')) return c - 0x20; return c; } int abs (int i) { if (i < 0) return -i; return i; } #if 0 int vsprintf(char *restrict s, const char *restrict format, .../*va_list va_arg*/) { return sprintf(s,format/*,va_arg*/); } #endif ssize_t read(int fd, void *buf, size_t count) { unsigned char *ptr = (unsigned char*)buf; while (count-- > 0) *ptr++ = any; return any; } frama-c-Fluorine-20130601/share/Makefile.dynamic_config.external0000644000175000017500000000373312155630244023340 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## export FRAMAC_INTERNAL=no export FRAMAC_PLUGINDIR=$(FRAMAC_LIBDIR)/plugins export FRAMAC_GUI_PLUGIN=$(FRAMAC_LIBDIR)/gui export FRAMAC_PLUGIN_TEST=. export FRAMAC_GUI_PLUGIN_TEST=. export FRAMAC_OPT=$(BINDIR)/frama-c$(EXE) export FRAMAC_BYTE=$(BINDIR)/frama-c.byte$(EXE) export FRAMAC_INCLUDES=-I "$(FRAMAC_LIBDIR)" export FRAMAC_LIB="$(FRAMAC_LIBDIR)" export PTESTS=$(BINDIR)/ptests.byte$(EXE) export DOC_DIR=$(FRAMAC_SHARE)/doc/code frama-c-Fluorine-20130601/share/Makefile.plugin0000644000175000017500000007601212155630244020044 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## ############################################################################### # # Generic makefile used to build plug-ins. # Setup the following required variables before including this makefile: # # Usual information # ----------------- # PLUGIN_NAME The ML module name of the plugin # PLUGIN_DIR The directory containing the source files # PLUGIN_ENABLE Whether the plugin is enabled # PLUGIN_DYNAMIC Set it to yes if the plugin is only dynamically linked with # Frama-C. # PLUGIN_HAS_MLI Set it to yes if your plugin has a .mli # # Source files # ------------ # PLUGIN_CMO The .cmo files (do not add the plugin path and the extension) # PLUGIN_CMI The .cmi files (only if there is no corresponding .cmo) # PLUGIN_TYPES_CMO The .cmo files containing the types definitions # PLUGIN_GUI_CMO The .cmo files to be linked with the graphical interface # # Compilation flags # ----------------- # PLUGIN_BFLAGS Additional options for the bytecode compiler # PLUGIN_OFLAGS Additional options for the native compiler # PLUGIN_EXTRA_BYTE Additional bytecode files to link against # PLUGIN_EXTRA_OPT Additional native files to link against # PLUGIN_LINK_BFLAGS Additional options for the bytecode linker # PLUGIN_LINK_OFLAGS Additional options for the native linker # PLUGIN_LINK_GUI_BFLAGS Additional options for the bytecode gui linker # PLUGIN_LINK_GUI_OFLAGS Additional options for the native gui linker # # Dependencies # ------------ # PLUGIN_DEPFLAGS Additional options for ocamldep # PLUGIN_GENERATED ML files that must be generated in order to compute # dependencies # PLUGIN_DEPENDS Plugins the current plugin depends upon # # Documentation # ------------- # PLUGIN_DOCFLAGS Additional options for ocamldoc # PLUGIN_UNDOC Do not document this source files (do not add the plugin path) # PLUGIN_TYPES_TODOC Do document this source files containing the types # definition # PLUGIN_INTRO Add this text file to the introduction of the documentation # PLUGIN_HAS_EXT_DOC (yes/no) Plugin has a pdf manual # # Testing # ------- # PLUGIN_NO_TEST Set it to a non-empty value if there is no specific # test directory for this plugin # PLUGIN_TESTS_DIRS Test directories of the plugin. # Default is tests/$(PLUGIN_DIR) # PLUGIN_TESTS_DIRS_DEFAULTS Tests directories that should be run by default # Defaults to $(PLUGIN_TESTS_DIRS) # PLUGIN_TESTS_LIB Additional .cmo files used by tests. # Should be part of one of the $(PLUGIN_TESTS_DIRS) # Do not write the file extension # PLUGIN_NO_DEFAULT_TEST Set it to a non-empty value if you don't want the # tests of your plugin to be executed systematically by make tests # # PLUGIN_INTERNAL_TEST Set it to a non-empty value if the tests of the plugin # are in Frama-C's tests directory and not a tests subdirectory of the plugin # (internal use only, obsolete and not recommanded way to handle tests) # # Distribution # ------------ # PLUGIN_DISTRIBUTED should the plugin be included in the distribution (yes/no) # PLUGIN_DISTRIB_BIN should the plugin be included in binary distributions # (defaults to ${PLUGIN_DISTRIBUTED}) # PLUGIN_DISTRIB_EXTERNAL list of files that should be distributed within the # source distribution for this plug-in. They will be put at their proper # place in the frama-c-$(VERSION) directory for a release. # # Kernel developers only # ---------------------- # PLUGIN_RESET Set it to no in order to NOT reset plug-in variable. # Default to yes # # Except for their initialisation, these variables should not be used outside of # Makefile.plugin. # Instead, you can safely use the corresponding following variables # in which $(PLUGIN_NAME) is the name of your plugin: # # $(PLUGIN_NAME)_DIR # $(PLUGIN_NAME)_CMO # $(PLUGIN_NAME)_CMX # $(PLUGIN_NAME)_CMI # $(PLUGIN_NAME)_TYPES_CMO # $(PLUGIN_NAME)_TYPES_CMX # $(PLUGIN_NAME)_TYPES_TODOC # $(PLUGIN_NAME)_BFLAGS # $(PLUGIN_NAME)_OFLAGS # $(PLUGIN_NAME)_DEPFLAGS # $(PLUGIN_NAME)_DOCFLAGS # $(PLUGIN_NAME)_GENERATED # $(PLUGIN_NAME)_TESTS_DIRS # $(PLUGIN_NAME)_TESTS_LIB # ############################################################################### # # Note for the Makefile.plugin developers: # If you add a new option to communicate with the main Makefile, # don't forget to reset it at the end of this file. # ############################################################################### # The plugin types .cm* files PLUGIN_TYPES_CMO:=$(addsuffix .cmo, $(PLUGIN_TYPES_CMO)) PLUGIN_TYPES_CMX:=$(PLUGIN_TYPES_CMO:.cmo=.cmx) $(PLUGIN_NAME)_TYPES_CMO:=$(PLUGIN_TYPES_CMO) $(PLUGIN_NAME)_TYPES_CMX:=$(PLUGIN_TYPES_CMX) $(PLUGIN_NAME)_TYPES_TODOC:=$(PLUGIN_TYPES_TODOC) PLUGIN_TYPES_CMO_LIST += $(PLUGIN_TYPES_CMO) PLUGIN_TYPES_CMX_LIST += $(PLUGIN_TYPES_CMX) # [VP] don't exactly know why, but make has a tendency to add a # spurious space at the beginning of PLUGIN_BASE. Fortunately, $(strip ) # is behaving correctly. PLUGIN_BASE:=$(strip $(if $(notdir $(PLUGIN_DIR)),$(notdir $(PLUGIN_DIR)),\ $(notdir $(patsubst %/,%,$(PLUGIN_DIR))))) ################ # ml sources # ################ PLUGIN_SRC:= $(patsubst %,$(PLUGIN_DIR)/%.ml*, $(PLUGIN_CMO)) \ $(patsubst %,$(PLUGIN_DIR)/%.mli, $(PLUGIN_CMI)) \ $(patsubst %.cmo,%.ml*, $(PLUGIN_TYPES_CMO)) ifneq ($(ENABLE_GUI),no) PLUGIN_SRC:= $(PLUGIN_SRC) $(patsubst %,$(PLUGIN_DIR)/%.ml*, $(PLUGIN_GUI_CMO)) endif $(PLUGIN_NAME)_SRC:=$(PLUGIN_SRC) PLUGIN_ML_SRC:=$(patsubst %.ml*,%.ml,$(PLUGIN_SRC)) \ $(patsubst %.ml*,%.mli,$(filter %.ml*,$(PLUGIN_SRC))) $(PLUGIN_NAME)_ML_SRC:=$(PLUGIN_ML_SRC) ################ # distribution # ################ ifneq ($(PLUGIN_ENABLE),no) ifneq ($(PLUGIN_DISTRIBUTED),no) PLUGIN_DISTRIBUTED_LIST += $(PLUGIN_SRC) ifeq ($(PLUGIN_HAS_MLI),yes) PLUGIN_DISTRIBUTED_LIST += $(PLUGIN_DIR)/$(PLUGIN_NAME).mli endif # VP: this needs to be adapted for external plugins. ifeq ($(PLUGIN_HAS_EXT_DOC),yes) PLUGIN_EXT_DOC_DIR:=doc/$(PLUGIN_BASE) PLUGIN_DIST_DOC_LIST += doc/plugins/$(PLUGIN_BASE).pdf $(PLUGIN_EXT_DOC_DIR)/$(PLUGIN_BASE).pdf: $(PRINT_MAKING) $@ $(MAKE) -C $(dir $@) doc/plugins/$(PLUGIN_BASE).pdf: \ $(PLUGIN_EXT_DOC_DIR)/$(PLUGIN_BASE).pdf $(PRINT_CP) $< $(MKDIR) doc/plugins $(CP) $< $@ endif ifneq ("$(strip $(PLUGIN_DISTRIB_EXTERNAL))","") PLUGIN_DIST_EXTERNAL_LIST += \ $(addprefix $(PLUGIN_DIR)/,$(PLUGIN_DISTRIB_EXTERNAL)) endif endif #PLUGIN_DISTRIBUTED endif #PLUGIN_ENABLE ifndef ($(PLUGIN_DISTRIB_BIN)) PLUGIN_DISTRIB_BIN:=$(PLUGIN_DISTRIBUTED) endif PLUGIN_OPT:=`echo "$(PLUGIN_NAME)" | tr 'A-Z' 'a-z' ` ifeq ("$(PLUGIN_DISTRIB_BIN)","yes") CONFIG_DISTRIB_BIN += "--enable-$(PLUGIN_OPT)" ifeq ("$(PLUGIN_HAS_EXT_DOC)","yes") PLUGIN_BIN_DOC_LIST+=doc/plugins/$(PLUGIN_BASE).pdf endif else CONFIG_DISTRIB_BIN += "--disable-$(PLUGIN_OPT)" endif # Export some variables which can be safely used outside/inside Makefile.plugin # even if the plug-in is not enabled $(PLUGIN_NAME)_DIR:=$(PLUGIN_DIR) ifneq ("$(PLUGIN_ENABLE)","no") # The .cm* files list PLUGIN_CMO:= $(patsubst %, $(PLUGIN_DIR)/%.cmo, $(PLUGIN_CMO)) PLUGIN_CMX:= $(PLUGIN_CMO:.cmo=.cmx) PLUGIN_CMI:= $(patsubst %, $(PLUGIN_DIR)/%.cmi, $(PLUGIN_CMI)) \ $(PLUGIN_CMO:.cmo=.cmi) PLUGIN_INFERRED_MLI:= $(PLUGIN_CMO:.cmo=.inferred.mli) $(PLUGIN_NAME)_CMO:=$(PLUGIN_CMO) $(PLUGIN_NAME)_CMX:=$(PLUGIN_CMX) $(PLUGIN_NAME)_CMI:=$(PLUGIN_CMI) $(PLUGIN_NAME)_INFERRED_MLI:=$(PLUGIN_INFERRED_MLI) HAS_GUI:=no ifneq ($(ENABLE_GUI),no) ifneq ("$(PLUGIN_GUI_CMO)","") # The .cm* gui files list PLUGIN_GUI_CMO:= $(PLUGIN_CMO) \ $(patsubst %, $(PLUGIN_DIR)/%.cmo, $(PLUGIN_GUI_CMO)) PLUGIN_GUI_CMX:= $(PLUGIN_GUI_CMO:.cmo=.cmx) PLUGIN_GUI_CMI:= $(patsubst %, $(PLUGIN_DIR)/%.cmi, $(PLUGIN_GUI_CMI)) \ $(PLUGIN_GUI_CMO:.cmo=.cmi) HAS_GUI:=yes endif endif $(PLUGIN_NAME)_GUI_CMO:=$(PLUGIN_GUI_CMO) $(PLUGIN_NAME)_GUI_CMX:=$(PLUGIN_GUI_CMX) $(PLUGIN_NAME)_GUI_CMI:=$(PLUGIN_GUI_CMI) # The packing files TARGET_CMO:= $(PLUGIN_LIB_DIR)/$(PLUGIN_NAME).cmo ifdef PLUGIN_EXTRA_BYTE TARGET_CMA:= $(TARGET_CMO:.cmo=.cma) endif TARGET_CMX:= $(TARGET_CMO:.cmo=.cmx) ifdef PLUGIN_EXTRA_OPT TARGET_CMXA:= $(TARGET_CMO:.cmo=.cmxa) endif ifeq ("$(USABLE_NATIVE_DYNLINK) $(PLUGIN_DYNAMIC)","yes yes") TARGET_CMXS:= $(TARGET_CMX:.cmx=.cmxs) else TARGET_CMXS:= endif #The packing gui files ifeq ($(HAS_GUI),yes) TARGET_GUI_CMO:= $(PLUGIN_LIB_DIR)/gui/$(PLUGIN_NAME).cmo TARGET_GUI_CMX:= $(TARGET_GUI_CMO:.cmo=.cmx) TARGET_GUI_CMA:= $(TARGET_GUI_CMO:.cmo=.cma) TARGET_GUI_CMXA:= $(TARGET_GUI_CMX:.cmx=.cmxa) ifeq ("$(USABLE_NATIVE_DYNLINK) $(PLUGIN_DYNAMIC)","yes yes") TARGET_GUI_CMXS:= $(TARGET_GUI_CMO:.cmo=.cmxs) else TARGET_GUI_CMXS:= endif else TARGET_GUI_CMO:= TARGET_GUI_CMX:= TARGET_GUI_CMA:= TARGET_GUI_CMXA:= endif # Some meta-variables for compilation flags NAME_BFLAGS :=$(PLUGIN_NAME)_BFLAGS NAME_OFLAGS :=$(PLUGIN_NAME)_OFLAGS TARGET_OFLAGS := $(PLUGIN_NAME)_TARGET_OFLAGS TARGET_BFLAGS := $(PLUGIN_NAME)_TARGET_BFLAGS ifeq ($(HAS_GUI),yes) NAME_GUI_BFLAGS := $(PLUGIN_NAME)_gui_BFLAGS NAME_GUI_OFLAGS := $(PLUGIN_NAME)_gui_OFLAGS TARGET_GUI_OFLAGS:= $(PLUGIN_NAME)_gui_TARGET_OFLAGS TARGET_GUI_BFLAGS:= $(PLUGIN_NAME)_gui_TARGET_BFLAGS endif NAME_DEPFLAGS :=$(PLUGIN_NAME)_DEPFLAGS NAME_DOCFLAGS :=$(PLUGIN_NAME)_DOCFLAGS # Export some variables which can be safely used outside/inside Makefile.plugin $(PLUGIN_NAME)_CMO:=$(PLUGIN_CMO) $(PLUGIN_NAME)_CMX:=$(PLUGIN_CMX) $(PLUGIN_NAME)_CMI:=$(PLUGIN_CMI) $(PLUGIN_NAME)_GENERATED:=$(PLUGIN_GENERATED) $(PLUGIN_NAME)_TARGET_BFLAGS:=$(PLUGIN_LINK_BFLAGS) $(PLUGIN_NAME)_TARGET_OFLAGS:=$(PLUGIN_LINK_OFLAGS) $(PLUGIN_NAME)_EXTRA_BYTE:=$(PLUGIN_EXTRA_BYTE) $(PLUGIN_NAME)_EXTRA_OPT:=$(PLUGIN_EXTRA_OPT) ifeq ($(HAS_GUI),yes) # gui variable $(PLUGIN_NAME)_gui_CMO:=$(PLUGIN_GUI_CMO) $(PLUGIN_NAME)_gui_CMX:=$(PLUGIN_GUI_CMX) $(PLUGIN_NAME)_gui_CMI:=$(PLUGIN_GUI_CMI) $(PLUGIN_NAME)_gui_TARGET_GUI_BFLAGS:=$(PLUGIN_LINK_GUI_BFLAGS) $(PLUGIN_NAME)_gui_TARGET_GUI_OFLAGS:=$(PLUGIN_LINK_GUI_OFLAGS) endif # Set the compilation flags for the plugin $(NAME_BFLAGS):=$(BFLAGS) -I $(PLUGIN_DIR) $(PLUGIN_BFLAGS) $(NAME_OFLAGS):=$(OFLAGS) -I $(PLUGIN_DIR) $(PLUGIN_OFLAGS) $(TARGET_BFLAGS):= $(PLUGIN_LINK_BFLAGS) $(TARGET_OFLAGS):= $(PLUGIN_LINK_OFLAGS) $(NAME_DOCFLAGS):= $(DOC_FLAGS) $(PLUGIN_DOCFLAGS) \ -I $($(PLUGIN_NAME)_DIR) -I . $(OCAMLGRAPH_INCLUDE) ifeq ($(HAS_GUI),yes) $(NAME_GUI_BFLAGS):=$(BFLAGS) -I $(PLUGIN_DIR) $(PLUGIN_BFLAGS) -I $(LABLGTK_PATH) $(NAME_GUI_OFLAGS):=$(OFLAGS) -I $(PLUGIN_DIR) $(PLUGIN_OFLAGS) -I $(LABLGTK_PATH) $(TARGET_GUI_BFLAGS):= $(PLUGIN_LINK_GUI_BFLAGS) $(TARGET_GUI_OFLAGS):= $(PLUGIN_LINK_GUI_OFLAGS) $(NAME_DOCFLAGS) := $($(NAME_DOCFLAGS)) -I $(LABLGTK_PATH) endif $(NAME_DEPFLAGS):= -I $(PLUGIN_DIR) $(PLUGIN_DEPFLAGS) # Add dependencies wrt other plugins for cmx. $(PLUGIN_CMX): $(PLUGIN_DEPENDS:%=$(PLUGIN_LIB_DIR)/%.cmx) # Add the flags to the compilation line of the plugin source files $(PLUGIN_CMO) $(PLUGIN_CMI) $(PLUGIN_INFERRED_MLI): BFLAGS:=$($(NAME_BFLAGS)) $(PLUGIN_CMX): OFLAGS:=$($(NAME_OFLAGS)) -for-pack $(PLUGIN_NAME) ifeq ($(HAS_GUI),yes) $(PLUGIN_GUI_CMO) $(PLUGIN_GUI_CMI): BFLAGS:=$($(NAME_GUI_BFLAGS)) $(PLUGIN_GUI_CMX): OFLAGS:=$($(NAME_GUI_OFLAGS)) -for-pack $(PLUGIN_NAME) endif # Now build the targets. Depend on the presence of a plugin interface. # Note: generate no documentation. Should be in Db. ######### ifeq ("$(PLUGIN_HAS_MLI)","yes") # A plugin signature exists: link with it PLUGIN_MLI:= $(PLUGIN_DIR)/$(PLUGIN_NAME).mli TARGET_MLI:= $(PLUGIN_LIB_DIR)/$(PLUGIN_NAME).mli TARGET_CMI:= $(TARGET_MLI:.mli=.cmi) ifneq ($(TARGET_MLI),$(PLUGIN_MLI)) # Copy the plugin interface in the plugins directory $(TARGET_MLI): $(PLUGIN_MLI) $(PRINT_MAKING) $@ $(RM) $@ $(ECHO) "(* This module was generated automatically by code in Makefile and $< *)" > $@ $(ECHO) "#1 \"$<\"" >> $@ $(CAT) $< >> $@ $(CHMOD_RO) $@ PLUGIN_GENERATED+= $(TARGET_MLI) endif $(PLUGIN_NAME)_MLI:=$(TARGET_MLI) $(TARGET_CMO): $(PLUGIN_CMO) $(TARGET_CMI) \ $(PLUGIN_DEPENDS:%=$(PLUGIN_LIB_DIR)/%.cmi) $(PRINT_PACKING) $@ $(OCAMLC) -o $@ $($(basename $(notdir $@))_BFLAGS) -pack \ $($(basename $(notdir $@))_TARGET_BFLAGS) \ $($(basename $(notdir $@))_CMO) $(TARGET_CMX): $(PLUGIN_CMX) $(TARGET_CMI) \ $(PLUGIN_DEPENDS:%=$(PLUGIN_LIB_DIR)/%.cmi) \ $(PLUGIN_DEPENDS:%=$(PLUGIN_LIB_DIR)/%.cmx) $(PRINT_PACKING) $@ $(OCAMLOPT) -o $@ $($(basename $(notdir $@))_OFLAGS) -pack \ $($(basename $(notdir $@))_TARGET_OFLAGS) \ $($(basename $(notdir $@))_CMX) ifeq ("$(USABLE_NATIVE_DYNLINK) $(PLUGIN_DYNAMIC)","yes yes") $(TARGET_CMXS): $(TARGET_CMX) $(PLUGIN_EXTRA_OPT) $(PRINT_PACKING) $@ $(OCAMLOPT) -o $@ -shared \ $($(basename $(notdir $@))_OFLAGS) \ $($(basename $(notdir $@))_EXTRA_OPT) \ $(@:.cmxs=.cmx) endif ######### else # No plugin signature PLUGIN_MLI:= $(PLUGIN_NAME)_MLI:= TARGET_CMI:= $(TARGET_CMO): $(PLUGIN_CMO) \ $(PLUGIN_DEPENDS:%=$(PLUGIN_LIB_DIR)/%.cmi) $(PRINT_PACKING) $@ $(OCAMLC) -o $@ $($(basename $(notdir $@))_BFLAGS) -pack \ $($(basename $(notdir $@))_TARGET_BFLAGS) \ $($(basename $(notdir $@))_CMO) $(TARGET_CMX): $(PLUGIN_CMX) \ $(PLUGIN_DEPENDS:%=$(PLUGIN_LIB_DIR)/%.cmi) \ $(PLUGIN_DEPENDS:%=$(PLUGIN_LIB_DIR)/%.cmx) $(PRINT_PACKING) $@ $(OCAMLOPT) -o $@ $($(basename $(notdir $@))_OFLAGS) -pack \ $($(basename $(notdir $@))_TARGET_OFLAGS) \ $($(basename $(notdir $@))_CMX) ifeq ("$(USABLE_NATIVE_DYNLINK) $(PLUGIN_DYNAMIC)","yes yes") $(TARGET_CMXS): $(TARGET_CMX) $(PLUGIN_EXTRA_OPT) $(PRINT_PACKING) $@ $(OCAMLOPT) -o $@ -shared \ $($(basename $(notdir $@))_OFLAGS) \ $($(basename $(notdir $@))_EXTRA_OPT) \ $(@:.cmxs=.cmx) endif endif # PLUGIN_HAS_MLI ifdef PLUGIN_EXTRA_BYTE $(TARGET_CMA): $(PLUGIN_EXTRA_BYTE) $(TARGET_CMO) $(PRINT_PACKING) $@ $(OCAMLC) -o $@ $($(basename $(notdir $@))_BFLAGS) \ $($(basename $(notdir $@))_TARGET_BFLAGS) \ -a $($(basename $(notdir $@))_EXTRA_BYTE) $(@:.cma=.cmo) endif ifdef PLUGIN_EXTRA_OPT $(TARGET_CMXA): $(PLUGIN_EXTRA_OPT) $(TARGET_CMX) $(PRINT_PACKING) $@ $(OCAMLOPT) -o $@ -a $($(basename $(notdir $@))_EXTRA_OPT) \ $(@:.cmxa=.cmx) endif ifeq ($(HAS_GUI),yes) ifeq ("$(PLUGIN_HAS_MLI)","yes") # packing gui files with signature ##################################### TARGET_GUI_MLI:= $(PLUGIN_LIB_DIR)/gui/$(PLUGIN_NAME).mli TARGET_GUI_CMI:= $(TARGET_GUI_MLI:.mli=.cmi) PLUGIN_GENERATED+= $(TARGET_GUI_MLI) $(TARGET_GUI_MLI): $(PLUGIN_MLI) $(PRINT_MAKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/gui $(RM) $@ $(ECHO) "(* This module was generated automatically by code in Makefile and $< *)" > $@ $(ECHO) "#1 \"$<\"" >> $@ $(CAT) $< >> $@ $(CHMOD_RO) $@ $(PLUGIN_NAME)_gui_MLI:=$(TARGET_GUI_MLI) $(TARGET_GUI_CMO): $(PLUGIN_GUI_CMO) $(TARGET_GUI_CMI) \ $(PLUGIN_DEPENDS:%=$(PLUGIN_LIB_DIR)/%.cmi) $(PRINT_PACKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/gui $(OCAMLC) -o $@ $($(basename $(notdir $@))_BFLAGS) -pack \ $($(basename $(notdir $@))_TARGET_GUI_BFLAGS) \ $($(basename $(notdir $@))_gui_CMO) $(TARGET_GUI_CMX): $(PLUGIN_GUI_CMX) $(TARGET_GUI_CMI) \ $(PLUGIN_DEPENDS:%=$(PLUGIN_LIB_DIR)/%.cmi) \ $(PLUGIN_DEPENDS:%=$(PLUGIN_LIB_DIR)/%.cmx) $(PRINT_PACKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/gui $(OCAMLOPT) -o $@ $($(basename $(notdir $@))_OFLAGS) -pack \ $($(basename $(notdir $@))_TARGET_OFLAGS) \ $($(basename $(notdir $@))_gui_CMX) ifeq ("$(USABLE_NATIVE_DYNLINK) $(PLUGIN_DYNAMIC)","yes yes") $(TARGET_GUI_CMXS): $(TARGET_GUI_CMX) $(PRINT_PACKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/gui $(OCAMLOPT) -o $@ -shared \ $($(basename $(notdir $@))_OFLAGS) \ $($(basename $(notdir $@))_TARGET_OFLAGS) \ $($(basename $(notdir $@))_EXTRA_OPT) \ $^ endif else # packing gui files without signature ##################################### TARGET_GUI_MLI:= TARGET_GUI_CMI:= $(PLUGIN_NAME)_gui_MLI:= $(TARGET_GUI_CMO): $(PLUGIN_GUI_CMO) \ $(PLUGIN_DEPENDS:%=$(PLUGIN_LIB_DIR)/%.cmi) $(PRINT_PACKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/gui $(OCAMLC) -o $@ $($(basename $(notdir $@))_BFLAGS) -pack \ $($(basename $(notdir $@))_TARGET_GUI_BFLAGS) \ $($(basename $(notdir $@))_gui_CMO) $(TARGET_GUI_CMX): $(PLUGIN_GUI_CMX) \ $(PLUGIN_DEPENDS:%=$(PLUGIN_LIB_DIR)/%.cmi) \ $(PLUGIN_DEPENDS:%=$(PLUGIN_LIB_DIR)/%.cmx) $(PRINT_PACKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/gui $(OCAMLOPT) -o $@ $($(basename $(notdir $@))_OFLAGS) -pack \ $($(basename $(notdir $@))_TARGET_OFLAGS) \ $($(basename $(notdir $@))_gui_CMX) ifeq ("$(USABLE_NATIVE_DYNLINK) $(PLUGIN_DYNAMIC)","yes yes") $(TARGET_GUI_CMXS): $(TARGET_GUI_CMX) $(PRINT_PACKING) $@ $(MKDIR) $(PLUGIN_LIB_DIR)/gui $(OCAMLOPT) -o $@ -shared \ $($(basename $(notdir $@))_OFLAGS) \ $($(basename $(notdir $@))_TARGET_OFLAGS) \ $($(basename $(notdir $@))_EXTRA_OPT) \ $^ endif endif # PLUGIN_HAS_MLI ifdef PLUGIN_EXTRA_BYTE $(TARGET_GUI_CMA): $(PLUGIN_EXTRA_BYTE) $(TARGET_GUI_CMO) $(PRINT_PACKING) $@ $(OCAMLC) -o $@ $($(basename $(notdir $@))_BFLAGS) \ $($(basename $(notdir $@))_TARGET_BFLAGS) \ -a $($(basename $(notdir $@))_EXTRA_BYTE) $(@:.cma=.cmo) endif ifdef PLUGIN_EXTRA_OPT $(TARGET_GUI_CMXA): $(PLUGIN_EXTRA_OPT) $(TARGET_GUI_CMX) $(PRINT_PACKING) $@ $(OCAMLOPT) -o $@ -a $($(basename $(notdir $@))_EXTRA_OPT) \ $(@:.cmxa=.cmx) endif else # No specific gui items TARGET_GUI_MLI:= TARGET_GUI_CMI:= endif # HAS_GUI ######### # The following rules used some plugin info (name and path) in their names # in order to used them in the command: # it is not possible to use $(PLUGIN_*) in commands due to the evaluation rules # of make ########################## # Internal documentation # ########################## MODULES_TODOC+= $(PLUGIN_TYPES_TODOC) PLUGIN_UNDOC := $(addprefix $(PLUGIN_DIR)/, $(PLUGIN_UNDOC)) PLUGIN_DOC_SRC:=$(filter-out $(PLUGIN_UNDOC), $(PLUGIN_ML_SRC)) $(PLUGIN_NAME)_DOC_SRC:=$(PLUGIN_DOC_SRC) ifndef PLUGIN_DOC_DIR PLUGIN_DOC_DIR := $(DOC_DIR)/$(PLUGIN_BASE) endif $(PLUGIN_NAME)_DOC_DIR:= $(PLUGIN_DOC_DIR) $(PLUGIN_NAME)_INTRO:=$(PLUGIN_INTRO) ifdef PLUGIN_INTRO $(PLUGIN_NAME)_CAT_INTRO:= $(SED) -e "/^@ignore/d" $(PLUGIN_INTRO) >> $(PLUGIN_DOC_DIR)/$(PLUGIN_NAME).txt else $(PLUGIN_NAME)_CAT_INTRO:= endif ifeq ($(FRAMAC_MAKE),yes) DOC_INTRO:= $(DOC_DIR)/intro_kernel_plugin.txt \ $(DOC_DIR)/intro_plugin.txt \ $(DOC_DIR)/intro_plugin_D_and_S.txt \ $(DOC_DIR)/intro_plugin_default.txt else DOC_INTRO:= endif $(PLUGIN_DOC_DIR)/$(PLUGIN_NAME).txt: $(DOC_INTRO) $(PLUGIN_INTRO) $(PRINT_MAKING) "$@" $(MKDIR) $(dir $@) if [ -f "$(DOC_DIR)/html/Db.$(basename $(notdir $@)).html" ] ; then \ if [ -f "$(DOC_DIR)/dynamic_plugins/Dynamic_plugins.$(basename $(notdir $@)).html" ] ; then \ cp -f $(DOC_DIR)/intro_plugin_D_and_S.txt $@ ; \ else \ cp -f $(DOC_DIR)/intro_kernel_plugin.txt $@ ; \ fi ; \ elif [ -f "$(DOC_DIR)/dynamic_plugins/Dynamic_plugins.$(basename $(notdir $@)).html" ] ; then \ cp -f $(DOC_DIR)/intro_plugin.txt $@ ; \ else \ cp -f $(DOC_DIR)/intro_plugin_default.txt $@ ; \ fi $(ISED) -e "s/_PluginName_/$(basename $(notdir $@))/g" \ -e "/^@ignore/d" $@ $($(basename $(notdir $@))_CAT_INTRO) ifeq ($(FRAMAC_INTERNAL),yes) OCAMLDOC_GEN:=$(DOC_PLUGIN) ifneq ($(FRAMAC_MAKE),yes) # not doing kernel documentation if just compiling plugin's one $(DOC_DIR)/docgen.cmo: $(DOC_DIR)/docgen.ml $(PRINT_OCAMLC) $@ $(OCAMLC) -c -I +ocamldoc $(DOC_DIR)/docgen.ml $(DOC_DIR)/docgen.cmxs: $(DOC_DIR)/docgen.ml $(PRINT_PACKING) $@ $(OCAMLOPT) -o $@ -shared -I +ocamldoc \ $(DOC_DIR)/docgen.ml else OCAMLDOC_GEN+=$(DOC_DIR)/kernel-doc.ocamldoc endif else OCAMLDOC_GEN:= endif OCAMLDOC_DEPEND:= $(PLUGIN_CMO) ifneq ($(ENABLE_GUI),no) OCAMLDOC_DEPEND:= $(OCAMLDOC_DEPEND) $(PLUGIN_GUI_CMO) endif .PHONY: $(PLUGIN_NAME)_DOC $(PLUGIN_NAME)_DOC: $(OCAMLDOC_DEPEND) \ $(OCAMLDOC_GEN) \ $(PLUGIN_DOC_DIR)/$(PLUGIN_NAME).txt \ $(PLUGIN_DOC_DIR)/modules.svg \ $(DOC_PLUGIN) $(PRINT_DOC) $(patsubst %_DOC,%,$@) $(MKDIR) $($@_DIR) $(RM) $($@_DIR)/*.html # Only generate toc for kernel's documentation if we are in Frama-C's main # Makefile ifeq ($(FRAMAC_MAKE), yes) $(ECHO) '
  • $(subst _, ,$(patsubst %_DOC,%,$@))
    • ' > $(DOC_DIR)/$(patsubst %_DOC,%,$@).toc endif $(OCAMLDOC) $($@FLAGS) \ -t "$(patsubst %_DOC,%,$@) plugin" \ -intro $($@_DIR)/$(patsubst %_DOC,%,$@).txt \ -css-style ../style.css \ -d $($@_DIR) -g $(DOC_PLUGIN) -docpath $(DOC_DIR)/html \ $(addprefix -load , $(wildcard $(DOC_DIR)/kernel-doc.ocamldoc)) \ $(wildcard $($@_SRC)) # [rb+js] 20090619 # pwd is required to avoid "bad directory" message on OpenBSD # don't know why cd `pwd`/$($(patsubst %_DOC,%_DOC_DIR,$@)); \ for f in $(foreach f,$($(patsubst %_DOC,%_TYPES_TODOC,$@)),\ $(basename $(notdir $f))); do \ for g in \ $(wildcard ../html/$(shell $(ECHO) $(f) | $(SED) 's/^./\u&/')); \ do \ ln -sf $$g; \ done; \ done; \ for f in *.html; do \ $(ISED) -e 's|\(doc/code/html\)|../../../\1|g' $$f ; \ done # removed dependencies: # $(PLUGIN_DOC_DIR)/modules.ps \ # $(PLUGIN_DOC_DIR)/modules-all.ps \ # $(PLUGIN_DOC_DIR)/types.ps $(PLUGIN_DOC_DIR)/modules.dot: DOC_FLAGS:=$($(NAME_DOCFLAGS)) $(PLUGIN_DOC_DIR)/modules.dot: $(wildcard $(PLUGIN_DOC_SRC)) $(PRINT_DOC) $@ $(MKDIR) $(dir $@) $(OCAMLDOC) $(DOC_FLAGS) -o $@ -dot $^ \ || { $(RM) $@; exit 2; } # in case of error, ocamldoc still generates # something $(ISED) -e "s/rotate=90;//" \ -e 's/digraph G/digraph "Plugin architecture ($(subst /,,$(subst doc/code,,$(dir $@))))"/' \ $@ $(PLUGIN_DOC_DIR)/modules-all.dot: DOC_FLAGS:=$($(NAME_DOCFLAGS)) $(PLUGIN_DOC_DIR)/modules-all.dot: $(wildcard $(PLUGIN_DOC_SRC)) $(PRINT_DOC) $@ $(MKDIR) $(dir $@) $(OCAMLDOC) $(DOC_FLAGS) $($(dir $@)FLAGS) -o $@ -dot \ -dot-include-all $^ $(ISED) -e "s/rotate=90;//" $@ $(PLUGIN_DOC_DIR)/types.dot: DOC_FLAGS:=$($(NAME_DOCFLAGS)) $(PLUGIN_DOC_DIR)/types.dot: $(wildcard $(PLUGIN_DOC_SRC)) $(PRINT_DOC) $@ $(MKDIR) $(dir $@) $(OCAMLDOC) $(DOC_FLAGS) $($(dir $@)FLAGS) -o $@ -dot -dot-types $^ $(ISED) -e "s/rotate=90;//" $@ .PHONY: $(PLUGIN_NAME)_metrics $(PLUGIN_NAME)_metrics : $(PLUGIN_DOC_DIR)/metrics.html $(PLUGIN_DOC_DIR)/metrics.html : $(wildcard $(PLUGIN_DOC_SRC)) $(PRINT_DOC) $@ ocamlmetrics $^ > $@ ############ # Tests # ############ ifneq ("$(PLUGIN_ENABLE)","no") ifndef PLUGIN_NO_TEST ifndef PLUGIN_TESTS_DIRS PLUGIN_TESTS_DIRS:=$(PLUGIN_BASE) endif endif ifndef PLUGIN_TESTS_DIRS_DEFAULT PLUGIN_TESTS_DIRS_DEFAULT:=$(PLUGIN_TESTS_DIRS) endif ifndef PLUGIN_NO_DEFAULT_TEST ifdef PLUGIN_INTERNAL_TEST PLUGIN_TESTS_LIST += $(PLUGIN_TESTS_DIRS_DEFAULT) endif endif $(PLUGIN_NAME)_TESTS_DIRS:=$(PLUGIN_TESTS_DIRS) $(PLUGIN_NAME)_DEPFLAGS_TEST:=$(add_prefix tests/,$(PLUGIN_TESTS_DIRS)) $(PLUGIN_NAME)_TESTS_LIB:=$(PLUGIN_TESTS_LIB:%=%.cmx) $(PLUGIN_NAME)_TESTS_LIB_BYTE:=$(PLUGIN_TESTS_LIB:%=%.cmo) # [JS 2009/03/18] both .PRECIOUS are required in order to prevent 'make' # deletion of intermediate generated files. Such a deletion forces 'make' to # unnecessarily recompile those files. .PRECIOUS: $($(PLUGIN_NAME)_TESTS_LIB) $($(PLUGIN_NAME)_TESTS_LIB_BYTE) $(foreach d,$(PLUGIN_TESTS_DIRS),$(eval $(call COMPILE_TESTS_ML_FILES,$d,$(PLUGIN_NAME),$($(PLUGIN_NAME)_TESTS_LIB)))) endif # PLUGIN_ENABLE ########## # Depend # ########## # for reasons known to themselves, ocamldep and make are confused by ./file.ml # hence (one of) the patsubst below in case PLUGIN_DIR is . # If you explicitly do "make depend", force the computation of dependencies .PHONY: $(PLUGIN_DIR)/$(PLUGIN_NAME)_DEP_REDO $(PLUGIN_DIR)/$(PLUGIN_NAME)_DEP_REDO: $(PLUGIN_GENERATED) $(TARGET_MLI) $(TARGET_GUI_MLI) $(PRINT_DEP) $(dir $@).depend $(CHMOD_RW) $(dir $@).depend $(OCAMLDEP) $(INCLUDES_FOR_OCAMLDEP) \ $($(patsubst %_DEP_REDO,%_DEPFLAGS,$(basename $(notdir $@)))) \ $(patsubst ./%,%, \ $($(patsubst %_DEP_REDO,%_ML_SRC,$(basename $(notdir $@)))) \ $($(patsubst %_DEP_REDO,%_MLI, $(basename $(notdir $@))))\ $($(patsubst %_DEP_REDO,%_gui_MLI, $(basename $(notdir $@))))) \ $(foreach d, \ $($(patsubst %_DEP_REDO,%_DEPFLAGS_TEST, \ $(basename $(notdir $@)))), \ -I $d $d/*.ml $d/*.mli) \ > $(dir $@).depend $(CHMOD_RO) $(dir $@).depend # Otherwise do it only if necessary $(PLUGIN_DIR)/$(PLUGIN_NAME)_DEP: $(PLUGIN_GENERATED) $(TARGET_MLI) $(TARGET_GUI_MLI) $(PRINT_DEP) $(dir $@).depend $(CHMOD_RW) $(dir $@).depend $(OCAMLDEP) $(INCLUDES_FOR_OCAMLDEP) \ $($(basename $(notdir $@))FLAGS) \ $(patsubst ./%,%, \ $($(patsubst %_DEP,%_ML_SRC,$(basename $(notdir $@)))) \ $($(patsubst %_DEP,%_MLI, $(basename $(notdir $@)))) \ $($(patsubst %_DEP,%_gui_MLI, $(basename $(notdir $@))))) \ $(foreach d, $($(basename $(notdir $@))FLAGS_TEST), -I $d $d/*.ml $d/*.mli) \ > $(dir $@).depend $(TOUCH) $@ $(CHMOD_RW) $(dir $@).depend # touch above = Do not recompute dependances each times ############ # Cleaning # ############ .PHONY: $(PLUGIN_DIR)/$(PLUGIN_NAME)_CLEAN $(PLUGIN_DIR)/$(PLUGIN_NAME)_CLEAN: $(PRINT_RM) $(patsubst %_CLEAN, %, $(notdir $@)) if test "$(FRAMAC_MAKE)" = "yes"; then \ $(RM) $(dir $@).depend; \ fi $(RM) $(PLUGIN_GENERATED) $(RM) $(@:%CLEAN=%DEP) $(@:%CLEAN=%DEP_REDO) $(RM) $(patsubst %.cmo,%.cm*,$($(patsubst %_CLEAN,%_CMO,$(notdir $@)))) $(RM) $(patsubst %.cmi,%.cm*,$($(patsubst %_CLEAN,%_CMI,$(notdir $@)))) $(RM) $(patsubst %.cmo,%.annot,\ $($(patsubst %_CLEAN,%_CMO,$(notdir $@)))) $(RM) $(patsubst %.cmo,%.o,$($(patsubst %_CLEAN,%_CMO,$(notdir $@)))) $(RM) $(patsubst %.cmo,%.cm*,\ $($(patsubst %_CLEAN,%_GUI_CMO,$(notdir $@)))) $(RM) $(patsubst %.cmi,%.cm*, \ $($(patsubst %_CLEAN,%_GUI_CMI,$(notdir $@)))) $(RM) $(patsubst %.cmo,%.annot, \ $($(patsubst %_CLEAN,%_GUI_CMO,$(notdir $@)))) $(RM) $(patsubst %.cmo,%.o, \ $($(patsubst %_CLEAN,%_GUI_CMO,$(notdir $@)))) $(RM) $(dir $@)*~ $(dir $@)*.cm* $(dir $@)*.o $(dir $@)*.annot $(RM) -r $(dir $@)gui $(RM) $(foreach d, $(@:%CLEAN=%TESTS_LIB), \ $(foreach f, $($(notdir $d)), \ $f $(f:.cmx=.cmo) $(f:.cmx=.opt) $(f:.cmx=.byte) $(f:.cmx=.o))) .PHONY: $(PLUGIN_DIR)/$(PLUGIN_NAME)_DIST_CLEAN $(PLUGIN_DIR)/$(PLUGIN_NAME)_DIST_CLEAN: $(RM) $(dir $@)/ptests_local_config.* .PHONY: $(PLUGIN_DIR)/$(PLUGIN_NAME)_CLEAN_DOC $($(PLUGIN_NAME)_DOC_DIR) $(PLUGIN_DIR)/$(PLUGIN_NAME)_CLEAN_DOC: $($(PLUGIN_NAME)_DOC_DIR) $(PRINT_RM) documentation of $(patsubst %_CLEAN_DOC, %, $(notdir $@)) $(RM) -r $< $(RM) $(DOC_DIR)/$(notdir $(patsubst %_CLEAN_DOC,%,$@).toc) # Global lists seen in Makefile.in ifeq ($(PLUGIN_DYNAMIC),yes) #dynamic plugin PLUGIN_DYN_EXISTS:=yes PLUGIN_DYN_LIST += $(PLUGIN_DIR)/$(PLUGIN_NAME) ifdef PLUGIN_EXTRA_BYTE .PRECIOUS: $(TARGET_CMO) PLUGIN_DYN_CMO_LIST += $(TARGET_CMA) else PLUGIN_DYN_CMO_LIST += $(TARGET_CMO) endif PLUGIN_DYN_DEP_GUI_CMO_LIST += $(PLUGIN_GUI_CMO) ifeq ($(HAS_GUI),yes) PLUGIN_DYN_GUI_EXISTS:=yes ifdef PLUGIN_EXTRA_BYTE PLUGIN_DYN_GUI_CMO_LIST += $(TARGET_GUI_CMA) else PLUGIN_DYN_GUI_CMO_LIST += $(TARGET_GUI_CMO) endif #EXTRA_BYTE endif #HAS_GUI ifeq ($(USABLE_NATIVE_DYNLINK),yes) PLUGIN_DYN_DEP_GUI_CMX_LIST += $(PLUGIN_GUI_CMX) PLUGIN_DYN_CMX_LIST += $(TARGET_CMXS) ifeq ($(HAS_GUI),yes) PLUGIN_DYN_GUI_CMX_LIST += $(TARGET_GUI_CMXS) endif else # No native dynlink: use a static version PLUGIN_CMX_LIST += $(TARGET_CMX) ifdef PLUGIN_EXTRA_OPT EXTRA_OPT_LIBS+= $(PLUGIN_EXTRA_OPT) endif PLUGIN_DEP_GUI_CMX_LIST += $(PLUGIN_GUI_CMX) ifeq ($(HAS_GUI),yes) PLUGIN_GUI_CMX_LIST += $(TARGET_GUI_CMX) endif # HAS_GUI endif # USABLE_NATIVE_DYNLINK else # Normal plugin PLUGIN_LIST += $(PLUGIN_DIR)/$(PLUGIN_NAME) ifdef PLUGIN_EXTRA_BYTE .PRECIOUS: $(TARGET_CMO) $(TARGET_GUI_CMO) PLUGIN_CMO_LIST += $(TARGET_CMA) PLUGIN_GUI_CMO_LIST += $(TARGET_GUI_CMA) PLUGIN_DEP_GUI_CMO_LIST += $(PLUGIN_GUI_CMA) else PLUGIN_CMO_LIST += $(TARGET_CMO) PLUGIN_GUI_CMO_LIST += $(TARGET_GUI_CMO) PLUGIN_DEP_GUI_CMO_LIST += $(PLUGIN_GUI_CMO) endif #PLUGIN_CMO_LIST += $(TARGET_CMO) ifdef PLUGIN_EXTRA_OPT .PRECIOUS: $(TARGET_CMX) $(TARGET_GUI_CMX) PLUGIN_CMX_LIST += $(TARGET_CMXA) PLUGIN_GUI_CMX_LIST += $(TARGET_GUI_CMXA) DEP_CMXS=$(TARGET_CMXA) PLUGIN_DEP_GUI_CMX_LIST += $(PLUGIN_GUI_CMXA) else PLUGIN_CMX_LIST += $(TARGET_CMX) PLUGIN_GUI_CMX_LIST += $(TARGET_GUI_CMX) DEP_CMXS=$(TARGET_CMX) PLUGIN_DEP_GUI_CMX_LIST += $(PLUGIN_GUI_CMO) endif endif PLUGIN_INTERNAL_CMO_LIST += $(PLUGIN_CMO) PLUGIN_INTERNAL_CMX_LIST += $(PLUGIN_CMX) PLUGIN_DOC_LIST += $(PLUGIN_NAME)_DOC PLUGIN_DOC_DIRS += $(PLUGIN_BASE) ifeq ($(PLUGIN_DISTRIBUTED),yes) PLUGIN_DISTRIBUTED_NAME_LIST += $(PLUGIN_NAME) endif else $(PLUGIN_DIR)/$(PLUGIN_NAME)_DEP_REDO: $(PLUGIN_DIR)/$(PLUGIN_NAME)_DEP: $(PLUGIN_DIR)/$(PLUGIN_NAME)_CLEAN: endif # Reset each "local" plugin variable ifneq ($(PLUGIN_RESET),no) PLUGIN_RESET:= #PLUGIN_NAME and PLUGIN_DIR must be redefined before any new inclusion. #PLUGIN_NAME:= #PLUGIN_DIR:= PLUGIN_CMI:= PLUGIN_CMO:= PLUGIN_BFLAGS:= PLUGIN_OFLAGS:= PLUGIN_DEPFLAGS:= PLUGIN_DOCFLAGS:= PLUGIN_GENERATED:= PLUGIN_HAS_MLI:= PLUGIN_DYNAMIC:= PLUGIN_TYPES_CMO:= PLUGIN_GUI_CMO:= PLUGIN_GUI_CMX:= PLUGIN_GUI_CMI:= PLUGIN_GUI_MLI:= TARGET_GUI_CMO:= TARGET_GUI_CMX:= PLUGIN_UNDOC:= PLUGIN_TYPES_TODOC:= PLUGIN_INTRO:= PLUGIN_ENABLE:= PLUGIN_NO_TEST:= PLUGIN_TESTS_LIB:= PLUGIN_TESTS_DIRS:= PLUGIN_DEPENDS:= PLUGIN_DISTRIBUTED:= PLUGIN_DISTRIB_BIN:= PLUGIN_DISTRIB_EXTERNAL:= PLUGIN_HAS_EXT_DOC:= PLUGIN_NO_DEFAULT_TEST:= PLUGIN_TESTS_DIRS_DEFAULT:= PLUGIN_LINK_GUI_BFLAGS:= PLUGIN_LINK_GUI_OFLAGS:= PLUGIN_LINK_BFLAGS:= PLUGIN_LINK_OFLAGS:= PLUGIN_EXTRA_BYTE:= PLUGIN_EXTRA_OPT:= PLUGIN_INTERNAL_TEST:= PLUGIN_DOC_DIR:= endif ############################################################################### # Local Variables: # mode: makefile # End: frama-c-Fluorine-20130601/share/Makefile.dynamic_config.internal0000644000175000017500000000424112155630244023325 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## export FRAMAC_INTERNAL=yes #export FRAMAC_SHARE=$(abspath $(FRAMAC_SRC)/share) export FRAMAC_PLUGIN_TEST=$(abspath $(FRAMAC_SRC)/lib/plugins) export FRAMAC_PLUGIN_GUI_TEST=$(abspath $(FRAMAC_SRC)/lib/plugins/gui) export FRAMAC_OPT=$(abspath $(FRAMAC_SRC)/bin/toplevel.opt$(EXE)) #export FRAMAC_BYTE=$(FRAMAC_SRC)/bin/toplevel.byte$(EXE) export FRAMAC_INCLUDES=$(addprefix -I $(FRAMAC_SRC)/, $(FRAMAC_SRC_DIRS) lib) export PTESTS=$(abspath $(FRAMAC_SRC)/bin/ptests.byte$(EXE)) export PLUGIN_LIB_DIR=$(abspath $(FRAMAC_SRC)/lib/plugins) export FRAMAC_LIB=$(abspath $(FRAMAC_SRC)/lib/fc) export DOC_DIR=$(abspath $(FRAMAC_SRC)/doc/code)frama-c-Fluorine-20130601/share/Makefile.common0000644000175000017500000002643612155630244020043 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## ########################################################################## # # # Define common stuff shared by makefiles. # # # ########################################################################## include $(MAKECONFIG_DIR)/Makefile.config ####################### # Working directories # ####################### # Frama-C kernel directories UNPACKED_DIRS= misc ai memory_state toplevel slicing_types pdg_types \ kernel logic lib printer project type buckx gui UNPACKED_DIRS:= $(addprefix src/, $(UNPACKED_DIRS)) UNPACKED_DIRS+= external CIL_PATH= cil/src CIL_DIRS= $(CIL_PATH) $(CIL_PATH)/ext $(CIL_PATH)/frontc $(CIL_PATH)/logic \ cil/ocamlutil FRAMAC_SRC_DIRS=$(UNPACKED_DIRS) $(CIL_DIRS) ################## # Flags # ################## ifeq ($(findstring 3.10,$(OCAMLVERSION)),) HAS_OCAML311 = yes else HAS_OCAML311 = no endif ifeq ($(HAS_OCAML311),yes) ifeq ($(findstring 3.12,$(OCAMLVERSION)),) ifeq ($(findstring 3.13,$(OCAMLVERSION)),) # obsolete version number ifeq ($(findstring 4.00,$(OCAMLVERSION)),) ifeq ($(findstring 4.01,$(OCAMLVERSION)),) HAS_OCAML312 = no # Ocaml 3.11 HAS_OCAML400 = no else HAS_OCAML312 = yes HAS_OCAML400 = yes endif # 4.01 else HAS_OCAML312 = yes HAS_OCAML400 = yes endif # 4.00 else HAS_OCAML312 = yes HAS_OCAML400 = no endif # 3.13 else HAS_OCAML312 = yes HAS_OCAML400 = no endif else HAS_OCAML312 = no # OCaml 3.10 HAS_OCAML400 = no endif # All warnings are activated by default: this could grow up the chance of # compatibility breaks with future versions of the caml compilers. # BUT that is only the case of the SVN version # since the distrib is not compiled with -warn-error. # See BTS #310 and #638. ifeq ($(HAS_OCAML312),yes) WARNINGS= -w +a-4-6-7-9 # add warning 7 and 9 whenever 3.12 will be mandatory else WARNINGS= -w Ael endif FLAGS = $(WARNINGS) $(OCAML_ANNOT_OPTION) $(OPTIM) DEBUG = -g ############# # Verbosing # ############# ifneq ($(VERBOSEMAKE),no) # Do not change to ifeq ($(VERBOSEMAKE),yes), as this # version makes it easier for the user to set the # option on the command-line to investigate # Makefile-related problems # ignore the PRINT_* materials but print all the other commands PRINT = @true # prevent the warning "jobserver unavailable: using -j1". # see GNU make manual (section 5.7.1 and appendix B) QUIET_MAKE:= + $(MAKE) # prevent the warning: "-jN forced in submake: disabling jobserver mode". # see GNU make manual (appendix B) MAKE := MAKEFLAGS="$(patsubst j,,$(MAKEFLAGS))" $(MAKE) else # print the PRINT_* materials PRINT = @echo # but silently execute all the other commands # fixed bug #637: do not write spaces between flags OLDFLAGS:=r$(MAKEFLAGS) MAKEFLAGS:=rs$(MAKEFLAGS) # do not silently execute other makefiles (e.g the one of why): # the redefinition of MAKE below is for this purpose # but use QUIET_MAKE in order to call silently the initial Makefile QUIET_MAKE:= + $(MAKE) MAKE := MAKEFLAGS="$(OLDFLAGS)" $(MAKE) endif ################ # Calling Make # ################ # Function to be called to call make on a given plugin (first argument) and # a given rule (second argument) external_make = \ $(MAKE) FRAMAC_INTERNAL=yes \ FRAMAC_SRC=$(FRAMAC_TOP_SRCDIR) \ PLUGIN_LIB_DIR="\ $(if $(filter /%,$(PLUGIN_LIB_DIR)),$(PLUGIN_LIB_DIR),\ $(FRAMAC_TOP_SRCDIR)/$(PLUGIN_LIB_DIR))" \ PLUGIN_GUI_LIB_DIR="\ $(if $(filter /%,$(PLUGIN_GUI_LIB_DIR)),$(PLUGIN_GUI_LIB_DIR),\ $(FRAMAC_TOP_SRCDIR)/$(PLUGIN_GUI_LIB_DIR))" \ FRAMAC_LIBDIR="$(FRAMAC_TOP_SRCDIR)/lib/fc" \ FRAMAC_SHARE="$(FRAMAC_TOP_SRCDIR)/share" -C $(1) $(2) ################## # Shell commands # ################## # prefer to use these commands and not directly "cp" or others CAT = cat CHMOD = chmod CHMOD_RO= chmod a-w CHMOD_RW= sh -c \ 'for f in "$$@"; do \ if test -e $$f; then chmod u+w $$f; fi \ done' chmod_rw CP = install ECHO = echo MKDIR = mkdir -p MV = mv ISED = sh -c \ 'new_temp=`mktemp /tmp/frama-c.XXXXXXX` || exit 1; \ sed "$$@" > $$new_temp; \ eval last=\$${$$\#}; \ mv $$new_temp $$last' sed_inplace SED = LC_ALL=C sed RM = rm -f TAR = tar TOUCH = touch ########################### # Command pretty printing # ########################### PRINT_OCAMLC =$(PRINT) 'Ocamlc '# PRINT_OCAMLOPT =$(PRINT) 'Ocamlopt '# PRINT_DEP =$(PRINT) 'Ocamldep '# PRINT_OCAMLLEX =$(PRINT) 'Ocamllex '# PRINT_OCAMLYACC =$(PRINT) 'Ocamlyacc '# PRINT_OCAMLMKTOP=$(PRINT) 'Ocamlmktop '# PRINT_DOC =$(PRINT) 'Ocamldoc '# PRINT_OCAMLCP =$(PRINT) 'Profiling '# PRINT_CAMLP4 =$(PRINT) 'Camlp4 '# PRINT_PACKING =$(PRINT) 'Packing '# PRINT_LINKING =$(PRINT) 'Linking '# PRINT_INFERRING =$(PRINT) 'Inferring '# PRINT_MAKING =$(PRINT) 'Generating '# PRINT_MV =$(PRINT) 'Moving to '# PRINT_CP =$(PRINT) 'Copying to '# PRINT_RM =$(PRINT) 'Cleaning '# PRINT_EXEC =$(PRINT) 'Running '# PRINT_TAR =$(PRINT) 'Archiving '# PRINT_UNTAR =$(PRINT) 'Unarchiving '# PRINT_CONFIG =$(PRINT) 'Configuring '# PRINT_BUILD =$(PRINT) 'Building '# PRINT_INSTALL =$(PRINT) 'Installing '# PRINT_UPDATE =$(PRINT) 'Updating '# PRINT_DOT =$(PRINT) 'Dot '# PRINT_LATEX =$(PRINT) 'Latex '# PRINT_DVIPS =$(PRINT) 'Dvips '# PRINT_HEVEA =$(PRINT) 'Hevea '# ######### # Tests # ######### define COMPILE_TESTS_ML_FILES # Function with two arguments: # - $(1) is the test directory under consideration. # - $(2) is the name of Frama-C component under test (plugin or some core part) ML_TESTS:=$(wildcard tests/$(1)/*.ml) .PRECIOUS: $(patsubst %.ml, %.cmo, $(ML_TESTS)) \ $(patsubst %.ml, %.cmx, $(ML_TESTS)) \ $(patsubst %.ml, %.cmxs, $(ML_TESTS)) \ $(patsubst %.ml, %.opt, $(ML_TESTS)) \ $(patsubst %.ml, %.byte, $(ML_TESTS)) # [JS 2009/03/18] in the 5 rules below, don't print anything while VERBOSEMAKE # is not set (otherwise "make tests" is too much verbose) $(1)_TESTS_INCLUDES=$$(addprefix -I tests/, $$($(2)_TESTS_DIRS)) tests/$(1)/%.cmo: BFLAGS+=$$($(2)_BFLAGS) $$($(1)_TESTS_INCLUDES) tests/$(1)/%.cmo: tests/$(1)/%.ml $$(CMO) $$($(2)_CMO) $$(GEN_BYTE_LIBS) $$(OCAMLC) -c $$(BFLAGS) $$($(1)_TESTS_INCLUDES) $$< tests/$(1)/%.byte: tests/$(1)/%.cmo $(3:.cmx=.cmo) bin/toplevel.byte$$(EXE) $$(OCAMLC) $$(BLINKFLAGS) $$($(1)_TESTS_INCLUDES) -o $$@ \ $$(BYTE_LIBS) $$(filter-out $$(STARTUP_CMO),$$(ALL_BATCH_CMO)) $(3:.cmx=.cmo) \ $$< $$(STARTUP_CMO) # [JS 2009/05/29] don't use $$(CMX) # [VP 2010/04/22] don't call directly ocamlopt, just refine flags of generic # rule, which is chosen by make anyway tests/$(1)/%.cmx: OFLAGS+= $$($(2)_OFLAGS) $$($(1)_TESTS_INCLUDES) $(patsubst %.ml,%.cmx,$(wildcard tests/$(1)/*.ml tests/$(1)/*/*.ml)): \ $$(CMO:.cmo=.cmx) $$($(2)_CMX) $$(GEN_OPT_LIBS) tests/$(1)/%.cmxs: OFLAGS+= $$($(2)_OFLAGS) $$($(1)_TESTS_INCLUDES) $(patsubst %.ml,%.cmxs,$(wildcard tests/$(1)/*.ml tests/$(1)/*/*.ml)): \ $$(CMO:.cmo=.cmx) $$($(2)_CMX) $$(GEN_OPT_LIBS) tests/$(1)/%.opt: tests/$(1)/%.cmx $(3) bin/toplevel.opt$$(EXE) $$(OCAMLOPT) $$(OLINKFLAGS) $$($(1)_TESTS_INCLUDES) -o $$@ \ $$(OPT_LIBS) $$(filter-out $$(STARTUP_CMX),$$(ALL_BATCH_CMX)) $(3) $$< $$(STARTUP_CMX) $(filter-out $(3),$(patsubst %.ml,%.cmx,$(wildcard tests/$(1)/*.ml))): $(3) $(filter-out $(3:.cmx=.cmo), \ $(patsubst %.ml,%.cmo,$(wildcard tests/$(1)/*.ml))): \ $(3:.cmx=.cmo) endef #COMPILE_TESTS_ML_FILES ################# # Documentation # ################# ifeq ("$(OCAMLDOC)","ocamldoc.opt") DOC_PLUGIN=$(DOC_DIR)/docgen.cmxs else DOC_PLUGIN=$(DOC_DIR)/docgen.cmo endif ################# # Generic rules # ################# .DEFAULT_GOAL=all ifndef SUFFIXES_ARE_SET SUFFIXES_ARE_SET:=true # The former .SUFFIXES delete all predefined implicit rules # The latter .SUFFIXES defines our suffix list # See GNU Make manual, section 10.7 # This way of declaring implicit rules is deprecated, # but that is the only way for removing **all** predefined implicit rules # The only other way is to remove each predefined implicit rule, one by one. .SUFFIXES: .SUFFIXES: .c .o .mli .ml .cmi .cmo .cmx .mll .mly .tex .dvi .ps .html .cmxs \ .png .svg .ps ifdef DOT %.png: %.dot $(PRINT_DOT) $@ $(DOT) -Tpng -o $@ $< %.svg: %.dot $(PRINT_DOT) $@ $(ISED) -e "s/\(digraph .*\)/\1 node [href=\"\\\\N.html\"];/" $< $(DOT) -Tsvg -o $@ $< %.ps: %.dot $(PRINT_DOT) $@ $(DOT) -Tps -o $@ $< else %.png: %.dot @$(ECHO) "dot missing: generation of $@ skipped." %.svg: %.dot @$(ECHO) "dot missing: generation of $@ skipped." %.ps: %.dot @$(ECHO) "dot missing: generation of $@ skipped." endif .mli.cmi: $(PRINT_OCAMLC) $@ $(OCAMLC) -c $(BFLAGS) $< .ml.cmi: $(PRINT_OCAMLC) $@ if `test -e $ $@ %.cmx: %.ml $(PRINT_OCAMLOPT) $@ $(OCAMLOPT) -c $(OFLAGS) $< # .o are generated together with .cmx, but %.o %.cmx: %.ml only confuses # make when computing dependencies... %.o: %.cmx : .ml.cmxs: $(PRINT_PACKING) $@ $(OCAMLOPT) -shared -o $@ $(OFLAGS) $< .mll.ml: $(PRINT_OCAMLLEX) $@ $(CHMOD_RW) $@ $(OCAMLLEX) $< $(CHMOD_RO) $@ %.mli %.ml: %.mly $(PRINT_OCAMLYACC) $@ $(CHMOD_RW) $(<:.mly=.ml) $(<:.mly=.mli) $(OCAMLYACC) -v $< $(CHMOD_RO) $(<:.mly=.ml) $(<:.mly=.mli) .tex.dvi: $(PRINT_LATEX) $@ latex $< && latex $< .dvi.ps: $(PRINT_DVIPS) $@ dvips $< -o $@ .tex.html: $(PRINT_HEVEA) $@ hevea $< .c.o: $(PRINT_OCAMLC) $@ $(OCAMLC) $(BFLAGS) -ccopt "-o $@" $< endif frama-c-Fluorine-20130601/share/configure.ac0000644000175000017500000004552112155630244017376 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## # AC_ARG_WITH(frama-c, # AC_HELP_STRING([Frama-C executable name (default is 'frama-c')]), # [FRAMA_C=$withval], # [FRAMA_C=frama-c]) # AC_ARG_WITH(frama-c-gui, # AC_HELP_STRING([Frama-C executable name (default is 'frama-c')]), # [FRAMA_C_GUI=$withval], # [FRAMA_C_GUI=frama-c-gui]) m4_ifdef([FRAMAC_MAIN_AUTOCONF],, [m4_ifdef([plugin_file], [AC_INIT(plugin_file)], [AC_INIT(aclocal.m4)]) [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 ] AC_SUBST([FRAMAC_VERSION], [`frama-c -version | sed -n -e "s|^Version: *\(.*\)$|\1|p"`]) AC_CHECK_PROG(ENABLE_GUI,[frama-c-gui],[yes],[no]) ]) m4_define([PLUGIN_RELATIVE_PATH], [m4_ifdef([plugin_prefix],plugin_prefix/$1,$1)]) upper() { echo "$1" | tr "a-z-" "A-Z_" } lower() { echo "$1" | tr "A-Z" "a-z" } m4_define([tovarname],[m4_esyscmd(printf "%s" $1 | tr "a-z-" "A-Z_")]) new_section() { banner=`echo "* $1 *" | sed -e 's/./*/g'` title=`echo "* $1 *" | tr "a-z" "A-Z"` AC_MSG_NOTICE($banner) AC_MSG_NOTICE($title) AC_MSG_NOTICE($banner) } define([FRAMAC_M4_MACROS]) # sadly, there's no way to define a new diversion beside the internal ones. # hoping for the best here... m4_define([frama_c_configure_tool],m4_incr(m4_divnum)) m4_define([PLUGINS_LIST],[]) # to distinguish internal plugins, known by the main configure, from # purely external plugins living in src/ and compiled together with the main # frama-c define([KNOWN_SRC_DIRS],[]) define([check_plugin], [ define([PLUGIN_NAME],$1) define([PLUGIN_FILE],$2) define([PLUGIN_MSG],$3) define([PLUGIN_DEFAULT],$4) define([PLUGIN_DYNAMIC],$5) define([PLUGIN_ADDITIONAL_DIR],$6) AC_CHECK_FILE(PLUGIN_FILE, default=PLUGIN_DEFAULT;plugin_present=yes, plugin_present=no;default=no) FORCE=no define([PLUGIN_HELP], AC_HELP_STRING([--enable-PLUGIN_NAME], [PLUGIN_MSG (default: PLUGIN_DEFAULT)])) AC_ARG_ENABLE( [PLUGIN_NAME], PLUGIN_HELP, ENABLE=$enableval;FORCE=$enableval, ENABLE=$default ) if test "$ONLY_KERNEL" = "yes" -a "$FORCE" = "no"; then ENABLE=no fi define([KNOWN_SRC_DIRS],KNOWN_SRC_DIRS PLUGIN_FILE PLUGIN_ADDITIONAL_DIR) # 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 AC_MSG_ERROR([PLUGIN_NAME is not available]) fi define([UP],[tovarname(PLUGIN_NAME)]) [FORCE_]UP=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "[FORCE_]UP define([PLUGINS_LIST],PLUGINS_LIST UP) [ENABLE_]UP=$ENABLE [NAME_]UP=PLUGIN_NAME if test "$default" = "no" -a "$FORCE" = "no"; then [INFO_]UP=" (not available by default)" fi # Dynamic plug-ins configuration m4_if("PLUGIN_DYNAMIC","yes", [define([STATIC_HELP], AC_HELP_STRING([--with-PLUGIN_NAME-static], [link PLUGIN_NAME statically (default: no)])) AC_ARG_WITH(PLUGIN_NAME[-static],STATIC_HELP, [is_static=$withval], [is_static=$IS_ALL_STATIC]) undefine([STATIC_HELP]) # 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_]UP=$is_static if test "$is_static" != "yes"; then USE_NATIVE_DYNLINK="${USE_NATIVE_DYNLINK} PLUGIN_NAME" [DYNAMIC_]UP=yes else [DYNAMIC_]UP=no fi], # static plug-in [[DYNAMIC_]UP=no]) AC_SUBST([ENABLE_]UP) AC_SUBST([DYNAMIC_]UP) echo "PLUGIN_NAME... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) m4_undefine([PLUGIN_FILE]) m4_undefine([PLUGIN_MSG]) m4_undefine([PLUGIN_DEFAULT]) m4_undefine([PLUGIN_DYNAMIC]) m4_undefine([PLUGIN_ADDITIONAL_DIR]) m4_undefine([UP]) ]) # 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) m4_define([configure_library], [ # No need to check the same thing multiple times. m4_ifdef(SELECTED_$1,, [ m4_define([VAR],[$1]) m4_define([SELECTED_VAR],[SELECTED_$1]) m4_define([PROG],[$2]) m4_define([require],[$REQUIRE_$1]) m4_define([use],[$USE_$1]) m4_define([msg],[$3]) m4_define([has],[HAS_$1]) m4_define([file],[FILE_$1]) # [JS 2009/06/02] sh tests and m4 variables do not mix well together. # It works by chance but it is not robust enough. # Should be rewritten has=no m4_foreach(file,[PROG], [if test "$has" != "yes"; then AC_CHECK_FILE(file,has=yes,has=no) if test "$has" = "yes"; then SELECTED_VAR=file fi fi] ) VAR=$SELECTED_VAR m4_divert_push(frama_c_configure_tool) if test -n "require" -o -n "use" -o "$force_check" = "yes"; then if test "$has" = "no"; then AC_MSG_WARN([msg]) reason="PROG missing" $5 for p in require; 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 AC_MSG_ERROR([$p requested but $reason.]) fi eval $ep="no\ \(see\ warning\ about\ PROG\)" AC_MSG_WARN([$p disabled because $reason.]) eval INFO_$up=\", $reason\" fi done for p in use; 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\ PROG\)" AC_MSG_WARN([$p partially enabled because $reason.]) eval INFO_$up=\", $reason\" fi done fi fi m4_divert_pop(frama_c_configure_tool) AC_SUBST(VAR) AC_SUBST(has) undefine([SELECTED_VAR]) undefine([VAR]) undefine([PROG]) undefine([require]) undefine([use]) undefine([msg]) undefine([has]) undefine([file]) ]) ]) # 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) m4_define([configure_tool], [ m4_ifdef(HAS_$1,, [ define([VAR],[$1]) define([PROG],[$2]) define([require],[$REQUIRE_$1]) define([use],[$USE_$1]) define([msg],[$3]) define([has],[HAS_$1]) define([force_check],[$4]) for file in PROG; do has= AC_CHECK_PROG(has,$file,yes,no) if test "$has" = "yes"; then SELECTED_VAR=$file break; fi done m4_divert_push(frama_c_configure_tool) if test -n "require" -o -n "use" -o "$force_check" = "yes"; then if test "$has" = "no"; then AC_MSG_WARN([msg]) reason="PROG missing" for p in require; 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 AC_MSG_ERROR([$p requested but $reason.]) fi eval $ep="no\ \(see\ warning\ about\ PROG\)" AC_MSG_WARN([$p disabled because $reason.]) eval INFO_$up=\", $reason\" fi done for p in use; 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\ PROG\)" AC_MSG_WARN([$p partially enabled because $reason.]) eval INFO_$up=\", $reason\" fi done else VAR=PROG fi fi m4_divert_pop(frama_c_configure_tool) AC_SUBST(VAR) AC_SUBST(has) undefine([VAR]) undefine([PROG]) undefine([require]) undefine([use]) undefine([msg]) undefine([has]) ]) ]) EXTERNAL_PLUGINS= define([plugin_require_external], [m4_define([UPORIG],tovarname($2)) m4_define([REQUIRE],[REQUIRE_]UPORIG) REQUIRE=$REQUIRE" "$1 m4_undefine([REQUIRE]) m4_undefine([UPORIG])]) define([plugin_use_external], [m4_define([UPORIG],tovarname($2)) m4_define([USE],[USE_]UPORIG) USE=$USE" "$1 m4_undefine([USE]) m4_undefine([UPORIG])]) define([plugin_require], [m4_define([UPTARGET],tovarname($1)) m4_define([UPORIG],tovarname($2)) m4_define([REQUIRE],[REQUIRE_]UPORIG) m4_define([REQUIRED],[REQUIRED_]UPTARGET) REQUIRE=$REQUIRE" "$1 REQUIRED=$REQUIRED" "$2 m4_undefine([UPTARGET]) m4_undefine([UPORIG]) m4_undefine([REQUIRE]) m4_undefine([REQUIRED]) ]) define([plugin_use], [m4_define([UPTARGET],tovarname($1)) m4_define([UPORIG],tovarname($2)) m4_define([USE],[USE_]UPORIG) m4_define([USED],[USED_]UPTARGET) USE=$USE" "$1 USED=$USED" "$2 m4_undefine([UPTARGET]) m4_undefine([UPORIG]) m4_undefine([USE]) m4_undefine([USED]) ]) # 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 AC_MSG_ERROR([$lp requested but $reason.]) else AC_MSG_WARN([$lp disabled because $reason.]) fi else if test "$short_mark" = "partial"; then reason=`echo $2 | sed -e 's/partial (\(.*\))/\1/' ` AC_MSG_WARN([$lp only partially enable because $reason.]) 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 AC_MSG_WARN([$lp only partially enabled because $reason.]) 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` AC_MSG_WARN([$p_name disabled because $reason.]) 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` AC_MSG_WARN([$p_name partially enabled because $reason.]) 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 } define([compute_plugin_dependencies], [ # 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 ]) define([check_frama_c_dependencies], [m4_undivert(frama_c_configure_tool) compute_plugin_dependencies]) define([check_plugin_dependencies], [m4_ifdef([FRAMAC_MAIN_AUTOCONF],, [m4_undivert(frama_c_configure_tool) compute_plugin_dependencies])]) define([write_plugin_summary], [ m4_ifdef([FRAMAC_MAIN_AUTOCONF],, [ # 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 AC_MSG_NOTICE([$name: $ep_v$info]) fi done])]) define([write_plugin_config], [m4_ifndef([plugin_prefix],[define([plugin_prefix],[.])]) m4_define([plugin_files], AC_FOREACH([plugin_file],$1,[plugin_prefix/plugin_file ])) m4_define([files_chmod], AC_FOREACH([plugin_file],plugin_files,[chmod -w plugin_file])) AC_CONFIG_FILES(plugin_files,files_chmod) m4_ifdef( [FRAMAC_MAIN_AUTOCONF], if test "$[ENABLE_]tovarname(PLUGIN_NAME)" != "no"; then [EXTERNAL_PLUGINS="${EXTERNAL_PLUGINS} plugin_prefix"]; fi, [ write_plugin_summary AC_OUTPUT() ]) ]) frama-c-Fluorine-20130601/share/frama-c.gif0000644000175000017500000001550312155630244017102 0ustar mehdimehdiGIF89ale!bG   # !&#$)&',)*0-.523C@AB?@@=>KHIHEFSPQMJK^[\`]^:89USTOMNdbcZXYWUVzxyustpnomklή "#+6DKT]d}NJМէp̔޻({2s m]^^`abcce g!f!f!f"uĩU Y[]]]^_``aabbacadd e!e!e"e"b"f"a!h&k)p1w:GOZ`i]"ɴUMLW"S#M#H"C F!E!E!G#G"H$G$F$E#F#E#F#H$L*R2X8\?_A_B`CcFbFdGhLlQv]~fyB$E$C#A#V9Y Q=sC>ʦ,89H B-A:)ƶ-0 PtP;xي =$* !AɣQieB4$@d #\:9|j衄B(砈FZVzDj* d@fA(☧Jc'ꪬIWT1뮸Re T 44c&3X봺Na03\0ٔl&\0\ 4O0Lq>_d;hHo!2/F R C*N&#!1gOv I$m$h`|"4DPJ(!K Nxn9LAnts 7T^1L[N5\5 8:,QJC[D&1u~$i ) ePQ<`4F@һv_2 hbv!I E0 뭿o8Q5tN1+eB B h8ou>xH1Ch0 @x@#N((⮒!D%@o=l"4N :%NJXpnPnX`6!!uSWwA `D݆H>ao|L &4=.P0z"AE$Qn6Q=d E& ō|l`?e_Zodq2v$|~+ߧ1 %x6Nv+$0'O ZA䱁Q" (;Xsƒ$P8"'` m+.DqeF` ENJ}C;Za Sas 0irzP !2q7Z4ERIXOnY(=8}RS`ыZÔ'2Aje ($bxEip ?8dz ZBRL"6 -mt`D8`"xS"Ҙ'D'.JHnqZI\*;lpT XuUp [ixHSs؄ GĠ (4Q̵lc"8,Є#`+ũ.0~ Z3`j^Ă sD!NECwA ns( < h+| p I(`M- q wPauNձD=ZE!ZbuRz&Q4Z V5{)7J_F7Ldþئ!uli_%E1b@ K @DvlUg91Q&!퀀 d;a@Y$0(Qyqu_ \ܹAOƙk .Zbl!m"u}'8NZ8hBPn ps"a=:u;7&>b4Sͱ $ QFqiWMtfr!;u!߯`5 D %Ѷj[@ @ | Ը,NeX2$ ,@@uw]@@`u D;v%@M̈A8BC!V6,'H: q H |vD'U`>,}R"0[I SZ3cq w͈F4F1 7|8/ K! WB,! _ׇo~ oBC{gJB}(C6iy `fFN6t@ Np y`oo{$D`WpCVP1wED^cW 3 1 ư ѐ`El~W#_pPX_QPp5YFC 0`e pr y0 j6VniA ~4g6Bt00tyne"{:UD;@lh 9  @@p) Tc7w;p`i_>XeЂS8pA>pxEv C7[~Po;Ws p HWtC 1%nd[4o&>iVaNusDGa >Wp@O`:Slps cЊ + W9lY`aG08<@cWX8;`q:w d C sNc Ípcr8(yMIFQm0t5QshC7xJJ`q'BD@pUl.&s v 9ǐ F8VO8::]!)냌b6u.PxNu `1 `3uyHJy\UCd`H`:E8dOeG `ٰ j9wcpw')I{)%8[FG ~q <J֘/P |8f\噷vofk$qEV>|`Y9Ġ ` ` iFP)Sr}酭國Ap 0݃mi峝vh!b0 p'6פv\%rjoQ7XwIUlYv ֐ }ٛ} Jq)si8 uXd6ln*4$u '`:/p 04Zrte7칣U7֔t oJUl7Xv` А ̠ Š[C^*WmFDw ߄  p$e'G$APzؚ`H!)av0nsH>N`(Wh?| @Be ְ ݀U vh*_:"~P)9 ڤ4U`a)`q*)P@*1akgGtAVv{\dTiF?  `9lJ \:8v) [ xy6)p `MM˪?o"kpxz"`/ps;jCJmg3pg|Yh9P`p PVohWʵ|)*ihcI yAt̚\uq0ۻ 06pNIYozWL& :iBIS텯@  D; jƺCG d: ;p4FsJ 6V#8E0u[9U^  ݐ ) Y@=H6lF@8^S98`̉S™tt0JIw GwSQzrX p<xNc{:8zQPP^ 2π }πmqf 6 pK6uB;?@uXq Y ð 0 @̰ wNt'>!@v@@#?<B0dZe w0p rp 7 m<8@ `i6Cd % O5O7R^Z PJd 5 P P ch=fbJ0d`Q66Ћpq% SQ S nPr Ll#[ C_@S:Ip9DÆbvOpmL9Q7*lY s8%H}s{uVXES=p1? U@vZKSY9 5>;uW ATI6 oV QǩWEC?Ӌh C H.KE҇:L@:c oՅo=K"A,[xIU4DHfMP`iB7)oF?\QϠJ*Ҝx C]H :Y0kMhEB7\LrlH'Ƅu*( rU⫗_}[BC=:v™`ܮ%OСE&]%;'>O cY(";x.. .%bg02 rs$RH "\r%\*82ԫ½4ұts$'}Fا|NjPP-A\JqN g\*'ub(:A'#=t88,t֒ȟN8aq걇|\Jp8H!"rJJ|raܹMpTgpH'vB"86^a4 A\3L쑧(R2OS8| }0XJL3|4pu`{4!FQ` 39ɀhu) TA7s'9$Y` Qy`} HrG t^zr: 8B S1G1azĹ4uDպX2%w\hp5bRBmRtIJ )a~'A{V,r$6^zhhVzii: jzkk{l6lV{m۶) ;frama-c-Fluorine-20130601/.make-clean-stamp0000644000175000017500000000000212155630370017107 0ustar mehdimehdi7 frama-c-Fluorine-20130601/INSTALL0000644000175000017500000002237312155630370015037 0ustar mehdimehdi ------------------------- INSTALLATION INSTRUCTIONS ------------------------- =============================================================================== SUMMARY =============================================================================== 0) Summary 1) Automatic Installation 2) Quick Start 3) Requirements 4) Configuration 5) Compilation 6) Installation 7) Custom Installation 8) Testing the Installation 9) Installation of additional plug-ins 10) API Documentation 11) Uninstallation 12) Have Fun with Frama-C! =============================================================================== AUTOMATIC INSTALLATION =============================================================================== ----------------------- Windows OS and Mac OS X ----------------------- Download the auto-installer corresponding to your system from http://frama-c.com/download.html Then just run it! Note: these auto-installers are **not** provided for each Frama-C version. ---------------------------------------------------- Debian >= Squeeze 6.0 and Ubuntu >= Lucid Lynx 10.04 ---------------------------------------------------- If you are using Debian >= Squeeze 6.0 or Ubuntu >= Lucid Lynx 10.04 then a Frama-C package is provided: sudo apt-get install frama-c or, if you don't want the Gtk-based GUI: sudo apt-get install frama-c-base ------------ Fedora >= 13 ------------ If you are using Fedora >= 13 then a Frama-C package is provided: yum install frama-c =============================================================================== The remainder of these installation instructions is for building Frama-C from source. QUICK START =============================================================================== 1) Install OCaml if not already installed. 1b) Optionally, for the GUI, also install Gtk, GtkSourceView, GnomeCanvas and Lablgtk2 if not already installed. 2a) On Linux-like distribution: ./configure && make && sudo make install 2b) On Windows+Cygwin or Windows+MinGW+msys: ./configure --prefix C:/windows/path/with/direct/slash && make && make install 3) The binary frama-c (and frama-c-gui if you have lablgtk2) is now installed. 4) Optionally, test your installation by running: frama-c -val tests/misc/CruiseControl*.c frama-c-gui -val tests/misc/CruiseControl*.c (if frama-c-gui is available) See below for more detailed and specific instructions. =============================================================================== REQUIREMENTS =============================================================================== - GNU make version >= 3.81 - Objective Caml >= 3.12.1; The Frama-C GUI also requires: - Gtk (>= 2.4) - GtkSourceView 2.x - GnomeCanvas 2.x - LablGtk >= 2.14.0 If OcamlGraph 1.8.3 [1] is already installed, then it will be used by Frama-C. Otherwise the distributed local copy (directory ocamlgraph) will be used. If Zarith [2] is installed, it will be used by Frama-C. Otherwise another equivalent less efficient library will be use. Plug-ins may have their own requirements. Consult their specific documentations for details. [1] OcamlGraph: http://ocamlgraph.lri.fr [2] Zarith: http://forge.ocamlcore.org/projects/zarith -------------------------- Ubuntu >= Lucid Lynx 10.04 -------------------------- If you are using Ubuntu >= Lucid Lynx 10.04 then an optimal list of packages is installed by: sudo apt-get install ocaml ocaml-native-compilers graphviz \ liblablgtksourceview2-ocaml-dev liblablgtk2-gnome-ocaml-dev ------------------- Other Linux systems ------------------- Some other Linux systems (e.g. Fedora) provide packages for the required tools and libraries. Please look at your favorite one. Anyway, on any Linux systems, you may use Godi (http://godi.camlcity.org/godi/index.html) for installing Frama-C with all the OCaml requirements (but you must install C libraries and tools before). =============================================================================== CONFIGURATION =============================================================================== Frama-C is configured by "./configure [options]" configure is generated by autoconf, so that the standard options for setting installation directories are available, in particular '--prefix=/path'. A plug-in can be enabled by --enable-plugin and disabled by --disable-plugin. By default, all distributed plug-ins are enabled. Those who defaults to 'no' are not part of the Frama-C distribution (usually because they are too experimental to be released as is). See ./configure --help for the current list of plug-ins, and available options. Under Cygwin or MinGW: ---------------------- Use "./configure --prefix C:/windows/path/with/direct/slash". =============================================================================== COMPILATION =============================================================================== Type "make". Some Makefile targets of interest are: - doc generates the API documentation - top generates an OCaml toplevel embedding Frama-C as a library. - ptests generates the executable that takes care of running Frama-C's tests - oracles set up the tests oracle of Frama-C test suite for your own configuration. - tests performs Frama-C's own tests (use it after oracles) =============================================================================== INSTALLATION =============================================================================== Type "make install" (depending on the installation directory, may require superuser privileges). It is possible to install in a given directory by setting the DESTDIR variable: "make install DESTDIR=/tmp" installs Frama-C in sub-directories of /tmp. The following files are installed. Executables: (usually in /usr/local/bin) ------------ - frama-c - frama-c-gui if available - frama-c.byte bytecode version of frama-c - frama-c-gui.byte bytecode version of frama-c-gui, if available - ptests.byte testing tools for Frama-c - frama-c.toplevel if 'make top' previously done Shared files: (usually in /usr/local/share/frama-c and subdirectories) ------------- - some .h and .c files used as preludes by Frama-C; - some Makefiles used to compile dynamic plug-ins - some .rc files used to configure Frama-C - some image files used by the Frama-C GUI Manuals: (usually in /usr/local/share/frama-c/manuals) -------- - the Frama-C manuals as .pdf files Documentation files: (usually in /usr/local/share/frama-c/doc) -------------------- - files used to generate dynamic plug-in documentation Object files: (usually in /usr/local/lib/frama-c) ------------- - object files used to compile dynamic plug-ins Plug-in files: (usually in /usr/local/lib/frama-c/plugins) -------------- - object files of available dynamic plug-ins Man files: (usually in /usr/local/man/man1) ---------- - man files for frama-c (and frama-c-gui if available) =============================================================================== CUSTOM INSTALLATION =============================================================================== You can manually move any installed files. However, in such a case, you have to set specific environment variables in order that Frama-C found the appropriate objects when required. The environment variables are: ------------------------------ FRAMAC_SHARE: absolute path to the Frama-C share subdirectory FRAMAC_LIB: absolute path of the Frama-C lib subdirectory FRAMAC_PLUGIN: absolute path of the Frama-C plug-in directory. =============================================================================== TESTING THE INSTALLATION =============================================================================== This step is optional. Test your installation by running: frama-c -val tests/misc/CruiseControl*.c frama-c-gui -val tests/misc/CruiseControl*.c (if frama-c-gui is available) =============================================================================== INSTALLATION OF ADDITIONAL PLUG-INS =============================================================================== Plug-ins may be released independently of Frama-C. The standard way for installing them should be: ./configure && make && sudo make install Plug-ins may have their own custom installation procedures. Consult their specific documentations for details. =============================================================================== API DOCUMENTATION =============================================================================== For plug-in developers, the API documentation of the Frama-C kernel and distributed plug-ins is available in the file frama-c-api.tar.gz, after running "make doc-distrib". =============================================================================== UNINSTALLATION =============================================================================== Type "make uninstall" to remove Frama-C and all the installed plug-ins (depending on the installation directory, may require superuser privileges). That works only if you have not manually moved the installed files (see Section "Custom Installation"). =============================================================================== HAVE FUN WITH FRAMA-C! =============================================================================== frama-c-Fluorine-20130601/INSTALL_WITH_WHY0000644000175000017500000000311512155630370016412 0ustar mehdimehdi ------------------------------------------- INSTALLATION INSTRUCTIONS for FRAMA_C + WHY ------------------------------------------- This file is useful only for source distributions including both Frama-C and Why (like http://frama-c.com/download/frama-c-Boron-20100401-why-2.24.tar.gz for instance). Thus it is useless in any other context. Note: such a file is **not** provided for each Frama-C version. =============================================================================== SUMMARY =============================================================================== 0) Summary 1) Installation Instructions 2) Additional Instructions 3) Have Fun With Frama-C and Why! =============================================================================== INSTALLATION INSTRUCTIONS =============================================================================== Run the following commands from the directory containing the Frama-C source. ./configure make make install (may require superuser right) cd why ./configure make make install (may require superuser right) =============================================================================== ADDITIONAL INSTRUCTIONS =============================================================================== Please refer to the specific installation instructions for Frama-C and Why: - file INSTALL of Frama-C - file INSTALL of Why =============================================================================== HAVE FUN WITH FRAMA-C AND WHY! =============================================================================== frama-c-Fluorine-20130601/.make-ocamlgraph-stamp0000644000175000017500000000000312155630370020143 0ustar mehdimehdi78 frama-c-Fluorine-20130601/src/0000755000175000017500000000000012155634040014564 5ustar mehdimehdiframa-c-Fluorine-20130601/src/from/0000755000175000017500000000000012155634040015527 5ustar mehdimehdiframa-c-Fluorine-20130601/src/from/from_register.ml0000644000175000017500000001405512155630224020735 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 let display_aux pp = !Db.Semantic_Callgraph.topologically_iter_on_functions (fun k -> if !Db.Value.is_called k then pp ("Function %a:@\n%a@." : (_, _, _, _, _, _) format6) Kernel_function.pretty k !Db.From.pretty k) let display fmt = Format.fprintf fmt "@["; display_aux (Format.fprintf fmt); Format.fprintf fmt "@]" module SortCalls = struct type t = stmt (* Sort first by original source code location, then by sid *) let compare s1 s2 = let r = Cil_datatype.Location.compare (Cil_datatype.Stmt.loc s1) (Cil_datatype.Stmt.loc s2) in if r = 0 then Cil_datatype.Stmt.compare s1 s2 (* This is not really stable, but no good criterion is left *) else r end module MapStmtCalls = Map.Make(SortCalls) let iter_callwise_calls_sorted f = let hkf = Kernel_function.Hashtbl.create 17 in let kglobal = ref None in !Db.From.Callwise.iter (fun ki d -> match ki with | Kglobal -> kglobal := Some d | Kstmt s -> let kf = Kernel_function.find_englobing_kf s in let m = try Kernel_function.Hashtbl.find hkf kf with Not_found -> MapStmtCalls.empty in let m = MapStmtCalls.add s d m in Kernel_function.Hashtbl.replace hkf kf m ); !Db.Semantic_Callgraph.topologically_iter_on_functions (fun kf -> try let m = Kernel_function.Hashtbl.find hkf kf in MapStmtCalls.iter (fun s d -> f (Kstmt s) d) m with Not_found -> () ); match !kglobal with | None -> () | Some d -> f Kglobal d let main () = let not_quiet = From_parameters.verbose_atleast 1 in let forcedeps = From_parameters.ForceDeps.get () in let forcecalldeps = From_parameters.ForceCallDeps.get () in if forcedeps then begin !Db.From.compute_all (); From_parameters.ForceDeps.output (fun () -> From_parameters.feedback "====== DEPENDENCIES COMPUTED ======@\n\ These dependencies hold at termination for the executions that terminate:"; display_aux (fun fm -> From_parameters.result fm); From_parameters.feedback "====== END OF DEPENDENCIES ======" ) end; if forcecalldeps then !Db.From.compute_all_calldeps (); if not_quiet && forcecalldeps then begin From_parameters.ForceCallDeps.output (fun () -> From_parameters.feedback "====== DISPLAYING CALLWISE DEPENDENCIES ======"; iter_callwise_calls_sorted (fun ki d -> let id,typ = match ki with | Cil_types.Kglobal -> "entry point", Kernel_function.get_type (fst (Globals.entry_point ())) | Cil_types.Kstmt s -> let set = Db.Value.call_to_kernel_function s in let f = try Kernel_function.Hptset.min_elt set with Not_found -> From_parameters.fatal ~source:(fst (Cil_datatype.Stmt.loc s)) "Invalid call %a@." Printer.pp_stmt s in let id = Pretty_utils.sfprintf "%a at %a (by %a)%t" Kernel_function.pretty f Cil_datatype.Location.pretty (Cil_datatype.Stmt.loc s) Kernel_function.pretty (Kernel_function.find_englobing_kf s) (fun fmt -> if From_parameters.debug_atleast 1 then Format.fprintf fmt " " s.Cil_types.sid) in id, Kernel_function.get_type f in From_parameters.result "@[call %s:@\n%a@\n@]@ " id (Function_Froms.pretty_with_type typ) d); From_parameters.feedback "====== END OF CALLWISE DEPENDENCIES ======"; ) end let () = Db.Main.extend main let update_from loc new_v mem = let exact = Locations.valid_cardinal_zero_or_one ~for_writing:true loc in let z = Locations.enumerate_valid_bits ~for_writing:true loc in Lmap_bitwise.From_Model.add_binding exact mem z new_v let access_from looking_for mem = Lmap_bitwise.From_Model.find mem looking_for (* Registration for most Db.From functions is done at the end of the Functionwise and Callwise modules *) let () = Db.From.display := display; Db.From.update := update_from; Db.From.access := access_from; (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/from/callwise.mli0000644000175000017500000000355612155630224020046 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Computation of callwise functional dependencies. The results are computed while the value analysis runs, and the results are usually much more precise than the functionwise results. Nothing is exported here, the API can be found in the Db.From.Callwise module *) frama-c-Fluorine-20130601/src/from/from_register.mli0000644000175000017500000000326612155630224021110 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Registration of the From plugin in Frama-C main loop. Nothing is exported in this module *) frama-c-Fluorine-20130601/src/from/from_parameters.mli0000644000175000017500000000371212155630224021423 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.S (** Option -deps *) module ForceDeps: Plugin.WithOutput (** Option -calldeps. @plugin development guide *) module ForceCallDeps: Plugin.WithOutput (** Option -experimental-path-deps *) module PathDeps: Plugin.Bool (** Option -experimental-mem-deps *) module MemDeps: Plugin.Bool (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/from/mem_dependencies.ml0000644000175000017500000001443112155630224021350 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Db open Locations module Functionwise_Memdeps = Kernel_function.Make_Table (Zone) (struct let name = "Functionwise memdeps" let size = 17 let dependencies = [ Value.self ] end) class do_memdeps froms callwise_states_with_formals = object(self) inherit Cil.nopCilVisitor val mutable inputs = Zone.bottom method result = inputs method join new_ = inputs <- Zone.join new_ inputs; method vstmt s = if Value.is_reachable (Value.get_stmt_state (Extlib.the self#current_stmt)) then begin match s.skind with | UnspecifiedSequence seq -> List.iter (fun (stmt,_,_,_,_) -> ignore (visitCilStmt (self:>cilVisitor) stmt)) seq; SkipChildren (* do not visit the additional lvals *) | If (_cond, _th, _el, _) -> DoChildren (* for _cond and for the statements in _th, _el *) | Loop _ | Block _ -> DoChildren (* for the statements *) | Switch _ -> DoChildren (* for the statements and the expression *) | Instr _ -> DoChildren (* for Calls *) | Return _ -> DoChildren | Goto _ | Break _ | Continue _ -> SkipChildren | TryExcept _ | TryFinally _ -> assert false end else SkipChildren method stmt_froms = let stmt = Extlib.the (self#current_stmt) in Stmt.Hashtbl.find froms stmt method vlval lv = let deps,_loc = !Value.lval_to_loc_with_deps ~with_alarms:CilE.warn_none_mode ~deps:Zone.bottom (Kstmt (Extlib.the self#current_stmt)) lv in let froms = self#stmt_froms in let all_f = Lmap_bitwise.From_Model.find froms deps in self#join all_f; (* Format.printf "lval: all %a all_f %a@." Zone.pretty all Zone.pretty all_f; *) SkipChildren method vinst i = let current_stmt = Extlib.the self#current_stmt in if Value.is_reachable (Value.get_stmt_state current_stmt) then begin match i with | Call (_lv_opt,_exp,_args,_) -> let current_stmt = Extlib.the self#current_stmt in let states_with_formals = try Stmt.Hashtbl.find callwise_states_with_formals current_stmt with Not_found -> assert false in let all_f = List.fold_left (fun acc (kf, state_with_formals) -> if not (!Db.Value.use_spec_instead_of_definition kf) then let deps = try Functionwise_Memdeps.find kf with Not_found -> Format.printf "Mem dependencies not found for %a@." Kernel_function.pretty kf; assert false in let deps_f = Lmap_bitwise.From_Model.find state_with_formals deps in Zone.join acc deps_f else begin Format.printf "Assuming library function %a has no mem dependencies@." Kernel_function.pretty kf; acc end) Zone.bottom states_with_formals in self#join all_f; DoChildren | _ -> DoChildren end else SkipChildren method vexpr exp = match exp.enode with | AddrOf lv | StartOf lv -> let deps,_loc = !Value.lval_to_loc_with_deps ~with_alarms:CilE.warn_none_mode ~deps:Zone.bottom (Kstmt (Extlib.the self#current_stmt)) lv in let froms = self#stmt_froms in let deps_f = Lmap_bitwise.From_Model.find froms deps in self#join deps_f; (* Format.printf "AddrOf: deps %a deps_f %a@." Zone.pretty deps Zone.pretty deps_f; *) SkipChildren | _ -> DoChildren end let compute_memdeps (stack, froms, callwise_states_with_formals) = let kf = Stack.top stack in let name = Kernel_function.get_name kf in Format.printf "Computing mem dependencies for function %s@." name; match kf.fundec with Definition (f, _) -> begin let computer = new do_memdeps froms callwise_states_with_formals in ignore (visitCilFunction (computer:>cilVisitor) f); let result = computer#result in Format.printf "Mem dependencies of %s: %a@." name Zone.pretty result; try ignore (Functionwise_Memdeps.find kf); assert false with Not_found -> Functionwise_Memdeps.add kf result end | Declaration _ -> assert false let () = Cmdline.run_after_configuring_stage (fun () -> if From_parameters.MemDeps.get () then Db.From.Record_From_Callbacks.extend_once compute_memdeps) frama-c-Fluorine-20130601/src/from/callwise.ml0000644000175000017500000001631312155630224017670 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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_datatype module Tbl = Cil_state_builder.Kinstr_hashtbl (Function_Froms) (struct let name = "Callwise dependencies" let size = 17 let dependencies = [ Db.Value.self ] end) let () = From_parameters.ForceCallDeps.set_output_dependencies [Tbl.self] let merge_call_froms table callsite froms = try let current = Kinstr.Hashtbl.find table callsite in let new_froms = Function_Froms.join froms current in Kinstr.Hashtbl.replace table callsite new_froms with Not_found -> Kinstr.Hashtbl.add table callsite froms let call_froms_stack = ref [] let record_callwise_dependencies_in_db call_site froms = try let previous = Tbl.find call_site in Tbl.replace call_site (Function_Froms.join previous froms) with Not_found -> Tbl.add call_site froms let call_for_individual_froms (state, call_stack) = if From_parameters.ForceCallDeps.get () then begin let current_function, call_site = List.hd call_stack in if not (!Db.Value.use_spec_instead_of_definition current_function) then let table_for_current_function = Kinstr.Hashtbl.create 7 in call_froms_stack := (current_function,table_for_current_function) :: !call_froms_stack else try let _above_function, table = List.hd !call_froms_stack in let froms = From_compute.compute_using_prototype_for_state state current_function in merge_call_froms table call_site froms; record_callwise_dependencies_in_db call_site froms; with Failure "hd" -> From_parameters.fatal "calldeps internal error 23 empty callfromsstack %a" Kernel_function.pretty current_function end let end_record call_stack froms = let (current_function, call_site) = List.hd call_stack in record_callwise_dependencies_in_db call_site froms; (* pop + record in top of stack the froms of function that just finished *) match !call_froms_stack with | (current_function2, _) :: (((_caller, table) :: _) as tail) -> if current_function2 != current_function then From_parameters.fatal "calldeps %a != %a@." Kernel_function.pretty current_function (* g *) Kernel_function.pretty current_function2; (* f *) call_froms_stack := tail; merge_call_froms table call_site froms | _ -> (* the entry point, probably *) Tbl.mark_as_computed (); call_froms_stack := [] module MemExec = State_builder.Hashtbl (Datatype.Int.Hashtbl) (Function_Froms) (struct let size = 17 let dependencies = [Tbl.self] let name = "From.Callwise.MemExec" end) let compute_call_from_value_states current_function states = let module Froms_To_Use = struct let get _f callsite = let _current_function, table = List.hd !call_froms_stack in try Kinstr.Hashtbl.find table callsite with Not_found -> raise From_compute.Call_did_not_take_place end in let module Values_To_Use = struct let get_stmt_state s = try Stmt.Hashtbl.find states s with Not_found -> Cvalue.Model.bottom let lval_to_loc_with_deps s ~deps lv = let state = get_stmt_state s in !Db.Value.lval_to_loc_with_deps_state state ~deps lv let expr_to_kernel_function kinstr ~deps exp = let state = get_stmt_state kinstr in !Db.Value.expr_to_kernel_function_state state ~deps exp let access_expr stmt expr = let state = get_stmt_state stmt in !Db.Value.eval_expr ~with_alarms:CilE.warn_none_mode state expr end in let module Recording_To_Do = struct let accept_base_in_lmap kf base = let fundec = Kernel_function.get_definition kf in not (Base.is_formal_or_local base fundec) let final_cleanup _kf froms = froms let record_kf _kf _last_froms = () end in let module Callwise_Froms = From_compute.Make(Values_To_Use)(Froms_To_Use)(Recording_To_Do) in Callwise_Froms.compute_and_return current_function let record_for_individual_froms (call_stack, value_res) = if From_parameters.ForceCallDeps.get () then begin let froms = match value_res with | Value_types.Normal states | Value_types.NormalStore (states, _) -> let cur_kf, _ = List.hd call_stack in let froms = if !Db.Value.no_results (Kernel_function.get_definition cur_kf) then Function_Froms.top else compute_call_from_value_states cur_kf (Lazy.force states) in (match value_res with | Value_types.NormalStore (_, memexec_counter) -> MemExec.replace memexec_counter froms | _ -> ()); froms | Value_types.Reuse counter -> MemExec.find counter in end_record call_stack froms end (* Register our callbacks inside the value analysis *) let () = From_parameters.ForceCallDeps.add_update_hook (fun _bold bnew -> if bnew then begin Db.Value.Call_Value_Callbacks.extend_once call_for_individual_froms; Db.Value.Record_Value_Callbacks_New.extend_once record_for_individual_froms; end) let force_compute_all_calldeps ()= if Db.Value.is_computed () then Project.clear ~selection:(State_selection.with_dependencies Db.Value.self) (); !Db.Value.compute () (* Registration for call-wise from *) let () = Db.register_guarded_compute "From.compute_all_calldeps" Tbl.is_computed Db.From.compute_all_calldeps force_compute_all_calldeps; Db.From.Callwise.iter := Tbl.iter; Db.From.Callwise.find := Tbl.find (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/from/from_compute.ml0000644000175000017500000006651412155630224020574 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Db open Abstract_interp open Locations exception Call_did_not_take_place module type Froms_To_Use_Sig = sig val get : kernel_function -> kinstr -> Function_Froms.t end module type Values_To_Use_Sig = sig val lval_to_loc_with_deps : stmt -> deps:Locations.Zone.t -> Cil_types.lval -> Locations.Zone.t * Locations.location val expr_to_kernel_function : stmt -> deps:Locations.Zone.t option -> Cil_types.exp -> Locations.Zone.t * Kernel_function.Hptset.t val get_stmt_state : stmt -> Db.Value.state val access_expr : Cil_types.stmt -> Cil_types.exp -> Db.Value.t end module type Recording_Sig = sig val accept_base_in_lmap : kernel_function -> Base.t -> bool val final_cleanup: kernel_function -> Function_Froms.t -> Function_Froms.t val record_kf : kernel_function -> Function_Froms.t -> unit (* function to call at the end of the treatment of a function *) end let rec find_deps_no_transitivity state expr = (* The value of the expression [expr], just before executing the statement [instr], is a function of the values of the returned zones. *) match expr.enode with | Info (e, _) -> find_deps_no_transitivity state e | AlignOfE _| AlignOf _| SizeOfStr _ |SizeOfE _| SizeOf _ | Const _ -> Zone.bottom | AddrOf lv | StartOf lv -> let deps, _ = !Db.Value.lval_to_loc_with_deps_state state ~deps:Zone.bottom lv in deps | CastE (_, e)|UnOp (_, e, _) -> find_deps_no_transitivity state e | BinOp (_, e1, e2, _) -> Zone.join (find_deps_no_transitivity state e1) (find_deps_no_transitivity state e2) | Lval v -> find_deps_lval_no_transitivity state v and find_deps_offset_no_transitivity state o = match o with | NoOffset -> Zone.bottom | Field (_,o) -> find_deps_offset_no_transitivity state o | Index (e,o) -> Zone.join (find_deps_no_transitivity state e) (find_deps_offset_no_transitivity state o) and find_deps_lval_no_transitivity state lv = let deps, loc = !Db.Value.lval_to_loc_with_deps_state state ~deps:Zone.bottom lv in let direct_deps = enumerate_valid_bits ~for_writing:false loc in let result = Zone.join deps direct_deps in From_parameters.debug "find_deps_lval_no_trs:@\n deps:%a@\n direct_deps:%a" Zone.pretty deps Zone.pretty direct_deps; result let compute_using_prototype_for_state state kf = let varinfo = Kernel_function.get_vi kf in let behaviors = !Value.valid_behaviors kf state in let assigns = Ast_info.merge_assigns behaviors in let return_deps,deps = match assigns with | WritesAny -> Lmap_bitwise.From_Model.LOffset.degenerate Zone.top, Lmap_bitwise.From_Model.top | Writes assigns -> let (rt_typ,_,_,_) = splitFunctionTypeVI varinfo in let input_zone out ins = (* Technically out is unused, but there is a signature problem *) !Db.Value.assigns_inputs_to_zone state (Writes [out, ins]) in let treat_assign acc (out, ins) = try let output_locs, _deps = !Properties.Interp.loc_to_locs ~result:None state out.it_content in let input_zone = input_zone out ins in let treat_one_output acc out_loc = let exact = Location_Bits.cardinal_zero_or_one out_loc.loc in let output_zone = Locations.enumerate_valid_bits ~for_writing:true out_loc in Lmap_bitwise.From_Model.add_binding ~exact acc output_zone input_zone in List.fold_left treat_one_output acc output_locs with Invalid_argument "not an lvalue" -> From_parameters.result ~once:true ~current:true "Unable to extract assigns in %a" Kernel_function.pretty kf; acc in let treat_ret_assign acc (out,ins) = try let coffs = !Properties.Interp.loc_to_offset ~result:None out.it_content in List.fold_left (fun acc coff -> let (base,width) = bitsOffset rt_typ coff in Lmap_bitwise.From_Model.LOffset.add_iset ~exact:true (Lattice_Interval_Set.Int_Intervals.from_ival_size (Ival.of_int base) (Int_Base.inject (Int.of_int width))) (input_zone out ins) acc) acc coffs with Invalid_argument "not an lvalue" | SizeOfError _ -> From_parameters.result ~once:true ~current:true "Unable to extract a proper offset. \ Using FROM for the whole \\result"; Lmap_bitwise.From_Model.LOffset.add_iset ~exact:false (Lattice_Interval_Set.Int_Intervals.from_ival_size (Ival.of_int 0) (Bit_utils.sizeof rt_typ)) (input_zone out ins) acc in let return_assigns, other_assigns = List.fold_left (fun (ra,oa) (loc,_ as a) -> if Logic_utils.is_result loc.it_content then a::ra,oa else ra,a::oa) ([],[]) assigns in let return_assigns = match return_assigns with | [] when Cil.isVoidType rt_typ -> Lmap_bitwise.From_Model.LOffset.empty | [] -> (* \from unspecified. *) Lmap_bitwise.From_Model.LOffset.add_iset ~exact:true (Lattice_Interval_Set.Int_Intervals.from_ival_size (Ival.of_int 0) (Bit_utils.sizeof rt_typ)) Zone.top Lmap_bitwise.From_Model.LOffset.empty | _ -> List.fold_left treat_ret_assign Lmap_bitwise.From_Model.LOffset.empty return_assigns in return_assigns, List.fold_left treat_assign Lmap_bitwise.From_Model.empty other_assigns in { deps_return = return_deps; Function_Froms.deps_table = deps } module Make (Values_To_Use:Values_To_Use_Sig) (Froms_To_Use: Froms_To_Use_Sig) (Recording_To_Do: Recording_Sig) = struct type t' = { additional_deps_table : Zone.t Stmt.Map.t; (** Additional dependencies to add to all modified variables. Example: variables in the condition of an IF. *) additional_deps : Zone.t; (** Union of the sets in StmtMap.t *) deps_table : Lmap_bitwise.From_Model.t (** dependency table *) } let call_stack : kernel_function Stack.t = Stack.create () (** Stack of function being processed *) let find_deps stmt deps_tbl expr = let state = Values_To_Use.get_stmt_state stmt in let deps_no_trans = find_deps_no_transitivity state expr in !Db.From.access deps_no_trans deps_tbl module Computer(REACH:sig val stmt_can_reach : stmt -> stmt -> bool val blocks_closed_by_edge: stmt -> stmt -> block list end) = struct let empty_from = { additional_deps_table = Stmt.Map.empty; additional_deps = Zone.bottom; deps_table = Lmap_bitwise.From_Model.empty } let bottom_from = { additional_deps_table = Stmt.Map.empty; additional_deps = Zone.bottom; deps_table = Lmap_bitwise.From_Model.bottom } let name = "from" let debug = ref false let stmt_can_reach = REACH.stmt_can_reach type t = t' module StmtStartData = Dataflow.StartData(struct type t = t' let size = 107 end) let callwise_states_with_formals = Stmt.Hashtbl.create 7 type substit = Froms of Zone.t (* VP: Unused constructor *) (* | Lvalue of Lmap_bitwise.From_Model.LOffset.t *) let cached_substitute call_site_froms extra_loc = let f k intervs = Lmap_bitwise.From_Model.find call_site_froms (Zone.inject k intervs) in let joiner = Zone.join in let projection base = match Base.validity base with | Base.Invalid -> Lattice_Interval_Set.Int_Intervals.bottom | Base.Periodic (min_valid, max_valid, _) | Base.Known (min_valid,max_valid) | Base.Unknown (min_valid,_,max_valid)-> Lattice_Interval_Set.Int_Intervals.inject_bounds min_valid max_valid in let zone_substitution = Zone.cached_fold ~cache:("from substitution", 331) ~temporary:true ~f ~joiner ~empty:Zone.bottom ~projection in let zone_substitution x = try zone_substitution x with Zone.Error_Top -> Zone.top in fun z -> Zone.join extra_loc (zone_substitution z) let display_one_from fmt v = Lmap_bitwise.From_Model.pretty fmt v.deps_table; Format.fprintf fmt "Additional Variable Map : %a@\n" (let module M = Stmt.Map.Make(Zone) in M.pretty) v.additional_deps_table; Format.fprintf fmt "Additional Variable Map Set : %a@\n" Zone.pretty v.additional_deps let copy (d: t) = d let pretty fmt (v: t) = display_one_from fmt v let eliminate_additional table s = let current_function = Stack.top call_stack in (* Eliminate additional variables originating from a branch closing at this statement. *) Stmt.Map.fold (fun k v (acc_set,acc_map,nb) -> if !Postdominators.is_postdominator current_function ~opening:k ~closing:s then acc_set,acc_map,nb else (Zone.join v acc_set), (Stmt.Map.add k v acc_map),nb+1 ) table (Zone.bottom, Stmt.Map.empty, 0) let computeFirstPredecessor (s: stmt) data = let new_additional_deps, new_additional_deps_table, _ = eliminate_additional data.additional_deps_table s in let data = {data with additional_deps = new_additional_deps; additional_deps_table = new_additional_deps_table} in match s.skind with | Switch (exp,_,_,_) | If (exp,_,_,_) -> let additional_vars = find_deps s data.deps_table exp in {data with additional_deps_table = Stmt.Map.add s additional_vars data.additional_deps_table; additional_deps = Zone.join additional_vars data.additional_deps } | _ -> data let combinePredecessors (s: stmt) ~old:({deps_table = old_table} as old) ({deps_table = new_table } as new_) = let new_ = computeFirstPredecessor s new_ in let changed = ref false in let merged = Stmt.Map.fold (fun k v acc -> try let current_val = Stmt.Map.find k acc.additional_deps_table in if Zone.is_included v current_val then acc else begin changed := true; {acc with additional_deps_table = Stmt.Map.add k (Zone.join current_val v) acc.additional_deps_table; additional_deps = Zone.join v acc.additional_deps} end with Not_found -> changed := true; {acc with additional_deps_table = Stmt.Map.add k v acc.additional_deps_table; additional_deps = Zone.join v acc.additional_deps } ) new_.additional_deps_table old in let result = Lmap_bitwise.From_Model.join old_table new_table in if (not !changed) && Lmap_bitwise.From_Model.is_included result old_table then None else Some ({merged with deps_table = result }) let resolv_func_vinfo ?deps stmt funcexp = Values_To_Use.expr_to_kernel_function ?deps stmt funcexp let doInstr stmt (i: instr) (d: t) = !Db.progress (); let add_with_additional_var lv v d = let deps, target = (* The modified location is [target], whose address is computed from [deps]. *) Values_To_Use.lval_to_loc_with_deps ~deps:Zone.bottom stmt lv in let deps = Zone.join v (Lmap_bitwise.From_Model.find d.deps_table deps) in let r = !Db.From.update target (Zone.join d.additional_deps deps) d.deps_table in {d with deps_table=r; } in match i with | Set (lv, exp, _) -> Dataflow.Post (fun state -> let comp_vars = find_deps stmt state.deps_table exp in let result = add_with_additional_var lv comp_vars state in result ) | Call (lvaloption,funcexp,argl,_) -> Dataflow.Post (fun state -> !Db.progress (); let funcexp_deps, called_vinfos = resolv_func_vinfo ~deps:Zone.bottom stmt funcexp in let funcexp_deps = (* dependencies for the evaluation of [funcexp] *) !Db.From.access funcexp_deps state.deps_table in let additional_deps = Zone.join d.additional_deps funcexp_deps in let args_froms = List.map (fun arg -> match arg with (* TODO : optimize the dependencies on subfields | Lval lv -> Lvalue (From_Model.LBase.find (Interp_loc.lval_to_loc_with_deps kinstr lv)) *) | _ -> Froms (find_deps stmt d.deps_table arg)) argl in let states_with_formals = ref [] in let do_on kernel_function = let called_vinfo = Kernel_function.get_vi kernel_function in if Ast_info.is_cea_function called_vinfo.vname then state else let { Function_Froms.deps_return = return_from; deps_table = called_func_froms } = Froms_To_Use.get kernel_function (Kstmt stmt) in if Lmap_bitwise.From_Model.is_bottom called_func_froms then bottom_from else let formal_args = Kernel_function.get_formals kernel_function in let state_with_formals = ref state.deps_table in begin try List.iter2 (fun vi from -> match from with | Froms from -> let zvi = Locations.zone_of_varinfo vi in state_with_formals := Lmap_bitwise.From_Model.add_binding ~exact:true !state_with_formals zvi from (*| Lvalue _ -> assert false *)) formal_args args_froms; with Invalid_argument "List.iter2" -> From_parameters.warning ~once:true ~current:true "variadic call detected. Using only %d argument(s)." (min (List.length formal_args) (List.length args_froms)) end; if not (Db.From.Record_From_Callbacks.is_empty ()) then states_with_formals := (kernel_function, !state_with_formals) :: !states_with_formals; let substitute = cached_substitute !state_with_formals additional_deps in let new_state = (* From state just after the call, but before the result assigment *) {state with deps_table = Lmap_bitwise.From_Model.map_and_merge substitute called_func_froms state.deps_table} in (* Treatement for the possible assignement of the call result *) (match lvaloption with | None -> new_state | Some lv -> let first = ref true in (try Lmap_bitwise.From_Model.LOffset.fold (fun _itv (_,x) acc -> if not !first then (*treatment below only compatible with imprecise handling of Return elsewhere in this file *) raise Not_found; first := false; let res = substitute x in let deps, loc = Values_To_Use.lval_to_loc_with_deps ~deps:Zone.bottom stmt lv in let deps = Lmap_bitwise.From_Model.find acc.deps_table deps in let deps = Zone.join res deps in let deps = Zone.join deps acc.additional_deps in { acc with deps_table = !Db.From.update loc deps acc.deps_table} ) return_from new_state with Not_found -> (* from find_lonely_binding *) let vars = Lmap_bitwise.From_Model.LOffset.map (fun (b,x) -> (b,substitute x)) return_from in add_with_additional_var lv (Lmap_bitwise.From_Model.LOffset.collapse vars) new_state )) in let f f acc = let p = do_on f in match acc with | None -> Some p | Some acc_memory -> Some {state with deps_table = Lmap_bitwise.From_Model.join p.deps_table acc_memory.deps_table} in let result = try (match Kernel_function.Hptset.fold f called_vinfos None with | None -> state | Some s -> s); with Call_did_not_take_place -> state in if not (Db.From.Record_From_Callbacks.is_empty ()) then Stmt.Hashtbl.replace callwise_states_with_formals stmt !states_with_formals; result ) | _ -> Dataflow.Default let doStmt s d = if Db.Value.is_reachable (Values_To_Use.get_stmt_state s) && not (Lmap_bitwise.From_Model.is_bottom d.deps_table) then Dataflow.SDefault else Dataflow.SDone let filterStmt stmt = Db.Value.is_reachable (Values_To_Use.get_stmt_state stmt) (* Remove all local variables and formals from table *) let externalize return kf state = let deps_return = (match return.skind with | Return (Some ({enode = Lval v}),_) -> let deps, target = Values_To_Use.lval_to_loc_with_deps ~deps:Zone.bottom return v in Lmap_bitwise.From_Model.LOffset.join (Lmap_bitwise.From_Model.find_base state.deps_table deps) (Lmap_bitwise.From_Model.find_base state.deps_table (enumerate_valid_bits ~for_writing:false target)) | Return (None,_) -> Lmap_bitwise.From_Model.LOffset.empty | _ -> assert false) in let deps_table = Lmap_bitwise.From_Model.filter_base (Recording_To_Do.accept_base_in_lmap kf) state.deps_table in { deps_return = deps_return; Function_Froms.deps_table = deps_table } let doGuard s e _t = let interpreted_e = Values_To_Use.access_expr s e in let t1 = unrollType (typeOf e) in let do_then, do_else = if isIntegralType t1 || isPointerType t1 then Cvalue.V.contains_non_zero interpreted_e, Cvalue.V.contains_zero interpreted_e else true, true (* TODO: a float condition is true iff != 0.0 *) in (if do_then then Dataflow.GDefault else Dataflow.GUnreachable), (if do_else then Dataflow.GDefault else Dataflow.GUnreachable) let doEdge s succ d = match REACH.blocks_closed_by_edge s succ with | [] -> d | closed_blocks -> let deps_table = Lmap_bitwise.From_Model.uninitialize (List.fold_left (fun x y -> y.blocals @ x) [] closed_blocks) d.deps_table in { d with deps_table = deps_table } end let compute_using_cfg kf = match kf.fundec with | Declaration _ -> assert false | Definition (f,_) -> try let module Computer = Computer (struct let stmt_can_reach = Stmts_graph.stmt_can_reach kf let blocks_closed_by_edge = Kernel_function.blocks_closed_by_edge end) in let module Compute = Dataflow.Forwards(Computer) in Stack.iter (fun g -> if kf == g then begin if Db.Value.ignored_recursive_call kf then From_parameters.error "during dependencies computations for %a, \ ignoring probable recursive" Kernel_function.pretty kf; raise Exit end) call_stack; Stack.push kf call_stack; let state = { Computer.empty_from with deps_table = Lmap_bitwise.From_Model.uninitialize f.slocals Computer.empty_from.deps_table } in 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 state); Compute.compute [start]; if not (Db.From.Record_From_Callbacks.is_empty ()) then begin From_parameters.feedback "Now calling From callbacks"; let states = Stmt.Hashtbl.create (Computer.StmtStartData.length ()) in Computer.StmtStartData.iter (fun k record -> Stmt.Hashtbl.add states k record.deps_table); Db.From.Record_From_Callbacks.apply (call_stack, states, Computer.callwise_states_with_formals) end; let _poped = Stack.pop call_stack in let last_from = try if Db.Value.is_reachable (Values_To_Use.get_stmt_state ret_id) then Computer.externalize ret_id kf (Computer.StmtStartData.find ret_id) else raise Not_found with Not_found -> begin From_parameters.result "Non-terminating function %a (no dependencies)" Kernel_function.pretty kf; { Function_Froms.deps_return = Lmap_bitwise.From_Model.LOffset.empty; deps_table = Lmap_bitwise.From_Model.bottom } end in last_from with Exit (* Recursive call *) -> { Function_Froms.deps_return = Lmap_bitwise.From_Model.LOffset.empty; deps_table = Lmap_bitwise.From_Model.empty } let compute_using_prototype kf = let state = Value.get_initial_state kf in compute_using_prototype_for_state state kf let compute_and_return kf = let call_site_loc = CurrentLoc.get () in From_parameters.feedback "Computing for function %a%s" Kernel_function.pretty kf (let s = ref "" in Stack.iter (fun kf -> s := !s^" <-"^(Pretty_utils.sfprintf "%a" Kernel_function.pretty kf)) call_stack; !s); !Db.progress (); let result = if !Db.Value.use_spec_instead_of_definition kf then compute_using_prototype kf else compute_using_cfg kf in let result = Recording_To_Do.final_cleanup kf result in Recording_To_Do.record_kf kf result; From_parameters.feedback "Done for function %a" Kernel_function.pretty kf; !Db.progress (); CurrentLoc.set call_site_loc; result let compute kf = !Db.Value.compute (); ignore (compute_and_return kf) end frama-c-Fluorine-20130601/src/from/from_compute.mli0000644000175000017500000001021212155630224020725 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Module implementing the computation of functional dependencies *) open Cil_types (** Signature of the module explaining how to find the Froms for a given call during the analysis. *) module type Froms_To_Use_Sig = sig val get : kernel_function -> kinstr -> Function_Froms.t end (** Signature of the module explaining how to evaluatue some values during the analysis. This is typically Db.Value, or a specialized versions of Db.Value on more precise state. *) module type Values_To_Use_Sig = sig val lval_to_loc_with_deps : stmt -> deps:Locations.Zone.t -> lval -> Locations.Zone.t * Locations.location val expr_to_kernel_function : stmt -> deps:Locations.Zone.t option -> exp -> Locations.Zone.t * Kernel_function.Hptset.t val get_stmt_state : stmt -> Db.Value.state val access_expr : stmt -> exp -> Db.Value.t end (** Module explaining how results should be recorded. *) module type Recording_Sig = sig val accept_base_in_lmap : kernel_function -> Base.t -> bool val final_cleanup : kernel_function -> Function_Froms.t -> Function_Froms.t val record_kf : kernel_function -> Function_Froms.t -> unit end (** Function that compute the Froms from a given prototype, called in the given state *) val compute_using_prototype_for_state : Db.Value.state -> Kernel_function.t -> Function_Froms.froms (** Direct computation of the dependencies on expressions, offsets and lvals. The state at the statement is taken from Values_To_Use *) val find_deps_no_transitivity : Db.Value.state -> exp -> Locations.Zone.t val find_deps_offset_no_transitivity : Db.Value.state -> offset -> Locations.Zone.t val find_deps_lval_no_transitivity : Db.Value.state -> lval -> Locations.Zone.t (** Functor computing the functional dependencies, according to the three modules above. *) module Make : functor (Values_To_Use : Values_To_Use_Sig) -> functor (Froms_To_Use : Froms_To_Use_Sig) -> functor (Recording_To_Do : Recording_Sig) -> sig (** Computation of the dependencies on an expression, but recursive dependencies are resolved using the value of type [Lmap_bitwise.From_Model.t]. *) val find_deps : stmt -> Lmap_bitwise.From_Model.t -> exp -> Locations.Zone.t (** Compute the dependencies of the given function, and return them *) val compute_and_return : Kernel_function.t -> Function_Froms.t (** Compute the dependencies of the given function *) val compute : Kernel_function.t -> unit end (** Exception indicating that a given call statement was not evaluated. *) exception Call_did_not_take_place frama-c-Fluorine-20130601/src/from/from_parameters.ml0000644000175000017500000000462312155630224021254 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.Register (struct let name = "from analysis" let shortname = "from" let help = "functional dependencies" end) module ForceDeps = WithOutput (struct let option_name = "-deps" let help = "force dependencies display" let output_by_default = true end) module ForceCallDeps = WithOutput (struct let option_name = "-calldeps" let help = "force callsite-wise dependencies" let output_by_default = true end) module PathDeps = False (struct let option_name = "-experimental-path-deps" let help = "experimental" end) module MemDeps = False (struct let option_name = "-experimental-mem-deps" let help = "experimental" end) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/from/from_register_gui.mli0000644000175000017500000000337412155630224021754 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Extension of the GUI in order to support the from analysis. No function is exported. *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.. -j" End: *) frama-c-Fluorine-20130601/src/from/from_register_gui.ml0000644000175000017500000000465412155630224021605 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Db let main (main_ui:Design.main_window_extension_points) = let filetree_selector ~was_activated ~activating globals = if Value.is_computed () then begin if not was_activated && activating then begin match globals with (* [JS 2009/30/03] GUI may become too slow if froms are displayed *) (* | [GFun ({svar=v},_)] -> begin try let kf = Globals.Functions.get v in if !From.is_computed kf then let s = fprintf_to_string "@[Functional dependencies:@\n%a@]@." !From.pretty kf in main_ui#annot_window#buffer#insert s with Not_found -> () end*) | _ -> (); end; end in main_ui#file_tree#add_select_function filetree_selector let () = Design.register_extension main (* Local Variables: compile-command: "LC_ALL=C make -C ../.. -j" End: *) frama-c-Fluorine-20130601/src/from/From.mli0000644000175000017500000000333212155630224017136 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* $Id: From.mli,v 1.6 2008-04-01 09:25:20 uid568 Exp $ *) (** No function is directly exported: they are registered in {!Db.From}. *) frama-c-Fluorine-20130601/src/from/functionwise.ml0000644000175000017500000001244312155630224020602 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 module Tbl = Kernel_function.Make_Table (Function_Froms) (struct let name = "Functionwise dependencies" let size = 17 let dependencies = [ Db.Value.self ] end) let () = From_parameters.ForceDeps.set_output_dependencies [Tbl.self] (* Forward reference to a function computing the from for a given function *) let force_compute = ref (fun _ -> assert false) module Functionwise_From_to_use = struct let memo kf = Tbl.memo (fun kf -> !force_compute kf; try Tbl.find kf with Not_found -> invalid_arg "could not compute dependencies") kf let get kf _ = memo kf end module Recording_To_Do = struct let accept_base_in_lmap kf = (* Eta-expansion required *) !Db.Semantic_Callgraph.accept_base ~with_formals:false ~with_locals:false kf let final_cleanup kf froms = if Lmap_bitwise.From_Model.is_bottom froms.Function_Froms.deps_table then froms else let f b intervs = if !Db.Semantic_Callgraph.accept_base ~with_formals:true ~with_locals:false kf b then Zone.inject b intervs else Zone.bottom in let joiner = Zone.join in let projection base = match Base.validity base with | Base.Invalid -> Lattice_Interval_Set.Int_Intervals.bottom | Base.Periodic (min_valid, max_valid, _) | Base.Known (min_valid,max_valid) | Base.Unknown (min_valid,_,max_valid)-> Lattice_Interval_Set.Int_Intervals.inject_bounds min_valid max_valid in let zone_substitution = Zone.cached_fold ~cache:("from cleanup", 331) ~temporary:true ~f ~joiner ~empty:Zone.bottom ~projection in let zone_substitution x = try zone_substitution x with Zone.Error_Top -> Zone.top in { Function_Froms.deps_table = Lmap_bitwise.From_Model.map_and_merge zone_substitution froms.Function_Froms.deps_table Lmap_bitwise.From_Model.empty; deps_return = Lmap_bitwise.From_Model.LOffset.map (function b, d -> b, zone_substitution d) froms.Function_Froms.deps_return; } let record_kf kf last_from = Tbl.add kf last_from end module Value_local = struct let get_stmt_state = Db.Value.get_stmt_state let access_expr s exp = !Db.Value.access_expr (Kstmt s) exp let expr_to_kernel_function s ~deps exp = !Db.Value.expr_to_kernel_function (Kstmt s) ~with_alarms:CilE.warn_none_mode ~deps exp let lval_to_loc_with_deps s ~deps lval = !Db.Value.lval_to_loc_with_deps (Kstmt s) ~with_alarms:CilE.warn_none_mode ~deps lval end module From = From_compute.Make(Value_local)(Functionwise_From_to_use)(Recording_To_Do) let () = force_compute := From.compute let force_compute_all () = !Db.Value.compute (); !Db.Semantic_Callgraph.topologically_iter_on_functions (fun kf -> if Kernel_function.is_definition kf && !Db.Value.is_called kf then !Db.From.compute kf) (* Db Registration for function-wise from *) let () = Db.From.self := Tbl.self; Db.From.is_computed := Tbl.mem; Db.From.compute := (fun kf -> ignore (Functionwise_From_to_use.memo kf)); Db.From.get := Functionwise_From_to_use.memo; Db.From.pretty := (fun fmt v -> let deps = Functionwise_From_to_use.memo v in Function_Froms.pretty_with_type (Kernel_function.get_type v) fmt deps); Db.From.find_deps_no_transitivity := (fun stmt lv -> let state = Db.Value.get_stmt_state stmt in From_compute.find_deps_no_transitivity state lv); Db.From.find_deps_no_transitivity_state := From_compute.find_deps_no_transitivity; ignore ( Db.register_compute "From.compute_all" [Tbl.self] Db.From.compute_all force_compute_all); frama-c-Fluorine-20130601/src/from/path_dependencies.ml0000644000175000017500000001513412155630224021527 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Db open Locations module Functionwise_Pathdeps = Kernel_function.Make_Table (Zone) (struct let name = "Functionwise pathdeps" let size = 17 let dependencies = [ Value.self ] end) class do_pathdeps froms callwise_states_with_formals = object(self) inherit Cil.nopCilVisitor val mutable inputs = Zone.bottom method result = inputs method join new_ = inputs <- Zone.join new_ inputs; method vstmt s = if Value.is_reachable (Value.get_stmt_state (Extlib.the self#current_stmt)) then begin match s.skind with | UnspecifiedSequence seq -> List.iter (fun (stmt,_,_,_,_) -> ignore (visitCilStmt (self:>cilVisitor) stmt)) seq; SkipChildren (* do not visit the additional lvals *) | If (_cond, _th, _el, _) -> DoChildren (* for _cond and for the statements in _th, _el *) | Loop _ | Block _ -> DoChildren (* for the statements *) | Switch _ -> DoChildren (* for the statements and the expression *) | Instr _ -> DoChildren (* for Calls *) | Return _ | Goto _ | Break _ | Continue _ -> SkipChildren | TryExcept _ | TryFinally _ -> assert false end else SkipChildren method stmt_froms = let stmt = Extlib.the (self#current_stmt) in Stmt.Hashtbl.find froms stmt method vlval lv = let deps,loc = !Value.lval_to_loc_with_deps ~with_alarms:CilE.warn_none_mode ~deps:Zone.bottom (Kstmt (Extlib.the self#current_stmt)) lv in let bits_loc = enumerate_valid_bits ~for_writing:false loc in let all = Zone.join bits_loc deps in let froms = self#stmt_froms in let all_f = Lmap_bitwise.From_Model.find froms all in self#join all_f; (* Format.printf "lval: all %a all_f %a@." Zone.pretty all Zone.pretty all_f; *) SkipChildren method vinst i = let current_stmt = Extlib.the self#current_stmt in if Value.is_reachable (Value.get_stmt_state current_stmt) then begin match i with | Call (_lv_opt,exp,_args,_) -> let current_stmt = Extlib.the self#current_stmt in let deps_callees, _callees = !Value.expr_to_kernel_function ~with_alarms:CilE.warn_none_mode ~deps:(Some Zone.bottom) (Kstmt current_stmt) exp in let states_with_formals = try Stmt.Hashtbl.find callwise_states_with_formals current_stmt with Not_found -> assert false in let all_f = List.fold_left (fun acc (kf, state_with_formals) -> if not (!Db.Value.use_spec_instead_of_definition kf) then let deps = try Functionwise_Pathdeps.find kf with Not_found -> Format.printf "pathdeps dependencies not found for %a@." Kernel_function.pretty kf; assert false in let deps_f = Lmap_bitwise.From_Model.find state_with_formals deps in Zone.join acc deps_f else begin Format.printf "Assuming library function %a has no path dependencies@." Kernel_function.pretty kf; acc end) deps_callees states_with_formals in self#join all_f; SkipChildren | _ -> SkipChildren end else SkipChildren method vexpr exp = match exp.enode with | AddrOf lv | StartOf lv -> let deps,_loc = !Value.lval_to_loc_with_deps ~with_alarms:CilE.warn_none_mode ~deps:Zone.bottom (Kstmt (Extlib.the self#current_stmt)) lv in let froms = self#stmt_froms in let deps_f = Lmap_bitwise.From_Model.find froms deps in self#join deps_f; (* Format.printf "AddrOf: deps %a deps_f %a@." Zone.pretty deps Zone.pretty deps_f; *) SkipChildren | _ -> DoChildren end let compute_pathdeps (stack, froms, callwise_states_with_formals) = let kf = Stack.top stack in let name = Kernel_function.get_name kf in Format.printf "Computing path dependencies for function %s@." name; match kf.fundec with Definition (f, _) -> begin let computer = new do_pathdeps froms callwise_states_with_formals in ignore (visitCilFunction (computer:>cilVisitor) f); let result = computer#result in Format.printf "Path dependencies of %s: %a@." name Zone.pretty result; try ignore (Functionwise_Pathdeps.find kf); assert false with Not_found -> Functionwise_Pathdeps.add kf result end | Declaration _ -> assert false let () = Cmdline.run_after_configuring_stage (fun () -> if From_parameters.PathDeps.get () then Db.From.Record_From_Callbacks.extend_once compute_pathdeps) frama-c-Fluorine-20130601/src/from/functionwise.mli0000644000175000017500000000345212155630224020753 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Computation of functional dependencies. In this module, the results are computed from the synthetic results of the value analysis. Nothing is exported here, the API can be found in the Db.From module *) frama-c-Fluorine-20130601/src/logic/0000755000175000017500000000000012155634040015661 5ustar mehdimehdiframa-c-Fluorine-20130601/src/logic/statuses_by_call.ml0000644000175000017500000001367312155630223021564 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 let preconditions_emitter = Emitter.create "Call Preconditions" [ Emitter.Property_status ] ~correctness:[] ~tuning:[] (* Map from a requires to the its specializations at all call sites. *) module PreCondProxyGenerated = State_builder.Hashtbl(Property.Hashtbl)(Datatype.List(Property)) (struct let name = "Call Preconditions Generated" let dependencies = [Ast.self; Property_status.self] let size = 97 end) module PropStmt = Datatype.Pair_with_collections(Property)(Cil_datatype.Stmt) (struct let module_name = "Statuses_by_call.PropStmt" end) (* Map from [requires * stmt] to the specialization of the requires at the statement. Only present if the kernel function that contains the requires can be called at the statement. *) module PreCondAt = State_builder.Hashtbl(PropStmt.Hashtbl)(Property) (struct let size = 37 let dependencies = [ Ast.self ] let name = "Statuses_by_call.PreCondAt" end) let rec precondition_at_call kf pid stmt = try PreCondAt.find (pid, stmt) with Not_found -> let loc = (Cil_datatype.Stmt.loc stmt) in let kf_call = Kernel_function.find_englobing_kf stmt in let name = Pretty_utils.sfprintf "%s: %a" (Property.Names.get_prop_name_id pid) (Description.pp_localized ~kf:`Never ~ki:false ~kloc:true) pid in let p = Property.ip_other name (Some kf_call) (Kstmt stmt) in PreCondAt.add (pid, stmt) p; (match stmt.skind with | Instr(Call(_, e, _, _)) -> (match e.enode with | Lval (Var vkf, NoOffset) -> assert (Cil_datatype.Varinfo.equal vkf (Kernel_function.get_vi kf)) | _ -> Kernel.debug ~source:(fst loc) "Adding precondition for call to %a through pointer" Kernel_function.pretty kf; add_call_precondition pid p ) | _ -> assert false (* meaningless on a non-call statement *) ); p and setup_precondition_proxy called_kf precondition = if not (PreCondProxyGenerated.mem precondition) then begin Kernel.debug "Setting up syntactic call-preconditions for precondition \ of %a" Kernel_function.pretty called_kf; let call_preconditions = List.map (fun (_,stmt) -> precondition_at_call called_kf precondition stmt) (Kernel_function.find_syntactic_callsites called_kf) in Property_status.logical_consequence preconditions_emitter precondition call_preconditions; PreCondProxyGenerated.add precondition call_preconditions end and add_call_precondition precondition call_precondition = let prev = try PreCondProxyGenerated.find precondition with Not_found -> [] in let all = call_precondition :: prev in PreCondProxyGenerated.replace precondition all; Property_status.logical_consequence preconditions_emitter precondition all let fold_requires f kf acc = let bhvs = Annotations.behaviors kf in List.fold_left (fun acc bhv -> List.fold_left (f bhv) acc bhv.b_requires) acc bhvs (* Properties for kf-preconditions at call-site stmt, if created. Returns both the initial property and its copy at call site. *) let all_call_preconditions_at ~warn_missing kf stmt = let aux bhv properties precond = let pid_spec = Property.ip_of_requires kf Kglobal bhv precond in if PreCondAt.mem (pid_spec, stmt) then let pid_call = precondition_at_call kf pid_spec stmt in (pid_spec, pid_call) :: properties else ( if warn_missing then Kernel.fatal ~source:(fst (Cil_datatype.Stmt.loc stmt)) "Preconditions %a for %a not yet registered at this statement" Printer.pp_identified_predicate precond Kernel_function.pretty kf; properties) in fold_requires aux kf [] let setup_all_preconditions_proxies kf = let aux bhv () req = let ip = Property.ip_of_requires kf Kglobal bhv req in setup_precondition_proxy kf ip in fold_requires aux kf () let replace_call_precondition ip stmt ip_at_call = (try (* Remove previous binding *) let cur = PreCondAt.find (ip, stmt) in PreCondAt.remove (ip, stmt); let all = PreCondProxyGenerated.find ip in let all' = Extlib.filter_out (Property.equal cur) all in PreCondProxyGenerated.replace ip all'; with Not_found -> ()); PreCondAt.replace (ip, stmt) ip_at_call; add_call_precondition ip ip_at_call (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/allocates.ml0000644000175000017500000000565112155630223020170 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (** Add [loop allocates \nothing] to the given stmt if no [loop allocates] clause currently exists for the default behavior *) let add_allocates_loop stmt = let _behav = Cil.default_behavior_name in let all_default _ rca r = match rca.annot_content with | AAllocation (b, alloc) -> r && (b <> [] || alloc = FreeAllocAny) | _ -> r in let all_default = Annotations.fold_code_annot all_default stmt true in if all_default then let ca = AAllocation ([], FreeAlloc ([], [])) in Annotations.add_code_annot Emitter.kernel stmt (Logic_const.new_code_annotation ca) let add_allocates_nothing_funspec kf = let behav = Cil.default_behavior_name in let all_default _ alloc r = r && alloc = FreeAllocAny in let all_default = Annotations.fold_allocates all_default kf behav true in if all_default then Annotations.add_allocates Emitter.kernel kf behav (FreeAlloc ([], [])) class vis_add_loop_allocates = object inherit Visitor.frama_c_inplace method vstmt s = (match s.skind with | Loop _ -> add_allocates_loop s; | _ -> () ); Cil.DoChildren method vinst _ = Cil.SkipChildren end let add_allocates_nothing () = Globals.Functions.iter add_allocates_nothing_funspec; let vis = new vis_add_loop_allocates in Visitor.visitFramacFileSameGlobals vis (Ast.get ()) frama-c-Fluorine-20130601/src/logic/property_status.ml0000644000175000017500000014243012155630223021505 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (**************************************************************************) (** {3 Datatypes} *) (**************************************************************************) module Caml_hashtbl = Hashtbl open Emitter module Emitted = struct type t = True | False_if_reachable | False_and_reachable | Dont_know end type emitted_status = Emitted.t = True | False_if_reachable | False_and_reachable | Dont_know module Emitted_status = Datatype.Make_with_collections (struct type t = emitted_status include Datatype.Serializable_undefined let name = "Property_status.emitted_status" let reprs = [ True; False_if_reachable; False_and_reachable; Dont_know ] let mem_project = Datatype.never_any_project let pretty fmt s = Format.fprintf fmt "%s" (match s with | True -> "VALID" | False_if_reachable | False_and_reachable -> "**NOT** VALID" | Dont_know -> "unknown") let compare (s1:t) s2 = Pervasives.compare s1 s2 let equal (s1:t) s2 = s1 = s2 let hash (s:t) = Caml_hashtbl.hash s end) type emitter_with_properties = { emitter: Usable_emitter.t; mutable properties: Property.t list; logical_consequence: bool } module Emitter_with_properties = Datatype.Make_with_collections (struct type t = emitter_with_properties let name = "Property_status.emitter" let rehash = Datatype.identity let structural_descr = Structural_descr.Abstract let reprs = List.fold_left (fun acc e -> { emitter = e; properties = Property.reprs; logical_consequence = false } :: acc) [] Usable_emitter.reprs let equal x y = Usable_emitter.equal x.emitter y.emitter let compare x y = Usable_emitter.compare x.emitter y.emitter let hash x = Caml_hashtbl.hash x.emitter let copy = Datatype.undefined let pretty fmt e = Usable_emitter.pretty fmt e.emitter let internal_pretty_code = Datatype.undefined let varname _ = assert false (* unused while [internal_pretty_code] unimplemented *) let mem_project = Datatype.never_any_project end) type inconsistent = { valid: emitter_with_properties list; invalid: emitter_with_properties list } module Local = struct type t = | Never_tried | Best of emitted_status * emitter_with_properties list | Inconsistent of inconsistent end type status = Local.t = | Never_tried | Best of emitted_status * emitter_with_properties list | Inconsistent of inconsistent module L = Datatype.Make (struct type t = status include Datatype.Serializable_undefined let name = "Property_status.t" let reprs = let l = Emitter_with_properties.reprs in [ Never_tried; Best(True, []); Inconsistent { valid = l; invalid = l } ] let mem_project = Datatype.never_any_project let pretty fmt s = let pp_emitters fmt l = Pretty_utils.pp_list ~sep:", " ~last:" and " Emitter_with_properties.pretty fmt l in match s with | Never_tried -> Format.fprintf fmt "no verification attempted" | Best(Dont_know as s, l) -> Format.fprintf fmt "@[%a@ @[(%a tried%s to verify@ \ but could not decide)@]@]" Emitted_status.pretty s pp_emitters l (match l with [] | [ _ ] -> "" | _ :: _ -> " each") | Best(True | False_if_reachable | False_and_reachable as s, l) -> Format.fprintf fmt "%a according to %a%s" Emitted_status.pretty s pp_emitters l (match l with | [] -> assert false | { properties = [] } :: _ -> "" | { properties = _ :: _ } :: _ -> " (under hypotheses)") | Inconsistent i -> Format.fprintf fmt "@[inconsistent status:@ \ @[%a according to %a@]@ \ @[but %a according to %a@]" Emitted_status.pretty True pp_emitters i.valid Emitted_status.pretty False_if_reachable pp_emitters i.invalid end) include L (**************************************************************************) (** {3 Projectified tables} *) (**************************************************************************) let register_as_kernel_logical_consequence_ref = Extlib.mk_fun "register_as_kernel_logical_consequence_ref" (* property -> emitter -> emitted_status *) module Status = Emitter.Make_table (Property.Hashtbl) (struct include Emitter_with_properties let local_clear p h = Hashtbl.clear h; !register_as_kernel_logical_consequence_ref p let usable_get e = e.emitter let get e = Emitter.Usable_emitter.get e.emitter end) (Emitted_status) (struct let name = "Property_status" let dependencies = [ Ast.self ] let kinds = [ Emitter.Property_status ] let size = 97 end) let self = Status.self let iter f = Status.iter (fun p _ -> f p) let fold f = Status.fold (fun p _ -> f p) (* ok to be computed once right now since there is no parameter dependency *) let usable_kernel_emitter = Emitter.get Emitter.kernel module Hypotheses = State_builder.Hashtbl (Property.Hashtbl) (Datatype.Ref (Datatype.List(Datatype.Pair(Property)(Emitter_with_properties)))) (struct let name = "Property_status.Hypotheses" let dependencies = [ self ] let size = 97 end) let () = Status.add_hook_on_remove (fun e ppt _ -> (* remove the property from the hypotheses table *) let remove h = try let l = Hypotheses.find h in l := List.filter (fun (ppt', _) -> not (Property.equal ppt ppt')) !l with Not_found -> () in List.iter remove e.properties) (**************************************************************************) (** {3 Unconsolidated property status} *) (**************************************************************************) exception Inconsistent_emitted_status of emitted_status * emitted_status (* @return [true] if the strongest is the first parameter. [false] otherwise. In case of equality, return [false]. @raise Inconsistent_emitted_status if the check fails *) let check_strongest_emitted x y = match x, y with | True, (False_if_reachable | False_and_reachable) | (False_if_reachable | False_and_reachable), True -> raise (Inconsistent_emitted_status (x, y)) | Dont_know, (True | False_if_reachable | False_and_reachable | Dont_know) | True, True | False_if_reachable, (False_and_reachable | False_if_reachable) | False_and_reachable, False_and_reachable -> false | (True | False_if_reachable | False_and_reachable), Dont_know | False_and_reachable, False_if_reachable -> true (* [strenghten emitter emitted_status status] gets [status] and updates it according to [emitted_status] (which was emitted by [emitter]): that returns the strongest status between them, or an inconsistency if any. *) let strenghten emitter emitted_status status = match status, emitted_status with | Never_tried, (True | False_if_reachable | False_and_reachable | Dont_know) -> (* was not tried, but now we have tried :) *) Best(emitted_status, [ emitter ]) | Best(s, l), s2 when s = s2 -> (* status are equal: update the emitters *) Best(s, emitter :: l) | Best(s, l), s2 (* when s <> emitted_status *) -> (try let first = check_strongest_emitted s s2 in if first then (* the old one is the strongest, keep it *) status else (* the new one is the strongest, replace the old one *) Best(emitted_status, [ emitter ]) with Inconsistent_emitted_status _ -> (* inconsistency detected *) (match s with | True -> assert (emitted_status = False_if_reachable || emitted_status = False_and_reachable); (* the old one is valid, but the new one is invalid *) Inconsistent { valid = l; invalid = [ emitter ] } | False_if_reachable | False_and_reachable -> assert (emitted_status = True); (* the old one is invalid, but the new one is valid *) Inconsistent { valid = [ emitter ]; invalid = l } | Dont_know -> assert false)) | Inconsistent i, True -> (* was already inconsistent and the new one is valid: update the valid field *) Inconsistent { i with valid = emitter :: i.valid } | Inconsistent i, (False_if_reachable | False_and_reachable) -> (* was already inconsistent and the new one is invalid: update the invalid field *) Inconsistent { i with invalid = emitter :: i.invalid } | Inconsistent _, Dont_know -> (* was already inconsistent, but the new one gets no new info: ignore it *) status exception Unmergeable (* @return [true] if one must keep the status of the first parameter. [false] otherwise. In case of equality, return [false]. @raise Unmergeable *) let merge_distinct_emitted x y = match x, y with | False_and_reachable, (True | Dont_know | False_if_reachable) | Dont_know, (True | False_if_reachable) -> true | (True | False_if_reachable | Dont_know), False_and_reachable | (False_if_reachable | True | Dont_know), Dont_know | False_if_reachable, False_if_reachable | False_and_reachable, False_and_reachable | True, True -> false | False_if_reachable, True | True, False_if_reachable -> raise Unmergeable let rec register ppt = Kernel.debug ~level:22 "REGISTERING %a in %a" Property.pretty ppt Project.pretty (Project.current ()); if Status.mem ppt then Kernel.fatal "trying to register twice property `%a'.\n\ That is forbidden (kernel invariant broken)." Property.pretty ppt; let h = Emitter_with_properties.Hashtbl.create 7 in Status.add ppt h; register_as_kernel_logical_consequence ppt (* the functions below and this one MUST be synchronized *) and register_as_kernel_logical_consequence ppt = match ppt with | Property.IPAxiom _ | Property.IPPredicate(Property.PKAssumes _, _, _, _) -> (* always valid, but must be verifiable by the end-user, see [is_not_verifiable_but_valid] *) () | Property.IPAxiomatic(_, l) -> logical_consequence Emitter.kernel ppt l | Property.IPBehavior(kf, ki, b) -> (* logical consequence of its postconditions *) logical_consequence Emitter.kernel ppt (Property.ip_post_cond_of_behavior kf ki b) | Property.IPReachable(None, Cil_types.Kglobal, Property.Before) -> (* valid: global properties are always reachable *) emit_valid ppt | Property.IPReachable(None, Cil_types.Kglobal, Property.After) -> assert false | Property.IPReachable(None, Cil_types.Kstmt _, _) -> Kernel.fatal "reachability of a stmt without function" | Property.IPReachable(Some kf, Cil_types.Kglobal, Property.Before) -> let f = kf.Cil_types.fundec in if Ast_info.Function.get_name f = Kernel.MainFunction.get () (* main is always reachable *) then emit_valid ppt | Property.IPOther _ | Property.IPReachable _ | Property.IPPredicate _ | Property.IPCodeAnnot _ | Property.IPComplete _ | Property.IPDisjoint _ | Property.IPAssigns _ | Property.IPFrom _ | Property.IPAllocation _ | Property.IPDecrease _ | Property.IPLemma _ -> () (* the functions above and below MUST be synchronized *) and is_kernel_logical_consequence ppt = match ppt with | Property.IPPredicate(Property.PKAssumes _, _, _, _) | Property.IPBehavior(_, _, _) | Property.IPReachable(None, Cil_types.Kglobal, Property.Before) -> true | Property.IPReachable(None, Cil_types.Kglobal, Property.After) -> assert false | Property.IPReachable(None, Cil_types.Kstmt _, _) -> Kernel.fatal "reachability of a stmt without function" | Property.IPReachable(Some kf, Cil_types.Kglobal, Property.Before) -> let f = kf.Cil_types.fundec in (* main is always reachable *) Ast_info.Function.get_name f = Kernel.MainFunction.get () | Property.IPAxiom _ | Property.IPAxiomatic _ | Property.IPOther _ | Property.IPReachable _ | Property.IPPredicate _ | Property.IPCodeAnnot _ | Property.IPComplete _ | Property.IPDisjoint _ | Property.IPAssigns _ | Property.IPFrom _ | Property.IPAllocation _ | Property.IPDecrease _ | Property.IPLemma _ -> false and unsafe_emit_and_get e ~hyps ~auto ppt ?(distinct=false) s = try let by_emitter = Status.find ppt in let emitter = { emitter = Emitter.get e; properties = hyps; logical_consequence = auto } in let emit s = (* do not use Hashtbl.replace, see OCaml BTS #5349 *) Emitter_with_properties.Hashtbl.remove by_emitter emitter; let selection = State_selection.only_dependencies Status.self in Project.clear ~selection (); let add e s = Emitter_with_properties.Hashtbl.add by_emitter e s; List.iter (function | Property.IPOther _ -> () | h -> let pair = ppt, e in try let l = Hypotheses.find h in l := pair :: !l with Not_found -> Hypotheses.add h (ref [ pair ])) e.properties in (match s with | True -> add emitter s | Dont_know -> add emitter s | False_and_reachable -> (match hyps with | [] -> add emitter s | _ :: _ -> Kernel.fatal "Emitter %a proves invalidity of %a under \ hypotheses: unsound!" Emitter.pretty e Property.pretty ppt) | False_if_reachable -> (match ppt with | Property.IPReachable _ -> Kernel.fatal "Emitter %a proves %a by using itself: unsound!" Emitter.pretty e Property.pretty ppt | _ -> ()); (match hyps with | [] -> let reach_ppt = Property.ip_reachable_ppt ppt in if is_kernel_logical_consequence reach_ppt then emit_valid reach_ppt; add { emitter with properties = [ reach_ppt ] } s | _ :: _ -> Kernel.fatal "Emitter %a proves invalidity of %a under \ hypotheses: unsound!" Emitter.pretty e Property.pretty ppt)); s in (try if auto then (* registering again a logical consequence because dependencies change, thus erase the previous (now erroneous) calculus *) emit s else let old_s = Emitter_with_properties.Hashtbl.find by_emitter emitter in try let first = (if distinct then merge_distinct_emitted else check_strongest_emitted) s old_s in if first then emit s else old_s with Unmergeable -> emit Dont_know with Not_found -> emit s) with Not_found -> (* assume that all ACSL properties are registered, except non-ACSL and conjunctions ones (but conjunctions are automatically computed and so already registered) *) match ppt with | Property.IPOther _ | Property.IPReachable _ -> register ppt; unsafe_emit_and_get e ~hyps ~auto ppt ~distinct s | Property.IPPredicate _ | Property.IPCodeAnnot _ | Property.IPComplete _ | Property.IPDisjoint _ | Property.IPAssigns _ | Property.IPFrom _ | Property.IPAllocation _ | Property.IPDecrease _ | Property.IPBehavior _ | Property.IPAxiom _ | Property.IPAxiomatic _ | Property.IPLemma _ -> Kernel.fatal "unregistered property %a" Property.pretty ppt and logical_consequence e ppt hyps = ignore (unsafe_emit_and_get e ~hyps ~auto:true ppt Dont_know) and emit_valid ppt = ignore (unsafe_emit_and_get Emitter.kernel ~hyps:[] ~auto:true ppt True) let () = register_as_kernel_logical_consequence_ref := register_as_kernel_logical_consequence let emit_and_get e ~hyps ppt ?distinct s = (match ppt with | Property.IPBehavior _ | Property.IPAxiom _ | Property.IPAxiomatic _ | Property.IPPredicate (Property.PKAssumes _, _, _, _) -> Kernel.fatal "only the kernel should set the status of property %a" Property.pretty ppt | Property.IPPredicate _ | Property.IPCodeAnnot _ | Property.IPComplete _ | Property.IPDisjoint _ | Property.IPAssigns _ | Property.IPFrom _ | Property.IPDecrease _ | Property.IPLemma _ | Property.IPReachable _ | Property.IPAllocation _ | Property.IPOther _ -> ()); unsafe_emit_and_get e ~hyps ~auto:false ppt ?distinct s let emit e ~hyps ppt ?distinct s = ignore (emit_and_get e ~hyps ppt ?distinct s) (* remove each status that used [hyp] as hypothesis *) let remove_when_used_as_hypothesis hyp = try let l = Hypotheses.find hyp in let remove (ppt, e) = if e.logical_consequence then (* only remove [hyp] from hypotheses without killing the status *) e.properties <- List.filter (fun ppt' -> ppt' != hyp) e.properties else let by_emitter = try Status.find ppt with Not_found -> assert false in Emitter_with_properties.Hashtbl.remove by_emitter e in List.iter remove !l with Not_found -> () (* remove each hypothese of [ppt] from the hypotheses table *) let remove_hyps_from_hypotheses ppt = try let by_emitter = Status.find ppt in Emitter_with_properties.Hashtbl.iter (fun e s -> Status.apply_hooks_on_remove e ppt s) by_emitter with Not_found -> () let remove ppt = (* Kernel.feedback "REMOVING %a in %a" Property.pretty ppt Project.pretty (Project.current ());*) remove_when_used_as_hypothesis ppt; remove_hyps_from_hypotheses ppt; Status.remove ppt let merge ~old l = let property_id fmt p = Format.fprintf fmt "%a(%d)" Property.pretty p (Property.hash p) in (*Kernel.feedback "MERGING ###%a###@\nWITH ###%a###" (Pretty_utils.pp_list ~sep:"\n###" property_id) old (Pretty_utils.pp_list ~sep:"\n###" property_id) l; *) let old_h = Property.Hashtbl.create 17 in List.iter (fun p -> assert (Kernel.verify (Status.mem p) "Unknown property %a" property_id p); Property.Hashtbl.add old_h p ()) old; List.iter (fun p -> if Property.Hashtbl.mem old_h p then begin (* [p] belongs to both lists *) (*Kernel.feedback "UNCHANGED %a" Property.pretty p;*) Property.Hashtbl.remove old_h p; (* if [p] was a logical consequence, its dependencies may change *) register_as_kernel_logical_consequence p end else begin (* [p] belongs only to the new list *) (*Kernel.feedback "ADD %a" Property.pretty p;*) register p end) l; (* remove the properties which are not in the new list *) Property.Hashtbl.iter (fun p () -> (* Kernel.feedback "REMOVE BY MERGE %a" Property.pretty p;*) remove p) old_h let conjunction s1 s2 = match s1, s2 with (* order does matter *) | False_and_reachable, _ | _, False_and_reachable -> False_and_reachable | False_if_reachable, _ | _, False_if_reachable -> False_if_reachable | Dont_know, _ | _, Dont_know -> Dont_know | True, True -> True let is_not_verifiable_but_valid ppt status = match status with | Never_tried | Best(Dont_know, _) -> (match ppt with | Property.IPOther _ -> (* Non-ACSL properties are not verifiable *) false | Property.IPReachable _ -> false | Property.IPAxiom _ | Property.IPAxiomatic _ -> true | _ -> match Property.get_kf ppt with | None -> false | Some kf -> (* cannot use module [Kernel_function] nor [Globals] here *) let f = kf.Cil_types.fundec in if Ast_info.Function.is_definition f then false else (* postconditions of functions without code are not verifiable *) match ppt with | Property.IPPredicate ((Property.PKEnsures _ | Property.PKTerminates), _, _, _) | Property.IPAssigns _ | Property.IPAllocation _ | Property.IPFrom _ -> true | _ -> false) | Best((True | False_if_reachable | False_and_reachable), _) | Inconsistent _ -> false let rec compute_automatic_status _e properties = let local_get p = let s = match get_status p with | Never_tried | Inconsistent _ -> Dont_know | Best(s, _) -> s in if is_not_verifiable_but_valid p (Best(s, [])) then True else s in List.fold_left (fun s p -> conjunction s (local_get p)) True properties and get_status ?(must_register=true) ppt = try let by_emitter = Status.find ppt in Emitter_with_properties.Hashtbl.fold (fun e s acc -> let s, tried = if e.logical_consequence && Emitted_status.equal s Dont_know then let ppts = List.filter (function Property.IPReachable _ -> false | _ -> true) e.properties in let new_s = compute_automatic_status e ppts in match new_s with | True | False_if_reachable | False_and_reachable -> (* the status is now known: register it *) Emitter_with_properties.Hashtbl.replace by_emitter e new_s; new_s, true | Dont_know -> (* no change *) new_s, (* there is a status for this logical consequence iff there is a status for one of its hypotheses *) List.exists (fun p -> get_status p <> Never_tried) ppts else s, true in if tried then strenghten e s acc else acc) by_emitter Never_tried with Not_found -> (* assume that all ACSL properties are registered, except non-ACSL ones *) match ppt with | Property.IPOther _ | Property.IPReachable _ -> if must_register then begin register ppt; if is_kernel_logical_consequence ppt then get_status ppt else Never_tried end else Never_tried | Property.IPBehavior _ | Property.IPPredicate _ | Property.IPCodeAnnot _ | Property.IPComplete _ | Property.IPDisjoint _ | Property.IPAssigns _ | Property.IPFrom _ | Property.IPDecrease _ | Property.IPAllocation _ | Property.IPAxiom _ | Property.IPAxiomatic _ | Property.IPLemma _ -> Kernel.fatal "trying to get status of unregistered property `%a'.\n\ That is forbidden (kernel invariant broken)." Property.pretty ppt (* local alias: too much local definitions of get implies name clashes *) let get ppt = get_status ppt let automatically_proven ppt = is_kernel_logical_consequence ppt && (* nobody else tried to prove it *) try let by_emitter = Status.find ppt in try Emitter_with_properties.Hashtbl.iter (fun e _ -> if not (Emitter.equal (Emitter.Usable_emitter.get e.emitter) Emitter.kernel) then raise Exit) by_emitter; true with Exit -> false with Not_found -> true module Valid_cycles : sig val add: Emitter.t -> Property.Set.t -> unit val _mem: Usable_emitter.t -> Property.t list -> bool end = struct module S = State_builder.Hashtbl (Datatype.String.Hashtbl) (* name of the emitter *) (Property.Set) (struct let size = 7 let dependencies = [ self ] let name = "Property_status.Valid_cycles" end) let _mem e path = try let all_cycles = S.find_all (Usable_emitter.get_name e) in List.exists (fun set -> List.for_all (fun p -> Property.Set.mem p set) path) all_cycles with Not_found -> false let add e path = S.add (Emitter.get_name e) path end let legal_dependency_cycle = Valid_cycles.add (**************************************************************************) (** {3 Consolidated property status} *) (**************************************************************************) module Consolidation = struct type pending = Property.Set.t Usable_emitter.Map.t Usable_emitter.Map.t type consolidated_status = | Never_tried | Considered_valid | Valid of Usable_emitter.Set.t | Valid_under_hyp of pending | Unknown of pending | Invalid of Emitter.Usable_emitter.Set.t | Invalid_under_hyp of pending | Invalid_but_dead of pending | Valid_but_dead of pending | Unknown_but_dead of pending | Inconsistent of string module D = Datatype.Make (struct type t = consolidated_status include Datatype.Serializable_undefined let name = "Property_status.consolidated_status" let reprs = [ Never_tried; Considered_valid; Valid Usable_emitter.Set.empty; Valid_under_hyp Usable_emitter.Map.empty; Unknown Usable_emitter.Map.empty; Invalid Usable_emitter.Set.empty; Invalid_under_hyp Usable_emitter.Map.empty; Invalid_but_dead Usable_emitter.Map.empty; Valid_but_dead Usable_emitter.Map.empty; Unknown_but_dead Usable_emitter.Map.empty; Inconsistent "" ] let mem_project = Datatype.never_any_project let pretty fmt s = let pp_emitters f fmt l = Pretty_utils.pp_list ~sep:", " ~last:" and " f fmt l in match s with | Never_tried -> Format.fprintf fmt "no verification attempted" | Considered_valid -> Format.fprintf fmt "unverifiable but considered %a; requires external review" Emitted_status.pretty Emitted.True | Valid set | Invalid set -> Format.fprintf fmt "%a according to %a" Emitted_status.pretty (match s with | Valid _ -> Emitted.True | Invalid _ -> Emitted.False_and_reachable | _ -> assert false) (pp_emitters Usable_emitter.pretty) (Usable_emitter.Set.elements set) | Valid_under_hyp map | Invalid_under_hyp map -> let l = Usable_emitter.Map.fold (fun e _ acc -> e :: acc) map [] in Format.fprintf fmt "@[%a@ @[(%a according to %a, but properties \ remain to be verified)@]@]" Emitted_status.pretty Emitted.Dont_know Emitted_status.pretty (match s with | Valid_under_hyp _ -> Emitted.True | Invalid_under_hyp _ -> Emitted.False_and_reachable | _ -> assert false) (pp_emitters Usable_emitter.pretty) l | Unknown map -> let l = Usable_emitter.Map.fold (fun e _ acc -> e :: acc) map [] in Format.fprintf fmt "@[%a@ @[(%a tried%s to verify@ \ but could not decide)@]@]" Emitted_status.pretty Emitted.Dont_know (pp_emitters Usable_emitter.pretty) l (match l with [] | [ _ ] -> "" | _ :: _ -> " each") | Valid_but_dead map | Invalid_but_dead map | Unknown_but_dead map -> let l = Usable_emitter.Map.fold (fun e _ acc -> e :: acc) map [] in Format.fprintf fmt "%a according to %a, but it is dead anyway" Emitted_status.pretty (match s with | Valid_but_dead _ -> Emitted.True | Invalid_but_dead _ -> Emitted.False_and_reachable | Unknown_but_dead _ -> Emitted.Dont_know | _ -> assert false) (pp_emitters Usable_emitter.pretty) l | Inconsistent msg -> Format.fprintf fmt "inconsistency detected:\n%s.\n\ Check your axiomatics and implicit hypotheses." msg end) include D module Consolidated_status = State_builder.Hashtbl (Property.Hashtbl) (D) (struct let name = "Consolidated_status" let dependencies = [ Status.self ] let size = 97 end) let merge_property e ppt map = try let set = Usable_emitter.Map.find e map in Usable_emitter.Map.add e (Property.Set.add ppt set) map with Not_found -> Usable_emitter.Map.add e (Property.Set.singleton ppt) map let merge_properties e set map = try let set2 = Usable_emitter.Map.find e map in Usable_emitter.Map.add e (Property.Set.union set set2) map with Not_found -> assert (not (Property.Set.is_empty set)); Usable_emitter.Map.add e set map let flatten_map init map = Usable_emitter.Map.fold (fun _ -> Usable_emitter.Map.fold merge_properties) map init let flatten_set init h set = Usable_emitter.Set.fold (fun e map -> merge_property e h map) set init let reduce_hypothesis_status ppt = function | Never_tried | Inconsistent _ -> let singleton_map v = Usable_emitter.Map.add usable_kernel_emitter v Usable_emitter.Map.empty in Unknown (singleton_map (singleton_map (Property.Set.singleton ppt))) | Invalid_under_hyp m -> Unknown m | Considered_valid | Valid _ -> Valid Emitter.Usable_emitter.Set.empty | Invalid_but_dead m | Valid_but_dead m | Unknown_but_dead m -> (* Must keep where are invalidities, thus keep the map. But anyway, each of these three "dead" status are consolidated in the same way *) Valid_but_dead m | Valid_under_hyp m | Unknown m -> Unknown m | Invalid _ as s -> s (* s1 = consolidated status of previous hypotheses; s2 = consolidated status of hypothesis h; e is the emitter of s2 for property h issues are the issues already computed compute: - consolidated status of (h1 /\ h2) - where are the issues and who finds them *) let hypotheses_conjunction issues h s1 s2 = match s1, s2 with (* order of patterns does matter *) | _, Never_tried | Considered_valid, _ | _, Considered_valid | Valid_under_hyp _, _ | _, Valid_under_hyp _ | Inconsistent _, _ | _, Inconsistent _ | Invalid_under_hyp _, _ | _, Invalid_under_hyp _ | Invalid_but_dead _, _ | _, Invalid_but_dead _ | Unknown_but_dead _, _ | _, Unknown_but_dead _ -> (* handle at callsite *) assert false | Never_tried, Unknown m -> (* first status encountered: keep the issues of the first hypothesis *) assert (Usable_emitter.Map.is_empty issues); Unknown Usable_emitter.Map.empty, flatten_map issues m | Never_tried, (Valid _ | Valid_but_dead _) -> (* first status encountered: no issue with the first hypothesis *) assert (Usable_emitter.Map.is_empty issues); Valid Usable_emitter.Set.empty, issues | Invalid set1, Invalid set2 -> assert (Usable_emitter.Set.is_empty set1); Invalid Usable_emitter.Set.empty, flatten_set issues h set2 | _, Invalid set -> Invalid Usable_emitter.Set.empty, flatten_set Usable_emitter.Map.empty h set | Invalid set, _ -> assert (Usable_emitter.Set.is_empty set); Invalid Usable_emitter.Set.empty, issues | Unknown m1, Unknown m2 -> assert (Usable_emitter.Map.is_empty m1); Unknown Usable_emitter.Map.empty, flatten_map issues m2 | Unknown m, (Valid _ | Valid_but_dead _) | (Valid _ | Valid_but_dead _), Unknown m -> Unknown Usable_emitter.Map.empty, flatten_map issues m | (Valid _ | Valid_but_dead _), (Valid _ | Valid_but_dead _) -> assert (Usable_emitter.Map.is_empty issues); Valid Usable_emitter.Set.empty, issues let singleton_map e m = Usable_emitter.Map.add e m Usable_emitter.Map.empty (* compute the best status [s] and add the emitter [e] if it computes [s] *) let choose_best_emitter old_status e (status, issues) = match old_status, status with | _, Never_tried | Considered_valid, _ | _, Considered_valid | Valid_under_hyp _, _ | _, Valid_under_hyp _ | Invalid_under_hyp _, _ | _, Invalid_under_hyp _ | Valid_but_dead _, _ | _, Valid_but_dead _ | Unknown_but_dead _, _ | _, Unknown_but_dead _ | Inconsistent _, _ | _, Inconsistent _ | Invalid _, _ (* the current best status cannot be invalid, but invalid_but_dead instead *) | _, Invalid_but_dead _ (* the last computed status cannot be invalid_but_dead, but invalid instead *) -> Kernel.fatal "@[[Property_status] invariant of consolidation broken:@ \ either status %a or %a not allowed when choosing the best emitter@]" pretty old_status pretty status (* first status encountered: keep it *) | Never_tried, Valid _ -> Valid (Usable_emitter.Set.singleton e) | Never_tried, Invalid _ -> Invalid_but_dead (singleton_map e issues) | Never_tried, Unknown _ -> Unknown (singleton_map e issues) (* the old computed status remains the best one *) | (Valid _ | Invalid_but_dead _), Unknown _ -> old_status (* [e] is the best *) | Unknown _, Valid _ -> Valid (Usable_emitter.Set.singleton e) | Unknown _, Invalid _ -> Invalid_but_dead (singleton_map e issues) (* [e] is as good as the previous best emitter *) | Valid set, Valid _ -> Valid (Usable_emitter.Set.add e set) | Invalid_but_dead m, Invalid _ -> Invalid_but_dead (Usable_emitter.Map.add e issues m) | Unknown m, Unknown _ -> Unknown (Usable_emitter.Map.add e issues m) (* Inconsistency! *) | Invalid_but_dead m, Valid _ -> assert (Usable_emitter.Map.is_empty issues); Inconsistent (let l = Usable_emitter.Map.fold (fun e _ acc -> e :: acc) m [] in Pretty_utils.sfprintf "@[Valid for: %a (at least).@\n\ Invalid for: %a.@]" Usable_emitter.pretty e (Pretty_utils.pp_list ~sep:", " ~last:" and " Usable_emitter.pretty) l) | Valid set, Invalid _ -> Inconsistent (let l = Usable_emitter.Set.elements set in Pretty_utils.sfprintf "@[Valid for: %a.@\n\ Invalid for: %a (at least).@]" (Pretty_utils.pp_list ~sep:", " ~last:" and " Usable_emitter.pretty) l Usable_emitter.pretty e) let mk_issue e ppt = Usable_emitter.Map.add e (Property.Set.singleton ppt) Usable_emitter.Map.empty let issues_without_emitter issues = Usable_emitter.Map.fold (fun _ -> Usable_emitter.Map.fold Usable_emitter.Map.add) issues Usable_emitter.Map.empty let local_hyp_issues emitters ppt issues = let m = issues_without_emitter issues in List.fold_left (fun acc ep -> let e = ep.emitter in Usable_emitter.Map.add e (merge_property e ppt m) acc) Usable_emitter.Map.empty emitters let merge_hypotheses_and_local_status ppt hyps_status local_status = match hyps_status, local_status with (* impossible cases: handle at callsite *) | Never_tried, _ | Considered_valid, _ | Valid_under_hyp _, _ | Invalid_under_hyp _, _ | Valid_but_dead _, _ | Unknown_but_dead _, _ | Invalid _, _ | _, Local.Never_tried -> Kernel.fatal "@[[Property_status] invariant of consolidation broken:@ \ either status %a or %a not allowed when merging status@]" pretty hyps_status L.pretty local_status (* status of hypotheses = valid; filter emitters by the one for which hypotheses are valid *) | Valid set, Best(Emitted.Dont_know, _) -> let mk e = mk_issue e ppt in let map = Usable_emitter.Set.fold (fun e -> Usable_emitter.Map.add e (mk e)) set Usable_emitter.Map.empty in Unknown map | Valid _, Best(Emitted.True, _) -> hyps_status | Valid set, Best((Emitted.False_and_reachable | Emitted.False_if_reachable), _) -> Invalid set | Valid set, (Local.Inconsistent i as s) -> let mk = let internal_map = Usable_emitter.Map.add usable_kernel_emitter (Property.Set.singleton ppt) Usable_emitter.Map.empty in List.fold_left (fun acc ep -> let e = ep.emitter in if Usable_emitter.Set.mem e set then Usable_emitter.Map.add e internal_map acc else acc) Usable_emitter.Map.empty in let valid_map = mk i.valid in let invalid_map = mk i.invalid in (* something strange locally appears: the only way that there is no global inconsistency if that this program point is actually dead *) if Usable_emitter.Map.is_empty valid_map then begin assert (not (Usable_emitter.Map.is_empty invalid_map)); Invalid_but_dead invalid_map end else if Usable_emitter.Map.is_empty invalid_map then Valid_but_dead valid_map else Inconsistent (Pretty_utils.sfprintf "%a" L.pretty s) (* status of hypotheses = invalid (encoded by invalid_but_dead) *) | Invalid_but_dead m, Best((Emitted.False_and_reachable | Emitted.False_if_reachable), _) -> Invalid_but_dead m | Invalid_but_dead m, Best(Emitted.True, _) -> Valid_but_dead m | Invalid_but_dead m, (Best(Emitted.Dont_know, _) | Local.Inconsistent _) -> Unknown_but_dead m (* status of hypotheses = dont_know *) | Unknown m, Best(Emitted.True, _) -> Valid_under_hyp m | Unknown m, Best((Emitted.False_if_reachable | Emitted.False_and_reachable), _) -> Invalid_under_hyp m | Unknown m, Best(Emitted.Dont_know, emitters) -> Unknown (local_hyp_issues emitters ppt m) | Unknown m, Local.Inconsistent _ -> Unknown m (* status of hypotheses = inconsistent *) | Inconsistent _, _ -> hyps_status let visited_ppt = Property.Hashtbl.create 97 let consolidate_reachable ppt = let reach_ppt = Property.ip_reachable_ppt ppt in match get_status ~must_register:false reach_ppt with | Best(False_and_reachable, _) -> (* someone proves unreachability of [ppt] *) (try let by_emitter = Status.find ppt in (* someone emits a status for [ppt]: add (reachable ppt) to hypotheses of [ppt] if that is not already the case *) Emitter_with_properties.Hashtbl.iter (fun e _ -> if List.for_all (fun p -> not (Property.equal p reach_ppt)) e.properties then e.properties <- reach_ppt :: e.properties) by_emitter with Not_found -> (* no-one emits a status for [ppt]: add an unknown status *) ()) | Local.Never_tried | Local.Best((True | Dont_know), _) | Local.Inconsistent _ -> () | Local.Best(False_if_reachable, _) -> assert false let consolidate ppt compute_deps_status = consolidate_reachable ppt; let local_status = get ppt in if is_not_verifiable_but_valid ppt local_status then Considered_valid else match local_status with | Local.Never_tried -> Never_tried | Best(_, l) as local -> let status = compute_deps_status l in (* Kernel.feedback "status of hypotheses of %a: %a" Property.pretty ppt pretty hyps_status;*) let s = merge_hypotheses_and_local_status ppt status local in (* Kernel.feedback "consolidated status of %a: %a" Property.pretty ppt pretty s;*) s | Local.Inconsistent { valid = valid; invalid = invalid } as local -> let hyps_status = compute_deps_status (valid @ invalid) in merge_hypotheses_and_local_status ppt hyps_status local type emitter = | Not_yet | Single of Usable_emitter.t | Several let rec memo_consolidated e path ppt = Consolidated_status.memo (fun ppt -> if Property.Hashtbl.mem visited_ppt ppt then begin Considered_valid (* [JS 2011/11/04] use the following code (to be tested) as soon as WP uses the new function [legal_dependency_cycle] *) (* match e with | Not_yet -> assert false | Single e -> if Valid_cycles.mem e path then Considered_valid else Kernel.fatal "illegal dependency cycle for emitter %a" Usable_emitter.pretty e | Several -> (* cycle because the proof of [ppt] with emitter [E1] depends on another [ppt'] which is proven with another emitter [E2] by using [ppt] itself: it is not inconsistent by itself, but we cannot use it as a proof. *) consolidate ppt (fun _ -> Unknown (Usable_emitter.Map.add usable_kernel_emitter (Usable_emitter.Map.add usable_kernel_emitter (List.fold_left (fun acc p -> Property.Set.add p acc) Property.Set.empty path) Usable_emitter.Map.empty) Usable_emitter.Map.empty))*) end else begin Property.Hashtbl.add visited_ppt ppt (); consolidate ppt (consolidated_emitters e (ppt :: path)) (* [JS 2011/11/04] think about that when uncommenting the code above *) (* try (* was previously added during its own calculus in case of inconsistent mutual dependency *) Consolidated_status.find ppt with Not_found ->*) (* consolidated_status*) end) ppt and consolidated_emitters current_e path l = (* [l] is the list of the best emitters of the local status of [ppt]. As they emit the same local status, we only choose the best one according to the status of their hypotheses. *) let status = List.fold_left (fun current_status e -> let current_e = match current_e with | Not_yet -> Single e.emitter | Single e' as x when Usable_emitter.equal e.emitter e' -> x | Single _ | Several -> Several in let (s, issues) = (* compute the status of conjunction of hypotheses of [e], with related issues *) List.fold_left (fun (status, issues) h -> let s = memo_consolidated current_e path h in let s = reduce_hypothesis_status h s in (* Kernel.feedback "status of hypothesis %a (for %a): %a" Property.pretty h Property.pretty ppt pretty s;*) hypotheses_conjunction issues h status s) (Never_tried, Usable_emitter.Map.empty) e.properties in let hyps_status = match s with | Never_tried -> (* if no hypothesis, status of hypotheses must be valid *) Valid (Usable_emitter.Set.singleton usable_kernel_emitter) | Valid _ | Invalid _ | Unknown _ -> s | Considered_valid | Inconsistent _ | Valid_under_hyp _ | Invalid_under_hyp _ | Valid_but_dead _ | Invalid_but_dead _ | Unknown_but_dead _ -> Kernel.fatal "@[[Property_status] invariant of consolidation \ broken:@ status %a not allowed when simplifying hypothesis status@]" pretty s in let cur = choose_best_emitter current_status e.emitter (hyps_status, issues) in (* Kernel.feedback "status of hypotheses for emitter `%a': %a" Usable_emitter.pretty e.emitter pretty s; Kernel.feedback "current best status: %a" pretty cur;*) cur) Never_tried l in match status with | Never_tried -> (* if no hypothesis, status of hypotheses must be valid *) Valid (Usable_emitter.Set.singleton usable_kernel_emitter) | _ -> status let get ppt = let s = memo_consolidated Not_yet [] ppt in Property.Hashtbl.clear visited_ppt; s let get_conjunction ppts = let tmp = Property.ip_other "$Feedback.tmp$" None Cil_types.Kglobal in logical_consequence Emitter.kernel tmp ppts ; let s = get tmp in remove tmp ; Consolidated_status.remove tmp ; s end module Feedback = struct type t = | Never_tried | Considered_valid | Valid | Valid_under_hyp | Unknown | Invalid | Invalid_under_hyp | Invalid_but_dead | Valid_but_dead | Unknown_but_dead | Inconsistent let from_consolidation = function | Consolidation.Never_tried -> Never_tried | Consolidation.Considered_valid -> Considered_valid | Consolidation.Valid _ -> Valid | Consolidation.Valid_under_hyp _ -> Valid_under_hyp | Consolidation.Unknown _ -> Unknown | Consolidation.Invalid _ -> Invalid | Consolidation.Invalid_under_hyp _ -> Invalid_under_hyp | Consolidation.Invalid_but_dead _ -> Invalid_but_dead | Consolidation.Valid_but_dead _ -> Valid_but_dead | Consolidation.Unknown_but_dead _ -> Unknown_but_dead | Consolidation.Inconsistent _ -> Inconsistent let get p = from_consolidation (Consolidation.get p) let get_conjunction l = from_consolidation (Consolidation.get_conjunction l) end (**************************************************************************) (** {3 Consolidation graph} *) (**************************************************************************) module Consolidation_graph = struct type v = | Property of Property.t | Emitter of string | Tuning_parameter of string | Correctness_parameter of string module Vertex = struct type t = v let compare v1 v2 = match v1, v2 with | Property p1, Property p2 -> Property.compare p1 p2 | Emitter s1, Emitter s2 -> String.compare s1 s2 | Tuning_parameter s1, Tuning_parameter s2 | Correctness_parameter s1, Correctness_parameter s2 -> String.compare s1 s2 | Property _, _ | Emitter _, (Tuning_parameter _ | Correctness_parameter _) | Tuning_parameter _, Correctness_parameter _ -> 1 | _, _ -> -1 let equal v1 v2 = compare v1 v2 = 0 let hash = function | Property p -> Caml_hashtbl.hash (0, Property.hash p) | Emitter s -> Caml_hashtbl.hash (1, s) | Tuning_parameter s -> Caml_hashtbl.hash (2, s) | Correctness_parameter s -> Caml_hashtbl.hash (3, s) end module Edge = struct include Datatype.Option_with_collections (Emitted_status) (struct let module_name = "Property_status.Consolidation_graph.Edge" end) let default = None end module G = Graph.Persistent.Digraph.ConcreteLabeled(Vertex)(Edge) module G_oper = Graph.Oper.P(G) module Graph_by_property = State_builder.Hashtbl (Property.Hashtbl) (Datatype.Make (struct type t = G.t let name = "consolidation graph" let reprs = [ G.empty ] include Datatype.Serializable_undefined end)) (struct let name = "Consolidation graph" let size = 97 let dependencies = [ Consolidation.Consolidated_status.self ] end) type t = G.t let get_parameter_string ~tuning e s = Pretty_utils.sfprintf "%t" (fun fmt -> Usable_emitter.pretty_parameter fmt ~tuning e s) let already_done = Property.Hashtbl.create 17 let rec get ppt = Graph_by_property.memo (fun ppt -> (* [JS 2011/07/21] Only the better proof is added on the graph. For instance, if the consolidated status is valid thanks to WP, it does not show the dont_know proof tried by Value. *) if Property.Hashtbl.mem already_done ppt then G.empty else begin Property.Hashtbl.add already_done ppt (); let v_ppt = Property ppt in (* adding the property *) let g = G.add_vertex G.empty v_ppt in match get_status ppt with | Never_tried -> g | Best(s, emitters) -> get_emitters g v_ppt s emitters | Inconsistent i -> let g = get_emitters g v_ppt True i.valid in get_emitters g v_ppt False_and_reachable i.invalid end) ppt and get_emitters g v_ppt s l = List.fold_left (fun g e -> let emitter = e.emitter in let v_e = Emitter (Usable_emitter.get_unique_name emitter) in (* adding the emitter with its computed status *) let g = G.add_edge_e g (v_ppt, Some s, v_e) in let g = (* adding the tuning parameters *) Datatype.String.Set.fold (fun p g -> let s = get_parameter_string ~tuning:true emitter p in G.add_edge g v_e (Tuning_parameter s)) (distinct_tuning_parameters emitter) g in let g = (* adding the correctness parameters *) Datatype.String.Set.fold (fun p g -> let s = get_parameter_string ~tuning:false emitter p in (* G.add_edge g v_e *)ignore (Correctness_parameter s); g) (distinct_correctness_parameters emitter) g in (* adding the hypotheses *) List.fold_left (fun g h -> let g' = get h in let union = G.fold_edges_e (fun e g -> G.add_edge_e g e) g g' in G.add_edge union v_ppt (Property h)) g e.properties) g l let get ppt = let g = get ppt in Property.Hashtbl.clear already_done; g let dump graph formatter = let module Dot = Graph.Graphviz.Dot (struct include G let emitted_status_color = function | True -> 0x00ff00 (* green *) | False_if_reachable | False_and_reachable -> 0xff0000 (* red *) | Dont_know -> 0xffa500 (* orange *) let status_color p s = if is_not_verifiable_but_valid p s then 0x00ff00 (* green *) else match s with | Never_tried -> 0x0011ff (* dark blue, only for border *) | Best(s, _) -> emitted_status_color s | Inconsistent _ -> 0x808080 (* gray *) let graph_attributes _ = [] let vertex_name v = let s = match v with | Property p -> Property.Names.get_prop_name_id p | Emitter s | Tuning_parameter s | Correctness_parameter s -> s in Pretty_utils.sfprintf "\"%s\"" s let label v = let s = match v with | Property p -> Pretty_utils.sfprintf "%a" Property.pretty p | Emitter s | Tuning_parameter s | Correctness_parameter s -> s in `Label (String.escaped s) let vertex_attributes = function | Property p as v -> let s = get_status p in let color = status_color p s in let style = match s with | Never_tried -> [`Style `Bold; `Width 0.8 ] | _ -> [`Style `Filled] in style @ [ label v; `Color color; `Shape `Box ] | Emitter _ as v -> [ label v; `Shape `Diamond; `Color 0xb0c4de; `Style `Filled ] | Tuning_parameter _ as v -> [ label v; (*`Style `Dotted;*) `Color 0xb0c4de; ] | Correctness_parameter _ (*as v*) -> assert false (*[ label v; `Color 0xb0c4de ]*) let edge_attributes e = match E.label e with | None -> [] | Some s -> let c = emitted_status_color s in [ `Color c; `Fontcolor c; `Style `Bold ] let default_vertex_attributes _ = [] let default_edge_attributes _ = [] let get_subgraph _ = None end) in try Kernel.Unicode.without_unicode (Dot.fprint_graph formatter) graph; with Sys_error _ as exn -> Kernel.error "issue when generating consolidation graph: %s" (Printexc.to_string exn) end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/logic_interp.ml0000644000175000017500000011106612155630223020675 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Cil_types open Cil_datatype exception Error of Cil_types.location * string exception Unbound of string let find_var kf x = let vi = try Globals.Vars.find_from_astinfo x (VLocal kf) with Not_found -> try Globals.Vars.find_from_astinfo x (VFormal kf) with Not_found -> try Globals.Vars.find_from_astinfo x VGlobal with Not_found -> raise (Unbound ("Unbound variable " ^ x)) in cvar_to_lvar vi (** Create a logic typer, the interpretation being done for the given kernel_function and stmt (the stmt is used check that loop invariants are allowed). *) (* It is theoretically possible to use a first-class module instead, but the required signatures are not exported in Logic_typing. *) module DefaultLT (X: sig val kf: Kernel_function.t val stmt: stmt end) = Logic_typing.Make (struct let anonCompFieldName = Cabs2cil.anonCompFieldName let conditionalConversion = Cabs2cil.logicConditionalConversion let is_loop () = Kernel_function.stmt_in_loop X.kf X.stmt let find_macro _ = raise Not_found let find_var x = try find_var X.kf x with Unbound s -> raise (Error (Stmt.loc X.stmt, s)) let find_enum_tag _ = assert false (*TODO*) let find_comp_type ~kind:_ _s = assert false (*TODO*) let find_comp_field info s = let field = Cil.getCompField info s in Field(field,NoOffset) let find_type _s = assert false (*TODO*) let find_label s = Kernel_function.find_label X.kf s include Logic_env let add_logic_function = add_logic_function_gen Logic_utils.is_same_logic_profile let integral_cast ty t = raise (Failure (Pretty_utils.sfprintf "term %a has type %a, but %a is expected." Printer.pp_term t Printer.pp_logic_type Linteger Printer.pp_typ ty)) end) let wrap f stmt = try f () with Unbound s -> raise (Error (Stmt.loc stmt, s)) let code_annot kf stmt s = let module LT = DefaultLT(struct let kf = kf let stmt = stmt end) in let loc = snd (Cabshelper.currentLoc ()) in let pa = match snd (Logic_lexer.annot (loc, s)) with | Logic_ptree.Acode_annot (_,a) -> a | _ -> raise (Error (Stmt.loc stmt, "Syntax error (expecting a code annotation)")) in let parse () = LT.code_annot (Stmt.loc stmt) (Logic_utils.get_behavior_names (Annotations.funspec kf)) (Ctype (Kernel_function.get_return_type kf)) pa in wrap parse stmt let expr kf stmt s = let module LT = DefaultLT(struct let kf = kf let stmt = stmt end) in let (_,pa_expr) = Logic_lexer.lexpr (Lexing.dummy_pos, s) in let parse () = LT.term (Logic_typing.append_here_label (Logic_typing.Lenv.empty())) pa_expr in wrap parse stmt let lval kf stmt s = match (expr kf stmt s).term_node with | TLval lv -> lv | _ -> raise (Error (Stmt.loc stmt, "Syntax error (expecting an lvalue)")) (* may raise [Invalid_argument "not an lvalue"] *) let error_lval () = invalid_arg "not an lvalue" let rec logic_type_to_typ = function | Ctype typ -> typ | Linteger -> TInt(ILongLong,[]) (*TODO: to have an unlimited integer type in the logic interpretation*) | Lreal -> TFloat(FLongDouble,[]) (* TODO: handle reals, not floats... *) | Ltype({lt_name = name},[]) when name = Utf8_logic.boolean -> TInt(ILongLong,[]) | Ltype({lt_name = "set"},[t]) -> logic_type_to_typ t | Ltype _ | Lvar _ | Larrow _ -> error_lval () (* Expect conversion to be possible on all sub-terms, otherwise raise an error. *) let logic_var_to_var { lv_origin = lv } = match lv with | None -> error_lval () | Some lv -> lv let create_const_list loc kind low high = let rec aux acc i = if Integer.lt i low then acc else aux (new_exp ~loc (Const (CInt64 (i,kind,None)))::acc) (Integer.pred i) in aux [] high let range low high = let loc = fst low.eloc, snd high.eloc in match (Cil.constFold true low).enode, (Cil.constFold true high).enode with Const(CInt64(low,kind,_)), Const(CInt64(high,_,_)) -> create_const_list loc kind low high | _ -> error_lval() let singleton f loc = match f loc with [ l ] -> l | _ -> error_lval() let rec loc_lval_to_lval ~result (lh, lo) = Extlib.product (fun x y -> (x,y)) (loc_lhost_to_lhost ~result lh) (loc_offset_to_offset ~result lo) and loc_lhost_to_lhost ~result = function | TVar lvar -> [Var (logic_var_to_var lvar)] | TMem lterm -> List.map (fun x -> Mem x) (loc_to_exp ~result lterm) | TResult _ -> ( match result with None -> error_lval() | Some v -> [Var v]) and loc_offset_to_offset ~result = function | TNoOffset -> [NoOffset] | TModel _ -> error_lval () | TField (fi, lo) -> List.map (fun x -> Field (fi,x)) (loc_offset_to_offset ~result lo) | TIndex (lexp, lo) -> Extlib.product (fun x y -> Index(x,y)) (loc_to_exp ~result lexp) (loc_offset_to_offset ~result lo) and loc_to_exp ~result {term_node = lnode ; term_type = ltype; term_loc = loc} = match lnode with | TLval lv -> List.map (fun x -> new_exp ~loc (Lval x)) (loc_lval_to_lval ~result lv) | TAddrOf lv -> List.map (fun x -> new_exp ~loc (AddrOf x)) (loc_lval_to_lval ~result lv) | TStartOf lv -> List.map (fun x -> new_exp ~loc (StartOf x)) (loc_lval_to_lval ~result lv) | TSizeOfE lexp -> List.map (fun x -> new_exp ~loc (SizeOfE x)) (loc_to_exp ~result lexp) | TAlignOfE lexp -> List.map (fun x -> new_exp ~loc (AlignOfE x)) (loc_to_exp ~result lexp) | TUnOp (unop, lexp) -> List.map (fun x -> new_exp ~loc (UnOp (unop, x, logic_type_to_typ ltype))) (loc_to_exp ~result lexp) | TBinOp (binop, lexp1, lexp2) -> Extlib.product (fun x y -> new_exp ~loc (BinOp (binop, x,y, logic_type_to_typ ltype))) (loc_to_exp ~result lexp1) (loc_to_exp ~result lexp2) | TSizeOfStr string -> [new_exp ~loc (SizeOfStr string)] | TConst constant -> (* TODO: Very likely to fail on large integer and incorrect on reals not representable as floats *) [new_exp ~loc (Const (Logic_utils.lconstant_to_constant constant))] | TCastE (typ, lexp) -> List.map (fun x -> new_exp ~loc (CastE (typ, x))) (loc_to_exp ~result lexp) | TAlignOf typ -> [new_exp ~loc (AlignOf typ)] | TSizeOf typ -> [new_exp ~loc (SizeOf typ)] | Trange (Some low, Some high) -> let low = singleton (loc_to_exp ~result) low in let high = singleton (loc_to_exp ~result) high in range low high | Tunion l -> List.concat (List.map (loc_to_exp ~result) l) | Tempty_set -> [] | Tinter _ | Tcomprehension _ -> error_lval() | Tat ({term_node = TAddrOf (TVar _, TNoOffset)} as taddroflval, _) -> loc_to_exp ~result taddroflval (* additional constructs *) | Tapp _ | Tlambda _ | Trange _ | Tlet _ | TDataCons _ | Tif _ | Tat _ | Tbase_addr _ | Toffset _ | Tblock_length _ | Tnull | TCoerce _ | TCoerceE _ | TUpdate _ | Ttypeof _ | Ttype _ | TLogic_coerce _ -> error_lval () let rec loc_to_lval ~result t = match t.term_node with | TLval lv -> loc_lval_to_lval ~result lv | TAddrOf lv -> loc_lval_to_lval ~result lv | TStartOf lv -> loc_lval_to_lval ~result lv | Tunion l1 -> List.concat (List.map (loc_to_lval ~result) l1) | Tempty_set -> [] | Tinter _ -> error_lval() (* TODO *) | Tcomprehension _ -> error_lval() | TSizeOfE _ | TAlignOfE _ | TUnOp _ | TBinOp _ | TSizeOfStr _ | TConst _ | TCastE _ | TAlignOf _ | TSizeOf _ | Tapp _ | Tif _ | Tat _ | Toffset _ | Tbase_addr _ | Tblock_length _ | Tnull | Trange _ | TCoerce _ | TCoerceE _ | TDataCons _ | TUpdate _ | Tlambda _ | Ttypeof _ | Ttype _ | Tlet _ | TLogic_coerce _ -> error_lval () let identified_term_zone_to_loc ~result state t = !Db.Properties.Interp.loc_to_loc ~result state t.it_content let loc_to_offset ~result loc = let rec aux h = function TLval(h',o) | TStartOf (h',o) -> (match h with None -> Some h', loc_offset_to_offset ~result o | Some h when Logic_utils.is_same_lhost h h' -> Some h, loc_offset_to_offset ~result o | Some _ -> error_lval() ) | Tat ({ term_node = TLval(TResult _,_)} as lv,LogicLabel (_,"Post")) -> aux h lv.term_node | Tunion locs -> List.fold_left (fun (b,l) x -> let (b,l') = aux b x.term_node in b, l @ l') (h,[]) locs | Tempty_set -> h,[] | Trange _ | TAddrOf _ | TSizeOfE _ | TAlignOfE _ | TUnOp _ | TBinOp _ | TSizeOfStr _ | TConst _ | TCastE _ | TAlignOf _ | TSizeOf _ | Tapp _ | Tif _ | Tat _ | Toffset _ | Tbase_addr _ | Tblock_length _ | Tnull | TCoerce _ | TCoerceE _ | TDataCons _ | TUpdate _ | Tlambda _ | Ttypeof _ | Ttype _ | Tcomprehension _ | Tinter _ | Tlet _ | TLogic_coerce _ -> error_lval () in snd (aux None loc.term_node) let term_lval_to_lval ~result = singleton (loc_lval_to_lval ~result) let term_to_lval ~result = singleton (loc_to_lval ~result) let term_to_exp ~result = singleton (loc_to_exp ~result) let term_offset_to_offset ~result = singleton (loc_offset_to_offset ~result) (** Utilities to identify [Locations.Zone.t] involved into [code_annotation]. *) module To_zone : sig type ctx = Db.Properties.Interp.To_zone.t_ctx = {state_opt:bool option; ki_opt:(stmt * bool) option; kf:Kernel_function.t} val mk_ctx_func_contrat: kernel_function -> state_opt:bool option -> ctx (** [mk_ctx_func_contrat] to define an interpretation context related to [kernel_function] contracts. The control point of the interpretation is defined as follow: - pre-state if [state_opt=Some true] - post-state if [state_opt=Some false] - pre-state with possible reference to the post-state if [state_opt=None]. *) val mk_ctx_stmt_contrat: kernel_function -> stmt -> state_opt:bool option -> ctx (** [mk_ctx_stmt_contrat] to define an interpretation context related to [stmt] contracts. The control point of the interpretation is defined as follow: - pre-state if [state_opt=Some true] - post-state if [state_opt=Some false] - pre-state with possible reference to the post-state if [state_opt=None]. *) val mk_ctx_stmt_annot: kernel_function -> stmt -> ctx (** [mk_ctx_stmt_annot] to define an interpretation context related to an annotation attached before the [stmt]. *) type zone_info = Db.Properties.Interp.To_zone.t_zone_info type decl = Db.Properties.Interp.To_zone.t_decl type pragmas = Db.Properties.Interp.To_zone.t_pragmas val not_yet_implemented : string ref exception NYI of string val from_term: term -> ctx -> (zone_info * decl) (** Entry point to get zones needed to evaluate the [term] relative to the [ctx] of interpretation. *) val from_terms: term list -> ctx -> (zone_info * decl) (** Entry point to get zones needed to evaluate the list of [terms] relative to the [ctx] of interpretation. *) val from_pred: predicate named -> ctx -> (zone_info * decl) (** Entry point to get zones needed to evaluate the [predicate] relative to the [ctx] of interpretation. *) val from_preds: predicate named list -> ctx -> (zone_info * decl) (** Entry point to get zones needed to evaluate the list of [predicates] relative to the [ctx] of interpretation. *) val from_stmt_annot: code_annotation -> (stmt * kernel_function) -> (zone_info * decl) * pragmas (** Entry point to get zones needed to evaluate code annotations of this [stmt]. *) val from_stmt_annots: (code_annotation -> bool) option -> (stmt * kernel_function) -> (zone_info * decl) * pragmas (** Entry point to get zones needed to evaluate code annotations of this [stmt]. *) val from_func_annots: ((stmt -> unit) -> kernel_function -> unit) -> (code_annotation -> bool) option -> kernel_function -> (zone_info * decl) * pragmas (** Entry point to get zones needed to evaluate code annotations of this [kf]. *) val code_annot_filter: code_annotation -> threat:bool -> user_assert:bool -> slicing_pragma:bool -> loop_inv:bool -> loop_var:bool -> others:bool -> bool (** To quickly build a annotation filter *) end = struct exception NYI of string (* Reimport here the type definitions of Db.Properties.Interp. See documentation there. *) type ctx = Db.Properties.Interp.To_zone.t_ctx = {state_opt:bool option; ki_opt:(stmt * bool) option; kf:Kernel_function.t} type pragmas = Db.Properties.Interp.To_zone.t_pragmas = {ctrl: Stmt.Set.t ; stmt: Stmt.Set.t} type t = Db.Properties.Interp.To_zone.t = {before:bool ; ki:stmt ; zone:Locations.Zone.t} type zone_info = Db.Properties.Interp.To_zone.t_zone_info type decl = Db.Properties.Interp.To_zone.t_decl = {var: Varinfo.Set.t ; lbl: Logic_label.Set.t} let mk_ctx_func_contrat kf ~state_opt = { state_opt = state_opt; ki_opt = None; kf = kf } let mk_ctx_stmt_contrat kf ki ~state_opt = { state_opt=state_opt; ki_opt= Some(ki, false); kf = kf } let mk_ctx_stmt_annot kf ki = { state_opt = Some true; ki_opt = Some(ki, true); kf = kf } let empty_pragmas = { ctrl = Stmt.Set.empty; stmt = Stmt.Set.empty } let other_zones = Stmt.Hashtbl.create 7 let locals = ref Varinfo.Set.empty let labels = ref Logic_label.Set.empty let pragmas = ref empty_pragmas let zone_result = ref (Some other_zones) let not_yet_implemented = ref "" let add_top_zone not_yet_implemented_msg = match !zone_result with | None -> (* top zone *) () | Some other_zones -> Stmt.Hashtbl.clear other_zones; not_yet_implemented := not_yet_implemented_msg; zone_result := None let add_result ~before ki zone = match !zone_result with | None -> (* top zone *) () | Some other_zones -> let zone_true, zone_false = try Stmt.Hashtbl.find other_zones ki with Not_found -> Locations.Zone.bottom, Locations.Zone.bottom in Stmt.Hashtbl.replace other_zones ki (if before then Locations.Zone.join zone_true zone, zone_false else zone_true, Locations.Zone.join zone_false zone) let get_result_aux () = let result = let zones = match !zone_result with | None -> (* clear references for the next time when giving the result. Note that other_zones has been cleared in [add_top_zone]. *) zone_result := Some other_zones; None | Some other_zones -> let z = Stmt.Hashtbl.fold (fun ki (zone_true, zone_false) other_zones -> let add before zone others = if Locations.Zone.equal Locations.Zone.bottom zone then others else { before = before; ki = ki; zone = zone} :: others in add true zone_true (add false zone_false other_zones)) other_zones [] in (* clear table for the next time when giving the result *) Stmt.Hashtbl.clear other_zones; Some z in zones, {var = !locals; lbl = !labels} in let res_pragmas = !pragmas in (* clear references for the next time when giving the result *) (* TODO: this is hideous and error-prone as some functions are recursive. See VP comment about a more functional setting *) locals := Varinfo.Set.empty ; labels := Logic_label.Set.empty ; pragmas := empty_pragmas; result, res_pragmas let get_result () = fst (get_result_aux ()) let get_annot_result () = get_result_aux () (** Logic_var utility: *) let extract_locals logicvars = Logic_var.Set.fold (fun lv cvars -> match lv.lv_origin with | None -> cvars | Some cvar -> if cvar.Cil_types.vglob then cvars else Varinfo.Set.add cvar cvars) logicvars Varinfo.Set.empty (** Term utility: Extract C local variables occuring into a [term]. *) let extract_locals_from_term term = extract_locals (extract_free_logicvars_from_term term) (** Predicate utility: Extract C local variables occuring into a [term]. *) let extract_locals_from_pred pred = extract_locals (extract_free_logicvars_from_predicate pred) type abs_label = | AbsLabel_here | AbsLabel_pre | AbsLabel_post | AbsLabel_stmt of stmt let is_same_label absl l = match absl, l with | AbsLabel_stmt s1, StmtLabel s2 -> Cil_datatype.Stmt.equal s1 !s2 | AbsLabel_here, LogicLabel (_, "Here") -> true | AbsLabel_pre, LogicLabel (_, "Pre") -> true | AbsLabel_post, LogicLabel (_, "Post") -> true | _ -> false class populate_zone before_opt ki_opt kf = (* interpretation from the - pre-state if [before_opt=Some true] - post-state if [before_opt=Some false] - pre-state with possible reference to the post-state if [before_opt=None] of a property relative to - the contract of function [kf] when [ki_opt=None] otherwise [ki_opt=Some(ki, code_annot)], - the contract of the statement [ki] when [code_annot=false] - the annotation of the statement [ki] when [code_annot=true] *) object(self) inherit Visitor.frama_c_inplace val mutable current_label = AbsLabel_here method private get_ctrl_point () = let get_fct_entry_point () = (* TODO: to replace by true, None *) true, (try Some (Kernel_function.find_first_stmt kf) with Kernel_function.No_Statement -> (* raised when [kf] has no code. *) None) in let get_ctrl_point dft = let before = Extlib.opt_conv dft before_opt in match ki_opt with | None -> (* function contract *) if before then get_fct_entry_point () else before, None (* statement contract *) | Some (ki,_) -> (* statement contract and code annotation *) before, Some ki in let result = match current_label with | AbsLabel_stmt stmt -> true, Some stmt | AbsLabel_pre -> get_fct_entry_point () | AbsLabel_here -> get_ctrl_point true | AbsLabel_post -> get_ctrl_point false in (* TODO: the method should be able to return result directly *) match result with | current_before, Some current_stmt -> current_before, current_stmt | _ -> raise (NYI "[logic_interp] clause related to a function contract") method private change_label: 'a.abs_label -> 'a -> 'a visitAction = fun label x -> let old_label = current_label in current_label <- label; ChangeDoChildrenPost (x,fun x -> current_label <- old_label; x) method private change_label_to_here: 'a.'a -> 'a visitAction = fun x -> self#change_label AbsLabel_here x method private change_label_to_old: 'a.'a -> 'a visitAction = fun x -> match ki_opt,before_opt with (* function contract *) | None,Some true -> failwith "The use of the label Old is forbiden inside clauses \ related the pre-state of function contracts." | None,None | None,Some false -> (* refers to the pre-state of the contract. *) self#change_label AbsLabel_pre x (* statement contract *) | Some (_ki,false),Some true -> failwith "The use of the label Old is forbiden inside clauses \ related the pre-state of statement contracts." | Some (ki,false),None | Some (ki,false),Some false -> (* refers to the pre-state of the contract. *) self#change_label (AbsLabel_stmt ki) x (* code annotation *) | Some (_ki,true),None | Some (_ki,true),Some _ -> (* refers to the pre-state of the function contract. *) self#change_label AbsLabel_pre x method private change_label_to_post: 'a.'a -> 'a visitAction = fun x -> (* allowed when [before_opt=None] for function/statement contracts *) match ki_opt,before_opt with (* function contract *) | None,Some _ -> failwith "Function contract where the use of the label Post is \ forbiden." | None,None -> (* refers to the post-state of the contract. *) self#change_label AbsLabel_post x (* statement contract *) | Some (_ki,false),Some _ -> failwith "Statement contract where the use of the label Post is \ forbiden." | Some (_ki,false),None -> (* refers to the pre-state of the contract. *) self#change_label AbsLabel_post x (* code annotation *) | Some (_ki,true), _ -> failwith "The use of the label Post is forbiden inside code \ annotations." method private change_label_to_pre: 'a.'a -> 'a visitAction = fun x -> match ki_opt with (* function contract *) | None -> failwith "The use of the label Pre is forbiden inside function \ contracts." (* statement contract *) (* code annotation *) | Some _ -> (* refers to the pre-state of the function contract. *) self#change_label AbsLabel_pre x method private change_label_to_stmt: 'a.stmt -> 'a -> 'a visitAction = fun stmt x -> match ki_opt with (* function contract *) | None -> failwith "the use of C labels is forbiden inside clauses related \ function contracts." (* statement contract *) (* code annotation *) | Some _ -> (* refers to the state at the C label of the statement [stmt]. *) self#change_label (AbsLabel_stmt stmt) x method vpredicate p = let fail () = raise (NYI (Pretty_utils.sfprintf "[logic_interp] %a" Printer.pp_predicate p)) in match p with | Pat (_, LogicLabel (_,"Old")) -> self#change_label_to_old p | Pat (_, LogicLabel (_,"Here")) -> self#change_label_to_here p | Pat (_, LogicLabel (_,"Pre")) -> self#change_label_to_pre p | Pat (_, LogicLabel (_,"Post")) -> self#change_label_to_post p | Pat (_, StmtLabel st) -> self#change_label_to_stmt !st p | Pat (_, LogicLabel (_,s)) -> failwith ("unknown logic label" ^ s) | Pfalse | Ptrue | Prel _ | Pand _ | Por _ | Pxor _ | Pimplies _ | Piff _ | Pnot _ | Pif _ | Plet _ | Pforall _ | Pexists _ | Papp (_, [], _) (* No label, thus cannot access memory *) | Pseparated _ (* need only to preserve the values of each pointer *) -> DoChildren | Pinitialized (lbl, t) -> if is_same_label current_label lbl then ( let typ = Logic_typing.type_of_pointed t.term_type in let tlv = Cil.mkTermMem t TNoOffset in let tlv' = Logic_const.term (TLval tlv) typ in self#do_term_lval tlv'; DoChildren ) else fail () | Pvalid_read (_lbl, _) | Pvalid (_lbl, _) -> (* Does not take dynamic allocation into account, but then Value does not either. [lbl] can be ignored because they are taken into account by the functions [from_...] below *) DoChildren | Papp _ | Pallocable _ | Pfreeable _ | Pfresh _ | Psubtype _ -> fail () method private do_term_lval t = let msg = "[logic_interp] dependencies of a term lval" in let exp = try (* to be removed *) !Db.Properties.Interp.term_to_exp ~result:None t with Invalid_argument "not an lvalue" -> raise (NYI msg) in let current_before, current_ki = self#get_ctrl_point () in let loc = try (* to be removed *) !Db.From.find_deps_no_transitivity current_ki exp with Invalid_argument "not an lvalue" -> raise (NYI msg) in add_result current_before current_ki loc; method vterm t = match t.term_node with | TAddrOf _ | TLval (TMem _,_) | TLval(TVar {lv_origin = Some _},_) | TStartOf _ -> self#do_term_lval t; SkipChildren | Tat (_, LogicLabel (_,"Old")) -> self#change_label_to_old t | Tat (_, LogicLabel (_,"Here")) -> self#change_label_to_here t | Tat (_, LogicLabel (_,"Pre")) -> self#change_label_to_pre t | Tat (_, LogicLabel (_,"Post")) -> self#change_label_to_post t | Tat (_, StmtLabel st) -> self#change_label_to_stmt !st t | Tat (_, LogicLabel (_,s)) -> failwith ("unknown logic label" ^ s) | _ -> DoChildren end (** Entry point to get the list of [ki] * [Locations.Zone.t] needed to evaluate the [term] relative to the [ctx] of interpretation. *) let from_term term ctx = (* [VP 2011-01-28] TODO: factorize from_terms and from_term, and use a more functional setting. *) (try ignore(Visitor.visitFramacTerm (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) term) with NYI msg -> add_top_zone msg) ; locals := Varinfo.Set.union (extract_locals_from_term term) !locals; labels := Logic_label.Set.union (extract_labels_from_term term) !labels; get_result () (** Entry point to get the list of [ki] * [Locations.Zone.t] needed to evaluate the list of [terms] relative to the [ctx] of interpretation. *) let from_terms terms ctx = let f x = (try ignore(Visitor.visitFramacTerm (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) x) with NYI msg -> add_top_zone msg) ; locals := Varinfo.Set.union (extract_locals_from_term x) !locals; labels := Logic_label.Set.union (extract_labels_from_term x) !labels in List.iter f terms; get_result () (** Entry point to get the list of [ki] * [Locations.Zone.t] needed to evaluate the [pred] relative to the [ctx] of interpretation. *) let from_pred pred ctx = (try ignore(Visitor.visitFramacPredicateNamed (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) pred) with NYI msg -> add_top_zone msg) ; locals := Varinfo.Set.union (extract_locals_from_pred pred) !locals; labels := Logic_label.Set.union (extract_labels_from_pred pred) !labels; get_result () (** Entry point to get the list of [ki] * [Locations.Zone.t] needed to evaluate the list of [preds] relative to the [ctx] of interpretation. *) let from_preds preds ctx = let f pred = (try ignore(Visitor.visitFramacPredicateNamed (new populate_zone ctx.state_opt ctx.ki_opt ctx.kf) pred) with NYI msg -> add_top_zone msg) ; locals := Varinfo.Set.union (extract_locals_from_pred pred) !locals; labels := Logic_label.Set.union (extract_labels_from_pred pred) !labels in List.iter f preds; get_result () (** Used by annotations entry points. *) let get_zone_from_annot a (ki,kf) loop_body_opt = assert (!pragmas = empty_pragmas); (* check before modification. Anne.*) let get_zone_from_term k x = (try ignore (Visitor.visitFramacTerm (new populate_zone (Some true) (Some (k, true)) kf) x) with NYI msg -> add_top_zone msg) ; (* to select the declaration of the variables *) locals := Varinfo.Set.union (extract_locals_from_term x) !locals; (* to select the labels of the annotation *) labels := Logic_label.Set.union (extract_labels_from_term x) !labels and get_zone_from_pred k x = (try ignore (Visitor.visitFramacPredicateNamed (new populate_zone (Some true) (Some (k,true)) kf) x) with NYI msg -> add_top_zone msg) ; (* to select the declaration of the variables *) locals := Varinfo.Set.union (extract_locals_from_pred x) !locals; (* to select the labels of the annotation *) labels := Logic_label.Set.union (extract_labels_from_pred x) !labels in match a.annot_content with | APragma (Slice_pragma (SPexpr term) | Impact_pragma (IPexpr term)) -> (* to preserve the interpretation of the pragma *) get_zone_from_term ki term; (* to select the reachability of the pragma *) pragmas := { !pragmas with ctrl = Stmt.Set.add ki !pragmas.ctrl } | APragma (Slice_pragma SPctrl) -> (* to select the reachability of the pragma *) pragmas := { !pragmas with ctrl = Stmt.Set.add ki !pragmas.ctrl } | APragma (Slice_pragma SPstmt | Impact_pragma IPstmt) -> (* to preserve the effect of the statement *) pragmas := { !pragmas with stmt = Stmt.Set.add ki !pragmas.stmt} | AAssert (_behav,pred) -> (* to preserve the interpretation of the assertion *) get_zone_from_pred ki pred; | AInvariant (_behav,true,pred) -> (* loop invariant *) (* WARNING this is obsolete *) (* [JS 2010/09/02] TODO: so what is the right way to do? *) (* to preserve the interpretation of the loop invariant *) get_zone_from_pred (Extlib.the loop_body_opt) pred; | AInvariant (_behav,false,pred) -> (* code invariant *) (* to preserve the interpretation of the code invariant *) get_zone_from_pred ki pred; | AVariant (term,_) -> (* to preserve the interpretation of the variant *) get_zone_from_term (Extlib.the loop_body_opt) term; | APragma (Loop_pragma (Unroll_specs terms)) | APragma (Loop_pragma (Widen_hints terms)) | APragma (Loop_pragma (Widen_variables terms)) -> (* to select the declaration of the variables *) List.iter (fun term -> locals := Varinfo.Set.union (extract_locals_from_term term) !locals; labels := Logic_label.Set.union (extract_labels_from_term term) !labels) terms | AAllocation (_,FreeAllocAny) -> (); | AAllocation (_,FreeAlloc(f,a)) -> let get_zone x = get_zone_from_term (Extlib.the loop_body_opt) x.it_content in List.iter get_zone f ; List.iter get_zone a | AAssigns (_, WritesAny) -> () | AAssigns (_, Writes l) -> (* loop assigns *) let get_zone x = get_zone_from_term (Extlib.the loop_body_opt) x.it_content in List.iter (fun (zone,deps) -> get_zone zone; match deps with FromAny -> () | From l -> List.iter get_zone l) l | AStmtSpec _ -> (* TODO *) raise (NYI "[logic_interp] statement contract") (** Used by annotations entry points. *) let get_from_stmt_annots code_annot_filter ((ki, _kf) as stmt) = Extlib.may (fun caf -> let loop_body_opt = match ki.skind with | Loop(_, { bstmts = body :: _ }, _, _, _) -> Some body | _ -> None in Annotations.iter_code_annot (fun _ a -> if caf a then get_zone_from_annot a stmt loop_body_opt) ki) code_annot_filter (** Used by annotations entry points. *) let from_ki_annot annot ((ki, _kf) as stmt) = let real_ki = match ki.skind with Loop(_,{bstmts = loop_entry::_},_,_,_) -> Some loop_entry | _ -> None in get_zone_from_annot annot stmt real_ki (** Entry point to get the list of [ki] * [Locations.Zone.t] needed to evaluate the code annotations related to this [stmt]. *) let from_stmt_annot annot stmt = from_ki_annot annot stmt; get_annot_result () (** Entry point to get the list of [ki] * [Locations.Zone.t] needed to evaluate the code annotations related to this [stmt]. *) let from_stmt_annots code_annot_filter stmt = get_from_stmt_annots code_annot_filter stmt ; get_annot_result () (** Entry point to get the list of [ki] * [Locations.Zone.t] needed to evaluate the code annotations related to this [kf]. *) let from_func_annots iter_on_kf_stmt code_annot_filter kf = let from_stmt_annots ki = get_from_stmt_annots code_annot_filter (ki, kf) in iter_on_kf_stmt from_stmt_annots kf; get_annot_result () (** To quickly build a annotation filter *) let code_annot_filter annot ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var ~others = match annot.annot_content with | APragma (Slice_pragma _) -> slicing_pragma | AAssert _ -> (match Alarms.find annot with | None -> user_assert | Some _a -> threat) | AVariant _ -> loop_var | AInvariant(_behav,true,_pred) -> loop_inv | AInvariant(_,false,_) -> others | AAllocation _ -> others | AAssigns _ -> others | APragma (Loop_pragma _)| APragma (Impact_pragma _) -> others | AStmtSpec _ (* TODO: statement contract *) -> false end exception Prune let to_result_from_pred p = let visitor = object (_self) inherit Visitor.frama_c_inplace method vterm_lhost t = match t with | TResult _ -> raise Prune | _ -> DoChildren end in (try ignore(Visitor.visitFramacPredicateNamed visitor p); false with Prune -> true) let () = Db.Properties.Interp.code_annot := code_annot; Db.Properties.Interp.lval := lval; Db.Properties.Interp.expr := expr; Db.Properties.Interp.term_lval_to_lval := term_lval_to_lval; Db.Properties.Interp.term_to_exp := term_to_exp; Db.Properties.Interp.term_to_lval := term_to_lval; Db.Properties.Interp.term_offset_to_offset := term_offset_to_offset; Db.Properties.Interp.loc_to_lval := loc_to_lval; Db.Properties.Interp.loc_to_offset := loc_to_offset; Db.Properties.Interp.loc_to_exp := loc_to_exp; Db.Properties.Interp.identified_term_zone_to_loc := identified_term_zone_to_loc; Db.Properties.Interp.To_zone.code_annot_filter := To_zone.code_annot_filter; Db.Properties.Interp.To_zone.mk_ctx_func_contrat := To_zone.mk_ctx_func_contrat; Db.Properties.Interp.To_zone.mk_ctx_stmt_contrat := To_zone.mk_ctx_stmt_contrat; Db.Properties.Interp.To_zone.mk_ctx_stmt_annot := To_zone.mk_ctx_stmt_annot; Db.Properties.Interp.To_zone.from_term := To_zone.from_term; Db.Properties.Interp.To_zone.from_terms := To_zone.from_terms; Db.Properties.Interp.To_zone.from_pred := To_zone.from_pred; Db.Properties.Interp.To_zone.from_preds := To_zone.from_preds; Db.Properties.Interp.To_zone.from_stmt_annot := To_zone.from_stmt_annot; Db.Properties.Interp.To_zone.from_stmt_annots := To_zone.from_stmt_annots; Db.Properties.Interp.To_zone.from_func_annots := To_zone.from_func_annots; Db.Properties.Interp.to_result_from_pred := to_result_from_pred; (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/logic_interp.mli0000644000175000017500000000375112155630223021047 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Undocumented. All the interesting functions defined below are exported through Db.Interp. *) (* TODO: remove the module Properties from Db and export directly the functions from here. *) open Cil_types module To_zone : sig exception NYI of string val not_yet_implemented : string ref end exception Error of location * string (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/translate_lightweight.mli0000644000175000017500000000336512155630223022766 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Annotate files interpreting lightweight annotations. *) val interprate : Cil_types.file -> unit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/statuses_by_call.mli0000644000175000017500000000656612155630223021740 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Statuses of preconditions specialized at a given call-point. *) open Cil_types val setup_precondition_proxy: kernel_function -> Property.t -> unit (** [setup_precondition_proxy kf p] creates a new property for [p] at each syntactic call site of [kf], representing the status of [p] at this particular call. [p] is considered proven if and only if all its instances are themselves proven. *) val setup_all_preconditions_proxies: kernel_function -> unit (** [setup_all_preconditions_proxies kf] is equivalent to calling [setup_precondition_proxy] on all the requires of [kf]. *) val precondition_at_call: kernel_function -> Property.t -> stmt -> Property.t (** [property_at_call kf p stmt] returns the property corresponding to the status of the precondition [p] at the call [stmt]. If [stmt] is a call through a pointer, the property at this call is created automatically if needed. For direct calls, [setup_precondition_proxy] must have been called before. *) val all_call_preconditions_at: warn_missing:bool -> kernel_function -> stmt -> (Property.t * Property.t) list (** [all_call_preconditions_at create kf stmt] returns the copies of all the requires of [kf] for the call statement at [stmt]. The first property in the tuple is the require, the second the copy at the call point. If [warn_missing] is true and a copy has not yet been created an error is raised. *) val replace_call_precondition: Property.t -> stmt -> Property.t -> unit (** [replace_for_call pre stmt pre_at_call] states that [pre_at_call] is the property corresponding to the status of [pre] at call [stmt]. The previous property, if any, is removed. Beware that this may also remove some already proved statuses *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/property.ml0000644000175000017500000007060612155630223020107 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 type behavior_or_loop = Id_behavior of funbehavior | Id_code_annot of code_annotation type identified_complete = kernel_function * kinstr * string list type identified_disjoint = identified_complete type identified_code_annotation = kernel_function * stmt * code_annotation type identified_allocation = kernel_function * kinstr * behavior_or_loop * (identified_term list * identified_term list) type identified_assigns = kernel_function * kinstr * behavior_or_loop * identified_term from list type identified_from = kernel_function * kinstr * behavior_or_loop * (identified_term from (* * identified_term list *) ) type identified_decrease = kernel_function * kinstr * code_annotation option * term variant type identified_behavior = kernel_function * kinstr * funbehavior type predicate_kind = | PKRequires of funbehavior | PKAssumes of funbehavior | PKEnsures of funbehavior * termination_kind | PKTerminates let pretty_predicate_kind fmt = function | PKRequires _ -> Format.pp_print_string fmt "requires" | PKAssumes _ -> Format.pp_print_string fmt "assumes" | PKEnsures(_, tk) -> Format.pp_print_string fmt (match tk with | Normal -> "ensures" | Exits -> "exits" | Breaks -> "breaks" | Continues -> "continues" | Returns -> "returns") | PKTerminates -> Format.pp_print_string fmt "terminates" type identified_predicate = predicate_kind * kernel_function * kinstr * Cil_types.identified_predicate type program_point = Before | After type identified_reachable = kernel_function option * kinstr * program_point and identified_axiomatic = string * identified_property list and identified_lemma = string * logic_label list * string list * predicate named * location and identified_axiom = identified_lemma and identified_property = | IPPredicate of identified_predicate | IPAxiom of identified_axiom | IPAxiomatic of identified_axiomatic | IPLemma of identified_lemma | IPBehavior of identified_behavior | IPComplete of identified_complete | IPDisjoint of identified_disjoint | IPCodeAnnot of identified_code_annotation | IPAllocation of identified_allocation | IPAssigns of identified_assigns | IPFrom of identified_from | IPDecrease of identified_decrease | IPReachable of identified_reachable | IPOther of string * kernel_function option * kinstr let get_kinstr = function | IPPredicate (_,_,ki,_) | IPBehavior(_, ki, _) | IPComplete (_,ki,_) | IPDisjoint(_,ki,_) | IPAllocation (_,ki,_,_) | IPAssigns (_,ki,_,_) | IPFrom(_,ki,_,_) | IPReachable (_, ki, _) | IPDecrease (_,ki,_,_) -> ki | IPAxiom _ | IPAxiomatic _ | IPLemma _ -> Kglobal | IPOther(_,_,ki) -> ki | IPCodeAnnot (_,s,_) -> Kstmt s let get_kf = function | IPPredicate (_,kf,_,_) | IPBehavior(kf, _, _) | IPCodeAnnot (kf,_,_) | IPComplete (kf,_,_) | IPDisjoint(kf,_,_) | IPAllocation(kf,_,_,_) | IPAssigns(kf,_,_,_) | IPFrom(kf,_,_,_) | IPDecrease (kf,_,_,_) -> Some kf | IPAxiom _ | IPAxiomatic _ | IPLemma _ -> None | IPReachable (kf, _, _) | IPOther(_,kf,_) -> kf (* avoid dependency cycle property -> globals -> kernel_function. *) let kernel_function_location = Extlib.mk_fun "Property.kernel_function_location" let loc_of_kf_ki kf ki = match ki with | Kstmt s -> Cil_datatype.Stmt.loc s | Kglobal -> !kernel_function_location kf let rec location = function | IPPredicate (_,_,_,ip) -> ip.ip_loc | IPBehavior(kf,ki, _) | IPComplete (kf,ki,_) | IPDisjoint(kf,ki,_) -> loc_of_kf_ki kf ki | IPCodeAnnot (_,s,_) -> Cil_datatype.Stmt.loc s | IPAssigns(kf,ki,_,a) -> (match a with | [] -> loc_of_kf_ki kf ki | (t,_) :: _ -> t.it_content.term_loc) | IPAllocation(kf,ki,_,fa) -> (match fa with | [],[] -> loc_of_kf_ki kf ki | (t :: _),_ | _,(t :: _) -> t.it_content.term_loc) | IPFrom(_,_,_,(t,_)) -> t.it_content.term_loc | IPDecrease (_,_,_,(t,_)) -> t.term_loc | IPReachable(None, _, _) -> Cil_datatype.Location.unknown | IPReachable(Some kf, ki, _) -> loc_of_kf_ki kf ki | IPAxiom (_,_,_,_,loc) -> loc | IPAxiomatic (_,l) -> (match l with | [] -> Cil_datatype.Location.unknown | p :: _ -> location p) | IPLemma (_,_,_,_,loc) -> loc | IPOther(_,kf,ki) -> (match kf with | None -> Cil_datatype.Location.unknown | Some kf -> loc_of_kf_ki kf ki) let get_pk_behavior = function | PKRequires b | PKAssumes b | PKEnsures (b,_) -> Some b | PKTerminates -> None let get_behavior = function | IPPredicate (pk,_,_,_) -> get_pk_behavior pk | IPBehavior(_, _, b) -> Some b | IPAllocation(_,_,Id_behavior b,_) | IPAssigns(_,_,Id_behavior b,_) | IPFrom(_,_,Id_behavior b,_) -> Some b | IPAllocation(_,_,Id_code_annot _,_) | IPAssigns(_,_,Id_code_annot _,_) | IPFrom(_,_,Id_code_annot _,_) | IPAxiom _ | IPAxiomatic _ | IPLemma _ | IPCodeAnnot (_,_,_) | IPComplete (_,_,_) | IPDisjoint(_,_,_) | IPDecrease _ | IPReachable _ | IPOther _ -> None include Datatype.Make_with_collections (struct include Datatype.Serializable_undefined type t = identified_property let name = "Property.t" let reprs = [ IPAxiom ("",[],[],Logic_const.ptrue,Location.unknown) ] let mem_project = Datatype.never_any_project let equal_opt eq a b = match a,b with | None,None -> true | Some _,None | None,Some _ -> false | Some x , Some y -> eq x y let compare_opt cmp a b = match a,b with | None,None -> 0 | None,Some _ -> (-1) | Some _,None -> 1 | Some x,Some y -> cmp x y let pretty fmt = function | IPPredicate (kind,_,_,p) -> Format.fprintf fmt "%a@ %a" pretty_predicate_kind kind Cil_printer.pp_identified_predicate p | IPAxiom (s,_,_,_,_) -> Format.fprintf fmt "axiom@ %s" s | IPAxiomatic(s, _) -> Format.fprintf fmt "axiomatic@ %s" s | IPLemma (s,_,_,_,_) -> Format.fprintf fmt "lemma@ %s" s | IPBehavior(_kf, ki, b) -> if Cil.is_default_behavior b then Format.pp_print_string fmt "default behavior" else Format.fprintf fmt "behavior %s" b.b_name; (match ki with | Kstmt s -> Format.fprintf fmt " for statement %d" s.sid | Kglobal -> ()) | IPCodeAnnot(_, _, a) -> Cil_printer.pp_code_annotation fmt a | IPComplete(_, _, l) -> Format.fprintf fmt "complete@ %a" (Pretty_utils.pp_list ~sep:"," (fun fmt s -> Format.fprintf fmt "@ %s" s)) l | IPDisjoint(_, _, l) -> Format.fprintf fmt "disjoint@ %a" (Pretty_utils.pp_list ~sep:"," (fun fmt s -> Format.fprintf fmt " %s" s)) l | IPAllocation(_, _, _, (f,a)) -> Cil_printer.pp_allocation fmt (FreeAlloc(f,a)) | IPAssigns(_, _, _, l) -> Cil_printer.pp_assigns fmt (Writes l) | IPFrom (_,_,_, f) -> Cil_printer.pp_from fmt f | IPDecrease(_, _, None,v) -> Cil_printer.pp_decreases fmt v | IPDecrease(_, _, _,v) -> Cil_printer.pp_variant fmt v | IPReachable(None, Kstmt _, _) -> assert false | IPReachable(None, Kglobal, _) -> Format.fprintf fmt "reachability of entry point" | IPReachable(Some kf, Kglobal, _) -> Format.fprintf fmt "reachability of function %a" Kf.pretty kf | IPReachable(Some kf, Kstmt stmt, ba) -> Format.fprintf fmt "reachability %s stmt %a in %a" (match ba with Before -> "of" | After -> "post") Cil_datatype.Location.pretty_line (Cil_datatype.Stmt.loc stmt) Kf.pretty kf | IPOther(s,_,_) -> Format.pp_print_string fmt s let hash = let hash_bhv_loop = function | Id_behavior b -> (0, Hashtbl.hash b.b_name) | Id_code_annot ca -> (1, ca.annot_id) in function | IPPredicate (_,_,_,x) -> Hashtbl.hash (1, x.ip_id) | IPAxiom (x,_,_,_,_) -> Hashtbl.hash (2, (x:string)) | IPAxiomatic (x,_) -> Hashtbl.hash (3, (x:string)) | IPLemma (x,_,_,_,_) -> Hashtbl.hash (4, (x:string)) | IPCodeAnnot(_,_, ca) -> Hashtbl.hash (5, ca.annot_id) | IPComplete(f, ki, x) -> Hashtbl.hash (6, Kf.hash f, Kinstr.hash ki, (x:string list)) | IPDisjoint(f, ki, x) -> Hashtbl.hash(7, Kf.hash f, Kinstr.hash ki, (x:string list)) | IPAssigns(f, ki, b, _l) -> Hashtbl.hash (8, Kf.hash f, Kinstr.hash ki, hash_bhv_loop b) | IPFrom(kf,ki,b,(t,_)) -> Hashtbl.hash (9, Kf.hash kf, Kinstr.hash ki, hash_bhv_loop b, Identified_term.hash t) | IPDecrease(kf, ki, _ca, _v) -> (* At most one loop variant per statement anyway, no need to discriminate against the code annotation itself *) Hashtbl.hash (10, Kf.hash kf, Kinstr.hash ki) | IPBehavior(kf, s, b) -> Hashtbl.hash (11, Kf.hash kf, Kinstr.hash s, (b.b_name:string)) | IPReachable(kf, ki, ba) -> Hashtbl.hash(12, Extlib.may_map Kf.hash ~dft:0 kf, Kinstr.hash ki, Hashtbl.hash ba) | IPAllocation(f, ki, b, _fa) -> Hashtbl.hash (13, Kf.hash f, Kinstr.hash ki, hash_bhv_loop b) | IPOther(s,_,_) -> Hashtbl.hash (14, (s:string)) let equal p1 p2 = let eq_bhv (f1,ki1,b1) (f2,ki2,b2) = Kf.equal f1 f2 && Kinstr.equal ki1 ki2 && (match b1, b2 with | Id_code_annot ca1, Id_code_annot ca2 -> ca1.annot_id = ca2.annot_id | Id_behavior b1, Id_behavior b2 -> b1.b_name = b2.b_name | Id_code_annot _, Id_behavior _ | Id_behavior _, Id_code_annot _ -> false) in match p1, p2 with | IPPredicate (_,_,_,s1), IPPredicate (_,_,_,s2) -> s1.ip_id = s2.ip_id | IPAxiom (s1,_,_,_,_), IPAxiom (s2,_,_,_,_) | IPAxiomatic(s1, _), IPAxiomatic(s2, _) | IPLemma (s1,_,_,_,_), IPLemma (s2,_,_,_,_) -> Datatype.String.equal s1 s2 | IPCodeAnnot(_,_,ca1), IPCodeAnnot(_,_,ca2) -> ca1.annot_id = ca2.annot_id | IPComplete(f1, ki1, x1), IPComplete(f2, ki2, x2) | IPDisjoint(f1, ki1, x1), IPDisjoint(f2, ki2, x2) -> Kf.equal f1 f2 && Kinstr.equal ki1 ki2 && x1 = x2 | IPAllocation (f1, ki1, b1, _), IPAllocation (f2, ki2, b2, _) -> eq_bhv (f1,ki1,b1) (f2,ki2,b2) | IPAssigns (f1, ki1, b1, _), IPAssigns (f2, ki2, b2, _) -> eq_bhv (f1,ki1,b1) (f2,ki2,b2) | IPFrom (f1,ki1,b1,(t1,_)), IPFrom (f2, ki2,b2,(t2,_)) -> eq_bhv (f1,ki1,b1) (f2,ki2,b2) && t1.it_id = t2.it_id | IPDecrease(f1, ki1, _, _), IPDecrease(f2, ki2, _, _) -> Kf.equal f1 f2 && Kinstr.equal ki1 ki2 | IPReachable(kf1, ki1, ba1), IPReachable(kf2, ki2, ba2) -> Extlib.opt_equal Kf.equal kf1 kf2 && Kinstr.equal ki1 ki2 && ba1 = ba2 | IPBehavior(f1, k1, b1), IPBehavior(f2, k2, b2) -> Kf.equal f1 f2 && Kinstr.equal k1 k2 && Datatype.String.equal b1.b_name b2.b_name | IPOther(s1,kf1,ki1), IPOther(s2,kf2,ki2) -> Datatype.String.equal s1 s2 && Kinstr.equal ki1 ki2 && equal_opt Kf.equal kf1 kf2 | (IPPredicate _ | IPAxiom _ | IPAxiomatic _ | IPLemma _ | IPCodeAnnot _ | IPComplete _ | IPDisjoint _ | IPAssigns _ | IPFrom _ | IPDecrease _ | IPBehavior _ | IPReachable _ | IPAllocation _ | IPOther _ ), _ -> false let compare x y = let cmp_bhv (f1,ki1,b1) (f2,ki2,b2) = let n = Kf.compare f1 f2 in if n = 0 then let n = Kinstr.compare ki1 ki2 in if n = 0 then match b1, b2 with | Id_behavior b1, Id_behavior b2 -> Datatype.String.compare b1.b_name b2.b_name | Id_code_annot ca1, Id_code_annot ca2 -> Datatype.Int.compare ca1.annot_id ca2.annot_id | Id_behavior _, Id_code_annot _ -> -1 | Id_code_annot _, Id_behavior _ -> 1 else n else n in match x, y with | IPPredicate (_,_,_,s1), IPPredicate (_,_,_,s2) -> Datatype.Int.compare s1.ip_id s2.ip_id | IPCodeAnnot(_,_,ca1), IPCodeAnnot(_,_,ca2) -> Datatype.Int.compare ca1.annot_id ca2.annot_id | IPBehavior(f1, k1, b1), IPBehavior(f2, k2, b2) -> cmp_bhv (f1, k1, Id_behavior b1) (f2, k2, Id_behavior b2) | IPComplete(f1, ki1, x1), IPComplete(f2, ki2, x2) | IPDisjoint(f1, ki1, x1), IPDisjoint(f2, ki2, x2) -> let n = Kf.compare f1 f2 in if n = 0 then let n = Kinstr.compare ki1 ki2 in if n = 0 then Extlib.compare_basic x1 x2 else n else n | IPAssigns (f1, ki1, b1, _), IPAssigns (f2, ki2, b2, _) -> cmp_bhv (f1,ki1,b1) (f2,ki2,b2) | IPFrom (f1,ki1,b1,(t1,_)), IPFrom(f2,ki2,b2,(t2,_)) -> let n = cmp_bhv (f1,ki1,b1) (f2,ki2,b2) in if n = 0 then Identified_term.compare t1 t2 else n | IPDecrease(f1, ki1,_,_), IPDecrease(f2, ki2,_,_) -> let n = Kf.compare f1 f2 in if n = 0 then Kinstr.compare ki1 ki2 else n | IPReachable(kf1, ki1, ba1), IPReachable(kf2, ki2, ba2) -> let n = Extlib.opt_compare Kf.compare kf1 kf2 in if n = 0 then let n = Kinstr.compare ki1 ki2 in if n = 0 then Pervasives.compare ba1 ba2 else n else n | IPAxiom (s1,_,_,_,_), IPAxiom (s2,_,_,_,_) | IPAxiomatic(s1, _), IPAxiomatic(s2, _) | IPLemma (s1,_,_,_,_), IPLemma (s2,_,_,_,_) -> Datatype.String.compare s1 s2 | IPOther(s1,kf1,ki1), IPOther(s2,kf2,ki2) -> let s = Datatype.String.compare s1 s2 in if s <> 0 then s else let s = compare_opt Kf.compare kf1 kf2 in if s <> 0 then s else Kinstr.compare ki1 ki2 | IPAllocation (f1, ki1, b1, _), IPAllocation (f2, ki2, b2, _) -> cmp_bhv (f1,ki1,b1) (f2,ki2,b2) | (IPPredicate _ | IPCodeAnnot _ | IPBehavior _ | IPComplete _ | IPDisjoint _ | IPAssigns _ | IPFrom _ | IPDecrease _ | IPReachable _ | IPAxiom _ | IPAxiomatic _ | IPLemma _ | IPOther _ | IPAllocation _) as x, y -> let nb = function | IPPredicate _ -> 1 | IPAssigns (_, _, _, _) -> 2 | IPDecrease _ -> 3 | IPAxiom _ -> 4 | IPAxiomatic _ -> 5 | IPLemma _ -> 6 | IPCodeAnnot _ -> 7 | IPComplete (_, _, _) -> 8 | IPDisjoint (_, _, _) -> 9 | IPFrom _ -> 10 | IPBehavior _ -> 11 | IPReachable _ -> 12 | IPAllocation _ -> 13 | IPOther _ -> 14 in Datatype.Int.compare (nb x) (nb y) end) module Names = struct module NamesTbl = State_builder.Hashtbl(Datatype.String.Hashtbl)(Datatype.Int) (struct let name = "PropertyNames" let dependencies = [ ] let size = 97 end) module IndexTbl = State_builder.Hashtbl(Hashtbl)(Datatype.String) (struct let name = "PropertyIndex" let dependencies = [ Ast.self; NamesTbl.self; Globals.Functions.self ] let size = 97 end) let self = IndexTbl.self let kf_prefix kf = (Ast_info.Function.get_vi kf.fundec).vname ^ "_" let ident_names names = List.filter (function "" -> true | _ as n -> '\"' <> (String.get n 0) ) names let pp_names fmt l = let l = ident_names l in match l with [] -> () | _ -> Format.fprintf fmt "_%a" (Pretty_utils.pp_list ~sep:"_" Format.pp_print_string) l let pp_code_annot_names fmt ca = match ca.annot_content with | AAssert(for_bhv,named_pred) | AInvariant(for_bhv,_,named_pred) -> let pp_for_bhv fmt l = match l with [] -> () | _ -> Format.fprintf fmt "_for_%a" (Pretty_utils.pp_list ~sep:"_" Format.pp_print_string) l in Format.fprintf fmt "%a%a" pp_names named_pred.name pp_for_bhv for_bhv | AVariant(term, _) -> pp_names fmt term.term_name | _ -> () (* TODO : add some more names ? *) let behavior_prefix b = if Cil.is_default_behavior b then "" else b.b_name ^ "_" let variant_suffix = function | (_,Some s) -> s | _ -> "" let string_of_termination_kind = function Normal -> "post" | Exits -> "exit" | Breaks -> "break" | Continues -> "continue" | Returns -> "return" let ki_prefix = function | Kglobal -> "" | Kstmt _ -> "stmt_" let predicate_kind_txt pk ki = let name = match pk with | PKRequires b -> (behavior_prefix b) ^ "pre" | PKAssumes b -> (behavior_prefix b) ^ "assume" | PKEnsures (b, tk) -> (behavior_prefix b) ^ string_of_termination_kind tk | PKTerminates -> "term" in (ki_prefix ki) ^ name let id_prop_txt p = match p with | IPPredicate (pk,kf,ki,idp) -> Pretty_utils.sfprintf "%s%s%a" (kf_prefix kf) (predicate_kind_txt pk ki) pp_names idp.ip_name | IPCodeAnnot (kf,_, ca) -> let name = match ca.annot_content with | AAssert _ -> "assert" | AInvariant (_,true,_) -> "loop_inv" | AInvariant _ -> "inv" | APragma _ -> "pragma" | _ -> assert false in Pretty_utils.sfprintf "%s%s%a" (kf_prefix kf) name pp_code_annot_names ca | IPComplete (kf, ki, lb) -> Pretty_utils.sfprintf "%s%scomplete%a" (kf_prefix kf) (ki_prefix ki) pp_names lb | IPDisjoint (kf, ki, lb) -> Pretty_utils.sfprintf "%s%sdisjoint%a" (kf_prefix kf) (ki_prefix ki) pp_names lb | IPDecrease (kf,_,None, variant) -> (kf_prefix kf) ^ "decr" ^ (variant_suffix variant) | IPDecrease (kf,_,_,variant) -> (kf_prefix kf) ^ "loop_term" ^ (variant_suffix variant) | IPAxiom (name,_,_,named_pred,_) -> Pretty_utils.sfprintf "axiom_%s%a" name pp_names named_pred.name | IPAxiomatic(name, _) -> "axiomatic_" ^ name | IPLemma (name,_,_,named_pred,_) -> Pretty_utils.sfprintf "lemma_%s%a" name pp_names named_pred.name | IPAllocation (kf, ki, (Id_behavior b), _) -> (kf_prefix kf) ^ (ki_prefix ki) ^ (behavior_prefix b) ^ "alloc" | IPAllocation (kf, Kstmt _s, (Id_code_annot ca), _) -> Pretty_utils.sfprintf "%sloop_alloc%a" (kf_prefix kf) pp_code_annot_names ca | IPAllocation _ -> assert false | IPAssigns (kf, ki, (Id_behavior b), _) -> (kf_prefix kf) ^ (ki_prefix ki) ^ (behavior_prefix b) ^ "assign" | IPAssigns (kf, Kstmt _s, (Id_code_annot ca), _) -> Pretty_utils.sfprintf "%sloop_assign%a" (kf_prefix kf) pp_code_annot_names ca | IPAssigns _ -> assert false | IPFrom (_, _, _, (out,_)) -> "from_id_"^(string_of_int (out.it_id)) | IPReachable _ -> "reachable_stmt" | IPBehavior(_, _, b) -> b.b_name | IPOther(s,Some kf,ki) -> (kf_prefix kf) ^ (ki_prefix ki) ^ s | IPOther(s,None,ki) -> (ki_prefix ki) ^ s (** function used to normanize basename *) let normalize_basename s = let is_valid_id = ref true and is_valid_char_id = function | 'a'..'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> true | _ -> false and is_numeric = function | '0'..'9' -> true | _ -> false in String.iter (fun c -> if not (is_valid_char_id c) then is_valid_id := false) s ; let s = if !is_valid_id then s else begin let sn = String.copy s and i = ref 0 in String.iter (fun c -> if not (is_valid_char_id c) then String.set sn !i '_' ; i := succ !i) s ; sn end in if s = "" then "property" else if is_numeric (String.get s 0) then "property_" ^ s else s (** returns the name that should be returned by the function [get_prop_name_id] if the given property has [name] as basename. That name is reserved so that [get_prop_name_id prop] can never return an identical name. *) let reserve_name_id basename = let basename = normalize_basename basename in try let speed_up_start = NamesTbl.find basename in (* this basename is already reserved *) let n,unique_name = Extlib.make_unique_name NamesTbl.mem ~sep:"_" ~start:speed_up_start basename in NamesTbl.replace basename (succ n) ; (* to speed up Extlib.make_unique_name for next time *) unique_name with Not_found -> (* first time that basename is reserved *) NamesTbl.add basename 2 ; basename (** returns the basename of the property. *) let get_prop_basename ip = normalize_basename (id_prop_txt ip) (** returns a unique name identifying the property. This name is built from the basename of the property. *) let get_prop_name_id ip = try IndexTbl.find ip with Not_found -> (* first time we are asking for a name for that [ip] *) let basename = get_prop_basename ip in let unique_name = reserve_name_id basename in IndexTbl.add ip unique_name ; unique_name (* (** force computation of the unique name identifying the property *) let make_prop_name_id ip = ignore (get_prop_name_id ip) let remove_prop_name_id ip = try ignore (IndexTbl.find ip); IndexTbl.remove ip with Not_found -> () *) end let ip_other s kf ki = IPOther(s,kf,ki) let ip_reachable_stmt kf ki = IPReachable(Some kf, Kstmt ki, Before) let ip_reachable_ppt p = let kf = get_kf p in let ki = get_kinstr p in let ba = match p with | IPPredicate((PKRequires _ | PKAssumes _ | PKTerminates), _, _, _) | IPAxiom _ | IPAxiomatic _ | IPLemma _ | IPComplete _ | IPDisjoint _ | IPCodeAnnot _ | IPAllocation _ | IPDecrease _ | IPReachable _ | IPOther _ -> Before | IPPredicate(PKEnsures _, _, _, _) | IPAssigns _ | IPFrom _ | IPBehavior _ -> After in IPReachable(kf, ki, ba) let ip_of_ensures kf st b (k,p) = IPPredicate (PKEnsures(b,k),kf,st,p) let ip_ensures_of_behavior kf st b = List.map (ip_of_ensures kf st b) b.b_post_cond let ip_of_allocation kf st loc = function | FreeAllocAny -> None | FreeAlloc(f,a) -> Some (IPAllocation (kf,st,loc,(f,a))) let ip_allocation_of_behavior kf st b = ip_of_allocation kf st (Id_behavior b) b.b_allocation let ip_of_assigns kf st loc = function | WritesAny -> None | Writes [(a,_)] when Logic_utils.is_result a.it_content -> (* We're only assigning the result (with dependencies), but no global variables, this amounts to \nothing. *) Some (IPAssigns (kf, st, loc, [])) | Writes a -> Some (IPAssigns (kf,st,loc,a)) let ip_assigns_of_behavior kf st b = ip_of_assigns kf st (Id_behavior b) b.b_assigns let ip_of_from kf st loc from = IPFrom (kf,st, loc, from) let ip_from_of_behavior kf st b = match b.b_assigns with | WritesAny -> [] | Writes l -> let treat_from acc (out, froms) = match froms with | FromAny -> acc | From _ -> let ip = ip_of_from kf st (Id_behavior b) (out, froms) in ip :: acc in List.fold_left treat_from [] l let ip_allocation_of_code_annot kf st ca = match ca.annot_content with | AAllocation (_,a) -> ip_of_allocation kf st (Id_code_annot ca) a | _ -> None let ip_assigns_of_code_annot kf st ca = match ca.annot_content with | AAssigns (_,a) -> ip_of_assigns kf st (Id_code_annot ca) a | _ -> None let ip_from_of_code_annot kf st ca = match ca.annot_content with | AAssigns(_,WritesAny) -> [] | AAssigns (_,Writes l) -> let treat_from acc (out, froms) = match froms with FromAny -> acc | From _ -> let ip = ip_of_from kf st (Id_code_annot ca) (out, froms) in ip::acc in List.fold_left treat_from [] l | _ -> [] let ip_post_cond_of_behavior kf st b = ip_ensures_of_behavior kf st b @ (Extlib.list_of_opt (ip_assigns_of_behavior kf st b)) @ ip_from_of_behavior kf st b @ (Extlib.list_of_opt (ip_allocation_of_behavior kf st b)) let ip_of_behavior kf s b = IPBehavior(kf, s, b) let ip_of_requires kf st b p = IPPredicate (PKRequires b,kf,st,p) let ip_requires_of_behavior kf st b = List.map (ip_of_requires kf st b) b.b_requires let ip_of_assumes kf st b p = IPPredicate (PKAssumes b,kf,st,p) let ip_assumes_of_behavior kf st b = List.map (ip_of_assumes kf st b) b.b_assumes let ip_all_of_behavior kf st b = ip_of_behavior kf st b :: ip_requires_of_behavior kf st b @ ip_assumes_of_behavior kf st b @ ip_post_cond_of_behavior kf st b let ip_of_complete kf st bhvs = IPComplete(kf,st,bhvs) let ip_complete_of_spec kf st s = List.map (ip_of_complete kf st) s.spec_complete_behaviors let ip_of_disjoint kf st bhvs = IPDisjoint(kf,st,bhvs) let ip_disjoint_of_spec kf st s = List.map (ip_of_disjoint kf st) s.spec_disjoint_behaviors let ip_of_terminates kf st p = IPPredicate(PKTerminates,kf,st,p) let ip_terminates_of_spec kf st s = match s.spec_terminates with | None -> None | Some p -> Some (ip_of_terminates kf st p) let ip_of_decreases kf st d = IPDecrease(kf,st,None,d) let ip_decreases_of_spec kf st s = Extlib.opt_map (ip_of_decreases kf st) s.spec_variant let ip_post_cond_of_spec kf st s = List.concat (List.map (ip_post_cond_of_behavior kf st) s.spec_behavior) let ip_of_spec kf st s = List.concat (List.map (ip_all_of_behavior kf st) s.spec_behavior) @ ip_complete_of_spec kf st s @ ip_disjoint_of_spec kf st s @ (Extlib.list_of_opt (ip_terminates_of_spec kf st s)) @ (Extlib.list_of_opt (ip_decreases_of_spec kf st s)) let ip_axiom s = IPAxiom s let ip_lemma s = IPLemma s let ip_of_code_annot kf ki ca = let st = Kstmt ki in match ca.annot_content with | AAssert _ | AInvariant _ -> [ IPCodeAnnot(kf, ki, ca) ] | AStmtSpec (_bhv,s) -> (* [JS 2011/08/29] seem to be incorrect since it does not use [bhv] while [ip_of_spec] keeps all behaviors *) ip_of_spec kf st s | AVariant t -> [ IPDecrease (kf,st,(Some ca),t) ] | AAllocation _ -> Extlib.list_of_opt (ip_allocation_of_code_annot kf st ca) @ ip_from_of_code_annot kf st ca | AAssigns _ -> Extlib.list_of_opt (ip_assigns_of_code_annot kf st ca) @ ip_from_of_code_annot kf st ca | APragma p when Logic_utils.is_property_pragma p -> [ IPCodeAnnot (kf,ki,ca) ] | APragma _ -> [] let ip_of_code_annot_single kf ki ca = match ip_of_code_annot kf ki ca with | [] -> (* [JS 2011/06/07] using Kernel.error here seems very strange. Actually it is incorrect in case of pragma which is not a property (see function ip_of_code_annot above. *) Kernel.error "@[cannot find a property to extract from code annotation@\n%a@]" Cil_printer.pp_code_annotation ca; raise (Invalid_argument "ip_of_code_annot_single") | [ ip ] -> ip | ip :: _ -> Kernel.warning "@[choosing one of multiple properties associated \ to code annotation@\n%a@]" Cil_printer.pp_code_annotation ca; ip (* Must ensure that the first property is the best one in order to represent the annotation (see ip_of_global_annotation_single) *) let ip_of_global_annotation a = let once = true in let rec aux acc = function | Daxiomatic(name, l, _) -> let ppts = List.fold_left aux [] l in IPAxiomatic(name, ppts) :: (ppts @ acc) | Dlemma(name, true, a, b, c, d) -> ip_axiom (name,a,b,c,d) :: acc | Dlemma(name, false, a, b, c, d) -> ip_lemma (name,a,b,c,d) :: acc | Dinvariant(l, _) -> (* TODO *) Kernel.warning ~once "ignoring status of global invariant `%s'" l.l_var_info.lv_name; acc | Dtype_annot(l, _) -> (* TODO *) Kernel.warning ~once "ignoring status of type invariant `%s'" l.l_var_info.lv_name; acc | Dcustom_annot(_c, _n, _) -> (* TODO *) Kernel.warning ~once "ignoring status of custom annotation"; acc | Dmodel_annot _ | Dfun_or_pred _ | Dvolatile _ | Dtype _ -> (* no associated status for these annotations *) acc in aux [] a let ip_of_global_annotation_single a = match ip_of_global_annotation a with | [] -> None | ip :: _ -> (* the first one is the good one, see ip_of_global_annotation *) Some ip (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/description.ml0000644000175000017500000003410612155630223020541 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Property open Cil_types let pp_loc = Cil_datatype.Location.pretty_long let pp_kloc kloc fmt loc = if kloc then Format.fprintf fmt " (%a)" pp_loc loc else () let pp_opt doit pp fmt x = if doit then pp fmt x let goto_stmt stmt = let rec goto_label = function | [] -> Printf.sprintf "s%04d" stmt.sid | Label(a,_,true)::_ -> a | _::labels -> goto_label labels in goto_label stmt.labels let rec stmt_labels = function | Label(a,_,true) :: ls -> a :: stmt_labels ls | Label _ :: ls -> stmt_labels ls | Case(e,_) :: ls -> let cvalue = (Cil.constFold true e) in Pretty_utils.sfprintf "case %a" Printer.pp_exp cvalue :: stmt_labels ls | Default _ :: ls -> "default" :: stmt_labels ls | [] -> [] let pp_labels fmt stmt = match stmt_labels stmt.labels with | [] -> () | ls -> Format.fprintf fmt " '%s'" (String.concat "," ls) let pp_idpred kloc fmt idpred = if idpred.ip_name <> [] then Format.fprintf fmt " '%s'" (String.concat "," idpred.ip_name) else pp_kloc kloc fmt idpred.ip_loc let pp_allocation kloc fmt (allocation:identified_term list) = if allocation = [] then Format.fprintf fmt "nothing" else let names = List.fold_left (fun names x -> names @ x.it_content.term_name) [] allocation in match names with | [] -> if kloc then let x = List.hd allocation in Format.fprintf fmt "(%a)" pp_loc x.it_content.term_loc else Format.fprintf fmt "..." | _ -> Format.fprintf fmt "'%s'" (String.concat "," names) let pp_region kloc fmt (region:identified_term from list) = if region = [] then Format.fprintf fmt "nothing" else let names = List.fold_left (fun names (x,_) -> names @ x.it_content.term_name) [] region in match names with | [] -> if kloc then let x = fst (List.hd region) in Format.fprintf fmt "(%a)" pp_loc x.it_content.term_loc else Format.fprintf fmt "..." | _ -> Format.fprintf fmt "'%s'" (String.concat "," names) let pp_bhv fmt bhv = if not (Cil.is_default_behavior bhv) then Format.fprintf fmt " for '%s'" bhv.b_name let pp_bhvs fmt = function | [] -> () | b::bs -> Format.fprintf fmt " @['%s'" b ; List.iter (fun b -> Format.fprintf fmt ",@ '%s'" b) bs ; Format.fprintf fmt "@]" let pp_for fmt = function | [] -> () | bs -> Format.fprintf fmt " for '%s'" (String.concat "," bs) let pp_named fmt nx = if nx.name <> [] then Format.fprintf fmt " '%s'" (String.concat "," nx.name) let pp_code_annot fmt ca = match ca.annot_content with | AAssert(bs,np) -> Format.fprintf fmt "assertion%a%a" pp_for bs pp_named np | AInvariant(bs,_,np) -> Format.fprintf fmt "invariant%a%a" pp_for bs pp_named np | AAssigns(bs,_) -> Format.fprintf fmt "assigns%a" pp_for bs | AAllocation(bs,_) -> Format.fprintf fmt "allocates_frees%a" pp_for bs | APragma _ -> Format.pp_print_string fmt "pragma" | AVariant _ -> Format.pp_print_string fmt "variant" | AStmtSpec _ -> Format.pp_print_string fmt "block contract" let pp_stmt kloc fmt stmt = match stmt.skind with | Instr (Call(_,{enode=Lval(Var v,_)},_,loc)) -> Format.fprintf fmt "call '%s'%a" v.vname (pp_kloc kloc) loc | Instr (Set(_,_,loc)|Call(_,_,_,loc)) -> Format.fprintf fmt "instruction%a" (pp_kloc kloc) loc | Instr (Asm(_,_,_,_,_,loc)) -> Format.fprintf fmt "assembly%a%a" pp_labels stmt (pp_kloc kloc) loc | Instr (Skip(_,loc)) -> Format.fprintf fmt "program point%a%a" pp_labels stmt (pp_kloc kloc) (loc,loc) | Instr (Code_annot(ca,loc)) -> Format.fprintf fmt "%a%a" pp_code_annot ca (pp_kloc kloc) loc | Return(_,loc) -> Format.fprintf fmt "return%a" (pp_kloc kloc) loc | Goto(s,loc) -> Format.fprintf fmt "goto %s%a" (goto_stmt !s) (pp_kloc kloc) loc | Break loc -> Format.fprintf fmt "break%a" (pp_kloc kloc) loc | Continue loc -> Format.fprintf fmt "continue%a" (pp_kloc kloc) loc | If(_,_,_,loc) -> Format.fprintf fmt "if-then-else%a" (pp_kloc kloc) loc | Switch(_,_,_,loc) -> Format.fprintf fmt "switch%a" (pp_kloc kloc) loc | Loop(_,_,loc,_,_) -> Format.fprintf fmt "loop%a" (pp_kloc kloc) loc | Block _ -> Format.fprintf fmt "block%a" pp_labels stmt | UnspecifiedSequence _ -> Format.fprintf fmt "instruction%a" pp_labels stmt | TryFinally(_,_,loc) | TryExcept(_,_,_,loc) -> Format.fprintf fmt "try-catch%a" (pp_kloc kloc) loc let pp_kinstr kloc fmt = function | Kglobal -> () | Kstmt s -> Format.fprintf fmt " at %a" (pp_stmt kloc) s let pp_predicate fmt = function | PKRequires bhv -> Format.fprintf fmt "Pre-condition%a" pp_bhv bhv | PKAssumes bhv -> Format.fprintf fmt "Assumption%a" pp_bhv bhv | PKEnsures(bhv,Normal) -> Format.fprintf fmt "Post-condition%a" pp_bhv bhv | PKEnsures(bhv,Breaks) -> Format.fprintf fmt "Breaking-condition%a" pp_bhv bhv | PKEnsures(bhv,Continues) -> Format.fprintf fmt "Continue-condition%a" pp_bhv bhv | PKEnsures(bhv,Returns) -> Format.fprintf fmt "Return-condition%a" pp_bhv bhv | PKEnsures(bhv,Exits) -> Format.fprintf fmt "Exit-condition%a" pp_bhv bhv | PKTerminates -> Format.fprintf fmt "Termination-condition" let pp_context kfopt fmt = function | None -> () | Some kf -> match kfopt with | `Always -> Format.fprintf fmt " in '%s'" (Kernel_function.get_name kf) | `Never -> () | `Context kf0 -> if not (Kernel_function.equal kf0 kf) then Format.fprintf fmt " of '%s'" (Kernel_function.get_name kf) let pp_prop kfopt kiopt kloc fmt = function | IPAxiom (s,_,_,_,_) -> Format.fprintf fmt "Axiom '%s'" s | IPLemma (s,_,_,_,_) -> Format.fprintf fmt "Lemma '%s'" s | IPAxiomatic (s,_) -> Format.fprintf fmt "Axiomatic '%s'" s | IPOther(s,kf,ki) -> Format.fprintf fmt "%s%a%a" s (pp_context kfopt) kf (pp_opt kiopt (pp_kinstr kloc)) ki | IPPredicate(kind,kf,Kglobal,idpred) -> Format.fprintf fmt "%a%a%a" pp_predicate kind (pp_idpred kloc) idpred (pp_context kfopt) (Some kf) | IPPredicate(kind,_,ki,idpred) -> Format.fprintf fmt "%a%a%a" pp_predicate kind (pp_idpred kloc) idpred (pp_kinstr kloc) ki | IPBehavior(_,ki,bhv) -> if Cil.is_default_behavior bhv then Format.fprintf fmt "Default behavior%a" (pp_opt kiopt (pp_kinstr kloc)) ki else Format.fprintf fmt "Behavior '%s'%a" bhv.b_name (pp_opt kiopt (pp_kinstr kloc)) ki | IPComplete(_,ki,bs) -> Format.fprintf fmt "Complete behaviors%a%a" pp_bhvs bs (pp_opt kiopt (pp_kinstr kloc)) ki | IPDisjoint(_,ki,bs) -> Format.fprintf fmt "Disjoint behaviors%a%a" pp_bhvs bs (pp_opt kiopt (pp_kinstr kloc)) ki | IPCodeAnnot(_,_,{annot_content=AAssert(bs,np)}) -> Format.fprintf fmt "Assertion%a%a%a" pp_for bs pp_named np (pp_kloc kloc) np.loc | IPCodeAnnot(_,_,{annot_content=AInvariant(bs,_,np)}) -> Format.fprintf fmt "Invariant%a%a%a" pp_for bs pp_named np (pp_kloc kloc) np.loc | IPCodeAnnot(_,stmt,_) -> Format.fprintf fmt "Annotation %a" (pp_stmt kloc) stmt | IPAllocation(kf,Kglobal,Id_behavior bhv,(frees,allocates)) -> Format.fprintf fmt "Frees/Allocates%a %a/%a %a" pp_bhv bhv (pp_allocation kloc) frees (pp_allocation kloc) allocates (pp_context kfopt) (Some kf) | IPAssigns(kf,Kglobal,Id_behavior bhv,region) -> Format.fprintf fmt "Assigns%a %a%a" pp_bhv bhv (pp_region kloc) region (pp_context kfopt) (Some kf) | IPFrom (kf,Kglobal,Id_behavior bhv,depend) -> Format.fprintf fmt "Froms%a %a%a" pp_bhv bhv (pp_region kloc) [depend] (pp_context kfopt) (Some kf) | IPAllocation(_,ki,Id_behavior bhv,(frees,allocates)) -> Format.fprintf fmt "Frees/Allocates%a %a/%a %a" pp_bhv bhv (pp_allocation kloc) frees (pp_allocation kloc) allocates (pp_opt kiopt (pp_kinstr kloc)) ki | IPAssigns(_,ki,Id_behavior bhv,region) -> Format.fprintf fmt "Assigns%a %a%a" pp_bhv bhv (pp_region kloc) region (pp_opt kiopt (pp_kinstr kloc)) ki | IPFrom (_,ki,Id_behavior bhv,depend) -> Format.fprintf fmt "Froms%a %a%a" pp_bhv bhv (pp_region kloc) [depend] (pp_opt kiopt (pp_kinstr kloc)) ki | IPAllocation(_,_,Id_code_annot _,(frees,allocates)) -> Format.fprintf fmt "Loop frees%a Loop allocates%a" (pp_allocation kloc) frees (pp_allocation kloc) allocates | IPAssigns(_,_,Id_code_annot _,region) -> Format.fprintf fmt "Loop assigns %a" (pp_region kloc) region | IPFrom(_,_,Id_code_annot _,depend) -> Format.fprintf fmt "Loop froms %a" (pp_region kloc) [depend] | IPDecrease(_,Kglobal,_,_) -> Format.fprintf fmt "Recursion variant" | IPDecrease(_,Kstmt stmt,_,_) -> Format.fprintf fmt "Loop variant at %a" (pp_stmt kloc) stmt | IPReachable (None, Kglobal, Before) -> (* print "Unreachable": it seems that it is what the user want to see *) Format.fprintf fmt "Unreachable entry point" | IPReachable (None, Kglobal, After) | IPReachable (None, Kstmt _, _) -> assert false | IPReachable (Some _, Kstmt stmt, ba) -> (* print "Unreachable": it seems that it is what the user want to see *) Format.fprintf fmt "Unreachable %a%s" (pp_stmt kloc) stmt (match ba with Before -> "" | After -> " (after it)") | IPReachable (Some kf, Kglobal, _) -> (* print "Unreachable": it seems that it is what the user want to see *) Format.fprintf fmt "Unreachable %a" Kernel_function.pretty kf type kf = [ `Always | `Never | `Context of kernel_function ] let pp_property = pp_prop `Always true true let pp_localized ~kf ~ki ~kloc = pp_prop kf ki kloc let pp_local = pp_prop `Never false false (* -------------------------------------------------------------------------- *) (* --- Property Comparison --- *) (* -------------------------------------------------------------------------- *) type order = | I of int | S of string | F of Kernel_function.t | K of kinstr | B of funbehavior let cmp_order a b = match a , b with | I a , I b -> Pervasives.compare a b | I _ , _ -> (-1) | _ , I _ -> 1 | S a , S b -> String.compare a b | S _ , _ -> (-1) | _ , S _ -> 1 | F f , F g -> Kernel_function.compare f g | F _ , _ -> (-1) | _ , F _ -> 1 | B a , B b -> begin match Cil.is_default_behavior a , Cil.is_default_behavior b with | true , true -> 0 | true , false -> (-1) | false , true -> 1 | false , false -> String.compare a.b_name b.b_name end | B _ , _ -> (-1) | _ , B _ -> 1 | K a , K b -> Cil_datatype.Kinstr.compare a b let rec cmp xs ys = match xs,ys with | [],[] -> 0 | [],_ -> (-1) | _,[] -> 1 | x::xs,y::ys -> let c = cmp_order x y in if c<>0 then c else cmp xs ys let kind_order = function | PKRequires bhv -> [B bhv;I 1] | PKAssumes bhv -> [B bhv; I 2] | PKEnsures(bhv,Normal) -> [B bhv;I 3] | PKEnsures(bhv,Breaks) -> [B bhv;I 4] | PKEnsures(bhv,Continues) -> [B bhv;I 5] | PKEnsures(bhv,Returns) -> [B bhv;I 6] | PKEnsures(bhv,Exits) -> [B bhv;I 7] | PKTerminates -> [I 8] let named_order xs = List.map (fun x -> S x) xs let for_order k = function | [] -> [I k] | bs -> I (succ k) :: named_order bs let annot_order = function | {annot_content=AAssert(bs,np)} -> for_order 0 bs @ named_order np.name | {annot_content=AInvariant(bs,_,np)} -> for_order 2 bs @ named_order np.name | _ -> [I 4] let loop_order = function | Id_behavior b -> [B b] | Id_code_annot _ -> [] let ip_order = function | IPAxiomatic(a,_) -> [I 0;S a] | IPAxiom(a,_,_,_,_) | IPLemma(a,_,_,_,_) -> [I 1;S a] | IPOther(s,None,ki) -> [I 3;K ki;S s] | IPOther(s,Some kf,ki) -> [I 4;F kf;K ki;S s] | IPBehavior(kf,ki,bhv) -> [I 5;F kf;K ki;B bhv] | IPComplete(kf,ki,bs) -> [I 6;F kf;K ki] @ for_order 0 bs | IPDisjoint(kf,ki,bs) -> [I 7;F kf;K ki] @ for_order 0 bs | IPPredicate(kind,kf,ki,_) -> [I 8;F kf;K ki] @ kind_order kind | IPCodeAnnot(kf,st,a) -> [I 9;F kf;K(Kstmt st)] @ annot_order a | IPAllocation(kf,ki,ib,_) -> [I 10;F kf;K ki] @ loop_order ib | IPAssigns(kf,ki,ib,_) -> [I 11;F kf;K ki] @ loop_order ib | IPFrom (kf,ki,ib,_) -> [I 12;F kf;K ki] @ loop_order ib | IPDecrease(kf,ki,None,_) -> [I 13;F kf;K ki] | IPDecrease(kf,ki,Some a,_) -> [I 14;F kf;K ki] @ annot_order a | IPReachable(None,_,_) -> [I 15] | IPReachable(Some kf,ki,_) -> [I 16;F kf;K ki] let pp_compare p q = cmp (ip_order p) (ip_order q) let full_compare p q = let cmp = pp_compare p q in if cmp<>0 then cmp else Property.compare p q (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/description.mli0000644000175000017500000000611012155630223020704 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Describe items of Source and Properties. @since Nitrogen-20111001 *) open Cil_types val pp_stmt : bool -> Format.formatter -> stmt -> unit (** prints "" or " ()" *) val pp_kinstr : bool -> Format.formatter -> kinstr -> unit (** prints nothing for global, or " at " *) val pp_idpred : bool -> Format.formatter -> identified_predicate -> unit (** prints the "''" or the "()" of the predicate *) val pp_region : bool -> Format.formatter -> identified_term from list -> unit (** prints message "nothing" or the "''" or the "()" of the relation *) val pp_for : Format.formatter -> string list -> unit (** prints nothing or " for 'b1,...,bn'" *) val pp_bhv : Format.formatter -> funbehavior -> unit (** prints nothing for default behavior, and " for 'b'" otherwize *) val pp_property : Format.formatter -> Property.t -> unit (** prints an identified property *) type kf = [ `Always | `Never | `Context of kernel_function ] val pp_localized : kf:kf -> ki:bool -> kloc:bool -> Format.formatter -> Property.t -> unit (** prints more-or-less localized property *) val pp_local : Format.formatter -> Property.t -> unit (** completely local printer *) val pp_compare : Property.t -> Property.t -> int (** Computes a partial order compatible with pretty printing *) val full_compare : Property.t -> Property.t -> int (** Completes [pp_compare] with [Property.compare] *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/allocates.mli0000644000175000017500000000411412155630223020332 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Generation of default [allocates \nothing] clauses. *) val add_allocates_nothing_funspec: Cil_types.kernel_function -> unit (** Adds [allocates \nothing] to the default behavior of the function if it does not have and allocation clause yet. *) class vis_add_loop_allocates: Visitor.frama_c_inplace (** This class adds [loop allocates] clauses to all the statements it visits. *) val add_allocates_nothing: unit -> unit (** Add default [allocates \nothing] clauses to all functions and loops. *) frama-c-Fluorine-20130601/src/logic/infer_annotations.mli0000644000175000017500000000337612155630223022114 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Generation of possible assigns from the C prototype of a function. *) val assigns_from_prototype: Kernel_function.t -> Cil_types.identified_term Cil_types.from list frama-c-Fluorine-20130601/src/logic/translate_lightweight.ml0000644000175000017500000002020512155630223022605 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 let mkterm tnode ty loc = { term_node = tnode; term_loc = loc; term_type = ty; term_name = [] } let term_of_var v= Ast_info.variable_term v.vdecl (cvar_to_lvar v) class annotateFunFromDeclspec = let recover_from_attr_param params attrparam = let rec aux = function | AInt i -> Ast_info.constant_term Cil_datatype.Location.unknown i | AUnOp(Neg,AInt i) -> Ast_info.constant_term Cil_datatype.Location.unknown (Integer.neg i) | AStr s | ACons(s,[]) -> begin try let v = List.find (fun v -> v.vname = s) params in term_of_var v with Not_found -> failwith "No recovery" end | ABinOp(bop,attr1,attr2) -> mkterm (TBinOp(bop,aux attr1,aux attr2)) Linteger Cil_datatype.Location.unknown | ACons _ | ASizeOf _ | ASizeOfE _ | AAlignOf _ | AAlignOfE _ | AUnOp _ | ADot _ | AStar _ | AAddrOf _ | AIndex _ | AQuestion _ -> failwith "No recovery" (* Not yet supported *) in aux attrparam in let recover_from_attribute params attr = match attr with | Attr(name,attrparams) -> begin try Some(name, List.map (recover_from_attr_param params) attrparams) with Failure "No recovery" -> None end | AttrAnnot _ -> None in (* Add precondition based on declspec on parameters *) let annotate_var params acc v = List.fold_left (fun acc attr -> match recover_from_attribute params attr with | None -> acc | Some(name,args) -> if name = "valid" || name = "valid_range" then let t1 = term_of_var v in let t1 = Logic_utils.mk_logic_pointer_or_StartOf t1 in let p = match name with | "valid" -> assert (args = []); Logic_const.pvalid (Logic_const.here_label,t1) | "valid_range" -> let args = match args with | [ b1; b2 ] -> (Logic_const.here_label,t1,b1,b2) | _ -> assert false in Logic_const.pvalid_range args | _ -> assert false in let app = Logic_const.new_predicate p in app :: acc else try let p = match Logic_env.find_all_logic_functions name with | [i] -> i | _ -> raise Not_found in assert (List.length p.l_profile = List.length(args) + 1); assert (List.length p.l_labels <= 1); let labels = match p.l_labels with | [] -> [] | [l] -> [ l, Logic_const.here_label ] | _ -> assert false in let args = term_of_var v :: args in let app = Logic_const.new_predicate (Logic_const.unamed (Papp(p,labels,args))) in app :: acc with Not_found -> acc ) acc (typeAttrs v.vtype) in let annotate_fun v = let kf = Globals.Functions.get v in let params = Globals.Functions.get_params kf in let requires = List.fold_left (annotate_var params) [] params in if requires <> [] then (* add [requires] to [b_requires] of default behavior *) let return_ty = getReturnType v.vtype in let loc = v.vdecl in Annotations.add_requires Emitter.end_user kf Cil.default_behavior_name requires; (* modify 'ensures' clauses *) let insert_spec behavior = let ens = List.fold_left (fun acc attr -> match recover_from_attribute params attr with | None -> acc | Some(name,args) -> if name = "valid" || name = "valid_range" then let t1 = Logic_const.tresult ~loc return_ty in let t1 = Logic_utils.mk_logic_pointer_or_StartOf t1 in let p = match name with | "valid" -> assert (args = []); Logic_const.pvalid (Logic_const.here_label,t1) | "valid_range" -> let args = match args with | [ b1; b2 ] -> (Logic_const.here_label,t1,b1,b2) | _ -> assert false in Logic_const.pvalid_range args | _ -> assert false in let app = Logic_const.new_predicate p in (Normal, app) :: acc else try let p = match Logic_env.find_all_logic_functions name with | [i] -> i | _ -> assert false in assert (List.length p.l_profile = List.length args + 1); assert (List.length p.l_labels <= 1); let res = Logic_const.tresult ~loc return_ty in let args = res :: args in let app = Logic_const.new_predicate (Logic_const.unamed (Papp(p,[],args))) in (Normal,app) :: acc with Not_found -> acc) behavior.b_post_cond (typeAttrs return_ty) in let ppt_ensures b = Property.ip_ensures_of_behavior kf Kglobal b in List.iter Property_status.remove (ppt_ensures behavior); behavior.b_post_cond <- ens; List.iter Property_status.register (ppt_ensures behavior); in let spec = Annotations.funspec ~populate:false kf in List.iter insert_spec spec.spec_behavior in object inherit Visitor.frama_c_inplace method vglob_aux = function | GFun(f,_) -> annotate_fun f.svar; SkipChildren | GVarDecl(_,v,_) | GVar(v,_,_) (*as g*) -> if isFunctionType v.vtype && not v.vdefined then annotate_fun v; SkipChildren (* ) else let inv = annotate_var [] [] v in let postaction gl = match inv with [] -> gl | _ -> (* Define a global string invariant *) let inv = List.map (fun p -> Logic_const.unamed p.ip_content) inv in let p = Logic_const.new_predicate (Logic_const.pands inv) in let globinv = Cil_const.make_logic_info (unique_logic_name ("valid_" ^ v.vname)) in globinv.l_labels <- [ LogicLabel "Here" ]; globinv.l_body <- LBpred (predicate v.vdecl p.ip_content); attach_globaction (fun () -> Logic_utils.add_logic_function globinv); gl @ [GAnnot(Dinvariant globinv,v.vdecl)] in ChangeDoChildrenPost ([g], postaction) *) | GAnnot _ -> DoChildren | GCompTag _ | GType _ | GCompTagDecl _ | GEnumTagDecl _ | GEnumTag _ | GAsm _ | GPragma _ | GText _ -> SkipChildren end let interprate file = let visitor = new annotateFunFromDeclspec in Visitor.visitFramacFile visitor file (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/property.mli0000644000175000017500000003111712155630223020252 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** ACSL comparable property. @since Carbon-20101201 *) open Cil_types (**************************************************************************) (** {2 Type declarations} *) (**************************************************************************) (* [JS 20110607] TODO: redesigned the type below in order to: - use private records instead of tuples whenever possible - extend identified_property to any possible annotations - design more consistent type For instance, - why code annotations are represented so differently? - why type [behavior_or_loop] does not contain "assigns" somewhere in its name? - why this last type cannot be private? *) (** assigns can belong either to a contract or a loop annotation *) type behavior_or_loop = (* private *) | Id_behavior of funbehavior | Id_code_annot of code_annotation type identified_complete = kernel_function * kinstr * string list type identified_disjoint = identified_complete (** Only AAssert, AInvariant, or APragma. Other code annotations are dispatched as identified_property of their own. *) type identified_code_annotation = kernel_function * stmt * code_annotation type identified_assigns = kernel_function * kinstr * behavior_or_loop * identified_term from list type identified_allocation = kernel_function * kinstr * behavior_or_loop * (identified_term list * identified_term list) type identified_from = kernel_function * kinstr * behavior_or_loop * (identified_term from (* identified_term list *) ) type identified_decrease = kernel_function * kinstr * code_annotation option * term variant (** code_annotation is None for decreases and [Some { AVariant }] for loop variant. *) type identified_behavior = kernel_function * kinstr * funbehavior type predicate_kind = private | PKRequires of funbehavior | PKAssumes of funbehavior | PKEnsures of funbehavior * termination_kind | PKTerminates type identified_predicate = predicate_kind * kernel_function * kinstr * Cil_types.identified_predicate type program_point = Before | After type identified_reachable = kernel_function option * kinstr * program_point (** [None, Kglobal] --> global property [None, Some kf] --> impossible [Some kf, Kglobal] --> property of a function without code [Some kf, Kstmt stmt] --> reachability of the given stmt (and the attached properties *) and identified_axiomatic = string * identified_property list and identified_lemma = string * logic_label list * string list * predicate named * location and identified_axiom = identified_lemma and identified_property = private | IPPredicate of identified_predicate | IPAxiom of identified_axiom | IPAxiomatic of identified_axiomatic | IPLemma of identified_lemma | IPBehavior of identified_behavior | IPComplete of identified_complete | IPDisjoint of identified_disjoint | IPCodeAnnot of identified_code_annotation | IPAllocation of identified_allocation | IPAssigns of identified_assigns | IPFrom of identified_from | IPDecrease of identified_decrease | IPReachable of identified_reachable | IPOther of string * kernel_function option * kinstr include Datatype.S_with_collections with type t = identified_property (* [JS 2011/08/04] seem to be unused *) (*val short_pretty: Format.formatter -> t -> unit*) (** @since Oxygen-20120901 *) val pretty_predicate_kind: Format.formatter -> predicate_kind -> unit (**************************************************************************) (** {2 Smart constructors} *) (**************************************************************************) val ip_other: string -> kernel_function option -> kinstr -> identified_property (** Create a non-standard property. @since Nitrogen-20111001 *) val ip_reachable_stmt: kernel_function -> stmt -> identified_property (** @since Oxygen-20120901 *) val ip_reachable_ppt: identified_property -> identified_property (** @since Oxygen-20120901 *) (** IPPredicate of a single requires. @since Carbon-20110201 *) val ip_of_requires: kernel_function -> kinstr -> funbehavior -> Cil_types.identified_predicate -> identified_property (** Builds the IPPredicate corresponding to requires of a behavior. @since Carbon-20110201 *) val ip_requires_of_behavior: kernel_function -> kinstr -> funbehavior -> identified_property list (** IPPredicate of a single assumes. @since Carbon-20110201 *) val ip_of_assumes: kernel_function -> kinstr -> funbehavior -> Cil_types.identified_predicate -> identified_property (** Builds the IPPredicate corresponding to assumes of a behavior. @since Carbon-20110201 *) val ip_assumes_of_behavior: kernel_function -> kinstr -> funbehavior -> identified_property list (** IPPredicate of single ensures. @since Carbon-20110201 *) val ip_of_ensures: kernel_function -> kinstr -> funbehavior -> (termination_kind * Cil_types.identified_predicate) -> identified_property (** Builds the IPPredicate PKEnsures corresponding to a behavior. @since Carbon-20110201 *) val ip_ensures_of_behavior: kernel_function -> kinstr -> funbehavior -> identified_property list (** Builds the corresponding IPAllocation. @since Oxygen-20120901 *) val ip_of_allocation: kernel_function -> kinstr -> behavior_or_loop -> identified_term allocation -> identified_property option (** Builds IPAllocation for a contract. @since Oxygen-20120901 *) val ip_allocation_of_behavior: kernel_function -> kinstr -> funbehavior -> identified_property option (** Builds the corresponding IPAssigns. @since Carbon-20110201 *) val ip_of_assigns: kernel_function -> kinstr -> behavior_or_loop -> identified_term assigns -> identified_property option (** Builds IPAssigns for a contract (if not WritesAny) @since Carbon-20110201 *) val ip_assigns_of_behavior: kernel_function -> kinstr -> funbehavior -> identified_property option (** Builds the corresponding IPFrom. @since Carbon-20110201 *) val ip_of_from: kernel_function -> kinstr -> behavior_or_loop -> identified_term from -> identified_property (** Builds IPFrom for a contract (if not ReadsAny) @since Carbon-20110201 *) val ip_from_of_behavior: kernel_function -> kinstr -> funbehavior -> identified_property list (** Builds IPAssigns for a loop annotation (if not WritesAny) @since Carbon-20110201 *) val ip_assigns_of_code_annot: kernel_function -> kinstr -> code_annotation -> identified_property option (** Builds IPFrom for a loop annotation(if not ReadsAny) @since Carbon-20110201 *) val ip_from_of_code_annot: kernel_function -> kinstr -> code_annotation -> identified_property list (** Builds all IP related to the post-conditions (including allocates, frees, assigns and from) @since Carbon-20110201 *) val ip_post_cond_of_behavior: kernel_function -> kinstr -> funbehavior -> identified_property list (** Builds the IP corresponding to the behavior itself. @since Carbon-20110201 *) val ip_of_behavior: kernel_function -> kinstr -> funbehavior -> identified_property (** Builds all IP related to a behavior. @since Carbon-20110201 *) val ip_all_of_behavior: kernel_function -> kinstr -> funbehavior -> identified_property list (** Builds IPComplete. @since Carbon-20110201 *) val ip_of_complete: kernel_function -> kinstr -> string list -> identified_property (** Builds IPComplete of a given spec. @since Carbon-20110201 *) val ip_complete_of_spec: kernel_function -> kinstr -> funspec -> identified_property list (** Builds IPDisjoint. @since Carbon-20110201 *) val ip_of_disjoint: kernel_function -> kinstr -> string list -> identified_property (** Builds IPDisjoint of a given spec. @since Carbon-20110201 *) val ip_disjoint_of_spec: kernel_function -> kinstr -> funspec -> identified_property list val ip_of_terminates: kernel_function -> kinstr -> Cil_types.identified_predicate -> identified_property (** Builds IPTerminates of a given spec. @since Carbon-20110201 *) val ip_terminates_of_spec: kernel_function -> kinstr -> funspec -> identified_property option (** Builds IPDecrease @since Carbon-20110201 *) val ip_of_decreases: kernel_function -> kinstr -> term variant -> identified_property (** Builds IPDecrease of a given spec. @since Carbon-20110201 *) val ip_decreases_of_spec: kernel_function -> kinstr -> funspec -> identified_property option (** Builds all IP of post-conditions related to a spec. @since Carbon-20110201 *) val ip_post_cond_of_spec: kernel_function -> kinstr -> funspec -> identified_property list (** Builds all IP related to a spec. @since Carbon-20110201 *) val ip_of_spec: kernel_function -> kinstr -> funspec -> identified_property list (** Builds an IPAxiom. @since Carbon-20110201 @modify Oxygen-20120901 takes an identified_axiom instead of a string *) val ip_axiom: identified_axiom -> identified_property (** Build an IPLemma. @since Nitrogen-20111001 @modify Oxygen-20120901 takes an identified_lemma instead of a string *) val ip_lemma: identified_lemma -> identified_property (** Builds all IP related to a given code annotation. @since Carbon-20110201 *) val ip_of_code_annot: kernel_function -> stmt -> code_annotation -> identified_property list (** Builds the IP related to the code annotation. should be used only on code annotations returning a single ip, i.e. assert, invariant, variant, pragma. @raise Invalid_argument if the resulting code annotation has an empty set of identified property @since Carbon-20110201 *) val ip_of_code_annot_single: kernel_function -> stmt -> code_annotation -> identified_property val ip_of_global_annotation: global_annotation -> identified_property list (** @since Nitrogen-20111001 *) val ip_of_global_annotation_single: global_annotation -> identified_property option (** @since Nitrogen-20111001 *) (**************************************************************************) (** {2 getters} *) (**************************************************************************) val get_kinstr: identified_property -> kinstr val get_kf: identified_property -> kernel_function option val get_behavior: identified_property -> funbehavior option val location: identified_property -> location (** returns the location of the property. @since Oxygen-20120901 *) (**************************************************************************) (** {2 names} *) (**************************************************************************) (** @since Oxygen-20120901 *) module Names: sig val self: State.t val get_prop_name_id: identified_property -> string (** returns a unique name identifying the property. This name is built from the basename of the property. *) val get_prop_basename: identified_property -> string (** returns the basename of the property. *) val reserve_name_id: string -> string (** returns the name that should be returned by the function [get_prop_name_id] if the given property has [name] as basename. That name is reserved so that [get_prop_name_id prop] can never return an identical name. *) end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/infer_annotations.ml0000644000175000017500000001617112155630223021740 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Cil_types open Logic_const let emitter = Emitter.create "Inferred annotations" [Emitter.Funspec] [] [] let assigns_from_prototype kf = let vi = Kernel_function.get_vi kf in let formals = try let formals = getFormalsDecl vi in (* Do ignore anonymous names *) List.filter (fun vi -> vi.vname <> "") formals with Not_found -> [] (* this may happen for function pointer used as formal parameters.*) in let rtyp, _, _, _ = splitFunctionTypeVI vi in let pointer_args,basic_args = List.partition (fun vi -> isPointerType vi.vtype) formals in (* Remove pointer to pointer types and pointer to void *) let pointer_args = List.filter (fun vi -> not (isVoidPtrType vi.vtype || isPointerType (typeOf_pointed vi.vtype))) pointer_args in let get_length full_typ = let attr = typeAttr full_typ in findAttribute "arraylen" attr in let mk_star_v v = let typ = unrollType v.vtype in let loc = v.vdecl in match get_length typ with [AInt length] -> let low = Logic_const.tinteger ~loc 0 in let high = Logic_const.tint ~loc (Integer.pred length) in let range = Logic_const.trange ~loc (Some low,Some high) in let shift = Logic_const.term ~loc (TBinOp(PlusPI,tvar(cvar_to_lvar v),range)) (make_set_type (Ctype typ)) in Logic_const.new_identified_term (term ~loc (TLval(TMem shift,TNoOffset)) (make_set_type (Ctype (Cil.typeOf_pointed typ)))) | _ -> let cell = tvar ~loc (cvar_to_lvar v) in Logic_const.new_identified_term (term ~loc (TLval (TMem cell,TNoOffset)) (Ctype (Cil.typeOf_pointed typ))) in let to_assign = List.map mk_star_v (List.filter (fun v -> let pointed_type = typeOf_pointed v.vtype in not (hasAttribute "const" (typeAttrs pointed_type)) && not (Cil.isVoidType pointed_type) ) pointer_args) in let pointer_args_content = List.map mk_star_v pointer_args in let inputs = (pointer_args_content @(List.map (fun v -> Logic_const.new_identified_term { term_node = TLval (TVar (cvar_to_lvar v),TNoOffset); term_type = Ctype v.vtype; term_name = []; term_loc = v.vdecl }) basic_args)) in let arguments = List.map (fun content -> content, From inputs) to_assign in match rtyp with | TVoid _ -> (* assigns all pointer args from basic args and content of pointer args *) arguments | _ -> (* assigns result from basic args and content of pointer args *) let loc = vi.vdecl in ((Logic_const.new_identified_term (Logic_const.tat ~loc (Logic_const.tresult ~loc rtyp, Logic_const.post_label)),From inputs):: arguments) let is_frama_c_builtin name = Ast_info.is_frama_c_builtin name let populate_funspec kf spec = assert (not (Kernel_function.is_definition kf)); let name = Kernel_function.get_name kf in match spec.spec_behavior with | [] -> (* case 1: there is no initial specification -> use generated_behavior *) if not (is_frama_c_builtin name) then begin Kernel.warning ~once:true "Neither code nor specification for function %a, \ generating default assigns from the prototype" Kernel_function.pretty kf; end; let assigns = Writes (assigns_from_prototype kf) in let bhv = Cil.mk_behavior ~assigns () in Annotations.add_behaviors emitter kf [ bhv ] | _ :: _ -> (* case 2: there is a specification, so look at assigns clause *) let bhv = match Cil.find_default_behavior spec with | None -> Cil.mk_behavior () | Some bhv -> bhv in if bhv.b_assigns = WritesAny then (* case 2.2 : some assigns have to be generated *) (* step 2.1: looks at ungarded behaviors and then at complete behaviors *) let warn_if_not_builtin explicit_name name orig_name = if not (is_frama_c_builtin name) then Kernel.warning ~once:true "No code nor %s assigns clause for function %a, \ generating default assigns from the %s" explicit_name Kernel_function.pretty kf orig_name in let assigns = Ast_info.merge_assigns_from_spec ~warn:false spec in let assigns = if assigns <> WritesAny then begin (* case 2.2.1. A correct assigns clause has been found *) warn_if_not_builtin "explicit" name "specification"; assigns end else begin (* case 2.2.1. No correct assigns clause can be found *) let assigns = try (* Takes the union the assigns clauses, even if it is not advertised as complete behaviors. Not more arbitrary than using prototype to infer assigns.*) List.fold_left (fun acc bhv -> if Cil.is_default_behavior bhv then acc else match acc, bhv.b_assigns with | _, WritesAny -> raise Not_found | WritesAny, a -> a | Writes l1, Writes l2 -> Writes (l1 @ l2)) WritesAny spec.spec_behavior with Not_found -> WritesAny in if assigns <> WritesAny then begin warn_if_not_builtin "implicit" name "specification" ; assigns end else begin (* The union gave WritesAny, so use the prototype *) warn_if_not_builtin "implicit" name "prototype"; Writes (assigns_from_prototype kf); end end in Annotations.add_assigns ~keep_empty:false emitter kf bhv.b_name assigns let () = Annotations.populate_spec_ref := populate_funspec (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/property_status.mli0000644000175000017500000002427012155630223021657 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Status of properties. @since Nitrogen-20111001 @plugin development guide *) (* ************************************************************************ *) (** {2 Local status} A local status (shortly, a status) of a property is a status directly set by an emitter. Thus a property may have several distinct status according to who attempts the verification. *) (* ************************************************************************ *) (* ************************************************************************ *) (** {3 Emitting a status} *) (* ************************************************************************ *) (** Type of status emitted by analyzers. Each Property is attached to a program point [s] and implicitely depends on an execution path from the program entry point to [s]. It also depends on an explicit set of hypotheses [H] indicating when emitting the property (see function {!emit}). *) type emitted_status = | True (** for each execution path [ep] from the program entry point to [s], the formula (/\_{h in H} h) ==> P(ep) is true *) | False_if_reachable (** for each execution path [ep] from the program entry point to [s], the formula (/\_{h in H} h) ==> P(ep) is false *) | False_and_reachable (** it exists an execution path [ep] from the program entry point to [s] such that the formula (/\_{h in H} h) ==> P(ep) is false *) | Dont_know (** any other case *) module Emitted_status: Datatype.S with type t = emitted_status exception Inconsistent_emitted_status of emitted_status * emitted_status val emit: Emitter.t -> hyps:Property.t list -> Property.t -> ?distinct:bool -> emitted_status -> unit (** [emit e ~hyps p s] indicates that the status of [p] is [s], is emitted by [e], and is based on the list of hypothesis [hyps]. If [e] previously emitted another status [s'], it must be emitted with the same hypotheses and a consistency check is performed between [s] and [s'] and the best (by default the strongest) status is kept. If [distinct] is [true] (default is [false]), then we consider than the given status actually merges several statuses coming from distinct execution paths. The strategy for computing the best status is changed accordingly. One example when [~distinct:true] may be required is when emitting a status for a pre-condition of a function [f] since the status associated to a pre-condition [p] merges all statuses of [p] at each callsite of the function [f]. @return the kept status. @raise Inconsistent_emitted_status when emiting False after emiting True or conversely *) val emit_and_get: Emitter.t -> hyps:Property.t list -> Property.t -> ?distinct:bool -> emitted_status -> emitted_status (** Like {!emit} but also returns the computed status. *) val logical_consequence: Emitter.t -> Property.t -> Property.t list -> unit (** [logical_consequence e ppt list] indicates that the emitter [e] considers that [ppt] is a logical consequence of the conjunction of properties [list]. Thus it lets the kernel automatically computes it: [e] must not call functions [emit*] itself on this property, but the kernel ensures that the status will be up-to-date when getting it. *) val legal_dependency_cycle: Emitter.t -> Property.Set.t -> unit (** The given properties may define a legal dependency cycle for the given emitter. @since Oxygen-20120901 *) val self: State.t (** The state which stores the computed status. *) (* ************************************************************************ *) (** {3 Getting a (local) status} *) (* ************************************************************************ *) type emitter_with_properties = private { emitter: Emitter.Usable_emitter.t; mutable properties: Property.t list; logical_consequence: bool (** Is the emitted status automatically infered? *) } type inconsistent = private { valid: emitter_with_properties list; invalid: emitter_with_properties list } (** Type of known precise status of a property. *) type status = private | Never_tried (** Nobody tries to verify the property *) | Best of emitted_status (** The know precise status *) * emitter_with_properties list (** who attempt the verification under which hypotheses *) | Inconsistent of inconsistent (** someone says the property is valid and someone else says it is invalid. *) include Datatype.S with type t = status val get: Property.t -> status (** @return the most precise status and all its emitters. *) (* ************************************************************************ *) (** {2 Consolidated status} *) (* ************************************************************************ *) (** Consolidation of a property status according to the (consolidated) status of the hypotheses of the property. *) module Consolidation: sig (** who do the job and, for each of them, who find which issues. *) type pending = Property.Set.t Emitter.Usable_emitter.Map.t Emitter.Usable_emitter.Map.t type consolidated_status = private | Never_tried (** Nobody tries to verify the property. The argument is for internal use only *) | Considered_valid (** Nobody succeeds to verifiy the property, but it is expected to be verified by another way (manual review, ...) *) | Valid of Emitter.Usable_emitter.Set.t (** The verification of this property is fully done. No work to do anymore for this property. The argument is the emitters who did the job. *) | Valid_under_hyp of pending (** The verification of this property is locally done, but it remains properties to verify in order to close the work. *) | Unknown of pending (** The verification of this property is not finished: the property itself remains to verify and it may also remain other pending properties. NB: the pendings contains the property itself. *) | Invalid of Emitter.Usable_emitter.Set.t (** The verification of this property is fully done. All its hypotheses have been verified, but it is false: that is a true bug. *) | Invalid_under_hyp of pending (** This property is locally false, but it remains properties to verify in order to be sure that is a bug. *) | Invalid_but_dead of pending (** This property is locally false, but there is other bugs in hypotheses *) | Valid_but_dead of pending (** This property is locally true, but there is bugs in hypotheses *) | Unknown_but_dead of pending (** This property is locally unknown, but there is other bugs in hypotheses *) | Inconsistent of string (** Inconsistency detected when computing the consolidated status. The string explains what is the issue for the end-user. *) include Datatype.S with type t = consolidated_status val get: Property.t -> t val get_conjunction: Property.t list -> t end (** Lighter version than Consolidation *) module Feedback: sig (** Same constructor than Consolidation.t, without argument. *) type t = | Never_tried | Considered_valid | Valid | Valid_under_hyp | Unknown | Invalid | Invalid_under_hyp | Invalid_but_dead | Valid_but_dead | Unknown_but_dead | Inconsistent val get: Property.t -> t val get_conjunction: Property.t list -> t end (** See the consolidated status of a property in a graph, which all its dependencies and their consolidated status. *) module Consolidation_graph: sig type t val get: Property.t -> t val dump: t -> Format.formatter -> unit end (* ************************************************************************* *) (** {2 Access to the registered properties} *) (* ************************************************************************* *) val iter: (Property.t -> unit) -> unit val fold: (Property.t -> 'a -> 'a) -> 'a -> 'a (* ************************************************************************* *) (** {2 API not for casual users} *) (* ************************************************************************* *) val register: Property.t -> unit (** Register the given property. It must not be already registered. *) val remove: Property.t -> unit (** Remove the property deeply. Must be called only when removing the corresponding annotation. *) val merge: old:Property.t list -> Property.t list -> unit (** [merge old new] registers properties in [new] which are not in [old] and removes properties in [old] which are not in [new]. *) val automatically_proven: Property.t -> bool (** Is the status of the given property only automatically handled by the kernel? *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/annotations.ml0000644000175000017500000011321512155630223020552 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Property open Cil_types open Cil_datatype (**************************************************************************) (** {2 Utilities} *) (**************************************************************************) let exists_in_funspec f tbl = try Emitter.Usable_emitter.Hashtbl.iter (fun _ s -> if f s then raise Exit) tbl; false with Exit -> true (**************************************************************************) (** {2 Internal State} *) (**************************************************************************) module Usable_emitter = struct include Emitter.Usable_emitter let local_clear _ h = Hashtbl.clear h let usable_get e = e end module Real_globals = Globals module Globals = Emitter.Make_table (Global_annotation.Hashtbl) (Usable_emitter) (Datatype.Unit) (struct let dependencies = [ Ast.self ] let name = "Annotations.Globals" let kinds = [ Emitter.Global_annot ] let size = 17 end) let global_state = Globals.self let () = Logic_env.init_dependencies global_state; Ast.add_linked_state global_state; Globals.add_hook_on_remove (fun _ a () -> List.iter Property_status.remove (Property.ip_of_global_annotation a)) module Model_fields = Emitter.Make_table (Cil_datatype.TypNoUnroll.Hashtbl) (Usable_emitter) (Datatype.List(Cil_datatype.Model_info)) (struct let dependencies = [ Globals.self ] let name = "Annotations.Model_fields" let kinds = [ Emitter.Global_annot ] let size = 7 end) let () = Ast.add_linked_state Model_fields.self module Funspecs = Emitter.Make_table (Kf.Hashtbl) (Usable_emitter) (Funspec) (struct let dependencies = [ Ast.self; Real_globals.Functions.self ] let name = "Annotations.Funspec" let kinds = [ Emitter.Funspec ] let size = 97 end) let funspec_state = Funspecs.self let () = Ast.add_linked_state funspec_state; Funspecs.add_hook_on_remove (fun _ kf spec -> let ppts = Property.ip_of_spec kf Kglobal spec in List.iter Property_status.remove ppts) module Is_populate = State_builder.Hashtbl (Kf.Hashtbl) (Datatype.Unit) (struct let size = 17 let dependencies = [ funspec_state ] let name = "Annotations.Is_populate" end) let () = Ast.add_linked_state Is_populate.self module Code_annots = Emitter.Make_table (Stmt.Hashtbl) (Usable_emitter) (Datatype.Ref(Datatype.List(Code_annotation))) (struct let dependencies = [ Ast.self ] let name = "Annotations.Code_annots" let kinds = [ Emitter.Code_annot; Emitter.Alarm ] let size = 97 end) let code_annot_state = Code_annots.self let remove_alarm_ref = Extlib.mk_fun "Annotations.remove_alarm_ref" let kf_ref = ref None let () = Ast.add_linked_state code_annot_state; Code_annots.add_hook_on_remove (fun e stmt l -> let kf = match !kf_ref with | None -> (try Kernel_function.find_englobing_kf stmt with Not_found -> Kernel.fatal "[Annotations] no function for stmt %a (%d)" Cil_printer.pp_stmt stmt stmt.sid) | Some kf -> kf in List.iter (fun a -> !remove_alarm_ref e stmt a; let ppts = Property.ip_of_code_annot kf stmt a in List.iter Property_status.remove ppts) !l) (**************************************************************************) (** {2 Getting annotations} *) (**************************************************************************) let code_annot ?emitter ?filter stmt = try let tbl = Code_annots.find stmt in match emitter with | None -> let filter l acc = match filter with | None -> l @ acc | Some f -> let rec aux acc = function | [] -> acc | x :: l -> aux (if f x then x :: acc else acc) l in aux acc l in Emitter.Usable_emitter.Hashtbl.fold (fun _ l acc -> filter !l acc) tbl [] | Some e -> let l = !(Emitter.Usable_emitter.Hashtbl.find tbl (Emitter.get e)) in match filter with | None -> l | Some f -> List.filter f l with Not_found -> [] let code_annot_emitter ?filter stmt = try let tbl = Code_annots.find stmt in let filter e l acc = let e = Emitter.Usable_emitter.get e in match filter with | None -> List.map (fun a -> a, e) l @ acc | Some f -> let rec aux acc = function | [] -> acc | x :: l -> aux (if f e x then (x, e) :: acc else acc) l in aux acc l in Emitter.Usable_emitter.Hashtbl.fold (fun e l acc -> filter e !l acc) tbl [] with Not_found -> [] let populate_spec_ref = Extlib.mk_fun "Annotations.populate_spec" let populate_spec populate kf spec = match kf.fundec with | Definition _ -> false | Declaration _ -> if populate && not (Is_populate.mem kf) then begin (* Kernel.feedback "infering contract for function %a" Kf.pretty kf; *) Is_populate.add kf (); !populate_spec_ref kf spec; true end else false let merge_assigns ~keep_empty a1 a2 = match a1, a2, keep_empty with | WritesAny, a, false | a, WritesAny, false | (WritesAny as a), _, true | _, (WritesAny as a), true -> a | Writes a1, Writes a2, _ -> Writes (a1 @ a2) let merge_behavior fresh_bhv bhv = assert (fresh_bhv.b_name = bhv.b_name); fresh_bhv.b_assumes <- bhv.b_assumes @ fresh_bhv.b_assumes; fresh_bhv.b_requires <- bhv.b_requires @ fresh_bhv.b_requires; fresh_bhv.b_post_cond <- bhv.b_post_cond @ fresh_bhv.b_post_cond; fresh_bhv.b_assigns <- merge_assigns ~keep_empty:false fresh_bhv.b_assigns bhv.b_assigns; fresh_bhv.b_allocation <- Logic_utils.merge_allocation fresh_bhv.b_allocation bhv.b_allocation let merge_behaviors fresh old = let init_fresh_bhvs = fresh.spec_behavior in let init_old_bhvs = old.spec_behavior in (* let pp_behav fmt b = Format.pp_print_string fmt b.b_name in let pp_behavs fmt = Pretty_utils.pp_list ~sep:" " pp_behav fmt in Format.printf "##[[ %a + %a ]]@." pp_behavs init_fresh_bhvs pp_behavs init_old_bhvs; *) let rec merge acc = function | [] -> acc | b :: tl -> (try let bhv = List.find (fun x -> x.b_name = b.b_name) init_old_bhvs in merge_behavior b bhv; with Not_found -> ()); merge (b :: acc) tl in let rec keep acc = function | [] -> List.rev acc | b :: tl -> let acc = if List.for_all (fun x -> x.b_name <> b.b_name) init_fresh_bhvs then begin (* do not share behaviors *) ({ b with b_assumes = b.b_assumes } :: acc) end else acc in keep acc tl in fresh.spec_behavior <- merge (keep [] init_old_bhvs) (List.rev init_fresh_bhvs) let merge_variant fresh old = match fresh.spec_variant, old.spec_variant with | _, None -> () | Some _, Some _ -> assert false | None, (Some _ as v) -> fresh.spec_variant <- v let merge_terminates fresh old = match fresh.spec_terminates, old.spec_terminates with | _, None -> () | Some _, Some _ -> assert false | None, (Some _ as v) -> fresh.spec_terminates <- v let merge_complete fresh old = fresh.spec_complete_behaviors <- old.spec_complete_behaviors @ fresh.spec_complete_behaviors let merge_disjoint fresh old = fresh.spec_disjoint_behaviors <- old.spec_disjoint_behaviors @ fresh.spec_disjoint_behaviors (* modifies [s1], let [s2] be unchanged. *) let merge_funspec s1 s2 = merge_behaviors s1 s2; merge_variant s1 s2; merge_terminates s1 s2; merge_complete s1 s2; merge_disjoint s1 s2 let pre_register_funspec ?tbl ?(emitter=Emitter.end_user) ?(force=false) kf = (* Avoid sharing with kf.spec *) let spec = { kf.spec with spec_behavior = kf.spec.spec_behavior } in let do_it = match tbl with | None -> if force then begin Funspecs.remove kf; true end else not (Funspecs.mem kf) | Some _ -> true in if do_it then begin let tbl = match tbl with | None -> Emitter.Usable_emitter.Hashtbl.create 7 | Some tbl -> tbl in Emitter.Usable_emitter.Hashtbl.add tbl (Emitter.get emitter) spec; (* Kernel.feedback "Registering contract of function %a (%a)" Kf.pretty kf Cil_printer.pp_funspec kf.spec;*) Funspecs.add kf tbl; (* Emitter.Usable_emitter.Hashtbl.iter (fun e spec -> Format.printf "Register for function %a, Emitter %a, spec %a@." Kf.pretty kf Emitter.Usable_emitter.pretty e Cil_printer.pp_funspec spec) tbl; *) List.iter Property_status.register (Property.ip_of_spec kf Kglobal spec) end let register_funspec ?emitter ?force kf = pre_register_funspec ?emitter ?force kf exception No_funspec of Emitter.t let generic_funspec merge get ?emitter ?(populate=true) kf = let merge tbl = (* Kernel.feedback "Getting spec of function %a" Kf.pretty kf; *) match emitter with | None -> let merged_spec () = let spec = Cil.empty_funspec () in Emitter.Usable_emitter.Hashtbl.iter (fun _e s -> (*Format.printf "emitter %a(%d):@\n%a@." Emitter.Usable_emitter.pretty _e (Obj.magic s) Cil_printer.pp_funspec s; *) merge spec s) tbl; spec in let spec = merged_spec () in let do_it = populate_spec populate kf spec in get (if do_it then merged_spec () else spec) | Some e -> try let s = Emitter.Usable_emitter.Hashtbl.find tbl (Emitter.get e) in get s with Not_found -> raise (No_funspec e) in try let tbl = Funspecs.find kf in merge tbl with Not_found -> let tbl = Emitter.Usable_emitter.Hashtbl.create 7 in pre_register_funspec ~tbl kf; merge tbl let funspec ?emitter ?populate kf = generic_funspec merge_funspec ?emitter ?populate (fun x -> x) kf (* Do not share behaviors with outside world if there's a single emitter. *) let behaviors = generic_funspec merge_behaviors (fun x -> List.map (fun b -> { b with b_name = b.b_name }) x.spec_behavior) let decreases = generic_funspec merge_variant (fun x -> x.spec_variant) let terminates = generic_funspec merge_terminates (fun x -> x.spec_terminates) let complete = generic_funspec merge_complete (fun x -> x.spec_complete_behaviors) let disjoint = generic_funspec merge_disjoint (fun x -> x.spec_disjoint_behaviors) let model_fields ?emitter t = let rec aux acc t = let self_fields = try let h = Model_fields.find t in match emitter with | None -> Emitter.Usable_emitter.Hashtbl.fold (fun _ m acc-> m @ acc) h acc | Some e -> let e = Emitter.get e in try Emitter.Usable_emitter.Hashtbl.find h e @ acc with Not_found -> acc with Not_found -> acc in match t with | TNamed (ty,_) -> aux self_fields ty.ttype | _ -> self_fields in aux [] t (**************************************************************************) (** {2 Iterating over annotations} *) (**************************************************************************) let iter_code_annot f stmt = try let tbl = Code_annots.find stmt in Emitter.Usable_emitter.Hashtbl.iter (fun e l -> List.iter (f (Emitter.Usable_emitter.get e)) !l) tbl with Not_found -> () let fold_code_annot f stmt acc = try let tbl = Code_annots.find stmt in Emitter.Usable_emitter.Hashtbl.fold (fun e l acc -> let e = Emitter.Usable_emitter.get e in List.fold_left (fun acc x -> f e x acc) acc !l) tbl acc with Not_found -> acc let iter_all_code_annot f = Code_annots.iter (fun stmt tbl -> Emitter.Usable_emitter.Hashtbl.iter (fun e l -> List.iter (f stmt (Emitter.Usable_emitter.get e)) !l) tbl) let fold_all_code_annot f = Code_annots.fold (fun stmt tbl acc -> Emitter.Usable_emitter.Hashtbl.fold (fun e l acc -> let e = Emitter.Usable_emitter.get e in List.fold_left (fun acc x -> f stmt e x acc) acc !l) tbl acc) let iter_global f = Globals.iter (fun g h -> Usable_emitter.Hashtbl.iter (fun e () -> f (Emitter.Usable_emitter.get e) g) h) let fold_global f = Globals.fold (fun g h acc -> Usable_emitter.Hashtbl.fold (fun e () -> f (Emitter.Usable_emitter.get e) g) h acc) let iter_spec_gen get iter f kf = try let tbl = Funspecs.find kf in let treat_one_emitter e spec = try let e = Emitter.Usable_emitter.get e in let orig = get spec in iter (f e) orig with Not_found -> () in Usable_emitter.Hashtbl.iter treat_one_emitter tbl with Not_found -> () let iter_behaviors f = iter_spec_gen (fun s -> s.spec_behavior) (fun f l -> List.iter (fun b -> f { b with b_name = b.b_name}) l) f let iter_complete f = iter_spec_gen (fun s -> s.spec_complete_behaviors) List.iter f let iter_disjoint f = iter_spec_gen (fun s -> s.spec_disjoint_behaviors) List.iter f let iter_terminates f = iter_spec_gen (fun s -> s.spec_terminates) Extlib.may f let iter_decreases f = iter_spec_gen (fun s -> s.spec_variant) Extlib.may f let iter_bhv_gen get iter f kf b = let get spec = let bhv = List.find (fun x -> x.b_name = b) spec.spec_behavior in get bhv in iter_spec_gen get iter f kf let iter_requires f = iter_bhv_gen (fun b -> b.b_requires) List.iter f let iter_assumes f = iter_bhv_gen (fun b -> b.b_assumes) List.iter f let iter_ensures f = iter_bhv_gen (fun b -> b.b_post_cond) List.iter f let iter_assigns f = iter_bhv_gen (fun b -> b.b_assigns) (fun f a -> f a) f let iter_allocates f = iter_bhv_gen (fun b -> b.b_allocation) (fun f a -> f a) f let fold_spec_gen get fold f kf acc = try let tbl = Funspecs.find kf in let treat_one_emitter e spec acc = try let e = Emitter.Usable_emitter.get e in let orig = get spec in fold (f e) orig acc with Not_found -> acc in Usable_emitter.Hashtbl.fold treat_one_emitter tbl acc with Not_found -> acc let fold_behaviors f = fold_spec_gen (fun s -> s.spec_behavior) (fun f l acc -> List.fold_left (fun acc b -> f { b with b_name = b.b_name} acc) acc l) f let fold_complete f = fold_spec_gen (fun s -> s.spec_complete_behaviors) (fun f l acc -> List.fold_left (Extlib.swap f) acc l) f let fold_disjoint f = fold_spec_gen (fun s -> s.spec_disjoint_behaviors) (fun f l acc -> List.fold_left (Extlib.swap f) acc l) f let fold_terminates f = fold_spec_gen (fun s -> s.spec_terminates) Extlib.opt_fold f let fold_decreases f = fold_spec_gen (fun s -> s.spec_variant) Extlib.opt_fold f let fold_bhv_gen get fold f kf b acc = let get spec = let bhv = List.find (fun x -> x.b_name = b) spec.spec_behavior in get bhv in fold_spec_gen get fold f kf acc let fold_requires f = fold_bhv_gen (fun b -> b.b_requires) (fun f l acc -> List.fold_left (Extlib.swap f) acc l) f let fold_assumes f = fold_bhv_gen (fun b -> b.b_assumes) (fun f l acc -> List.fold_left (Extlib.swap f) acc l) f let fold_ensures f = fold_bhv_gen (fun b -> b.b_post_cond) (fun f l acc -> List.fold_left (Extlib.swap f) acc l) f let fold_assigns f = fold_bhv_gen (fun b -> b.b_assigns) (fun f a acc -> f a acc) f let fold_allocates f = fold_bhv_gen (fun b -> b.b_allocation) (fun f a acc -> f a acc) f (**************************************************************************) (** {2 Adding annotations} *) (**************************************************************************) let extend_name e pred = if Emitter.equal e Emitter.end_user || Emitter.equal e Emitter.kernel then pred else let names = pred.name in let s = Emitter.get_name e in if (List.mem s names) || let acsl_identifier_regexp = Str.regexp "^\\([\\][_a-zA-Z]\\|[_a-zA-Z]\\)[0-9_a-zA-Z]*$" in not (Str.string_match acsl_identifier_regexp s 0) then pred else { pred with name = s :: names } (** {3 Adding code annotations} *) let add_code_annot e ?kf stmt ca = (* Kernel.feedback "%a: adding code annot %a with stmt %a (%d)" Project.pretty (Project.current ()) Code_annotation.pretty ca Stmt.pretty stmt stmt.sid;*) let convert a = let c = a.annot_content in { a with annot_content = match c with | AAssert(l, p) -> AAssert(l, extend_name e p) | AInvariant(l, b, p) -> AInvariant(l, b, extend_name e p) | AStmtSpec _ | AVariant _ | AAssigns _ | AAllocation _ | APragma _ -> c } in let ca = convert ca in let e = Emitter.get e in let kf = match kf with | None -> Kernel_function.find_englobing_kf stmt | Some kf -> kf in let ppts = Property.ip_of_code_annot kf stmt ca in List.iter Property_status.register ppts; let add_emitter tbl = Emitter.Usable_emitter.Hashtbl.add tbl e (ref [ ca ]) in try let tbl = Code_annots.find stmt in try let l = Emitter.Usable_emitter.Hashtbl.find tbl e in l := ca :: !l; with Not_found -> add_emitter tbl with Not_found -> let tbl = Emitter.Usable_emitter.Hashtbl.create 7 in add_emitter tbl; Code_annots.add stmt tbl let add_assert e ?kf stmt a = let a = Logic_const.new_code_annotation (AAssert ([],a)) in add_code_annot e ?kf stmt a (** {3 Adding globals} *) let dependencies_of_global annot = let c_vars = ref Cil_datatype.Varinfo.Set.empty in let logic_vars = ref Cil_datatype.Logic_info.Set.empty in let local_logics = ref Cil_datatype.Logic_info.Set.empty in let vis = object (* do not use Visitor here, we're above it in link order. Anyway, there's nothing Frama-C-specific in the visitor. *) inherit Cil.nopCilVisitor method vvrbl vi = if vi.vglob then c_vars := Cil_datatype.Varinfo.Set.add vi !c_vars; Cil.DoChildren method vlogic_info_use li = if not (Cil_datatype.Logic_info.Set.mem li !local_logics) then logic_vars := Cil_datatype.Logic_info.Set.add li !logic_vars; Cil.DoChildren method vlogic_info_decl li = local_logics := Cil_datatype.Logic_info.Set.add li !local_logics; Cil.DoChildren end in ignore (Cil.visitCilAnnotation vis annot); (!c_vars, !logic_vars) let rec remove_declared_global_annot logic_vars = function | Dfun_or_pred(li,_) | Dinvariant(li,_) | Dtype_annot(li,_) -> Cil_datatype.Logic_info.Set.remove li logic_vars | Dvolatile _ | Dtype _ | Dlemma _ | Dmodel_annot _ | Dcustom_annot _ -> logic_vars | Daxiomatic (_,l,_) -> List.fold_left remove_declared_global_annot logic_vars l let remove_declared_global c_vars logic_vars = function | GType _ | GCompTag _ | GCompTagDecl _ | GEnumTag _ | GEnumTagDecl _ | GAsm _ | GPragma _ | GText _ -> c_vars, logic_vars | GVarDecl (_,vi,_) | GVar(vi,_,_) | GFun ({ svar = vi; },_) -> Cil_datatype.Varinfo.Set.remove vi c_vars, logic_vars | GAnnot (g,_) -> c_vars, remove_declared_global_annot logic_vars g let insert_global_in_ast annot = let glob = GAnnot(annot, Cil_datatype.Global_annotation.loc annot) in let file = Ast.get () in (* We always put global annotations after types, so there's no need to trace their dependencies. *) let deps = dependencies_of_global annot in let rec insert_after (c_vars, logic_vars as deps) acc l = match l with | [] -> (* Some dependencies might be missing, but we suppose that caller knows what s/he's doing. *) List.rev (glob :: acc) | (GType _ | GCompTag _ | GCompTagDecl _ | GEnumTag _ | GEnumTagDecl _ as g) :: l -> insert_after deps (g :: acc) l | g :: l -> let c_vars, logic_vars as deps = remove_declared_global c_vars logic_vars g in if Cil_datatype.Varinfo.Set.is_empty c_vars && Cil_datatype.Logic_info.Set.is_empty logic_vars then List.rev acc @ g :: glob :: l else insert_after deps (g :: acc) l in let globs = insert_after deps [] file.globals in file.globals <- globs let add_model_field e m = let e = Emitter.get e in let h = try Model_fields.find m.mi_base_type with Not_found -> let res = Emitter.Usable_emitter.Hashtbl.create 13 in Model_fields.add m.mi_base_type res; res in let l = try Emitter.Usable_emitter.Hashtbl.find h e with Not_found -> [] in Emitter.Usable_emitter.Hashtbl.replace h e (m::l) let unsafe_add_global e a = (* Kernel.feedback "adding global %a in project %a" Cil_printer.pp_annotation a Project.pretty (Project.current ());*) let h = Usable_emitter.Hashtbl.create 17 in Usable_emitter.Hashtbl.add h (Emitter.get e) (); Globals.add a h; (match a with | Dmodel_annot (m,_) -> add_model_field e m | _ -> ()); List.iter Property_status.register (Property.ip_of_global_annotation a) let add_global e a = unsafe_add_global e a; if not (Emitter.equal Emitter.end_user e) then insert_global_in_ast a (** {3 Adding subparts of a function contract} *) let mk_spec bhv variant terminates complete disjoint = { spec_behavior = bhv; spec_variant = variant; spec_terminates = terminates; spec_complete_behaviors = complete; spec_disjoint_behaviors = disjoint; } let extend_funspec e kf mk_spec set_spec = let e = Emitter.get e in let add_emitter tbl = let spec = mk_spec () in (* Kernel.feedback "Creating spec %a" Cil_printer.pp_funspec spec;*) Emitter.Usable_emitter.Hashtbl.add tbl e spec in try let tbl = Funspecs.find kf in try let spec = Emitter.Usable_emitter.Hashtbl.find tbl e in set_spec spec tbl with Not_found -> add_emitter tbl with Not_found -> let tbl = Emitter.Usable_emitter.Hashtbl.create 7 in add_emitter tbl; Funspecs.add kf tbl let add_behaviors ?(register_children=true) e kf bhvs = let mk_spec_all () = mk_spec bhvs None None [] [] in let set_spec spec _tbl = if register_children then merge_behaviors spec (mk_spec_all ()) else List.iter (fun b -> if not (List.exists (fun x -> x.b_name = b.b_name) spec.spec_behavior) then merge_behaviors spec (mk_spec [b] None None [] [])) bhvs in extend_funspec e kf mk_spec_all set_spec; (* update ip in property_status: the kernel relies on the behavior stored in the ip to determine the validity. If we change something in our own tables, this must be reflected there. *) List.iter (fun b -> if List.exists (fun b' -> b'.b_name = b.b_name) bhvs then let ip = Property.ip_of_behavior kf Kglobal b in Property_status.remove ip; Property_status.register ip) (behaviors ~populate:false kf); if register_children then begin List.iter (fun bhv -> List.iter (fun ip -> match ip with IPBehavior _ -> () | _ -> Property_status.register ip) (Property.ip_all_of_behavior kf Kglobal bhv)) bhvs end let add_decreases e kf v = let mk_spec () = mk_spec [] (Some v) None [] [] in let set_spec spec tbl = if exists_in_funspec (fun s -> s.spec_variant <> None) tbl then Kernel.fatal "already a variant for function %a" Kf.pretty kf; spec.spec_variant <- Some v in extend_funspec e kf mk_spec set_spec; Property_status.register (Property.ip_of_decreases kf Kglobal v) let add_terminates e kf t = let mk_spec () = mk_spec [] None (Some t) [] [] in let set_spec spec tbl = if exists_in_funspec (fun s -> s.spec_terminates <> None) tbl then Kernel.fatal "already a terminates clause for function %a" Kf.pretty kf; spec.spec_terminates <- Some t in extend_funspec e kf mk_spec set_spec; Property_status.register (Property.ip_of_terminates kf Kglobal t) let add_complete e kf l = let mk_spec () = mk_spec [] None None [ l ] [] in let set_spec spec _tbl = spec.spec_complete_behaviors <- l :: spec.spec_complete_behaviors in extend_funspec e kf mk_spec set_spec; Property_status.register (Property.ip_of_complete kf Kglobal l) let add_disjoint e kf l = let mk_spec () = mk_spec [] None None [] [ l ] in let set_spec spec _tbl = spec.spec_disjoint_behaviors <- l :: spec.spec_disjoint_behaviors in extend_funspec e kf mk_spec set_spec; Property_status.register (Property.ip_of_disjoint kf Kglobal l) let extend_behavior e kf bhv_name set_bhv = (* Kernel.feedback "Function %a, behavior %s" Kf.pretty kf bhv_name;*) let e = Emitter.get e in let mk_bhv () = let bhv = Cil.mk_behavior ~name:bhv_name () in set_bhv bhv; bhv in let add_emitter_contract tbl = let bhv = mk_bhv () in let spec = mk_spec [ bhv ] None None [] [] in Emitter.Usable_emitter.Hashtbl.add tbl e spec; bhv in let my_bhv = try let tbl = Funspecs.find kf in try let spec = Emitter.Usable_emitter.Hashtbl.find tbl e in try let bhv = List.find (fun b -> b.b_name = bhv_name) spec.spec_behavior in (* this emitter already creates this behavior *) set_bhv bhv; bhv with Not_found (* List.find *) -> (* unexisting behavior for this emitter *) let bhv = mk_bhv () in spec.spec_behavior <- bhv :: spec.spec_behavior; bhv with Not_found (* Emitter.Usable_emitter.Hashtbl.find *) -> (* this emitter never adds a spec to this contract *) add_emitter_contract tbl with Not_found (* Funspecs.find *) -> (* no function contract *) let tbl = Emitter.Usable_emitter.Hashtbl.create 7 in Funspecs.add kf tbl; add_emitter_contract tbl in let bhv = List.find (fun b -> b.b_name = bhv_name) (behaviors ~populate:false kf) in (* Property_status uses bhv to determine the validity of [ip]. We must update that accordingly... *) let ip = Property.ip_of_behavior kf Kglobal bhv in Property_status.remove ip; Property_status.register ip; my_bhv let add_requires e kf bhv_name l = let bhv = extend_behavior e kf bhv_name (fun b -> b.b_requires <- l @ b.b_requires) in List.iter (fun p -> Property_status.register (Property.ip_of_requires kf Kglobal bhv p)) l let add_assumes e kf bhv_name l = let bhv = extend_behavior e kf bhv_name (fun b -> b.b_assumes <- l @ b.b_assumes) in List.iter (fun p -> Property_status.register (Property.ip_of_assumes kf Kglobal bhv p)) l let add_ensures e kf bhv_name l = let bhv = extend_behavior e kf bhv_name (fun b -> b.b_post_cond <- l @ b.b_post_cond) in List.iter (fun a -> Property_status.register (Property.ip_of_ensures kf Kglobal bhv a)) l let add_assigns ~keep_empty e kf bhv_name a = let bhv = extend_behavior e kf bhv_name (fun b -> let keep_empty = keep_empty && let bhvs = behaviors ~populate:false kf in List.for_all (fun b -> b.b_name <> bhv_name || b.b_assigns = WritesAny) bhvs in b.b_assigns <- merge_assigns ~keep_empty b.b_assigns a) in (match a with | WritesAny -> () | Writes l -> List.iter (fun f -> let ip = Property.ip_of_from kf Kglobal (Property.Id_behavior bhv) f in Property_status.remove ip; Property_status.register ip) l); Extlib.may (fun a -> (* All assigns of a same behavior share the property. Thus must remove the previous property before adding the new one *) Property_status.remove a; Property_status.register a) (Property.ip_of_assigns kf Kglobal (Property.Id_behavior bhv) a) let add_allocates e kf bhv_name a = let bhv = extend_behavior e kf bhv_name (fun b -> b.b_allocation <- Logic_utils.merge_allocation b.b_allocation a) in Extlib.may Property_status.register (Property.ip_of_allocation kf Kglobal (Property.Id_behavior bhv) a) (**************************************************************************) (** {2 Removing annotations} *) (**************************************************************************) (* use unicity: more efficient than using [List.filter ((!=) x)] *) let filterq ?(eq = ( == )) x l = let rec aux acc = function | [] -> List.rev acc | y :: l -> if eq x y then (* equivalent but more efficient than List.rev acc @ l *) List.fold_left (fun l x -> x :: l) l acc else aux (y :: acc) l in aux [] l let remove_code_annot e ?kf stmt ca = (* Kernel.feedback "%a: removing code annot %a of stmt %a (%d)" Project.pretty (Project.current ()) Code_annotation.pretty ca Stmt.pretty stmt stmt.sid;*) kf_ref := kf; let e = Emitter.get e in Code_annots.apply_hooks_on_remove e stmt (ref [ ca ]); kf_ref := None; try let tbl = Code_annots.find stmt in try let l = Emitter.Usable_emitter.Hashtbl.find tbl e in (* [JS 2012/11/08] (==) is not compatible with the equality over code annot *) l := filterq ~eq:Code_annotation.equal ca !l; with Not_found -> () with Not_found -> () (* If this function gets exported, please turn e into an Emitter.t *) let remove_model_field (e:Usable_emitter.t) m = try let ty = m.mi_base_type in let h = Model_fields.find ty in let l = Usable_emitter.Hashtbl.find h e in let l' = List.filter (fun x -> not (Cil_datatype.Model_info.equal x m)) l in Usable_emitter.Hashtbl.replace h e l'; Model_fields.apply_hooks_on_remove e ty l' with Not_found -> () let remove_global e a = try let e = Emitter.get e in let h = Globals.find a in Usable_emitter.Hashtbl.iter (fun e' () -> if Emitter.Usable_emitter.equal e e' then begin Globals.remove a; (match a with | Dmodel_annot (m,_) -> remove_model_field e m | _ -> ()); let file = Ast.get () in file.globals <- List.filter (fun a' -> not (Global.equal (GAnnot(a, Global_annotation.loc a)) a')) file.globals; Globals.apply_hooks_on_remove e a () end) h; with Not_found -> () let remove_in_funspec e kf set_spec = try let tbl = Funspecs.find kf in let e = Emitter.get e in try let spec = Emitter.Usable_emitter.Hashtbl.find tbl e in (* Format.printf "Known specs for %a@." Kf.pretty kf;*) (* Emitter.Usable_emitter.Hashtbl.iter (fun e spec -> Format.printf "For emitter %a: %a@." Emitter.Usable_emitter.pretty e Cil_printer.pp_funspec spec) tbl; *) set_spec spec tbl with Not_found -> () with Not_found -> assert false let remove_behavior e kf bhv = let set_spec spec tbl = (* Kernel.feedback "Current spec is %a@." Cil_printer.pp_funspec spec; *) spec.spec_behavior <- filterq bhv spec.spec_behavior; let name = bhv.b_name in let check get = if exists_in_funspec (fun s -> List.exists (List.exists ((=) name)) (get s)) tbl then Kernel.fatal "trying to remove a behavior used in a complete or disjoint clause" in check (fun s -> s.spec_complete_behaviors); check (fun s -> s.spec_disjoint_behaviors); (* Kernel.feedback "Removing behavior %s@." bhv.b_name; *) (* Kernel.feedback "New spec is %a@." Cil_printer.pp_funspec spec; *) List.iter Property_status.remove (Property.ip_all_of_behavior kf Kglobal bhv) in remove_in_funspec e kf set_spec let remove_decreases e kf = let set_spec spec _tbl = match spec.spec_variant with | None -> () | Some d -> Property_status.remove (Property.ip_of_decreases kf Kglobal d); spec.spec_variant <- None in remove_in_funspec e kf set_spec let remove_terminates e kf = let set_spec spec _tbl = match spec.spec_terminates with | None -> () | Some t -> Property_status.remove (Property.ip_of_terminates kf Kglobal t); spec.spec_terminates <- None in remove_in_funspec e kf set_spec let remove_complete e kf l = let set_spec spec _tbl = spec.spec_complete_behaviors <- filterq l spec.spec_complete_behaviors in remove_in_funspec e kf set_spec; Property_status.remove (Property.ip_of_complete kf Kglobal l) let remove_disjoint e kf l = let set_spec spec _tbl = spec.spec_disjoint_behaviors <- filterq l spec.spec_disjoint_behaviors in remove_in_funspec e kf set_spec; Property_status.remove (Property.ip_of_disjoint kf Kglobal l) let remove_requires e kf p = let set_spec spec _tbl = List.iter (fun b -> if List.memq p b.b_requires then begin b.b_requires <- filterq p b.b_requires; Property_status.remove (Property.ip_of_requires kf Kglobal b p) end) spec.spec_behavior in remove_in_funspec e kf set_spec let remove_assumes e kf p = let set_spec spec _tbl = List.iter (fun b -> if List.memq p b.b_assumes then begin b.b_assumes <- filterq p b.b_assumes; Property_status.remove (Property.ip_of_assumes kf Kglobal b p) end) spec.spec_behavior in remove_in_funspec e kf set_spec let remove_ensures e kf p = let set_spec spec _tbl = List.iter (fun b -> if List.memq p b.b_post_cond then begin b.b_post_cond <- filterq p b.b_post_cond; Property_status.remove (Property.ip_of_ensures kf Kglobal b p) end) spec.spec_behavior in remove_in_funspec e kf set_spec let remove_allocates e kf p = let set_spec spec _tbl = List.iter (fun b -> if b.b_allocation == p then begin b.b_allocation <- FreeAllocAny; Extlib.may Property_status.remove (Property.ip_of_allocation kf Kglobal (Id_behavior b) p) end) spec.spec_behavior in remove_in_funspec e kf set_spec let remove_assigns e kf p = let set_spec spec _tbl = List.iter (fun b -> if b.b_assigns == p then begin b.b_assigns <- WritesAny; Extlib.may Property_status.remove (Property.ip_of_assigns kf Kglobal (Id_behavior b) p); (match p with | WritesAny -> () | Writes l -> List.iter (fun f -> Property_status.remove (Property.ip_of_from kf Kglobal (Id_behavior b) f)) l) end) spec.spec_behavior in remove_in_funspec e kf set_spec let remove_behavior_components e kf b = List.iter (remove_requires e kf) b.b_requires; List.iter (remove_assumes e kf) b.b_assumes; List.iter (remove_ensures e kf) b.b_post_cond; remove_assigns e kf b.b_assigns; remove_allocates e kf b.b_allocation (**************************************************************************) (** {2 Other useful functions} *) (**************************************************************************) let has_code_annot ?emitter stmt = match emitter with | None -> Code_annots.mem stmt | Some e -> try let tbl = Code_annots.find stmt in Emitter.Usable_emitter.Hashtbl.mem tbl (Emitter.get e) with Not_found -> false exception Found of Emitter.t let emitter_of_global a = let h = Globals.find a in try Emitter.Usable_emitter.Hashtbl.iter (fun e () -> raise (Found (Emitter.Usable_emitter.get e))) h; assert false with Found e -> e let logic_info_of_global s = let check_logic_info li acc = if li.l_var_info.lv_name = s then li::acc else acc in let rec check_one acc = function | Dfun_or_pred(li,_) | Dinvariant(li,_) | Dtype_annot(li,_) -> check_logic_info li acc | Daxiomatic (_,l,_) -> List.fold_left check_one acc l | Dtype _ | Dvolatile _ | Dlemma _ | Dmodel_annot _ | Dcustom_annot _ -> acc in fold_global (fun _ g acc -> check_one acc g) [] let behavior_names_of_stmt_in_kf kf = match kf.fundec with | Definition(def, _) -> List.fold_left (fun known_names stmt -> List.fold_left (fun known_names (_bhv,spec) -> (List.map (fun x -> x.b_name) spec.spec_behavior) @ known_names) known_names (Logic_utils.extract_contract (code_annot stmt))) [] def.sallstmts | Declaration _ -> [] let spec_function_behaviors kf = List.map (fun x -> x.b_name) (behaviors ~populate:false kf) let all_function_behaviors kf = behavior_names_of_stmt_in_kf kf @ spec_function_behaviors kf (* [JS 2012/06/01] TODO: better way to generate fresh name *) let fresh_behavior_name kf name = let existing_behaviors = all_function_behaviors kf in let rec aux i = let name = name ^ "_" ^ (string_of_int i) in if List.mem name existing_behaviors then aux (i+1) else name in if List.mem name existing_behaviors then aux 0 else name let code_annot_of_kf kf = match kf.fundec with | Definition(f, _) -> List.fold_left (fun acc stmt -> fold_code_annot (fun _ a acc -> (stmt, a) :: acc) stmt acc) [] f.sallstmts | Declaration _ -> [] (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/logic/annotations.mli0000644000175000017500000004454712155630223020736 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Annotations in the AST. The AST should be computed before calling functions of this module. @modify Oxygen-20120901 fully rewritten. @plugin development guide *) open Cil_types (**************************************************************************) (** {2 Getting annotations} *) (**************************************************************************) (**************************************************************************) (** {3 Code annotations} *) (**************************************************************************) val code_annot: ?emitter:Emitter.t -> ?filter:(code_annotation -> bool) -> stmt -> code_annotation list (** Get all the code annotations attached to the given statement. If [emitter] (resp. [filter]) is specified, return only the annotations that has been generated by this [emitter] (resp. that satisfies the given predicate). *) val code_annot_emitter: ?filter:(Emitter.t -> code_annotation -> bool) -> stmt -> (code_annotation * Emitter.t) list (** Same as {!code_annot}, but also returns the emitter who emitted the annotation. @since Fluorine-20130401 *) (**************************************************************************) (** {3 Function Contracts} *) (**************************************************************************) exception No_funspec of Emitter.t val funspec: ?emitter:Emitter.t -> ?populate:bool -> kernel_function -> funspec (** Get the contract associated to the given function. If [emitter] is specified, return only the annotations that has been generated by this [emitter]. If [populate] is set to [false] (default is [true]), then the default contract of function declaration is generated. *) val behaviors: ?emitter:Emitter.t -> ?populate:bool -> kernel_function -> (identified_predicate, identified_term) behavior list (** Get the behaviors clause of the contract associated to the given function. Meaning of [emitter] and [populate] is similar to {!funspec}. *) val decreases: ?emitter:Emitter.t -> ?populate:bool -> kernel_function -> term variant option (** If any, get the decrease clause of the contract associated to the given function. Meaning of [emitter] and [populate] is similar to {!funspec}. *) val terminates: ?emitter:Emitter.t -> ?populate:bool -> kernel_function -> identified_predicate option (** If any, get the terminates clause of the contract associated to the given function. Meaning of [emitter] and [populate] is similar to {!funspec}. *) val complete: ?emitter:Emitter.t -> ?populate:bool -> kernel_function -> string list list (** Get the complete behaviors clause of the contract associated to the given function. Meaning of [emitter] and [populate] is similar to {!funspec}. *) val disjoint: ?emitter:Emitter.t -> ?populate:bool -> kernel_function -> string list list (** If any, get the disjoint behavior clause of the contract associated to the given function. Meaning of [emitter] and [populate] is similar to {!funspec}. *) (**************************************************************************) (** {3 Global Annotations} *) (**************************************************************************) val model_fields: ?emitter:Emitter.t -> typ -> model_info list (** returns the model fields attached to a given type (either directly or because the type is a typedef of something that has model fields. @since Fluorine-20130401 *) (**************************************************************************) (** {2 Iterating over annotations} *) (**************************************************************************) val iter_code_annot: (Emitter.t -> code_annotation -> unit) -> stmt -> unit (** Iter on each code annotation attached to the given statement. *) val fold_code_annot: (Emitter.t -> code_annotation -> 'a -> 'a) -> stmt -> 'a -> 'a (** Fold on each code annotation attached to the given statement. *) val iter_all_code_annot: (stmt -> Emitter.t -> code_annotation -> unit) -> unit (** Iter on each code annotation of the program. *) val fold_all_code_annot: (stmt -> Emitter.t -> code_annotation -> 'a -> 'a) -> 'a -> 'a (** Fold on each code annotation of the program. *) val iter_global: (Emitter.t -> global_annotation -> unit) -> unit (** Iter on each global annotation of the program. *) val fold_global: (Emitter.t -> global_annotation -> 'a -> 'a) -> 'a -> 'a (** Fold on each global annotation of the program. *) val iter_requires: (Emitter.t -> identified_predicate -> unit) -> kernel_function -> string -> unit (** Iter on the requires of the corresponding behavior. @since Fluorine-20130401 *) val fold_requires: (Emitter.t -> identified_predicate -> 'a -> 'a) -> kernel_function -> string -> 'a -> 'a (** Fold on the requires of the corresponding behavior. *) val iter_assumes: (Emitter.t -> identified_predicate -> unit) -> kernel_function -> string -> unit (** Iter on the assumes of the corresponding behavior. @since Fluorine-20130401 *) val fold_assumes: (Emitter.t -> identified_predicate -> 'a -> 'a) -> kernel_function -> string -> 'a -> 'a (** Fold on the assumes of the corresponding behavior. *) val iter_ensures: (Emitter.t -> (termination_kind * identified_predicate) -> unit) -> kernel_function -> string -> unit (** Iter on the ensures of the corresponding behavior. @since Fluorine-20130401 *) val fold_ensures: (Emitter.t -> (termination_kind * identified_predicate) -> 'a -> 'a) -> kernel_function -> string -> 'a -> 'a (** Fold on the ensures of the corresponding behavior. *) val iter_assigns: (Emitter.t -> identified_term assigns -> unit) -> kernel_function -> string -> unit (** Iter on the assigns of the corresponding behavior. @since Fluorine-20130401 *) val fold_assigns: (Emitter.t -> identified_term assigns -> 'a -> 'a) -> kernel_function -> string -> 'a -> 'a (** Fold on the assigns of the corresponding behavior. *) val iter_allocates: (Emitter.t -> identified_term allocation -> unit) -> kernel_function -> string -> unit (** Iter on the allocates of the corresponding behavior. @since Fluorine-20130401 *) val fold_allocates: (Emitter.t -> identified_term allocation -> 'a -> 'a) -> kernel_function -> string -> 'a -> 'a (** Fold on the allocates of the corresponding behavior. *) val iter_behaviors: (Emitter.t -> (identified_predicate, identified_term) behavior -> unit) -> kernel_function -> unit (** Iter on the behaviors of the given kernel function. @since Fluorine-20130401 *) val fold_behaviors: (Emitter.t -> (identified_predicate, identified_term) behavior -> 'a -> 'a) -> kernel_function -> 'a -> 'a (** Fold on the behaviors of the given kernel function. *) val iter_complete: (Emitter.t -> string list -> unit) -> kernel_function -> unit (** Iter on the complete clauses of the given kernel function. @since Fluorine-20130401 *) val fold_complete: (Emitter.t -> string list -> 'a -> 'a) -> kernel_function -> 'a -> 'a (** Fold on the complete clauses of the given kernel function. *) val iter_disjoint: (Emitter.t -> string list -> unit) -> kernel_function -> unit (** Iter on the disjoint clauses of the given kernel function. @since Fluorine-20130401 *) val fold_disjoint: (Emitter.t -> string list -> 'a -> 'a) -> kernel_function -> 'a -> 'a (** Fold on the disjoint clauses of the given kernel function. *) val iter_terminates: (Emitter.t -> identified_predicate -> unit) -> kernel_function -> unit (** apply f to the terminates predicate if any. @since Fluorine-20130401 *) val fold_terminates: (Emitter.t -> identified_predicate -> 'a -> 'a) -> kernel_function -> 'a -> 'a (** apply f to the terminates predicate if any. *) val iter_decreases: (Emitter.t -> term variant -> unit) -> kernel_function -> unit (** apply f to the decreases term if any. @since Fluorine-20130401 *) val fold_decreases: (Emitter.t -> term variant -> 'a -> 'a) -> kernel_function -> 'a -> 'a (** apply f to the decreases term if any. *) (**************************************************************************) (** {2 Adding annotations} *) (**************************************************************************) val add_code_annot: Emitter.t -> ?kf:kernel_function -> stmt -> code_annotation -> unit (** Add a new code annotation attached to the given statement. If [kf] is provided, the function runs faster. *) val add_assert: Emitter.t -> ?kf:kernel_function -> stmt -> predicate named -> unit (** Add an assertion attached to the given statement. If [kf] is provided, the function runs faster. @plugin development guide *) val add_global: Emitter.t -> global_annotation -> unit (** Add a new global annotation into the program. *) val add_behaviors: ?register_children:bool -> Emitter.t -> kernel_function -> (identified_predicate, identified_term) behavior list -> unit (** Add new behaviors into the contract of the given function. if [register_children] is [true] (the default), inner clauses of the behavior will also be registered by the function. *) val add_decreases: Emitter.t -> kernel_function -> term variant -> unit (** Add a decrease clause into the contract of the given function. No decrease clause must previously be attached to this function. *) val add_terminates: Emitter.t -> kernel_function -> identified_predicate -> unit (** Add a terminates clause into the contract of the given function. No terminates clause must previously be attached to this function. *) val add_complete: Emitter.t -> kernel_function -> string list -> unit (** Add a new complete behaviors clause into the contract of the given function. *) val add_disjoint: Emitter.t -> kernel_function -> string list -> unit (** Add a new disjoint behaviors clause into the contract of the given function. *) val add_requires: Emitter.t -> kernel_function -> string -> identified_predicate list -> unit (** Add new requires clauses into the given behavior (provided by its name) of the given function. *) val add_assumes: Emitter.t -> kernel_function -> string -> identified_predicate list -> unit (** Add new assumes clauses into the given behavior (provided by its name) of the given function. *) val add_ensures: Emitter.t -> kernel_function -> string -> (termination_kind * identified_predicate) list -> unit (** Add new ensures clauses into the given behavior (provided by its name) of the given function. *) val add_assigns: keep_empty:bool -> Emitter.t -> kernel_function -> string -> identified_term assigns -> unit (** Add new assigns into the given behavior (provided by its name) of the given function. If [keep_empty] is [true] and the assigns clause were empty, then the assigns clause remains empty. (That corresponds to the ACSL semantics of an assigns clause: if no assigns is specified, that is equivalent to assigns everything.) *) val add_allocates: Emitter.t -> kernel_function -> string -> identified_term allocation -> unit (** Add new allocates into the given behavior (provided by its name) of the given function. *) (**************************************************************************) (** {2 Removing annotations} *) (**************************************************************************) val remove_code_annot: Emitter.t -> ?kf:kernel_function -> stmt -> code_annotation -> unit (** Remove a code annotation attached to a statement. The provided emitter must be the one that emits this annotation. Do nothing if the annotation does not exist, or if the emitter is not ok. *) val remove_global: Emitter.t -> global_annotation -> unit (** Remove a global annotation. The provided emitter must be the one that emits this annotation. Do nothing if the annotation does not exist, or if the emitter is not ok. *) val remove_behavior: Emitter.t -> kernel_function -> (identified_predicate, identified_term) behavior -> unit (** Remove a behavior attached to a function. The provided emitter must be the one that emits this annotation. Do nothing if the annotation does not exist, or if the emitter is not ok. *) val remove_behavior_components: Emitter.t -> kernel_function -> funbehavior -> unit (** remove all the component of a behavior, but keeps the name (so as to avoid issues with disjoint/complete clauses. *) val remove_decreases: Emitter.t -> kernel_function -> unit (** Remove the decreases clause attached to a function. The provided emitter must be the one that emits this annotation. Do nothing if the annotation does not exist, or if the emitter is not ok. *) val remove_terminates: Emitter.t -> kernel_function -> unit (** Remove the terminates clause attached to a function. The provided emitter must be the one that emits this annotation. Do nothing if the annotation does not exist, or if the emitter is not ok. *) val remove_complete: Emitter.t -> kernel_function -> string list -> unit (** Remove a complete behaviors clause attached to a function. The provided emitter must be the one that emits this annotation. Do nothing if the annotation does not exist, or if the emitter is not ok. *) val remove_disjoint: Emitter.t -> kernel_function -> string list -> unit (** Remove a disjoint behaviors clause attached to a function. The provided emitter must be the one that emits this annotation. Do nothing if the annotation does not exist, or if the emitter is not ok. *) val remove_requires: Emitter.t -> kernel_function -> identified_predicate -> unit (** Remove a requires clause from the spec of the given function. Do nothing if the predicate does not exist or was not emitted by the given emitter. *) val remove_assumes: Emitter.t -> kernel_function -> identified_predicate -> unit (** Remove an assumes clause from the spec of the given function. Do nothing if the predicate does not exist or was not emitted by the given emitter. *) val remove_ensures: Emitter.t -> kernel_function -> (termination_kind * identified_predicate) -> unit (** Remove a post-condition from the spec of the given function. Do nothing if the post-cond does not exist or was not emitted by the given emitter. *) val remove_allocates: Emitter.t -> kernel_function -> identified_term allocation -> unit (** Remove the corresponding allocation clause. Do nothing if the clause does not exist or was not emitted by the given emitter. *) val remove_assigns: Emitter.t -> kernel_function -> identified_term assigns -> unit (** Remove the corresponding assigns clause. Do nothing if the clause does not exist or was not emitted by the given emitter. *) (**************************************************************************) (** {2 Other useful functions} *) (**************************************************************************) val has_code_annot: ?emitter:Emitter.t -> stmt -> bool (** @return [true] iff there is some annotation attached to the given statement (and generated by the given emitter, if any). *) val emitter_of_global: global_annotation -> Emitter.t (** @return the emitter which generates a global annotation. @raise Not_found if the global annotation is not registered. *) val logic_info_of_global: string -> logic_info list (** @return the purely logic var of the given name @raise Not_found if no global annotation declare such a variable *) val behavior_names_of_stmt_in_kf: kernel_function -> string list (** @return all the behavior names included in any statement contract of the given function. *) val code_annot_of_kf: kernel_function -> (stmt * code_annotation) list (** @return all the annotations attached to a statement of the given function. *) val fresh_behavior_name: kernel_function -> string -> string (** @return a valid behavior name for the given function and based on the given name. *) (**************************************************************************) (** {2 States} *) (**************************************************************************) val code_annot_state: State.t (** The state which stores all the code annotations of the program. *) val funspec_state: State.t (** The state which stores all the function contracts of the program. *) val global_state: State.t (** The state which stores all the global annotations of the program. *) (**/**) (**************************************************************************) (** {2 Internal stuff} *) (**************************************************************************) val populate_spec_ref: (kernel_function -> funspec -> unit) ref val unsafe_add_global: Emitter.t -> global_annotation -> unit val register_funspec: ?emitter:Emitter.t -> ?force:bool -> kernel_function -> unit val remove_alarm_ref: (Emitter.Usable_emitter.t -> stmt -> code_annotation -> unit) ref (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/toplevel/0000755000175000017500000000000012155634040016416 5ustar mehdimehdiframa-c-Fluorine-20130601/src/toplevel/toplevel_config.ml0000644000175000017500000000317712155630234022140 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let () = Topdirs.dir_directory Config.libdir frama-c-Fluorine-20130601/src/rte/0000755000175000017500000000000012155634040015356 5ustar mehdimehdiframa-c-Fluorine-20130601/src/rte/RteGen.mli0000644000175000017500000000323712155630217017254 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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: they are registered in {!Db.Value}. *) frama-c-Fluorine-20130601/src/rte/generator.mli0000644000175000017500000000475612155630217020065 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module type S = sig val is_computed: Kernel_function.t -> bool val set: Kernel_function.t -> bool -> unit val self: State.t end module Signed: S module Mem_access: S module Div_mod: S module Downcast: S module Unsigned_overflow: S module Unsigned_downcast: S module Float_to_int: S module Called_precond: S val emitter: Emitter.t val precond_status: unit -> Db.RteGen.status_accessor val signed_status: unit -> Db.RteGen.status_accessor val div_mod_status: unit -> Db.RteGen.status_accessor val downcast_status: unit -> Db.RteGen.status_accessor val mem_access_status: unit -> Db.RteGen.status_accessor val float_to_int_status: unit -> Db.RteGen.status_accessor val unsigned_overflow_status: unit -> Db.RteGen.status_accessor val unsigned_downcast_status: unit -> Db.RteGen.status_accessor val all_status: unit -> Db.RteGen.status_accessor list (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/rte/generator.ml0000644000175000017500000001265612155630217017712 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 module type S = sig val is_computed: kernel_function -> bool val set: kernel_function -> bool -> unit val self: State.t end module Make (M:sig val name:string val default: kernel_function -> bool val parameter: Parameter.t val additional_parameters: Parameter.t list end) = struct module H = Kernel_function.Make_Table (Datatype.Bool) (struct let name = M.name let size = 17 let dependencies = let extract p = State.get p.Parameter.name in List.map extract (M.parameter :: M.additional_parameters) @ [ Ast.self; Options.Trivial.self] end) let is_computed kf = H.memo M.default kf let set = H.replace let self = H.self let triple = M.name, set, is_computed end module Signed = Make (struct let name = "signed_overflow" let default kf = not (Kernel_function.is_definition kf) let parameter = Kernel.SignedOverflow.parameter let additional_parameters = [] end) module Mem_access = Make (struct let name = "mem_access" let default kf = not (Kernel_function.is_definition kf) let parameter = Options.DoMemAccess.parameter let additional_parameters = [ Kernel.SafeArrays.parameter ] end) module Div_mod = Make (struct let name = "division_by_zero" let default kf = not (Kernel_function.is_definition kf) let parameter = Options.DoDivMod.parameter let additional_parameters = [] end) module Downcast = Make (struct let name = "downcast" let default kf = not (Kernel_function.is_definition kf) let parameter = Kernel.SignedDowncast.parameter let additional_parameters = [] end) module Unsigned_overflow = Make (struct let name = "unsigned_overflow" let default kf = not (Kernel_function.is_definition kf) let parameter = Kernel.UnsignedOverflow.parameter let additional_parameters = [] end) module Unsigned_downcast = Make (struct let name = "unsigned_downcast" let default kf = not (Kernel_function.is_definition kf) let parameter = Kernel.UnsignedDowncast.parameter let additional_parameters = [] end) module Float_to_int = Make (struct let name = "float_to_int" let default kf = not (Kernel_function.is_definition kf) let parameter = Options.DoFloatToInt.parameter let additional_parameters = [] end) module Called_precond = Make (struct let name = "precondition" let default kf = not (Kernel_function.is_definition kf) let parameter = Options.DoCalledPrecond.parameter let additional_parameters = [] end) let proxy = State_builder.Proxy.create "RTE" State_builder.Proxy.Backward [ Signed.self; Mem_access.self; Div_mod.self; Downcast.self; Unsigned_downcast.self; Unsigned_overflow.self; Float_to_int.self; Called_precond.self ] let self = State_builder.Proxy.get proxy let () = Db.RteGen.self := self let precond_status () = Called_precond.triple let signed_status () = Signed.triple let div_mod_status () = Div_mod.triple let downcast_status () = Downcast.triple let mem_access_status () = Mem_access.triple let float_to_int_status () = Float_to_int.triple let unsigned_overflow_status () = Unsigned_overflow.triple let unsigned_downcast_status () = Unsigned_downcast.triple let all_status () = [ precond_status (); signed_status (); mem_access_status (); div_mod_status (); downcast_status (); float_to_int_status (); unsigned_overflow_status (); unsigned_downcast_status (); ] let emitter = Emitter.create "rte" [ Emitter.Property_status; Emitter.Alarm ] ~correctness:[ Kernel.SafeArrays.parameter ] ~tuning:[] (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/rte/visit.mli0000644000175000017500000000404112155630217017220 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 annotate_kf: kernel_function -> unit val compute: unit -> unit val do_precond: kernel_function -> unit val do_all_rte: kernel_function -> unit val do_rte: kernel_function -> unit val rte_annotations: stmt -> code_annotation list val do_stmt_annotations: kernel_function -> stmt -> code_annotation list val do_exp_annotations: kernel_function -> stmt -> exp -> code_annotation list (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/rte/options.ml0000644000175000017500000001150112155630217017403 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let help_msg = "generates annotations for runtime error checking and \ preconditions at call sites" include Plugin.Register (struct let name = "rte annotation" let shortname = "rte" let help = help_msg end) (* enabling/disabling plugin *) module Enabled = False (struct let option_name = "-rte" let help = "when on (off by default), " ^ help_msg end) (* annotates division by zero (undefined behavior) *) module DoDivMod = True (struct let option_name = "-rte-div" let help = "when on (default), annotate for division by zero" end) (* annotates division by zero (undefined behavior) *) module DoFloatToInt = True (struct let option_name = "-rte-float-to-int" let help = "when on (default), annotate casts from floating-point to \ integer" end) (* annotates invalid memory access (undefined behavior) *) module DoMemAccess = True (struct let option_name = "-rte-mem" let help = "when on (default), annotate for valid pointer or \ array access" end) (* if DoAll is true: all other options become true, except for UnsignedOverflow, UnsignedDownCast and "PreConds" <=> only "true" runtime error and some implementation-defined behaviors assertions are generated *) module DoAll = True (struct let option_name = "-rte-all" let help = "when on (by default), generate everything (supersedes all -rte-no-*)" end) let () = DoAll.add_set_hook (fun _ b -> DoMemAccess.set b; DoDivMod.set b; DoFloatToInt.set b; Kernel.SignedOverflow.set b; Kernel.SignedDowncast.set b) (* uses results of basic constant propagation in order to check validity / invalidity of generated assertions, emitting a status if possible *) module Trivial = False (struct let option_name = "-rte-trivial-annotations" let help = "generate annotations for constant expressions, even when \ they trivially hold" (* if on, evaluates constants in order to check if assertions are trivially true / false *) end) (* For functions having an ACSL contract, generates a corresponding statement contract before each function's call statement (provided the call is not performed thorugh a function pointer). *) module DoCalledPrecond = False (struct let option_name = "-rte-precond" let help = "when on (off by default), generate assertions on function calls based on contracts" end) (* emits a warning when an assertion generated by rte is clearly invalid (using constant folding, see ConstFold *) module Warn = True (struct let option_name = "-rte-warn" let help = "when on (default), emits warning on broken asserts" end) (* this option allows the user to select a set of functions on which the plug-in performs its jobs (and only those). By default all functions are annotated *) module FunctionSelection = StringSet (struct let option_name = "-rte-select" let arg_name = "fun" let help = "select for analysis (default all functions)" end) let warn ?source fmt = warning ?source ~current:true ~once:true fmt (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/rte/rte.mli0000644000175000017500000000504612155630217016662 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 type ('a, 'b) alarm_gen = remove_trivial:bool -> warning:bool -> kernel_function -> kinstr -> 'a -> 'b val lval_assertion: read_only: Alarms.access_kind -> (lval, unit) alarm_gen val divmod_assertion: (exp, unit) alarm_gen val signed_div_assertion: (exp * exp * exp, unit) alarm_gen val shift_alarm: (exp * int option, unit) alarm_gen val signed_shift_assertion: (exp * binop * exp * exp, unit) alarm_gen val unsigned_shift_assertion: (exp * exp * exp, unit) alarm_gen val mult_sub_add_assertion: (bool * exp * binop * exp * exp, unit) alarm_gen val uminus_assertion: (exp, unit) alarm_gen val signed_downcast_assertion: (typ * exp, bool) alarm_gen val unsigned_downcast_assertion: (typ * exp, bool) alarm_gen val float_to_int_assertion: (typ * exp, bool) alarm_gen val generated_annotations: unit -> code_annotation list val reset_generated_annotations: unit -> unit val save_alarms: bool ref (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/rte/options.mli0000644000175000017500000000402412155630217017556 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.S module Enabled: Plugin.Bool module DoAll: Plugin.Bool module DoDivMod : Plugin.Bool module DoFloatToInt : Plugin.Bool module DoMemAccess : Plugin.Bool module DoCalledPrecond : Plugin.Bool module Trivial : Plugin.Bool module Warn : Plugin.Bool module FunctionSelection : Plugin.String_set val warn: ?source:Lexing.position -> ('a, Format.formatter, unit) format -> 'a (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/rte/register.ml0000644000175000017500000001176612155630217017551 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let journal_register ?comment is_dyn name ty_arg fctref fct = let ty = Datatype.func ty_arg Datatype.unit in Db.register (Db.Journalize("RteGen." ^ name, ty)) fctref fct; if is_dyn then let _ = Dynamic.register ?comment ~plugin:"RteGen" name ty ~journalize:true fct in () let nojournal_register fctref fct = Db.register Db.Journalization_not_required fctref fct let () = journal_register false "annotate_kf" Kernel_function.ty Db.RteGen.annotate_kf Visit.annotate_kf; journal_register false "compute" Datatype.unit Db.RteGen.compute Visit.compute; journal_register true "do_precond" Kernel_function.ty Db.RteGen.do_precond Visit.do_precond ~comment:"Generate RTE annotations corresponding to -rte-precond in the \ given function."; journal_register true ~comment:"Generate RTE annotations corresponding to -rte in the \ given function." "do_all_rte" Kernel_function.ty Db.RteGen.do_all_rte Visit.do_all_rte; journal_register false "do_rte" Kernel_function.ty Db.RteGen.do_rte Visit.do_rte; nojournal_register Db.RteGen.get_precond_status Generator.precond_status; nojournal_register Db.RteGen.get_signedOv_status Generator.signed_status; nojournal_register Db.RteGen.get_divMod_status Generator.div_mod_status; nojournal_register Db.RteGen.get_downCast_status Generator.downcast_status; nojournal_register Db.RteGen.get_memAccess_status Generator.mem_access_status; nojournal_register Db.RteGen.get_unsignedOv_status Generator.unsigned_overflow_status; nojournal_register Db.RteGen.get_unsignedDownCast_status Generator.unsigned_downcast_status; nojournal_register Db.RteGen.get_all_status Generator.all_status (* dynamic registration *) let _ = Dynamic.register ~comment:"The emitter used for generating RTE annotations" ~plugin:"RteGen" "emitter" Emitter.ty ~journalize:false Generator.emitter (* retrieve list of generated rte annotations (not precond) for a given stmt *) let _ = Dynamic.register ~comment:"Get the list of annotations previously emitted by RTE for the \ given statement." ~plugin:"RteGen" "get_rte_annotations" (Datatype.func Cil_datatype.Stmt.ty (let module L = Datatype.List(Cil_datatype.Code_annotation) in L.ty)) ~journalize:true Visit.rte_annotations let _ = Dynamic.register ~comment:"Generate RTE annotations corresponding to the given stmt of \ the given function." ~plugin:"RteGen" "stmt_annotations" (Datatype.func2 Kernel_function.ty Cil_datatype.Stmt.ty (let module L = Datatype.List(Cil_datatype.Code_annotation) in L.ty)) ~journalize:false Visit.do_stmt_annotations let _ = Dynamic.register ~comment:"Generate RTE annotations corresponding to the given exp \ of the given stmt in the given function." ~plugin:"RteGen" "exp_annotations" (Datatype.func3 Kernel_function.ty Cil_datatype.Stmt.ty Cil_datatype.Exp.ty (let module L = Datatype.List(Cil_datatype.Code_annotation) in L.ty)) ~journalize:false Visit.do_exp_annotations let main () = (* reset "rte generated"/"called precond generated" properties for all functions *) if Options.Enabled.get () then begin Options.feedback ~level:2 "generating annotations"; !Db.RteGen.compute (); Options.feedback ~level:2 "annotations computed" end let () = Db.Main.extend main (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/rte/rte.ml0000644000175000017500000005334312155630217016514 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 type ('a, 'b) alarm_gen = remove_trivial:bool -> warning:bool -> kernel_function -> kinstr -> 'a -> 'b let annotations = ref [] let generated_annotations () = !annotations let reset_generated_annotations () = annotations := [] let save_alarms = ref true let register_alarm e kf ki ?status alarm = let a, _ = Alarms.register e ~kf ki ?status ~save:!save_alarms alarm in annotations := a :: !annotations; a (* [JS 2012/10/17] pretty printing hack to preserve previous behavior which does not display labels of generated assertions. *) let local_printer: Printer.extensible_printer = object (self) inherit Printer.extensible_printer () method code_annotation fmt ca = match ca.annot_content with | AAssert(_, p) -> (* ignore the name *) Format.fprintf fmt "%a" self#predicate p.content | _ -> assert false end (* Tries to evaluate expr as a constant value (Int64.t). Uses Cil constant folding (e.g. for (-0x7ffffff -1) => Some (-2147483648)) on 32 bits *) let get_expr_val expr = let cexpr = Cil.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 (Cil.charConstToInt c) | CInt64 (d64,_,_) -> Some d64 | _ -> None in get_constant_expr_val c | _ -> None (* Creates [0 <= e] and [e < size] assertions *) let valid_index ~remove_trivial kf kinstr e size = let emit left = ignore (register_alarm Generator.emitter kf kinstr (Alarms.Index_out_of_bound(e, if left then None else Some size))) in if remove_trivial then begin (* See if the two assertions do not trivially hold. In this case, do not return then *) let v_e = get_expr_val e in let v_size = get_expr_val size in let neg_ok = Extlib.may_map ~dft:false (Integer.le Integer.zero) v_e || Cil.isUnsignedInteger (Cil.typeOf e) in if not neg_ok then emit true; let pos_ok = match v_e, v_size with | Some v_e, Some v_size -> Integer.lt v_e v_size | None, _ | _, None -> false in if not pos_ok then emit false end else begin emit true; emit false end (* returns the assertion associated with an lvalue: returns non empty assertions only on pointer dereferencing and array access. Dereferencing a function pointer generates no assertion (but a warning is emitted). The validity assertions are emitted using [valid] if [~read_only] is false, or with [valid_read] otherwise *) let lval_assertion ~read_only ~remove_trivial ~warning:_ kf kinstr lv = (* For accesses to known arrays we generate an assertions that constrains the index. This is simpler than the [\valid] assertion *) let rec check_array_access default off typ in_struct = match off with | NoOffset -> if default then ignore (register_alarm Generator.emitter kf kinstr (Alarms.Memory_access(lv, read_only))) | Field (fi, off) -> (* Mark that we went through a struct field, then recurse *) check_array_access default off fi.ftype true | Index (e, off) -> match Cil.unrollType typ with | TArray (bt, Some size, _, _) -> if Kernel.SafeArrays.get () || not in_struct then begin (* Generate an assertion for this access, then go deeper in case other accesses exist *) valid_index kf kinstr e size ~remove_trivial; check_array_access default off bt in_struct end else (* Access to an array embedded in a struct with option [-unsafe-arrays]. Honor the option and generate only the default [\valid] assertion *) check_array_access true off bt in_struct | TArray (bt, None, _, _) -> check_array_access true off bt in_struct | _ -> assert false in match lv with | Var vi , off -> check_array_access false off vi.vtype false | Mem _exp as lh, off -> let dft = if Cil.isFunctionType (Cil.typeOfLval lv) then begin Options.warn "no predicate available yet to check validity of function pointer \ dereferencing %a" Printer.pp_lval lv; false end else true in check_array_access dft off (Cil.typeOfLhost lh) false (* assertion for unary minus signed overflow *) let uminus_assertion ~remove_trivial ~warning kf kinstr exp = (* - expr overflows if exp is TYPE_MIN *) let t = Cil.unrollType (Cil.typeOf exp) in let size = Cil.bitsSizeOf t in let min_ty = Cil.min_signed_number size in (* alarm is bound <= exp, hence bound must be MIN_INT+1 *) let bound = Integer.add Integer.one min_ty in let assertion ?status () = register_alarm Generator.emitter ?status kf kinstr (Alarms.Overflow(Alarms.Signed, exp, bound, Alarms.Lower_bound)) in if remove_trivial then begin match get_expr_val exp with | None -> ignore (assertion ()) | Some a64 -> (* constant operand *) if Integer.equal a64 min_ty then let a = assertion ~status:Property_status.False_if_reachable () in if warning then Options.warn "unary minus assert broken: %a" local_printer#code_annotation a end (* assertions for multiplication/addition/subtraction signed overflow *) let mult_sub_add_assertion ~remove_trivial ~warning kf kinstr (signed, exp, op, lexp, rexp) = (* signed multiplication/addition/subtraction: the expression overflows iff its integer value is strictly more than TYPE_MAX or strictly less than TYPE_MIN *) let t = Cil.unrollType (Cil.typeOf exp) in let size = Cil.bitsSizeOf t in if (not signed && size > 32) || size > 64 then (* should never happen *) Options.warn "bitsSize of %a > %d: not treated" Printer.pp_exp exp (if signed then 64 else 32) else let min_ty, max_ty = if signed then Cil.min_signed_number size, Cil.max_signed_number size else Integer.zero, Cil.max_unsigned_number size in let assertion ?status up = let bound, b = if up then max_ty, Alarms.Upper_bound else min_ty, Alarms.Lower_bound in register_alarm Generator.emitter ?status kf kinstr (Alarms.Overflow ((if signed then Alarms.Signed else Alarms.Unsigned), exp, bound, b)) in let full_assertion () = ignore (assertion false); ignore (assertion true) in if remove_trivial then match get_expr_val lexp, get_expr_val rexp with | None, None -> full_assertion () | Some a64, None | None, Some a64 -> (* one operand is constant *) (match op with | MinusA -> ignore (assertion false) | PlusA -> ignore (assertion true) | Mult -> (* multiplying by 1 or 0 is not dangerous *) if not (Integer.equal a64 Integer.zero || Integer.equal a64 Integer.one) then (* multiplying by -1 is dangerous (albeit seldom) *) if Integer.equal a64 Integer.minus_one then ignore (assertion false) else full_assertion () | _ -> assert false) | Some big_a64, Some big_b64 -> let warn up = let status = Property_status.False_if_reachable in let a = assertion ~status up in if warning then Options.warn "%s overflow assert broken: %a" (if signed then "signed" else "unsigned") local_printer#code_annotation a in (* both operands are constant *) (match op with | MinusA -> let big_diff = Integer.sub big_a64 big_b64 in if Integer.lt big_diff min_ty then warn false | PlusA -> let big_add = Integer.add big_a64 big_b64 in if Integer.gt big_add max_ty then warn true | Mult -> let big_mult = Integer.mul big_a64 big_b64 in if Integer.gt big_mult max_ty then warn true else if Integer.lt big_mult min_ty then warn false | _ -> assert false) else full_assertion () (* assertions for division and modulo (divisor is 0) *) let divmod_assertion ~remove_trivial ~warning kf kinstr divisor = (* division or modulo: overflow occurs when divisor is equal to zero *) let assertion ?status () = register_alarm Generator.emitter ?status kf kinstr (Alarms.Division_by_zero divisor) in if remove_trivial then (match get_expr_val divisor with | None -> (* divisor is not a constant (or it's value has not been computed) *) ignore (assertion ()); | Some v64 -> if Integer.equal v64 Integer.zero then (* divide by 0 *) let a = assertion ~status:Property_status.False_if_reachable () in if warning then Options.warn "divisor assert broken: %a" local_printer#code_annotation a; (* else divide by constant which is not 0: nothing to assert *)) else ignore (assertion ()) (* assertion for signed division overflow *) let signed_div_assertion ~remove_trivial ~warning kf kinstr (exp, lexp, rexp) = (* Signed division: overflow occurs when dividend is equal to the the minimum (negative) value for the signed integer type, and divisor is equal to -1. Under the hypothesis (cf Value) that integers are 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 division) *) let t = Cil.unrollType (Cil.typeOf rexp) in let size = Cil.bitsSizeOf t in (* check dividend_expr / divisor_expr : if constants ... *) if size > 64 then (* should never happen *) Options.warn "bitsSize of %a > 64: not treated" Printer.pp_exp exp else (* compute smallest representable "size bits" (signed) integer *) let max_ty = Cil.max_signed_number size in let emit ?status () = register_alarm ?status Generator.emitter kf kinstr (Alarms.Overflow(Alarms.Signed, exp, max_ty, Alarms.Upper_bound)) in if remove_trivial then let min = Cil.min_signed_number size in match get_expr_val lexp, get_expr_val rexp with | Some e1, _ when not (Integer.equal e1 min) -> (* divident is constant, with an unproblematic value *) () | _, Some e2 when not (Integer.equal e2 Integer.minus_one) -> (* divisor is constant, with an unproblematic value *) () | Some _, Some _ -> (* invalid constant division *) let a = emit ~status:Property_status.False_if_reachable () in if warning then Options.warn "signed overflow assert broken: %a" local_printer#code_annotation a; | None, Some _ | Some _, None | None, None -> (* at least one is not constant: cannot conclude *) ignore (emit ()) else ignore (emit ()) let shift_alarm ~remove_trivial ~warning kf kinstr (exp, upper_bound) = let alarm ?status () = register_alarm Generator.emitter kf kinstr ?status (Alarms.Invalid_shift(exp, upper_bound)) in if remove_trivial then (match get_expr_val exp with | None -> ignore (alarm ()) | Some c64 -> (* operand is constant: check it is nonnegative and stricly less than the upper bound (if any) *) let upper_bound_ok = match upper_bound with | None -> true | Some u -> Integer.lt c64 (Integer.of_int u) in if not (Integer.ge c64 Integer.zero && upper_bound_ok) then begin let a = alarm ~status:Property_status.False_if_reachable () in if warning then Options.warn "shift assert broken (bad operand): %a" local_printer#code_annotation a end) else ignore (alarm ()) (* assertions for bitwise left/right shift signed overflow *) let signed_shift_assertion ~remove_trivial ~warning kf kinstr (exp, op, lexp, rexp) = (* - (1) right operand should be nonnegative and strictly less than the width of promoted left operand: now done by shift_right_operand_assertion - (2) (since signed version) left operand should be nonnegative (implementation defined for right shift, undefined for left shift) - (3) (for signed left shift): result should be representable in result type *) let t = Cil.unrollType (Cil.typeOf exp) in let size = Cil.bitsSizeOf t in if size <> Cil.bitsSizeOf (Cil.typeOf lexp) || size > 64 then (* size of result type should be size of left (promoted) operand *) Options.warn "problem with bitsSize of %a: not treated" Printer.pp_exp exp; shift_alarm remove_trivial warning kf kinstr (lexp, None); if op = Shiftlt then (* compute greatest representable "size bits" (signed) integer *) let maxValResult = Cil.max_signed_number size in let overflow_alarm ?status () = register_alarm Generator.emitter kf kinstr ?status (Alarms.Overflow(Alarms.Signed, exp, maxValResult, Alarms.Upper_bound)) in if remove_trivial then (match get_expr_val lexp, get_expr_val rexp with | None,_ | _, None -> ignore (overflow_alarm ()) | Some lval64, Some rval64 -> (* both operands are constant: check result is representable in result type *) if Integer.ge rval64 Integer.zero && Integer.gt (Integer.shift_left lval64 rval64) maxValResult then let a = overflow_alarm ~status:Property_status.False_if_reachable () in if warning then Options.warn "shift assert broken (signed overflow): %a" local_printer#code_annotation a) else ignore (overflow_alarm ()) (* Assertions for bitwise left shift unsigned overflow. this is allowed by C and NOT a runtime-error *) let unsigned_shift_assertion ~remove_trivial ~warning kf kinstr (exp, lexp, rexp) = (* result should be representable in result type *) let t = Cil.unrollType (Cil.typeOf exp) in let size = Cil.bitsSizeOf t in (* compute greatest reprensentable "size bits" unsigned integer *) let maxValResult = Cil.max_unsigned_number size in let alarm ?status () = (* 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 *) register_alarm Generator.emitter kf kinstr ?status (Alarms.Overflow(Alarms.Unsigned, exp, maxValResult, Alarms.Upper_bound)) in if remove_trivial then (match get_expr_val lexp, get_expr_val rexp with | None,_ | _, None -> ignore (alarm ()) | Some lval64, Some rval64 -> (* both operands are constant: check result is representable in result type *) if Integer.ge rval64 Integer.zero && Integer.gt (Integer.shift_left lval64 rval64) maxValResult then (* constant operators and assertion does not hold *) let a = alarm ~status:Property_status.False_if_reachable () in if warning then Options.warn "shift assert broken (unsigned overflow): %a" local_printer#code_annotation a) else ignore (alarm ()) (* assertion for downcasting an integer to an unsigned integer type without requiring modification of value to reach target domain (well-defined behavior though) *) let unsigned_downcast_assertion ~remove_trivial ~warning kf kinstr (ty, exp) = let e_typ = Cil.unrollType (Cil.typeOf exp) in match e_typ with | TInt (kind,_) -> let szTo = Cil.bitsSizeOf ty in let szFrom = Cil.bitsSizeOf e_typ in (if szTo < szFrom || Cil.isSigned kind then (* case signed to unsigned: requires signed to be >= 0 and also <= max of unsigned size *) (* cast unsigned to unsigned: ok is same bit size ; if target is <, requires <= max target *) let max_ty = Cil.max_unsigned_number szTo in let alarms ?status bound = register_alarm Generator.emitter kf kinstr ?status (Alarms.Overflow (Alarms.Unsigned_downcast, exp, (match bound with | Alarms.Lower_bound -> Integer.zero | Alarms.Upper_bound -> max_ty), bound)) in let full_alarms () = if Cil.isSigned kind then begin (* signed to unsigned *) ignore (alarms Alarms.Upper_bound); ignore (alarms Alarms.Lower_bound) end else (* unsigned to unsigned *) ignore (alarms Alarms.Upper_bound) in if remove_trivial then match get_expr_val exp with | None -> full_alarms () | Some a64 -> (if Integer.lt a64 Integer.zero then begin let a = alarms ~status:Property_status.False_if_reachable Alarms.Lower_bound in if warning then Options.warn "unsigned downcast assert broken: %a" local_printer#code_annotation a end else if Integer.gt a64 max_ty then let a = alarms ~status:Property_status.False_if_reachable Alarms.Upper_bound in if warning then Options.warn "unsigned downcast assert broken: %a" local_printer#code_annotation a) else full_alarms ()); true | _ -> false (* assertion for downcasting an integer to a signed integer type *) (* which can raise an implementation defined behavior *) let signed_downcast_assertion ~remove_trivial ~warning kf kinstr (ty, exp) = let e_typ = Cil.unrollType (Cil.typeOf exp) in match e_typ with | TInt (kind,_) -> (let szTo = Cil.bitsSizeOf ty in let szFrom = Cil.bitsSizeOf e_typ in if szTo < szFrom || (szTo == szFrom && not (Cil.isSigned kind)) then (* downcast: the expression result should fit on szTo bits *) let min_ty = Cil.min_signed_number szTo in let max_ty = Cil.max_signed_number szTo in let alarms ?status bound = register_alarm Generator.emitter kf kinstr ?status (Alarms.Overflow (Alarms.Signed_downcast, exp, (match bound with | Alarms.Lower_bound -> min_ty | Alarms.Upper_bound -> max_ty), bound)) in let full_alarms () = if Cil.isSigned kind then begin (* signed to signed *) ignore (alarms Alarms.Upper_bound); ignore (alarms Alarms.Lower_bound) end else ignore (alarms Alarms.Upper_bound) in if remove_trivial then match get_expr_val exp with | None -> full_alarms () | Some a64 -> (if Integer.lt a64 min_ty then begin let a = alarms ~status:Property_status.False_if_reachable Alarms.Lower_bound in if warning then Options.warn "signed downcast assert broken: %a" local_printer#code_annotation a end else if Integer.gt a64 max_ty then let a = alarms ~status:Property_status.False_if_reachable Alarms.Upper_bound in if warning then Options.warn "signed downcast assert broken: %a" local_printer#code_annotation a) else full_alarms ()); true | _ -> false (* assertion for casting a floating-point value to an integer *) let float_to_int_assertion ~remove_trivial ~warning kf kinstr (ty, exp) = let e_typ = Cil.unrollType (Cil.typeOf exp) in match e_typ, ty with | TFloat _, TInt (ikind,_) -> let szTo = Cil.bitsSizeOf ty in let min_ty, max_ty = if Cil.isSigned ikind then Cil.min_signed_number szTo, Cil.max_signed_number szTo else Integer.zero, Cil.max_unsigned_number szTo in let alarms ?status bound = register_alarm Generator.emitter kf kinstr ?status (Alarms.Float_to_int (exp, (match bound with | Alarms.Lower_bound -> min_ty | Alarms.Upper_bound -> max_ty), bound)) in let full_alarms () = ignore (alarms Alarms.Upper_bound); ignore (alarms Alarms.Lower_bound); in let f = match exp.enode with | Const (CReal (f, _, _)) -> Some f | UnOp (Neg, { enode = Const (CReal (f, _, _))}, _) -> Some (-. f) | _ -> None in (match remove_trivial, f with | true, Some f -> begin try let fint = Floating_point.truncate_to_integer f in if Integer.lt fint min_ty then ( let a = alarms ~status:Property_status.False_if_reachable Alarms.Lower_bound in if warning then Options.warn "float to int assert broken: %a" local_printer#code_annotation a; true) else if Integer.gt fint max_ty then ( let a = alarms ~status:Property_status.False_if_reachable Alarms.Upper_bound in if warning then Options.warn "float to int assert broken: %a" local_printer#code_annotation a; true) else false with Floating_point.Float_Non_representable_as_Int64 -> (* One of the alarms is False, but which one? ... *) full_alarms (); true end | _ -> full_alarms (); true ) | _ -> false (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/rte/visit.ml0000644000175000017500000007636112155630217017065 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Runtime Error annotation generation plugin *) open Cil_types open Cil_datatype let precond_prefix = "pre" (* prefix for generated behaviors *) (* assertion for preconditions *) type orig_lval = (* StartOfOrig | *) AddrOfOrig | LvalOrig let rec find_term_to_replace vinfo = function | [] -> None | (formal, term) :: tl -> if vinfo.vid = formal.vid then Some term else find_term_to_replace vinfo tl exception AddrOfFormal exception NoResult (* 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 *) let treat_tlval fa_terms ret_opt origin tlval = let prefix_origin ntlval = match origin with | LvalOrig -> TLval ntlval | AddrOfOrig -> TAddrOf ntlval in let t_lhost, t_offset = tlval in match t_lhost with | TMem _st -> Cil.DoChildren | 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? *) Cil.ChangeTo (prefix_origin trm)) | TVar { lv_origin = Some vinfo } when vinfo.vformal -> (match find_term_to_replace vinfo fa_terms with | None -> Cil.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 = Cil.make_temp_logic_var nt.term_type in Tlet (make_li tmp_lvar, Logic_const.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. *) Cil.ChangeTo nt.term_node else (* May need substitution in t_offset. *) Cil.ChangeDoChildrenPost (make_tlet (), fun x -> x) in let add_offset lval = Logic_const.addTermOffsetLval t_offset lval in match nt.term_node with | TLval lv -> Cil.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 Cil.ChangeDoChildrenPost(t, 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 (Cil.typeOfTermLval lv) in Cil.ChangeTo (TCastE(TPtr(ty,[]), t)) | AddrOfOrig -> let lh = TMem nt in Cil.ChangeDoChildrenPost (TAddrOf (lh,t_offset),fun x -> x)) | _ when origin = AddrOfOrig -> Options.warn ~source:(fst nt.term_loc) "Cannot substitute a non-lval parameter under an addrof operation"; raise AddrOfFormal | _ -> tlet_or_ident ()) | _ -> Cil.DoChildren 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 *) (* BTS 1052: must use a copy visitor *) inherit Cil.genericCilVisitor (Cil.copy_visit (Project.current ())) method vterm_node = function | TConst _ | TSizeOf _ | TSizeOfStr _ | TAlignOf _ | Tnull | Ttype _ | Tempty_set -> Cil.SkipChildren | TLval tlval -> treat_tlval fa_terms ret_opt LvalOrig tlval | TAddrOf tlval -> treat_tlval fa_terms ret_opt AddrOfOrig tlval | TStartOf _ (* [VP] Neither parameters nor returned value can be an array in a C function. Hence, TStartOf can not have \result or a formal as base. *) | _ -> Cil.DoChildren method vlogic_label = function | StmtLabel _ -> Cil.DoChildren | LogicLabel _ as l when Logic_label.equal l Logic_const.pre_label -> Cil.ChangeDoChildrenPost(replace_pre, fun x->x) | LogicLabel _ -> Cil.DoChildren end let treat_pred replace_pre pred fa_terms (ret_opt : term_lval option) = let visitor = replacement_visitor replace_pre fa_terms ret_opt in Cil.visitCilPredicate (visitor :> Cil.cilVisitor) pred let treat_term replace_pre trm fa_terms ret_opt = let visitor = replacement_visitor replace_pre fa_terms ret_opt in Cil.visitCilTerm (visitor :> Cil.cilVisitor) trm (* AST inplace visitor for runtime annotation generation *) (* module for bypassing categories of annotation generation for certain expression ids ; useful in a case such as signed char cx,cy,cz; cz = cx * cy; which translates to cz = (signed char) ((int) cx * (int) cz) ; which would in this case be annotated both by assert (((int )cx+(int )cy <= 2147483647) and ((int )cx+(int )cy >= (-0x7FFFFFFF-1))); and assert (((int )cx+(int )cy <= 127) and ((int )cx+(int )cy >= -128)); while we only want to keep the second assert (comes from the cast, and is stronger) *) exception Untreated_assign (* Used to generate fresh names for the behaviors introduced by -rte-precond *) module KfPrecondBehaviors = Datatype.Triple_with_collections (Kernel_function) (* Caller *) (Kernel_function) (* Callee *) (Datatype.String) (* Behavior *) (struct let module_name = "Rte.KfBehaviors" end) class annot_visitor kf = object (self) inherit Visitor.frama_c_inplace val mutable skip_set = Exp.Set.empty val mutable index_behavior = 0 val behavior_names = KfPrecondBehaviors.Hashtbl.create 7 method private mark_to_skip exp = skip_set <- Exp.Set.add exp skip_set method private must_skip exp = Exp.Set.mem exp skip_set method private do_mem_access () = Options.DoMemAccess.get () && not (Generator.Mem_access.is_computed kf) method private do_called_precond () = Options.DoCalledPrecond.get () && not (Generator.Called_precond.is_computed kf) method private do_div_mod () = Options.DoDivMod.get () && not (Generator.Div_mod.is_computed kf) method private do_signed_overflow () = Kernel.SignedOverflow.get () && not (Generator.Signed.is_computed kf) method private do_unsigned_overflow () = Kernel.UnsignedOverflow.get () && not (Generator.Unsigned_overflow.is_computed kf) method private do_downcast () = Kernel.SignedDowncast.get () && not (Generator.Downcast.is_computed kf) method private do_unsigned_downcast () = Kernel.UnsignedDowncast.get () && not (Generator.Unsigned_downcast.is_computed kf) method private do_float_to_int () = Options.DoFloatToInt.get () && not (Generator.Float_to_int.is_computed kf) method private queue_stmt_spec spec = let stmt = Extlib.the (self#current_stmt) in Queue.add (fun () -> let annot = Logic_const.new_code_annotation (AStmtSpec ([], spec)) in Annotations.add_code_annot Generator.emitter ~kf stmt annot) self#get_filling_actions method private mk_new_behavior_name kf_callee behav = let fname = Kernel_function.get_name kf_callee in let bname = if Cil.is_default_behavior behav then "" else "_" ^ behav.b_name in let key = kf, kf_callee, bname in let name = try let n = KfPrecondBehaviors.Hashtbl.find behavior_names key in incr n; precond_prefix ^ "_" ^ fname ^ bname ^ "_" ^ string_of_int !n with Not_found -> KfPrecondBehaviors.Hashtbl.add behavior_names key (ref 1); precond_prefix ^ "_" ^ fname ^ bname in Annotations.fresh_behavior_name kf name method private make_stmt_contract kf formals_actuals_terms ret_opt call_stmt = 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 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 } with | AddrOfFormal | NoResult -> (* A warning has been emitted, we simply ignore the predicate here. *) Logic_const.new_predicate Logic_const.ptrue in let fun_transform_allocations allocs = let treat_alloc it = Logic_const.new_identified_term (treat_term Logic_const.old_label it.it_content formals_actuals_terms tret_opt) in match allocs with | FreeAlloc (lfree_loc, lalloc_loc) -> FreeAlloc (List.map treat_alloc lfree_loc, List.map treat_alloc lalloc_loc) | FreeAllocAny -> FreeAllocAny in let fun_transform_assigns assigns = (* substitute terms, then for each from extract lvals and 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 | TLogic_coerce (_,te) -> keep_it te | Tinter locs | Tunion locs -> (try List.iter (fun loc -> if not (keep_it loc) then raise Exit) locs; true with Exit -> 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 Logic_const.old_label it.it_content formals_actuals_terms tret_opt in if keep_it nterm then [ Logic_const.new_identified_term (transform_term nterm) ] else [] in let treat_identified_term_zone_froms = function | FromAny -> FromAny | From l -> From (List.flatten (List.rev_map treat_from l)) in let treat_assign (z,lz) = try 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 Untreated_assign with AddrOfFormal | NoResult -> raise Untreated_assign in let treat_assigns_clause = function (* 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 *) | WritesAny -> WritesAny | Writes l -> try Writes (List.map treat_assign l) with Untreated_assign -> WritesAny in let final_assigns_list = match ret_opt with | None -> (* no return value: there should be no assign of \result *) assigns | Some ret -> let ret_type = Cil.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 = function | [] -> 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 (Logic_const.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 in (* bug #559 *) (* Logic_utils.typ_to_logic_type ret_type *) let nterm = Logic_const.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 in let behaviors, default_assigns = (* calling get_spec on a function with a contract but no code generates default assigns *) let spec = Annotations.funspec kf in (* [JS 2012/06/01] looks quite close of Infer_annotations.populate_spec, but it is not equivalent... *) let bhvs = spec.spec_behavior in bhvs, (* Looking for management of default assigns clause. *) (match Ast_info.merge_assigns_from_complete_bhvs ~warn:false bhvs [] with WritesAny -> (* Case 1: it isn't possible to find good assigns from ungarded behaviors. S, looks at assigns from complete behaviors clauses. *) (match Ast_info.merge_assigns_from_complete_bhvs ~warn:true ~ungarded:false bhvs spec.spec_complete_behaviors with | WritesAny -> (* Case 1.1: no better thing to do than nothing *) None | assigns -> (* Case 1.2: that assigns will be used as default assigns later. note: a message has been emmited. *) Some assigns) | _ -> (* Case 2: no special thing to do *) None) in try let new_behaviors = let default_allocation_assigns = ref (None, None) in let new_bhvs = List.fold_left (fun acc bhv -> (* step 1: looking for managment of allocation and assigns clause. *) let allocation = Some (fun_transform_allocations bhv.b_allocation) in let assigns, allocation, name = if Cil.is_default_behavior bhv then match bhv with | { b_post_cond = []; b_assumes = []; b_requires = []; b_assigns = WritesAny} -> (* The default bhv contents only an allocation clause. So, keeps it as the new default bhv. *) (* here no call to mk_new_behavior_name, need to ensure same side-effect (populate englobing func spec) *) ignore (Annotations.funspec kf); let assigns = match default_assigns with | Some assigns -> (* Use these assigns as default assigns *) assigns | None -> (* No special thing to do about assigns*) WritesAny in assigns, allocation, Cil.default_behavior_name | _ -> (* The default bhv contents other clauses. So, extract the allocation clause for the new bhv where the eventual default assigns will be set. *) default_allocation_assigns := allocation, default_assigns; bhv.b_assigns, None, self#mk_new_behavior_name kf bhv else bhv.b_assigns,allocation, self#mk_new_behavior_name kf bhv in (* We store a mapping between the old and the copied requires, in order to position some status dependencies between them *) let new_requires = ref [] in let requires = List.map (fun pred -> let after = fun_transform_pred Logic_const.here_label pred in new_requires := (pred, after) :: !new_requires; after) bhv.b_requires in let b = (* step 2: just map the current behavior *) (* As said before, assigns, allocation and names have a special management *) Cil.mk_behavior ~assigns:(fun_transform_assigns assigns) ~allocation ~name ~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 ~extended:[] () in (* Update the dependencies between the original require, and the copy at the syntactic call-site. Done once all the requires and behaviors have been created by the visitore *) let requires_deps () = let kf_call = Kernel_function.find_englobing_kf call_stmt in let ki_call = Kstmt call_stmt in let aux (old, after) = let old_ip = Property.ip_of_requires kf Kglobal bhv old in let new_ip =Property.ip_of_requires kf_call ki_call b after in Statuses_by_call.replace_call_precondition old_ip call_stmt new_ip in List.iter aux !new_requires in Queue.add requires_deps self#get_filling_actions; b :: acc) [] behaviors in (* step 3: adds the allocation clause into a default behavior *) match !default_allocation_assigns with | None,None -> new_bhvs | allocation,None -> Cil.mk_behavior ~allocation () :: new_bhvs | allocation,Some assigns -> Cil.mk_behavior ~allocation ~assigns:(fun_transform_assigns assigns) () :: new_bhvs 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 private generate_assertion: 'a 'b. ('a, 'b) Rte.alarm_gen -> 'a -> 'b = let remove_trivial = not (Options.Trivial.get ()) in let warning = Options.Warn.get () in fun f -> let kinstr = self#current_kinstr in f ~remove_trivial ~warning kf kinstr method vstmt s = match s.skind with | UnspecifiedSequence l -> (* UnspecifiedSequences may contain lvals for side-effects, that give rise to spurious assertions *) let no_lval = List.map (fun (s, _, _, _, sref) -> s, [], [], [], sref) l in let s' = { s with skind = UnspecifiedSequence no_lval } in Cil.ChangeDoChildrenPost (s', fun _ -> s) | _ -> Cil.DoChildren (* assigned left values are checked for valid access *) method vinst = function | Set (lval,_,_) -> if self#do_mem_access () then begin Options.debug "lval %a: validity of potential mem access checked\n" Printer.pp_lval lval; self#generate_assertion (Rte.lval_assertion ~read_only:Alarms.For_writing) lval end; Cil.DoChildren | Call (ret_opt,funcexp,argl,_) -> (match ret_opt, self#do_mem_access () with | None, _ | Some _, false -> () | Some ret, true -> Options.debug "lval %a: validity of potential mem access checked\n" Printer.pp_lval ret; self#generate_assertion (Rte.lval_assertion ~read_only:Alarms.For_writing) ret); if self#do_called_precond () then 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 begin Options.warn "(%a) function call with # actuals <> # formals: not treated" Printer.pp_stmt (Extlib.the (self#current_stmt)); Cil.DoChildren end else let formals_actuals_terms = List.rev_map2 (fun formal 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 (Extlib.the (self#current_stmt)) with | None -> Cil.DoChildren | Some contract_stmt -> self#queue_stmt_spec contract_stmt; Cil.DoChildren in (match ret_opt with | None -> do_no_implicit_cast () | Some lv -> let kf_ret_type = Kernel_function.get_return_type kf in let lv_type = Cil.typeOfLval lv in if Cil.need_cast kf_ret_type lv_type then begin Options.warn "(%a) function call with intermediate cast: not treated" Printer.pp_stmt (Extlib.the (self#current_stmt)); Cil.DoChildren end else do_no_implicit_cast ()) | Lval (Mem _,NoOffset) -> Options.warn "(%a) function called through a pointer: not treated" Printer.pp_stmt (Extlib.the (self#current_stmt)); Cil.DoChildren | _ -> assert false else Cil.DoChildren | _ -> Cil.DoChildren method vexpr exp = Options.debug "considering exp %a\n" Printer.pp_exp exp; match exp.enode with | BinOp((Div | Mod) as op, lexp, rexp, ty) -> (match Cil.unrollType ty with | TInt(kind,_) -> (* add assertion "divisor not zero" *) if self#do_div_mod () then self#generate_assertion Rte.divmod_assertion rexp; if self#do_signed_overflow () && op = Div && Cil.isSigned kind then (* treat the special case of signed division overflow (no signed modulo overflow) *) self#generate_assertion Rte.signed_div_assertion (exp, lexp, rexp); Cil.DoChildren | _ -> Cil.DoChildren) | BinOp((Shiftlt | Shiftrt) as op, lexp, rexp,ttype ) -> (match Cil.unrollType ttype with | TInt(kind,_) -> let do_signed = self#do_signed_overflow () in let do_unsigned = self#do_unsigned_overflow () in if do_signed || do_unsigned then begin let t = Cil.unrollType (Cil.typeOf exp) in let size = Cil.bitsSizeOf t in self#generate_assertion Rte.shift_alarm (rexp, Some size); if do_signed && Cil.isSigned kind then self#generate_assertion Rte.signed_shift_assertion (exp, op, lexp, rexp) else if do_unsigned && not (Cil.isSigned kind) && op = Shiftlt then (* assertions specific to unsigned shift *) self#generate_assertion Rte.unsigned_shift_assertion (exp, lexp, rexp) end; Cil.DoChildren | _ -> Cil.DoChildren) | BinOp((PlusA |MinusA | Mult) as op, lexp, rexp, ttype) -> (* may be skipped if the enclosing expression is a downcast to a signed type *) (match Cil.unrollType ttype with | TInt(kind,_) when Cil.isSigned kind -> if self#do_signed_overflow () && not (self#must_skip exp) then self#generate_assertion Rte.mult_sub_add_assertion (true, exp, op, lexp, rexp); Cil.DoChildren | TInt(kind,_) when not (Cil.isSigned kind) -> if self#do_unsigned_overflow () then self#generate_assertion Rte.mult_sub_add_assertion (false, exp, op, lexp, rexp); Cil.DoChildren | _ -> Cil.DoChildren) | UnOp(Neg, exp, ty) -> (* 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 *) (match Cil.unrollType ty with | TInt(kind,_) when Cil.isSigned kind -> if self#do_signed_overflow () then self#generate_assertion Rte.uminus_assertion exp; | _ -> ()); Cil.DoChildren | Lval lval -> (* left values are checked for valid access *) Cil.DoChildrenPost (fun new_e -> (* Use Cil.DoChildrenPost so that inner expression and lvals are checked first. The order of resulting assertions will be better. *) if self#do_mem_access () then begin Options.debug "exp %a is an lval: validity of potential mem access checked" Printer.pp_exp exp; self#generate_assertion (Rte.lval_assertion ~read_only:Alarms.For_reading) lval end; new_e) | CastE (ty, e) -> (match Cil.unrollType ty, Cil.unrollType (Cil.typeOf e) with | TInt(kind,_), TInt (_, _) -> if Cil.isSigned kind then begin if self#do_downcast () then let alarm = self#generate_assertion Rte.signed_downcast_assertion (ty, e) in if alarm then self#mark_to_skip e end else if self#do_unsigned_downcast () then let alarm = self#generate_assertion Rte.unsigned_downcast_assertion (ty, e) in if alarm then () (* self#mark_to_skip e *) | TInt _, TFloat _ -> if self#do_float_to_int () then let _alarm = self#generate_assertion Rte.float_to_int_assertion (ty, e) in () | _ -> ()); Cil.DoChildren | StartOf _ | AddrOf _ | Info _ | UnOp _ | Const _ | BinOp _ -> Cil.DoChildren | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> Cil.SkipChildren end let rte_annotations stmt = Annotations.fold_code_annot (fun e a acc -> if Emitter.equal e Generator.emitter then a ::acc else acc) stmt [] let get_annotations from kf stmt x = Rte.reset_generated_annotations (); let old = !Rte.save_alarms in Rte.save_alarms := false; let o = object (self) inherit annot_visitor kf initializer self#push_stmt stmt end in ignore (from (o :> Cil.cilVisitor) x); Rte.save_alarms := old; Rte.generated_annotations () let do_stmt_annotations kf stmt = get_annotations Cil.visitCilStmt kf stmt stmt let do_exp_annotations = get_annotations Cil.visitCilExpr let check_compute kf get is_computed set update_acc = (* feedback "get %b / doall %b / is_computed %b" (get ()) (DoAll.get ()) (is_computed kf);*) if get () && not (is_computed kf) then true, (fun () -> update_acc (); set kf true) else false, update_acc let annotate_kf kf = (* generates annotation for function kf on the basis of command-line options *) Options.debug "annotating function %a" Kernel_function.pretty kf; (* add annotations *) match kf.fundec with | Declaration _ -> () | Definition(f, _) -> let update = ref (fun () -> ()) in let module Check (M: Generator.S) (P: sig val get: unit -> bool end) = struct let compute () = let get () = P.get () in let b, u = check_compute kf get M.is_computed M.set !update in update := u; b end in let must_run1 = let module C = Check(Generator.Signed)(Kernel.SignedOverflow) in C.compute () in let must_run2 = let module C = Check(Generator.Mem_access)(Options.DoMemAccess) in C.compute () in let must_run3 = let module C = Check(Generator.Div_mod)(Options.DoDivMod) in C.compute () in let must_run4 = let module C = Check (Generator.Downcast)(Kernel.SignedDowncast) in C.compute () in let must_run5 = let module C = Check(Generator.Unsigned_overflow)(Kernel.UnsignedOverflow) in C.compute () in let must_run6 = let module C = Check(Generator.Unsigned_downcast)(Kernel.UnsignedDowncast) in C.compute () in let must_run7 = let module C = Check(Generator.Float_to_int)(Options.DoFloatToInt) in C.compute () in let must_run8 = let module C = Check(Generator.Called_precond)(Options.DoCalledPrecond) in C.compute () in if must_run1 || must_run2 || must_run3 || must_run4 || must_run5 || must_run6 || must_run7 || must_run8 then begin Options.feedback "annotating function %a" Kernel_function.pretty kf; let vis = new annot_visitor kf in let nkf = Visitor.visitFramacFunction vis f in assert(nkf == f); !update () end let do_precond kf = (* annotate call sites with contracts, for a given function *) let old_signed = Generator.Signed.is_computed kf in Generator.Signed.set kf true; let old_mem = Generator.Mem_access.is_computed kf in Generator.Mem_access.set kf true; let old_divmod = Generator.Div_mod.is_computed kf in Generator.Div_mod.set kf true; let old_uo = Generator.Unsigned_overflow.is_computed kf in Generator.Unsigned_overflow.set kf true; let old_ud = Generator.Unsigned_downcast.is_computed kf in Generator.Unsigned_downcast.set kf true; let old_downcast = Generator.Downcast.is_computed kf in Generator.Downcast.set kf true; let old_float_to_int = Generator.Float_to_int.is_computed kf in Generator.Float_to_int.set kf true; (* TODO: Why is this option set to true without being restored later? *) Options.DoCalledPrecond.on (); annotate_kf kf; Generator.Signed.set kf old_signed; Generator.Mem_access.set kf old_mem; Generator.Div_mod.set kf old_divmod; Generator.Unsigned_overflow.set kf old_uo; Generator.Unsigned_downcast.set kf old_ud; Generator.Downcast.set kf old_downcast; Generator.Float_to_int.set kf old_float_to_int; ;; let do_all_rte kf = (* annonate for all rte + unsigned overflows (which are not rte), for a given function *) Options.DoAll.on (); Kernel.SignedOverflow.off (); let old_ud = Generator.Unsigned_downcast.is_computed kf in Generator.Unsigned_downcast.set kf true; let old_called = Generator.Called_precond.is_computed kf in Generator.Called_precond.set kf true; annotate_kf kf; Generator.Unsigned_downcast.set kf old_ud; Generator.Called_precond.set kf old_called let do_rte kf = (* annotate for rte only (not unsigned overflows and downcasts) for a given function *) Options.DoAll.on (); let old_uo = Generator.Unsigned_overflow.is_computed kf in Generator.Unsigned_overflow.set kf true; let old_ud = Generator.Unsigned_downcast.is_computed kf in Generator.Unsigned_downcast.set kf true; let old_called = Generator.Called_precond.is_computed kf in Generator.Called_precond.set kf true; annotate_kf kf; Generator.Unsigned_overflow.set kf old_uo; Generator.Unsigned_downcast.set kf old_ud; Generator.Called_precond.set kf old_called let compute () = (* compute RTE annotations, whether Enabled is set or not *) Ast.compute () ; let include_function kf = let fsel = Options.FunctionSelection.get () in Datatype.String.Set.is_empty fsel || let name = Kernel_function.get_name kf in Datatype.String.Set.mem name fsel in Globals.Functions.iter (fun kf -> if include_function kf && Kernel_function.is_definition kf then !Db.RteGen.annotate_kf kf) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/0000755000175000017500000000000012155634040015700 5ustar mehdimehdiframa-c-Fluorine-20130601/src/value/c_assert.mli0000644000175000017500000000361612155630231020212 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Translate a Value state into a bunch of C assertions *) (** This file is experimental, and partly tuned to Csmith programs. In particular, it might not follow your machedp, or fail to translate some variables. Use at your own risk *) val pretty_state_as_c_assert: Cvalue.Model.t Pretty_utils.formatter frama-c-Fluorine-20130601/src/value/eval_terms.mli0000644000175000017500000000777712155630231020564 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Cvalue (** Evaluating a predicate. [Unknown] is the Top of the lattice *) type predicate_value = True | False | Unknown val pretty_predicate_value : Format.formatter -> predicate_value -> unit val join_predicate : predicate_value -> predicate_value -> predicate_value val fold_join_predicate : ((predicate_value option -> 'a -> predicate_value option) -> 'b option -> 'c -> predicate_value option) -> ('a -> predicate_value) -> 'c -> predicate_value (** Error during the evaluation of a term or a predicate *) type logic_evaluation_error = | Unsupported of string | AstError of string | NoEnv of logic_label | NoResult | CAlarm val pretty_logic_evaluation_error : Format.formatter -> logic_evaluation_error -> unit exception LogicEvalError of logic_evaluation_error type labels_states = Cvalue.Model.t Cil_datatype.Logic_label.Map.t (** Evaluation environment. Currently available are function Pre and Post, or the environment to evaluate an annotation *) type eval_env val env_pre_f : ?c_labels:labels_states -> init:Model.t -> unit -> eval_env val env_annot : ?c_labels:labels_states -> pre:Model.t -> here:Model.t -> unit -> eval_env val env_post_f : ?c_labels:labels_states -> pre:Model.t -> post:Model.t -> result:varinfo option -> unit -> eval_env val env_assigns: init:Model.t -> eval_env (** Dependencies needed to evaluate a term or a predicate *) type edeps = Zone.t Cil_datatype.Logic_label.Map.t type 'a eval_result = { etype: Cil_types.typ; evalue: 'a list; edeps: edeps; } val eval_term : with_alarms:CilE.warn_mode -> eval_env -> term -> V.t eval_result val eval_tlval : with_alarms:CilE.warn_mode -> eval_env -> term -> Location_Bits.t eval_result val eval_tlval_as_location : with_alarms:CilE.warn_mode -> eval_env -> term -> location val eval_tlval_as_locations : with_alarms:CilE.warn_mode -> eval_env -> term -> location list * edeps val eval_tlval_as_zone : with_alarms:CilE.warn_mode -> for_writing:bool -> eval_env -> term -> Zone.t exception Not_an_exact_loc val eval_term_as_exact_loc : with_alarms:CilE.warn_mode -> eval_env -> term -> Cil_datatype.Typ.t * location val eval_predicate : eval_env -> predicate named -> predicate_value val reduce_by_predicate : eval_env -> bool -> predicate named -> eval_env val reduce_by_disjunction : always:bool -> env:eval_env -> State_set.t -> int -> predicate named -> State_set.t frama-c-Fluorine-20130601/src/value/state_imp.ml0000644000175000017500000001256012155630231020221 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module Sindexed = Hashtbl.Make (struct type t = Cvalue.Model.subtree let hash = Cvalue.Model.hash_subtree let equal = Cvalue.Model.equal_subtree end) let sentinel = Sindexed.create 1 type t = { mutable t : Cvalue.Model.t Sindexed.t ; mutable p : Hptmap.prefix ; mutable o : Cvalue.Model.t list ; } let fold f acc { t = t ; o = o } = List.fold_left f (Sindexed.fold (fun _k v a -> f a v) t acc) o let iter f { t = t ; o = o } = Sindexed.iter (fun _k v -> f v) t; List.iter f o exception Found let empty () = { t = sentinel ; p = Hptmap.sentinel_prefix ; o = [] } let is_empty t = t.t == sentinel && t.o = [] let exists f s = try iter (fun v -> if f v then raise Found) s; false with Found -> true let length s = List.length s.o + Sindexed.length s.t exception Unchanged let pretty fmt s = iter (fun state -> Format.fprintf fmt "set contains %a@\n" Cvalue.Model.pretty state) s let add_to_list v s = if List.exists (fun e -> Cvalue.Model.is_included v e) s then raise Unchanged; (* let nl, ns = filter (fun e -> not (Cvalue.Model.is_included e v)) w in *) v :: s let rec add_exn v s = if not (Cvalue.Model.is_reachable v) then raise Unchanged; if s.t == sentinel then begin match s.o with [ v1 ; v2 ] -> begin assert(not (Cvalue.Model.equal v1 v2)); try Cvalue.Model.comp_prefixes v1 v2; s.o <- add_to_list v s.o with Cvalue.Model.Found_prefix (p, subtree1, subtree2) -> (* Format.printf "COMP h1 %d@." (Cvalue.Model.hash_subtree subtree1); Format.printf "COMP h2 %d@." (Cvalue.Model.hash_subtree subtree2); *) let t = Sindexed.create 13 in Sindexed.add t subtree1 v1; Sindexed.add t subtree2 v2; s.t <- t; s.p <- p; s.o <- []; add_exn v s end | _ -> s.o <- add_to_list v s.o end else begin let subtree = Cvalue.Model.find_prefix v s.p in begin match subtree with None -> s.o <- add_to_list v s.o | Some subtree -> let candidates = Sindexed.find_all s.t subtree in (* Format.printf "COMP indexed %d %d@." (List.length candidates) (List.length s.o); *) let v_incl = Cvalue.Model.is_included v in if List.exists v_incl candidates || List.exists v_incl s.o then raise Unchanged else Sindexed.add s.t subtree v end end let merge_into sa sb = let unchanged = ref true in let f e = try add_exn e sb ; unchanged := false with Unchanged -> () in let result = iter f sa in if !unchanged then raise Unchanged; result let merge_set_into set sb = let unchanged = ref true in let f e = try add_exn e sb ; unchanged := false with Unchanged -> () in let result = State_set.iter f set in if !unchanged then raise Unchanged; result let merge_set_return_new set sb = let f acc e = try add_exn e sb ; e :: acc with Unchanged -> acc in let result = State_set.fold f [] set in State_set.of_list result let add v s = try add_exn v s with Unchanged -> () let singleton v = let r = empty () in add v r; r let join s = fold Cvalue.Model.join Cvalue.Model.bottom s let fold f acc s = fold (fun acc v -> f v acc) s acc let to_list i = Sindexed.fold (fun _k v a -> v :: a) i.t i.o let to_set i = State_set.of_list (to_list i) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/c_assert.ml0000644000175000017500000001430712155630231020040 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp open Cvalue let pretty_int_range fmt print_ampamp typname lv v = let v = V.project_ival v in match Ival.min_and_max v with | Some mn, Some mx -> let mn_repr = if Int.equal mn (Int.of_string "-2147483648") then "-2147483648LL" else Int.to_string mn in if Int.equal mn mx then begin print_ampamp(); Format.fprintf fmt "*(%s*)%s == %s" typname lv mn_repr end else begin let mx_repr = if Int.equal mx (Int.of_string "-2147483648") then "-2147483648LL" else Int.to_string mx in print_ampamp(); Format.fprintf fmt "%s <= *(%s*)%s && *(%s*)%s <= %s" mn_repr typname lv typname lv mx_repr end | _ -> () let pretty_float_range fmt print_ampamp typname lv v = let use_hex = true in let pp_float = Ival.F.pretty_normal ~use_hex in let mn, mx = V.min_and_max_float v in if Ival.F.equal mn mx then begin print_ampamp(); Format.fprintf fmt "*(%s*)%s == %a" typname lv pp_float mn end else begin print_ampamp(); Format.fprintf fmt "%a <= *(%s*)%s && *(%s*)%s <= %a" pp_float mn typname lv typname lv pp_float mx; end let types = Hashtbl.create 7;; let () = Hashtbl.add types 1 [V.inject_ival (Ival.inject_range (Some Int.zero) (Some (Int.of_int 255))), "unsigned char", pretty_int_range; V.inject_ival (Ival.inject_range (Some (Int.of_int (-128))) (Some (Int.of_int 127))), "char", pretty_int_range]; Hashtbl.add types 2 [V.inject_ival (Ival.inject_range (Some Int.zero) (Some (Int.of_int 65535))), "unsigned short", pretty_int_range; V.inject_ival (Ival.inject_range (Some (Int.of_int (-32768))) (Some (Int.of_int 32767))), "short", pretty_int_range]; Hashtbl.add types 4 [ V.top_float, "float", pretty_float_range; V.inject_ival (Ival.inject_range (Some Int.zero) (Some (Int.of_string "4294967295"))), "unsigned int", pretty_int_range; V.inject_ival (Ival.inject_range (Some (Int.of_string "-2147483648")) (Some (Int.of_string "2147483647"))), "int", pretty_int_range]; Hashtbl.add types 8 [ V.top_float, "double", pretty_float_range]; ;; let value_pretty print_ampamp lv s_bytes fmt v = try let candidate_types = Hashtbl.find types s_bytes in let rec find_typ = function | [] -> () | (range, _, _) :: t when not (V.is_included v range) -> find_typ t | (_range, typname, pr) :: _ -> pr fmt print_ampamp typname lv v in find_typ candidate_types with V.Not_based_on_null -> () let value_uninit_pretty prampamp lv s fmt = function | V_Or_Uninitialized.C_init_noesc v -> value_pretty prampamp lv s fmt v | _ -> () let offsetmap_pretty name print_ampamp fmt offsm = let pretty_binding (bk,ek) (v, modu, offset) = let iso = V_Or_Uninitialized.is_isotropic v in if Integer.is_zero (Integer.rem bk Integer.eight) && (Rel.is_zero offset) && (iso || (Integer.is_zero (Integer.rem modu Integer.eight))) then let ek = Integer.succ ek in if Integer.is_zero (Integer.rem ek Integer.eight) then let step = if iso then 1 else (Integer.to_int modu) / 8 in let start = ref ((Integer.to_int bk) / 8) in let ek = Integer.to_int ek in let ek = ek / 8 in while !start + step <= ek do let lv = if !start = 0 then Format.sprintf "&%s" name else Format.sprintf "((unsigned char*)&%s+%d)" name !start in value_uninit_pretty print_ampamp lv step fmt v; start := !start + step done; else () else () in Cvalue.V_Offsetmap.iter pretty_binding offsm let state_pretty fmt m = Format.fprintf fmt "@["; (match m with | Model.Bottom -> Format.fprintf fmt "0" | Model.Map m -> let first = ref true in let print_ampamp () = if !first then first := false else Format.fprintf fmt "@\n&& "; in Model.LBase.iter (fun base offs -> match base with | Base.Var(v,_) -> let name = v.Cil_types.vname in if name <> "crc32_tab" (* Specialized for Csmith *) then offsetmap_pretty name print_ampamp fmt offs | _ -> ()) m | Model.Top -> Format.fprintf fmt "1" ); Format.fprintf fmt "@]" let pretty_state_as_c_assert = state_pretty frama-c-Fluorine-20130601/src/value/mem_exec.ml0000644000175000017500000002273212155630231020020 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 exception TooImprecise (* Extract all the bases from a zone *) let bases z = try Locations.Zone.fold_bases (fun b acc -> Base.Hptset.add b acc) z Base.Hptset.empty with Locations.Zone.Error_Top -> raise TooImprecise (* Auxiliary function that keeps only some bases inside a memory state *) let filter_state bases state = if Cvalue.Model.is_reachable state then let keep_base base = Base.Hptset.mem base bases in let keep = Cvalue.Model.filter_base keep_base in keep state else state module ValueOutputs = Datatype.Pair (Datatype.List( Datatype.Pair (Datatype.Option(Cvalue.V_Offsetmap)) (* Return *) (Cvalue.Model) (* Memory state *))) (Base.SetLattice) (* cloberred set for local variables *) (* let pretty fmt (((bin, stin), (_, stout, _), _i) : PreviousState.t) = Format.fprintf fmt "@[@[Inputs contained in %a]@ \ @[Values of inputs:@]@ %a\ @[Values of outputs:@]@ %a@]" Base.Hptset.pretty bin Cvalue.Model.pretty stin Cvalue.Model.pretty stout *) module PreviousState = Datatype.Pair (ValueOutputs (* Outputs *)) (Datatype.Int(* Call number, for plugins *)) (* Map input states filtered on relevant bases to the relevant data *) module MapInputsPrevious = Cvalue.Model.Hashtbl.Make(PreviousState) (* Map from useful inputs to stored previous results *) module MapBasesInputsPrevious = Base.Hptset.Hashtbl.Make(MapInputsPrevious) module PreviousStates = State_builder.Hashtbl(Kernel_function.Hashtbl)(MapBasesInputsPrevious) (struct let size = 17 let dependencies = [Db.Value.self] let name = "Mem_exec.PreviousStates" end) (* Reference filled in by the callwise-inout callback *) module ResultFromCallback = State_builder.Option_ref(Datatype.Pair(Value_types.Callstack)(Inout_type)) (struct let dependencies = [Db.Value.self] let name = "Mem_exec.ResultFromCallback" end) (* TODO: it would be great to clear also the tables within the plugins. Export self and add dependencies *) let cleanup_results () = PreviousStates.clear (); ResultFromCallback.clear (); ;; let register_callback () = if Value_parameters.MemExecAll.get () then Db.Operational_inputs.Record_Inout_Callbacks.extend_once (fun (_stack, _inout as v) -> ResultFromCallback.set v) let () = Cmdline.run_after_configuring_stage register_callback module SaveCounter = State_builder.SharedCounter(struct let name = "Mem_exec.save_counter" end) let new_counter, current_counter = let cur = ref (-1) in (fun () -> cur := SaveCounter.next (); !cur), (fun () -> !cur) let store_computed_call (callsite: Value_types.call_site) input_state callres = if callres.Value_types.c_cacheable = Value_types.Cacheable then match ResultFromCallback.get_option () with | None -> () | Some (_stack, inout) -> try let kf, _ki = callsite in let input_bases = bases inout.Inout_type.over_inputs and output_bases = bases inout.Inout_type.over_outputs_if_termination in (* TODO. add only outputs that are not completely overwritten *) let input_bases = Base.Hptset.union input_bases output_bases in let state_input = filter_state input_bases input_state in let clear = filter_state output_bases in let outputs = Value_util.map_outputs clear callres.Value_types.c_values in let call_number = current_counter () in let hkf = try PreviousStates.find kf with Not_found -> let h = Base.Hptset.Hashtbl.create 11 in PreviousStates.add kf h; h in let hkb = try Base.Hptset.Hashtbl.find hkf input_bases with Not_found -> let h = Cvalue.Model.Hashtbl.create 11 in Base.Hptset.Hashtbl.add hkf input_bases h; h in Cvalue.Model.Hashtbl.add hkb state_input ((outputs, callres.Value_types.c_clobbered), call_number); ResultFromCallback.clear () with | TooImprecise | Kernel_function.No_Statement | Not_found -> ResultFromCallback.clear () exception Result_found of ValueOutputs.t * int let previous_matches st (map_inputs: MapBasesInputsPrevious.t) = let aux binputs hstates = let st_filtered = filter_state binputs st in try let old = Cvalue.Model.Hashtbl.find hstates st_filtered in let (outputs, clobbered), i = old in let aux st_outputs = if Cvalue.Model.is_reachable st_outputs then Cvalue.Model.fold_base_offsetmap Cvalue.Model.add_base st_outputs st(*=acc*) else st_outputs in let outputs = Value_util.map_outputs aux outputs in raise (Result_found ((outputs, clobbered), i)) with Not_found -> () in Base.Hptset.Hashtbl.iter aux map_inputs let reuse_previous_call (kf, _ as _callsite: Value_types.call_site) state = try let previous = PreviousStates.find kf in previous_matches state previous; None with | Not_found -> None | Result_found ((out, clob), i) -> (* TODO: check this. Do we record the result too early? *) let st_without_formals = match kf.fundec with | Definition (fdec, _) -> Value_util.map_outputs (Value_util.remove_formals_from_state fdec.sformals) out | Declaration _ -> out in let res_call = { Value_types.c_values = st_without_formals; c_clobbered = clob; c_cacheable = Value_types.Cacheable (* call can be cached since it was cached once *); } in Some (res_call, i) (* TEST code, to be pasted in eval_funs, below the call to reuse_previous_state let res = match compute_call_to_builtin kf initial_state actuals with | Some r -> r | None -> let res = compute_call_to_cil_function kf with_formals call_kinstr in res in match Mem_exec.reuse_previous_state with_formals (kf, call_kinstr) with | None -> Mem_exec.store_previous_state (kf, call_kinstr) with_formals res; res | Some res' -> let _ret, st, _ = res and (_ret', st', _ as res'), _, out, in_ = res' in if not (Cvalue.Model.equal st st') then begin begin (match st with | Cvalue.Model.Top | Cvalue.Model.Bottom -> assert false | Cvalue.Model.Map lb -> Cvalue.Model.LBase.iter (fun b offsm -> let offsm' = Cvalue.Model.find_base b st' in if not (V_Offsetmap.equal offsm offsm') then ( Format.printf "Different offsm for %a@\n%a@\n%a@." Base.pretty b V_Offsetmap.pretty offsm V_Offsetmap.pretty offsm' ) ) lb); (match st' with | Cvalue.Model.Top | Cvalue.Model.Bottom -> assert false | Cvalue.Model.Map lb' -> Cvalue.Model.LBase.iter (fun b offsm' -> let offsm = Cvalue.Model.find_base b st in if not (V_Offsetmap.equal offsm offsm') then Format.printf "Different offsm2 for %a@." Base.pretty b ) lb'); end; let fmti = Format.formatter_of_out_channel (open_out "stinit") and fmt1 = Format.formatter_of_out_channel (open_out "st1") and fmt2 = Format.formatter_of_out_channel (open_out "st2") in Format.fprintf fmti "###INITIAL STATE@.%a@." Cvalue.Model.pretty with_formals; Format.fprintf fmt1 "###RESULT NORMAL@.%a@." Cvalue.Model.pretty st; Format.fprintf fmt2 "###RESULT CACHED@.%a@." Cvalue.Model.pretty st'; Value_parameters.result "Caching failed for function %a,@.out %a@.in %a" Kernel_function.pretty kf Cvalue.Model.pretty out Cvalue.Model.pretty in_; do_degenerate None end; res' *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/current_table.ml0000644000175000017500000001127612155630231021070 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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_datatype type record = { 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 = Cvalue.Model.bottom } type t = record Stmt.Hashtbl.t let create () = Stmt.Hashtbl.create 257 let clear t = Stmt.Hashtbl.clear t let find_current current_table kinstr = try Stmt.Hashtbl.find current_table kinstr with Not_found -> let record = empty_record () in 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 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 = try update_current_exn current_table kinstr v with State_imp.Unchanged -> () let update_and_tell_if_changed current_table kinstr d = let record = find_current current_table kinstr in 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 let merge_db_table hash_states callstack = let treat_stmt k sum = let current_state = Db.Value.noassert_get_stmt_state k in let is_top_already = Cvalue.Model.is_top current_state in if not is_top_already then Db.Value.update_table k sum; if Value_parameters.ResultsCallstack.get () then Db.Value.update_callstack_table ~after:false k callstack sum in if Mark_noresults.should_memorize_function (Kernel_function.get_definition (Value_util.current_kf())) then Stmt.Hashtbl.iter treat_stmt (Lazy.force hash_states) let superpositions current_table = let r = Stmt.Hashtbl.create (Stmt.Hashtbl.length current_table) in Stmt.Hashtbl.iter (fun k record -> let sup = State_imp.to_list record.superposition in Stmt.Hashtbl.add r k sup) current_table; r let states current_table = let r = Stmt.Hashtbl.create (Stmt.Hashtbl.length current_table) in Stmt.Hashtbl.iter (fun k record -> Stmt.Hashtbl.add r k (Cvalue.Model.join (State_imp.join record.superposition) record.widening_state)) current_table; r let find_superposition current_table s = 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 frama-c-Fluorine-20130601/src/value/eval_funs.mli0000644000175000017500000000337512155630231020373 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 entire functions. Nothing is exported, but this module fills [Db.Value.compute] *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/non_linear.mli0000644000175000017500000000334612155630231020533 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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: *) frama-c-Fluorine-20130601/src/value/state_set.mli0000644000175000017500000000466212155630231020404 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Functional sets of [Cvalue.Model.t], currently implemented as lists without repetition. *) type t val pretty : Format.formatter -> t -> unit (** Creation *) val empty : t val singleton : Cvalue.Model.t -> t val of_list : Cvalue.Model.t list -> t (** Information *) val is_empty : t -> bool val length : t -> int (** Adding elements *) val add : Cvalue.Model.t -> t -> t exception Unchanged val merge_into : t -> t -> t (** Raise [Unchanged] if the second set was already included in the first *) (** Iterators *) val fold : ('a -> Cvalue.Model.t -> 'a) -> 'a -> t -> 'a val iter : (Cvalue.Model.t -> unit) -> t -> unit val exists : (Cvalue.Model.t -> bool) -> t -> bool (** Export *) val join : t -> Cvalue.Model.t val to_list: t -> Cvalue.Model.t list (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/separate.ml0000644000175000017500000000704512155630231020042 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let mask = ref 0 let prologue () = let sep_of = Value_parameters.SeparateStmtOf.get() in if sep_of <> 0 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; 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 *) assert (sep_case >= 0); assert (sep_case <= sep_of); mask := (succ sep_of) lsr 1; end else begin mask := 0; end let filter_if stmt (th, el as thel) = if th = Dataflow.GUnreachable || el = Dataflow.GUnreachable then thel else let sep = !mask in if sep <> 0 && ( Value_parameters.SeparateStmtStart.is_empty() || (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 end else thel let epilogue () = let sep = !mask in let word1 = Value_parameters.SeparateStmtWord.get() in 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 end else succ word1 in if next <= Value_parameters.SeparateStmtOf.get() then Value_parameters.feedback "Next case to cover in sequential order: %d" next; frama-c-Fluorine-20130601/src/value/local_slevel_compute.ml0000644000175000017500000000653512155630231022441 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Value_util open Local_slevel_types let compute_sub_function kf start info initial_states = let current_merges = info.merges in (* FIXME [SCM] Strict mode only support *) assert(Cil_datatype.Stmt.Hptset.cardinal current_merges = 1); let module Computer = Eval_slevel.Computer (struct let kf = kf let slevel = match info.slevel with Some level -> level | None -> get_slevel kf let initial_states = initial_states (* for future reference *) let active_behaviors = Eval_annots.ActiveBehaviors.create (State_set.join initial_states) kf let local_slevel_info = info end) in let module Compute = Dataflow.Forwards(Computer) in let add_to_worklist stmt = Queue.add stmt Compute.worklist in Computer.add_to_worklist := add_to_worklist; (* FIX [SCM] Strict mode *) let merge = List.hd (Cil_datatype.Stmt.Hptset.elements current_merges) in (* Init the dataflow state for the first statement *) let dinit = { Computer.counter_unroll = 0; value = initial_states} in let dinit = Computer.computeFirstPredecessor start dinit in Computer.StmtStartData.add start dinit; Compute.compute [start]; (* Here I will have to collect the results of all merges or returns in non * strict mode * maybe build a Cil_datatype.Stmt.Map, return this and let ret set * stmtstartdata * OR this is probably a map or hashtbl already - why double the work*) let state = Computer.getStateSet merge in Computer.merge_results ~inform:false; State_set.join state, Computer.clob.Locals_scoping.clob let () = Local_slevel.compute_sub_function_ref := compute_sub_function (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/stop_at_nth.mli0000644000175000017500000000320112155630231020717 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 clear: unit -> unit val incr: unit -> bool frama-c-Fluorine-20130601/src/value/eval_slevel.mli0000644000175000017500000000442712155630231020711 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module Computer (AnalysisParam : sig val kf : Cil_types.kernel_function val slevel : int val initial_states : State_set.t val active_behaviors : Eval_annots.ActiveBehaviors.t val local_slevel_info : Local_slevel_types.local_slevel_info end) : sig type u = { counter_unroll : int; mutable value : State_set.t; } include Dataflow.ForwardsTransfer with type t = u val merge_results : inform:bool -> unit val results: unit -> Value_types.call_result (* For local_slevel_compute: to be removed eventually *) val clob : Locals_scoping.clobbered_set val add_to_worklist : (Cil_datatype.Stmt.Hptset.elt -> unit) ref val getStateSet : Cil_types.stmt -> State_set.t end frama-c-Fluorine-20130601/src/value/eval_annots.ml0000644000175000017500000002653712155630231020556 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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_terms let emit_status ppt s = Property_status.emit ~distinct:true Value_util.emitter ~hyps:[] ppt s let emit_unreachable ppt = let reach_p = Property.ip_reachable_ppt ppt in Property_status.emit ~distinct:false Value_util.emitter ~hyps:[] reach_p Property_status.False_and_reachable module ActiveBehaviors = struct let header b = if Cil.is_default_behavior b then "" else ", behavior " ^ b.b_name let pp_bhv fmt b = if not (Cil.is_default_behavior b) then Format.fprintf fmt ", behavior %s" b.b_name let is_active_aux init_state b = let assumes = (Logic_const.pands (List.map Logic_const.pred_of_id_pred b.b_assumes)) in eval_predicate (env_pre_f ~init:init_state ()) assumes type t = { init_state: Cvalue.Model.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_from_spec init_state funspec = let h = HashBehaviors.create 3 in { is_active = (fun b -> try HashBehaviors.find h b with Not_found -> let active = is_active_aux init_state b in HashBehaviors.add h b active; active ); init_state = init_state; funspec = funspec; } let create init_state kf = let funspec = Annotations.funspec kf in create_from_spec init_state 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 end let conv_status = function | False -> Property_status.False_if_reachable; | True -> Property_status.True; | Unknown -> Property_status.Dont_know let behavior_inactive fmt = Format.fprintf fmt " (Behavior may be inactive, no reduction performed.)" let pp_header kf fmt b = Format.fprintf fmt "Function %a%a" Kernel_function.pretty kf ActiveBehaviors.pp_bhv b (** [eval_and_reduce preds ab b proj states update_status pp_header env slevel ab b] *) let eval_and_reduce ab b preds states update_status env slevel pp_header str = let aux_pred reduce states ({ip_content=pr; ip_loc= (source, _ as loc)} as pred) = if State_set.is_empty states then (Value_parameters.result ~once:true ~source "%a: no state left in which to evaluate %s, status not \ computed.%t" pp_header b str Value_util.pp_callstack; states) else let pr = Ast_info.predicate loc pr in let res = fold_join_predicate State_set.fold (fun state -> eval_predicate (env state) pr) states in Value_parameters.result ~once:true ~source "%a: %s got status %a.%t%t" pp_header b str pretty_predicate_value res (if reduce then (fun _ -> ()) else behavior_inactive) Value_util.pp_callstack; update_status (conv_status res) pred; if reduce then match res with | False -> State_set.empty | True -> let env = env (State_set.join states) in (* Reduce in case [pre] is a disjunction *) reduce_by_disjunction ~always:false ~env states slevel pr | Unknown -> let env = env (State_set.join states) in (* Reduce in all cases *) reduce_by_disjunction ~always:true ~env states slevel pr else states in match ActiveBehaviors.active ab b with | True -> List.fold_left (aux_pred true) states preds | Unknown -> List.fold_left (aux_pred false) states preds | False -> (match preds with | [] -> () | {ip_loc=(source,_)} ::_ -> Value_parameters.result ~once:true ~source "%a: assumes got status invalid; %s not evaluated.%t" pp_header b str Value_util.pp_callstack ); states let check_fct_postconditions kf ab ~result ~init_state ~post_states kind = let behaviors = Annotations.behaviors kf in let slevel = Value_util.get_slevel kf in let incorporate_behavior states b = if b.b_post_cond = [] then states else let posts = List.filter (fun (x,_) -> x = kind) b.b_post_cond in let posts = List.map snd posts in let update_status st post = let ip = Property.ip_of_ensures kf Kglobal b (kind, post) in emit_status ip st in let env state = env_post_f ~post:state ~pre:init_state ~result () in eval_and_reduce ab b posts states update_status env slevel (pp_header kf) "postcondition" in List.fold_left incorporate_behavior post_states behaviors (** Check the precondition of [kf]. This may result in splitting [init_state] into multiple states if the precondition contains disjunctions. *) let check_fct_preconditions kf ab call_ki init_state = let init_states = State_set.singleton init_state in let spec = Annotations.funspec kf in let slevel = Value_util.get_slevel kf in let incorporate_behavior states b = if b.b_requires = [] then states else let emit st vc = let ip = Property.ip_of_requires kf Kglobal b vc in match call_ki with | Kglobal -> (* status of the main function. We update the global status, and pray that there is no recursion. TODO: check what the WP does.*) emit_status ip st | Kstmt stmt -> Statuses_by_call.setup_precondition_proxy kf ip; let ip_call = Statuses_by_call.precondition_at_call kf ip stmt in emit_status ip_call st in eval_and_reduce ab b b.b_requires states emit (fun init -> env_pre_f ~init ()) slevel (pp_header kf) "precondition" in List.fold_left incorporate_behavior init_states spec.spec_behavior (* 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 kf ab initial_state slevel states stmt ca record = let source = match Cil_datatype.Code_annotation.loc ca with | Some loc when not (Cil_datatype.Location.equal loc Cil_datatype.Location.unknown) -> fst loc | _ -> fst (Cil.CurrentLoc.get ()) (* fallback: current statement *) in let aux text behav p = let in_behavior = match behav with | [] -> `True | behavs -> let aux acc b = let b = ActiveBehaviors.behavior_from_name ab b in match ActiveBehaviors.active ab b with | True -> `True | Unknown -> if acc = `True then `True else `Unknown | False -> acc in List.fold_left aux `False behavs in match in_behavior with | `False -> states | `True | `Unknown as in_behavior -> let result = fold_join_predicate State_set.fold (fun here -> let env = env_annot ~pre:initial_state ~here () in eval_predicate env p) states in let ip = Property.ip_of_code_annot kf stmt ca in let change_status st = if record then List.iter (fun p -> emit_status p st) ip in let message, states = (match result, in_behavior with | Unknown, _ -> change_status Property_status.Dont_know; "unknown", states | True, _ -> change_status Property_status.True; "valid", states | False, `True -> change_status Property_status.False_if_reachable; "invalid (stopping propagation)", State_set.empty | False, `Unknown -> change_status Property_status.False_if_reachable; "invalid", states ) in if record then Value_parameters.result ~once:true ~source "%s got status %s." text message; if in_behavior = `True then let here = State_set.join states in let env = env_annot ~pre:initial_state ~here () in reduce_by_disjunction ~always:(result = Unknown) ~env states slevel p else states 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 _ | AAllocation _ | AStmtSpec _ (*TODO*) -> states let mark_unreachable () = let do_stmt stmt _emit ca = if not (Db.Value.is_reachable_stmt stmt) then let kf = Kernel_function.find_englobing_kf stmt in let ppts = Property.ip_of_code_annot kf stmt ca in List.iter (fun p -> Value_parameters.debug "Marking property %a as dead" Description.pp_property p; emit_unreachable p ) ppts in Annotations.iter_all_code_annot do_stmt let mark_rte () = let _, mem, _ = !Db.RteGen.get_memAccess_status () in let _, arith, _ = !Db.RteGen.get_divMod_status () in let _, signed_ovf, _ = !Db.RteGen.get_signedOv_status () in let _, unsigned_ovf, _ = !Db.RteGen.get_unsignedOv_status () in let signed = Kernel.SignedOverflow.get () in let unsigned = Kernel.UnsignedOverflow.get () in Globals.Functions.iter (fun kf -> if !Db.Value.is_called kf then ( mem kf true; arith kf true; signed_ovf kf signed; unsigned_ovf kf unsigned; ) ) let () = Db.Value.valid_behaviors := (fun kf state -> let ab = ActiveBehaviors.create state kf in ActiveBehaviors.active_behaviors ab ); (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/builtins.ml0000644000175000017500000003232012155630231020061 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Cvalue open Abstract_interp open Cil open Locations open Value_util let table = Hashtbl.create 17 let register_builtin name f = Hashtbl.add table name f let () = Db.Value.register_builtin := register_builtin let find_builtin name = Hashtbl.find table name 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 double_double_fun name caml_fun state actuals = match actuals with [_, arg, _] -> begin 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 { Value_types.c_values = [ Eval_op.wrap_double r, state ]; c_clobbered = Base.SetLattice.bottom; c_cacheable = Value_types.Cacheable; } end | _ -> 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 *) *) Floating_point.set_round_nearest_even(); (* system cos probably isn't designed for non-default rounding *) let lref = cos uarg in let uref = cos larg in Floating_point.set_round_upward(); let lallow = uref -. ueps in Floating_point.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; { Value_types.c_values = [ None, state ]; c_clobbered = Base.SetLattice.bottom; c_cacheable = Value_types.Cacheable; } 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.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 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 "invalid float sqrt: assert(Ook)"; V.bottom in { Value_types.c_values = [ Eval_op.wrap_double r, state] ; c_clobbered = Base.SetLattice.bottom; c_cacheable = Value_types.Cacheable; } end | _ -> Value_parameters.error "Invalid argument for Frama_C_sqrt function"; do_degenerate None; raise Db.Value.Aborted let () = register_builtin "Frama_C_sqrt" frama_C_sqrt let frama_C_assert state actuals = let do_bottom () = warning_once_current "Frama_C_assert: false"; Cvalue.Model.bottom in match actuals with [arg_exp, arg, _arg_offsm] -> begin let state = if Cvalue.V.is_zero arg then do_bottom () else if Cvalue.V.contains_zero arg then begin try let state = Eval_exprs.reduce_by_cond state { Eval_exprs.exp = arg_exp ; positive = true } in warning_once_current "Frama_C_assert: unknown"; state with Eval_exprs.Reduce_to_bottom -> do_bottom () end else begin warning_once_current "Frama_C_assert: true"; state end in { Value_types.c_values = [ None, state ] ; c_clobbered = Base.SetLattice.bottom; c_cacheable = Value_types.NoCache; } end | _ -> Value_parameters.error "Invalid argument for Frama_C_assert function"; do_degenerate None; raise Db.Value.Aborted let () = register_builtin "Frama_C_assert" frama_C_assert 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" C_assert.pretty_state_as_c_assert state; { Value_types.c_values = [None, state]; c_clobbered = Base.SetLattice.bottom; c_cacheable = Value_types.NoCache; } let () = register_builtin "Frama_C_dump_assert_each" frama_c_dump_assert let found_split state _ = { Value_types.c_values = [None, state]; c_clobbered = Base.SetLattice.bottom; c_cacheable = Value_types.NoCache; } let () = register_builtin "Frama_C_split" found_split let found_merge state _ = { Value_types.c_values = [None, state]; c_clobbered = Base.SetLattice.bottom; c_cacheable = Value_types.NoCache; } let () = register_builtin "Frama_C_merge" found_merge let frama_c_bzero state actuals = if Value_parameters.ValShowProgress.get () then Value_parameters.feedback "Call to builtin bzero(%a)%t" pretty_actuals actuals Value_util.pp_callstack; match actuals with | [(exp_dst, dst, _); (exp_size, size, _)] -> let with_alarms = warn_all_quiet_mode () in let size = try let size = Cvalue.V.project_ival size in Int.mul Int.eight (Ival.project_int size) with V.Not_based_on_null | Ival.Not_Singleton_Int -> raise Db.Value.Outside_builtin_possibilities in let term_size = Logic_utils.expr_to_term ~cast:true exp_size in let array_dst = Logic_utils.array_with_range exp_dst term_size in CilE.set_syntactic_context (CilE.SyMemLogic array_dst); if not (Cvalue.V.cardinal_zero_or_one dst) then raise Db.Value.Outside_builtin_possibilities; let left = loc_bytes_to_loc_bits dst and offsm_repeat = V_Offsetmap.create_isotropic ~size (V_Or_Uninitialized.initialized Cvalue.V.singleton_zero) in let state = if Int.gt size Int.zero then Cvalue.Model.paste_offsetmap ~with_alarms ~from:offsm_repeat ~dst_loc:left ~start:Int.zero ~size:size ~exact:true state else state in { Value_types.c_values = [ None, state ] ; c_clobbered = Base.SetLattice.bottom; c_cacheable = Value_types.Cacheable; } | _ -> raise Db.Value.Outside_builtin_possibilities let () = register_builtin "Frama_C_bzero" frama_c_bzero (* -------------------------------------------------------------------------- *) (* --- Multi-names builtins, not registered in the table --- *) (* -------------------------------------------------------------------------- *) 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; { Value_types.c_values = [None, initial_state]; c_clobbered = Base.SetLattice.bottom; c_cacheable = Value_types.NoCache; } module DumpFileCounters = State_builder.Hashtbl (Datatype.String.Hashtbl)(Datatype.Int) (struct let size = 3 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 (* 0 5 1 5 2 5 *) (* 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) ); { Value_types.c_values = [None, initial_state]; c_clobbered = Base.SetLattice.bottom; c_cacheable = Value_types.NoCache; } let dump_args name initial_state actuals = Value_parameters.result "Called %s%a%t" name pretty_actuals actuals Value_util.pp_callstack; { Value_types.c_values = [ None, initial_state] ; c_clobbered = Base.SetLattice.bottom; c_cacheable = Value_types.Cacheable; } (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/mark_noresults.ml0000644000175000017500000000472612155630231021311 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 class mark_visitor = object(_self) inherit Cil.nopCilVisitor method vstmt s = Db.Value.update_table s Cvalue.Model.top; Cil.DoChildren end let should_memorize_function name = 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 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)) let () = Db.Value.no_results := (fun fd -> not (should_memorize_function fd)) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/local_slevel.ml0000644000175000017500000003205512155630231020701 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* Currently, non strict mode is not available as it needs multiple return *) open Cil_types open Local_slevel_types (* Forward reference to {Local_slevel.compute_sub_function} *) let (compute_sub_function_ref : (Kernel_function.t -> stmt -> local_slevel_info -> State_set.t -> Cvalue.Model.t * Base.SetLattice.t) ref) = ref (fun _ -> assert false) let compute_sub_function kf = !compute_sub_function_ref kf (* Checks for a function call of a given name *) let is_call_with_name stmt name = match stmt.skind with | Instr (Call (None , {enode = Lval (Var {vname = vname; vtype = TFun _}, _)} , _ , _ ) ) when vname = name -> true | _ -> false let is_split_builtin_call stmt = is_call_with_name stmt "Frama_C_split" let is_merge_builtin_call stmt = is_call_with_name stmt "Frama_C_merge" let optional_slevel stmt = let fail () = Value_parameters.abort "Slevel must be a positive\ integral number, fitting into type int" in match stmt.skind with | Instr (Call (None, {enode = Lval (Var {vtype = TFun _}, _)}, _ :: {enode = Const (CInt64 (n, _, _))} :: _, _)) -> let n' = try Integer.to_int n with Assert_failure _ -> fail () in if n' < 0 then fail () else Some n' | _ -> None let get_id stmt = let fail () = Value_parameters.abort "Each \"Frama_C_split\" and \ \"Frama_C_merge\" builtin must have an integral as first argument." in match stmt.skind with | Instr (Call (None , {enode = Lval (Var {vtype = TFun _}, _)} , {enode = Const (CInt64 (n, _, _))} :: _ , _ ) ) -> begin try Integer.to_int n with Assert_failure _ -> fail () end | _ -> fail () (* This represents a split instruction: * map from split stmt to pair of * optional slevel * set of merge stmts *) module Split_merge = Cil_datatype.Stmt.Map.Make (Datatype.Pair (Datatype.Option (Datatype.Int)) (Cil_datatype.Stmt.Hptset)) (* Contains a mapping betwen kf and associated Split_merge_set. * this is the datastructure expected from other modules * kf -> (splitstmt -> mergestmt set) *) module Kf_split_merge_map = struct include Kernel_function.Map.Make(Split_merge) end let get_split_merge kf map = try Kernel_function.Map.find kf map with Not_found -> Cil_datatype.Stmt.Map.empty module Api_kf_split_merge_map = State_builder.Ref (Kf_split_merge_map) (struct let name = "empty" (* FIXME [SCM] check! *) let dependencies = [ Ast.self ] (* FIXME [SCM] check! *) let default () = Kernel_function.Map.empty end) module Strict_mode = State_builder.Ref (Datatype.Bool) (struct let name = "true" (* FIXME [SCM] check! *) let dependencies = [ Ast.self ] (* FIXME [SCM] check! *) let default () = true end) (* Checks a set of split/merge tuples for validity * * A valid set of split/merge tuples fulfills the follwing: 1 Each split must be associated to a function of the current project FIXME [SCM] currently not checked 2 The collection of all split nodes forms a set (uniqueness) checked by build_kf_split_merge_map 3 There does not exist a path of length >= 1 from split to split without going through an associated mege 4 A split node dominates all associated merge nodes 5 All merge nodes associated with a split are inside the same function (6) Strict mode: 1 The merge part of the tuple must be a singleton 2 A split must dominate its merge and a merge must postdominate its split 3 If on a cfg, there exists a split node s1 and a split node s2, such that s2 is reachable from s1 without going through merge(s1), then merge(s2) must postdominate merge(s1) 4 A node must not be a split and a merge node FIXME [SCM] untested *) let check_split_merges_for_kf kf strict split_merges = Value_parameters.debug "Checking split/merge configuration for function %s" (Kernel_function.get_name kf); let check3 (split, merges) = begin if Stmts_graph.stmt_is_in_cycle_filtered (fun x -> not (Cil_datatype.Stmt.Hptset.mem x merges)) split then Value_parameters.abort "Split node in cycle without any associated \ merges" end in let check_4_and_5 (split, merges) = let check4 merge = begin if not (!Db.Dominators.is_dominator kf ~opening:split ~closing:merge) then Value_parameters.abort "Split node must dominate all associated merges" end in let check5 merge = begin if not (try Kernel_function.equal kf (Kernel_function.find_englobing_kf merge) with Not_found -> false) then Value_parameters.abort "Split/merge combination not in same function" end in Cil_datatype.Stmt.Hptset.iter (fun merge -> check4 merge; check5 merge) merges in let check6 (split, merges) = let from_singleton ms = match Cil_datatype.Stmt.Hptset.elements ms with | [m] -> m | _ -> assert false (* call check61 first *) in let check61 merges = if Cil_datatype.Stmt.Hptset.cardinal merges <> 1 then Value_parameters.abort "In strict mode, only one merge allowed per \ split" in let check62 merge = if not (!Db.Dominators.is_dominator kf ~opening:split ~closing:merge && !Db.Postdominators.is_postdominator kf ~opening:split ~closing:merge) then Value_parameters.abort "In srict mode, a split must dominate its \ merge, and the merge must postdominate its split." in let check6_3_and_4 merge = let check63 split2 merge2 = if Stmts_graph.stmt_can_reach_filtered (fun s -> s.sid <> merge.sid) split split2 && not (!Db.Postdominators.is_postdominator kf ~opening:merge2 ~closing:merge) then Value_parameters.abort "In strict mode, split instructions must be \ well matched." in let check64 merge2 = if split.sid = merge2.sid then Value_parameters.abort "In strict mode, a stmt can either be a split \ a merge, or neither" in Cil_datatype.Stmt.Map.iter (fun split2 (_, merges2) -> check61 merges; let merge2 = from_singleton merges2 in check63 split2 merge2; check64 merge2) split_merges in check61 merges; let merge = from_singleton merges in check62 merge; check6_3_and_4 merge in Cil_datatype.Stmt.Map.iter (fun split (_, merges) -> let split_merge = split, merges in check3 split_merge ; check_4_and_5 split_merge ; if strict then check6 split_merge) split_merges (* Finds the explicit split/merge buildin in function kf * Aborts on error *) let retrieve_inner_split_merges kf : Split_merge.t = (* FIXME [SCM] exception unhandled - get_definition *) let fun_stmts = (Kernel_function.get_definition kf).sallstmts in let (stmt_id, id_mergeset) = List.fold_left (fun (stmt_id, id_mergeset) stmt -> match is_split_builtin_call stmt, is_merge_builtin_call stmt with | false, false -> stmt_id, id_mergeset | true, true -> assert false | true, false -> let id = get_id stmt in let slevel = optional_slevel stmt in Cil_datatype.Stmt.Map.add stmt (slevel, id) stmt_id, id_mergeset | false, true -> let id = get_id stmt in let newval = try let oldval = Datatype.Int.Map.find id id_mergeset in Cil_datatype.Stmt.Hptset.add stmt oldval with Not_found -> Cil_datatype.Stmt.Hptset.singleton stmt in stmt_id, Datatype.Int.Map.add id newval id_mergeset ) (Cil_datatype.Stmt.Map.empty, Datatype.Int.Map.empty) fun_stmts in Cil_datatype.Stmt.Map.fold (fun split (slevel, id) map -> let stmtset = try Datatype.Int.Map.find id id_mergeset with Not_found -> Cil_datatype.Stmt.Hptset.empty in Cil_datatype.Stmt.Map.add split (slevel, stmtset) map) stmt_id Cil_datatype.Stmt.Map.empty (* This function takes two split_merges and merges them to one * It fails if it finds a split instruction with the same split stmt *) let merge_split_merges split_merge1 split_merge2 = Cil_datatype.Stmt.Map.fold (fun split split_merge map -> if Cil_datatype.Stmt.Map.mem split split_merge1 then Value_parameters.abort "Same split stmt defined twice."; Cil_datatype.Stmt.Map.add split split_merge map ) split_merge2 split_merge1 (* Worker for get_check_tuples *) let get_check_tuples_raw kf = let strict = Strict_mode.get () in let split_merges_api_all = Api_kf_split_merge_map.get () in let split_merges_api = get_split_merge kf split_merges_api_all in let split_merges_kf = retrieve_inner_split_merges kf in let split_merges = merge_split_merges split_merges_api split_merges_kf in check_split_merges_for_kf kf strict split_merges; split_merges (* Cache for get_check_tuples *) module Get_check_tuples_cache = Kernel_function.Make_Table (Split_merge) (struct let size = 10 (* FIXME [SCM] Check! *) let name = "Get_check_tuples_cache" let dependencies = [ Ast.self ; Api_kf_split_merge_map.self ; Strict_mode.self ] (* FIXME [SCM] Check! *) end) (* This is the key function that retrieves the split instructions for kf by * looking up programmatically defined instructions * retrieving instructions from the statements in kf * merging both sets together * checking the merged set (according to strictness setting) * The result of this function is memoized *) let get_check_tuples = Get_check_tuples_cache.memo get_check_tuples_raw (* This function determines what should be done in eval_slevel.ml computers * doStmt * FIXME [SCM] currently only implemented for strict mode because of single * return restriction * * 1 Look at prevmode: * Merge -> set prevmode to normal and return merge * Split -> set prevmode to normal and return normal * Normal -> look at current stmt type * 2 Current stmt type: * issplit -> return Split with prevmode field set to split and merges set to corresponding merge set * ismerge -> set info.prevmode to merge and return normal * neither -> return normal *) let determine_mode kf stmt info = assert (Strict_mode.get ()); (* FIXME [SCM] currently only strict mode *) let split_merges = get_check_tuples kf in match info.prevmode with | MergeSplit _ -> assert false (*| Merge -> info.prevmode <- Normal; Merge*) | Split _ -> info.prevmode <- Normal; Normal (*| Normal ->*) | _ -> let issplit = try Some (Cil_datatype.Stmt.Map.find stmt split_merges) with Not_found -> None in let ismerge = Cil_datatype.Stmt.Hptset.mem stmt info.merges in match issplit, ismerge with | Some _, true -> assert false | Some (slevel, mergeset), false -> Split { prevmode = Split (empty_info()) ; merges = mergeset ; slevel = slevel } | None, true -> (*info.prevmode <- Merge; Normal*) Merge | None, false -> Normal (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/kf_state.ml0000644000175000017500000000673012155630231020036 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Db open Cil_datatype (* ************************************************************************* *) (** {2 Is called} *) (* ************************************************************************* *) module Is_Called = Kernel_function.Make_Table (Datatype.Bool) (struct let name = "is_called" let dependencies = [ Value.self ] let size = 17 end) let is_called = Is_Called.memo (fun kf -> try Value.is_reachable_stmt (Kernel_function.find_first_stmt kf) with Kernel_function.No_Statement -> false) let mark_as_called kf = Is_Called.replace kf true (* ************************************************************************* *) (** {2 Callers} *) (* ************************************************************************* *) module Callers = Kernel_function.Make_Table (Kernel_function.Map.Make(Stmt.Set)) (struct let name = "Callers" let dependencies = [ Value.self ] let size = 17 end) let add_caller ~caller:(caller_kf, call_site) kf = let add m = Kernel_function.Map.add caller_kf (Stmt.Set.singleton call_site) m in let change m = try let call_sites = Kernel_function.Map.find caller_kf m in Kernel_function.Map.add caller_kf (Stmt.Set.add call_site call_sites) m with Not_found -> add m in ignore (Callers.memo ~change (fun _kf -> add Kernel_function.Map.empty) kf) let callers kf = try let m = Callers.find kf in Kernel_function.Map.fold (fun key v acc -> (key, Stmt.Set.elements v) :: acc) m [] with Not_found -> [] (* ************************************************************************* *) (** {2 Registration.} *) (* ************************************************************************* *) let () = Value.is_called := is_called; Value.callers := callers; (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/library_functions.mli0000644000175000017500000000406212155630231022137 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 -> Cvalue.Model.t -> Cvalue.V.t * Cvalue.Model.t (** Auxiliary function that registers a new variable declared by Value within the kernel internal tables *) val register_new_var: varinfo -> typ -> unit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/function_args.ml0000644000175000017500000001415112155630231021073 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp open Locations open Cvalue exception Actual_is_bottom exception WrongFunctionType (* at a call through a pointer *) (* We cannot statically check that a call through a function pointer is correct wrt the number of arguments and their types (see the examples at the end of tests/misc/fun_ptr.i). Thus, we make additional checks here: the arguments size are correct, and the number of arguments is sufficient.*) let check_arg_size expr formal = if Cil.bitsSizeOf (Cil.typeOf expr) <> Cil.bitsSizeOf (formal.vtype) then raise WrongFunctionType let rec fold_left2_best_effort f acc l1 l2 = match l1,l2 with | _,[] -> acc | [],_ -> raise WrongFunctionType (* Too few arguments *) | (x1::r1),(x2::r2) -> fold_left2_best_effort f (f acc x1 x2) r1 r2 let actualize_formals ?(check = fun _ _ -> ()) ?(exact = fun _ -> true) kf state actuals = let formals = Kernel_function.get_formals kf in let treat_one_formal acc (expr, actual_o) formal = (check expr formal: unit); let loc_without_size = Location_Bits.inject (Base.create_varinfo formal) (Ival.zero) in Cvalue.Model.paste_offsetmap ~with_alarms:CilE.warn_none_mode ~from:actual_o ~dst_loc:loc_without_size ~start:Int.zero ~size:(Int_Base.project (Bit_utils.sizeof_vid formal)) ~exact:(exact formal) acc in fold_left2_best_effort treat_one_formal state actuals formals let main_initial_state_with_formals kf (state:Cvalue.Model.t) = match kf.fundec with | Declaration (_, _, None, _) -> state | Declaration (_, _, Some l, _) | Definition ({ sformals = l }, _) -> if l <> [] && Value_parameters.InterpreterMode.get() then begin Value_parameters.error "Entry point %a has arguments" Kernel_function.pretty kf; exit 0; end; List.fold_right Initial_state.initialize_var_using_type l state let offsetmap_contains_indeterminate offs = V_Offsetmap.fold_on_values (fun v _ (allbot, init, noesc) -> let allbot = allbot && V.is_bottom (V_Or_Uninitialized.get_v v) in let flags = V_Or_Uninitialized.get_flags v in let init = init && V_Or_Uninitialized.is_initialized flags in let noesc = noesc && V_Or_Uninitialized.is_noesc flags in (allbot, init, noesc) ) offs (true, true, true) let compute_actual ~with_alarms one_library_fun state e = let offsm = match e with | { enode = Lval lv } when not (Eval_op.is_bitfield (Cil.typeOfLval lv)) -> let loc, _, o = Eval_exprs.offsetmap_of_lv ~with_alarms state lv in (match o with | Some o -> (match Warn.offsetmap_contains_imprecision o with | Some v -> Warn.warn_imprecise_lval_read ~with_alarms lv loc v | None -> ()); let allbot, init, noesc = offsetmap_contains_indeterminate o in if one_library_fun || allbot then ( CilE.set_syntactic_context (CilE.SyMem lv); if not init then CilE.warn_uninitialized with_alarms; if not noesc then CilE.warn_escapingaddr with_alarms; ); if allbot then ( if with_alarms.CilE.imprecision_tracing.CilE.a_log != None then Value_parameters.result ~current:true ~once:true "completely invalid@ value in evaluation of@ argument %a" Printer.pp_lval lv; raise Actual_is_bottom); o | None -> if with_alarms.CilE.imprecision_tracing.CilE.a_log != None then Value_parameters.result ~current:true ~once:true "completely invalid@ location in evaluation of@ argument %a" Printer.pp_lval lv; raise Actual_is_bottom) | _ -> let interpreted_expr = Eval_exprs.eval_expr ~with_alarms state e in if Cvalue.V.is_bottom interpreted_expr then begin if with_alarms.CilE.imprecision_tracing.CilE.a_log != None then Value_parameters.result ~current:true "all evaluations are invalid@ for function call argument@ @[%a@]" Printer.pp_exp e; raise Actual_is_bottom end; let typ = Cil.typeOf e in Eval_op.offsetmap_of_v ~typ interpreted_expr in e, offsm let () = Db.Value.add_formals_to_state := (fun state kf exps -> try let compute_actual = compute_actual ~with_alarms:CilE.warn_none_mode false in let actuals = List.map (compute_actual state) exps in actualize_formals kf state actuals with Actual_is_bottom -> Cvalue.Model.bottom) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/initial_state.ml0000644000175000017500000006374012155630231021073 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp open Cvalue open Locations open Value_util exception Initialization_failed let typeHasAttribute attr typ = Cil.hasAttribute attr (Cil.typeAttrs typ) (* If [filled] is true, bind the contents of hidden_base to a well of itself. If not, do not bind it (typically for function pointers) *) let make_well ~filled hidden_base state loc = let size = Bit_utils.max_bit_size () in let well = Cvalue.V.inject_top_origin Origin.Well (Base.Hptset.singleton hidden_base) in let well_loc = Locations.make_loc (Location_Bits.inject hidden_base Ival.zero) (Int_Base.inject size) in let with_alarms = CilE.warn_none_mode in let state = if filled then Cvalue.Model.add_binding ~with_alarms ~exact:true state well_loc well else state in Cvalue.Model.add_binding ~with_alarms ~exact:true state loc well let warn_unknown_size_aux pp v (messt, t) = Value_parameters.warning ~once:true ~current:true "@[during initialization@ of %a,@ size of@ type '%a'@ cannot be@ computed@ \ (%s)@]" pp v Printer.pp_typ t messt let warn_unknown_size = warn_unknown_size_aux (fun fmt v -> Format.fprintf fmt "variable '%a'" Printer.pp_varinfo v) type validity_hidden_base = | Invalid (* Base is completely invalid *) | Unknown (* Base is maybe invalid on its entire validity *) | KnownUnknown of Integer.t (* Base is valid on i bits, then maybe invalid on the remainder of its validity *) let create_hidden_base ~valid ~hidden_var_name ~name_desc pointed_typ = let hidden_var = Cil.makeGlobalVar ~generated:false ~logic:true hidden_var_name pointed_typ in Library_functions.register_new_var hidden_var pointed_typ; hidden_var.vdescr <- Some name_desc; let validity = match valid with | Invalid -> Base.Invalid | _ -> (* Add a special case for void* pointers: we do not want to compute the size of void *) let validity = match Cil.unrollType pointed_typ with | TVoid _ -> Base.Unknown (Int.zero, None, Bit_utils.max_bit_address ()) | _ -> Base.validity_from_type hidden_var in match validity with | Base.Known (a,b) when not (Value_parameters.AllocatedContextValid.get ()) -> (match valid with | KnownUnknown size -> let size = Integer.pred size in assert (Integer.le size b); Base.Unknown (a, Some size, b) | _ -> Base.Unknown (a, None, b) ) | Base.Unknown _ | Base.Known _ | Base.Invalid as s -> s | Base.Periodic _ -> assert false in Base.create_logic hidden_var validity (** [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 = let with_alarms = CilE.warn_none_mode in Cil.CurrentLoc.set varinfo.vdecl; 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 bind_entire_loc ?(state=state) v = (* Shortcut *) Cvalue.Model.add_binding ~with_alarms ~exact:true state loc v in match typ with | TInt _ | TEnum (_, _)-> bind_entire_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"; bind_entire_loc Cvalue.V.top_float | TFloat (FFloat, _) -> bind_entire_loc Cvalue.V.top_single_precision_float | TFun _ -> state | TPtr (typ, _) as full_typ when depth <= Value_parameters.AutomaticContextMaxDepth.get () -> let attr = Cil.typeAttr full_typ in let context_max_width = Value_parameters.AutomaticContextMaxWidth.get () in if not (Cil.isVoidType typ) && not (Cil.isFunctionType typ) then let i = match Cil.findAttribute "arraylen" attr with | [AInt i] -> i | _ -> Integer.of_int context_max_width in let arr_pointed_typ = TArray(typ, Some (Cil.kinteger64 ~loc:varinfo.vdecl IULong i), Cil.empty_size_cache (), []) in let hidden_var_name = Cabs2cil.fresh_global ("S_" ^ name) in let name_desc = "*"^name_desc in (* Make first cell of the array valid. The NULL pointer takes care of a potential invalid pointer. *) let valid = try KnownUnknown (Integer.of_int (Cil.bitsSizeOf typ)) with Cil.SizeOfError _ -> Unknown in let hidden_base = create_hidden_base ~valid ~hidden_var_name ~name_desc arr_pointed_typ in let state = add_offsetmap (depth + 1) hidden_base name_desc hidden_var_name arr_pointed_typ NoOffset arr_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 bind_entire_loc ~state value else let hidden_var_name = Cabs2cil.fresh_global ("S_" ^ name) in let name_desc = "*"^name_desc in let valid, filled = if Cil.isFunctionType typ then Invalid, false else Unknown, true in let hidden_base = create_hidden_base ~valid ~hidden_var_name ~name_desc typ in make_well ~filled hidden_base state loc | TArray (typ, len, _, _) -> begin try let size = Cil.lenOfArray len in let size_elt = Int.of_int (Cil.bitsSizeOf typ) in let psize = pred size in let state = ref state in let typ = Cil.unrollType typ in let max_precise_size = Value_parameters.AutomaticContextMaxWidth.get () in let locs = ref [] in for i = 0 to min psize (pred max_precise_size) do (* Cells that are treated really precisely. We create new pointers (if needed) for each distinct cell *) let offset = Cil.addOffset (Index (Cil.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 state := add_offsetmap depth v name_desc name typ offset typ_orig !state; locs := loc_of_typoffset v typ_orig offset :: !locs; done; if max_precise_size < size then begin (* Some elements remain to be initialized *) let offsm_of_loc loc = (* This rereads one of the first cells*) Extlib.the (Cvalue.Model.copy_offsetmap ~with_alarms loc !state) in let last_loc, locs = match !locs with | [] -> assert false (* AutomaticContextMaxWidth is at least 1*) | l :: ll -> l, ll in (* Join of the contents of the first elements *) let offsm_joined = List.fold_left (fun offsm loc -> let offsm' = offsm_of_loc loc in Cvalue.V_Offsetmap.join offsm offsm' ) (offsm_of_loc last_loc) locs in let nb_fields = Cvalue.V_Offsetmap.fold (fun _itv _ -> succ) offsm_joined 0 in if nb_fields = 1 then (* offsm_joined is very regular (typically Top_int, or some pointers). We read its contents and copy it everywhere else. The periodicity of the contents may be smaller than the size of a cell; take this into account. *) let v, modu, offset = Extlib.the (Cvalue.V_Offsetmap.fold (fun _itv v _ -> Some v) offsm_joined None) in assert (Rel.equal offset Rel.zero); let ncells = size - max_precise_size in let total_size = Int.mul size_elt (Int.of_int ncells) in let offsm_repeat = V_Offsetmap.create ~size_v:modu ~size:total_size v in let loc = Location_Bits.shift (Ival.inject_singleton size_elt) last_loc.loc; in (* paste [size - max_precise_size] elements, starting from the last location initialized + 1 *) state := Cvalue.Model.paste_offsetmap ~with_alarms ~from:offsm_repeat ~dst_loc:loc ~start:Int.zero ~size:total_size ~exact:true !state else ( (* We have probably initialized a struct with different fields. We must perform offsetmap copies, that are slower *) if nb_fields * psize >= 5000 then Value_parameters.result ~once:true ~current:true "Initializing a complex array of %d elements. This may \ take some time" size; let loc = ref last_loc.loc in for _i = max_precise_size to psize do loc := Location_Bits.shift (Ival.inject_singleton size_elt) !loc; state := Cvalue.Model.paste_offsetmap ~with_alarms ~from:offsm_joined ~dst_loc:!loc ~start:Int.zero ~size:size_elt ~exact:true !state done); end; !state with | Cil.LenOfArray -> Value_parameters.result ~once:true ~current:true "could not find a size for array"; state (* TODOBY: use same strategy as for pointer *) | Cil.SizeOfError (s, t) -> warn_unknown_size varinfo (s, t); bind_entire_loc Cvalue.V.top_int; end | TComp ({cstruct=true;} as compinfo, _, _) -> (* Struct *) let treat_field (next_offset,state) field = let new_offset = Field (field, NoOffset) in let offset = Cil.addOffset new_offset offset_orig in let field_offset,field_width = Cil.bitsOffset typ_orig offset in let state = if field_offset>next_offset then (* padding bits need 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 = Cil.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 (s, t) -> warn_unknown_size varinfo (s, t); bind_entire_loc Cvalue.V.top_int; end | TComp ({cstruct=false}, _, _) when Cil.is_fully_arithmetic typ -> (* Union of arithmetic types *) bind_entire_loc Cvalue.V.top_int | TPtr _ when Value_parameters.AllocatedContextValid.get () -> (* deep pointers map to NULL in this case *) bind_entire_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 = Cil.makeGlobalVar ~logic:true hidden_var_name Cil.charType in hidden_var.vdescr <- Some (name_desc^"_WELL"); let validity = Base.Known (Int.zero, Bit_utils.max_bit_address ()) in let hidden_base = Base.create_logic hidden_var validity in make_well ~filled:true 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 init_var_zero vi state = let loc = Locations.loc_of_varinfo vi in let v = if typeHasAttribute "volatile" vi.vtype then V.top_int else V.singleton_zero in (try ignore (Cil.bitsSizeOf vi.vtype) with Cil.SizeOfError (s, t)-> warn_unknown_size vi (s, t); ); Cvalue.Model.add_binding ~with_alarms:CilE.warn_none_mode ~exact:true state loc v let initialized_padding () = Value_parameters.InitializedPaddingGlobals.get () (* initialize the padding needing for type [typ], assuming that [last_bitsoffset] bits have been initialized. The padding is added starting from [lval+abs_offset bits] *) let init_trailing_padding state ~last_bitsoffset ~abs_offset typ lval = try let size_to_add = Cil.bitsSizeOf typ - last_bitsoffset in let offset = 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 make_loc loc (Int_Base.inject size) | _ -> assert false in if initialized_padding () then let v = if typeHasAttribute "volatile" typ then V.top_int else V.singleton_zero in Cvalue.Model.add_binding ~with_alarms:CilE.warn_none_mode ~exact:true state loc v else Cvalue.Model.add_binding_not_initialized state loc else state with Cil.SizeOfError (s,t) -> warn_unknown_size_aux Printer.pp_lval lval (s, t); state (* Evaluation of a [SingleInit] in Cil parlance *) let eval_single_initializer state lval exp = let with_alarms = CilE.warn_none_mode in (* Eval in Top state. We do not want the location to depend on other globals*) let _, loc, typ_lval = Eval_exprs.lval_to_loc_state ~with_alarms Cvalue.Model.top lval in if not (cardinal_zero_or_one loc) then Value_parameters.fatal ~current:true "In global initialisation, the location can not be represented. Aborting."; let value = Eval_exprs.eval_expr ~with_alarms:(warn_all_quiet_mode ()) state exp in let v = if typeHasAttribute "volatile" typ_lval then V.top_int else if Eval_op.is_bitfield typ_lval then Eval_op.cast_lval_bitfield typ_lval loc.Locations.size value else value in Cvalue.Model.add_binding ~with_alarms ~exact:true state loc v let rec eval_initializer state lval init = match init with | SingleInit exp -> eval_single_initializer state lval exp | CompoundInit (base_typ, l) -> if typeHasAttribute "volatile" base_typ then state (* initializer is not useful *) else let last_bitsoffset, state = Cil.foldLeftCompound ~implicit:(not (initialized_padding ())) ~doinit: (fun off init typ (acc, state) -> let o,w = Cil.bitsOffset base_typ off in (* Format.printf "acc:%d o:%d w:%d@." acc o w; *) let state = if acc vinfo, (Cil.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; *) Cvalue.Model.add_binding_not_initialized state loc end else (assert (acc=o); state) in if typeHasAttribute "volatile" typ then warning_once_current "global initialization of volatile %s ignored" (match off with | Field _ -> "field" | Index _ -> "array element" | NoOffset -> "element"); o+w, eval_initializer state (Cil.addOffsetLval off lval) init ) ~ct:base_typ ~initl:l ~acc:(0, state) in let base_off,_ = (match lval with | Var vinfo, abs_offset -> Cil.bitsOffset vinfo.vtype abs_offset | _ -> Value_parameters.fatal "Whacky initializer?") in if initialized_padding () then init_trailing_padding state ~last_bitsoffset ~abs_offset:(base_off+last_bitsoffset) base_typ lval else state (* Special initializers. Only lval with attributes 'const' are initialized *) let rec eval_const_initializer state lval init = match init with | SingleInit exp -> let typ_lval = Cil.typeOfLval lval in let attrs = Cil.typeAttrs typ_lval in if Cil.hasAttribute "const" attrs && not (Cil.hasAttribute "volatile" attrs) then eval_single_initializer state lval exp else state | CompoundInit (base_typ, l) -> if typeHasAttribute "volatile" base_typ || not (Cil.typeHasAttributeDeep "const" base_typ) then state (* initializer is not useful *) else Cil.foldLeftCompound ~implicit:true ~doinit: (fun off init _typ state -> eval_const_initializer state (Cil.addOffsetLval off lval) init) ~ct:base_typ ~initl:l ~acc:state (** Initial value for globals and NULL in no-lib-entry mode (everything initialized to 0). *) let initial_state_only_globals = let module S = State_builder.Option_ref (Cvalue.Model) (struct let name = "Value.Initial_state.Not_context_free" let dependencies = [ Ast.self; Kernel.AbsoluteValidRange.self; Value_parameters.InitializedPaddingGlobals.self ] 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 Globals.Vars.iter_in_file_order (fun varinfo init -> if not varinfo.vlogic then begin Cil.CurrentLoc.set varinfo.vdecl; let volatile = typeHasAttribute "volatile" varinfo.vtype in match init.init, volatile with | None, _ | _, true -> (* Default to zero init *) if volatile && init.init != None then warning_once_current "global initialization of volatile value ignored"; if varinfo.vstorage = Extern then (* Must not assume zero when the storage is extern. *) update_state (initialize_var_using_type varinfo !state) else if initialized_padding () then update_state (init_var_zero varinfo !state) else let typ = varinfo.vtype in let loc = Cil_datatype.Location.unknown in let zi = Cil.makeZeroInit ~loc typ in update_state (eval_initializer !state (Var varinfo,NoOffset) zi) | Some i, false -> update_state (eval_initializer !state (Var varinfo,NoOffset) i) end); (** Bind the declared range for NULL to top int *) 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 (* Bind everything between [0..max] to bottom. Offsetmaps cannot contain holes, which would happend if min > 0 holds. *) let bot = V_Offsetmap.create_isotropic ~size:max_valid (V_Or_Uninitialized.initialized V.bottom) in let v = if true (* TODO: command line option *) then V_Or_Uninitialized.initialized V.top_int else V_Or_Uninitialized.uninitialized in let offsm = V_Offsetmap.add (min_valid, max_valid) (v, Int.one, Rel.zero) bot in state := Cvalue.Model.add_base Base.null offsm !state end; let result = !state in result in S.memo (fun () -> try compute () with Initialization_failed -> Cvalue.Model.bottom) module ContextfreeGlobals = State_builder.Option_ref (Cvalue.Model) (struct let name = "Value.Initial_state.ContextfreeGlobals" open Value_parameters let dependencies = [ Ast.self; Kernel.AbsoluteValidRange.self; InitializedPaddingGlobals.self; AllocatedContextValid.self; AutomaticContextMaxWidth.self; AutomaticContextMaxDepth.self; ] end) let () = Ast.add_monotonic_state ContextfreeGlobals.self (** Initial state in [-lib-entry] mode *) let initial_state_contextfree_only_globals () = let add_varinfo state vi = Cil.CurrentLoc.set vi.vdecl; let state = initialize_var_using_type vi state in (* We may do a second phase to initialize const fields again. In the first phase, they have been set to generic values *) if Cil.typeHasAttributeDeep "const" vi.vtype && not (vi.vstorage = Extern) then let init = match (Globals.Vars.find vi).init with | None -> Cil.makeZeroInit ~loc:vi.vdecl vi.vtype | Some init -> init in eval_const_initializer state (Var vi, NoOffset) init else 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 ContextfreeGlobals.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: *) frama-c-Fluorine-20130601/src/value/initial_state.mli0000644000175000017500000000354112155630231021235 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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: *) frama-c-Fluorine-20130601/src/value/warn.ml0000644000175000017500000003435012155630231017204 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Value_util open Locations exception Distinguishable_strings (* Does the comparison of [ev1] and [ev2] involve the comparison of invalid pointers, or is undefined (typically pointers in different bases) *) let check_not_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 Integer.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 with Not_found | Base.Not_valid_offset -> true exception Recursive_call (** Check that [kf] is not already present in the call stack *) let check_no_recursive_call kf = try List.iter (function (g,_) -> if kf == g then begin if Value_parameters.IgnoreRecursiveCalls.get() then begin warning_once_current "@[recursive call@ during@ value@ analysis@ of %a @[(%a <- %a)@].@ \ Using specification of %a.@]" Kernel_function.pretty kf Kernel_function.pretty kf pretty_call_stack (call_stack ()) Kernel_function.pretty kf; Db.Value.recursive_call_occurred kf; raise Recursive_call end else begin warning_once_current "@[@[detected@ recursive@ call@ (%a <- %a)@]@;@[Use %s@ to@ ignore@ (beware@ this@ will@ make@ the analysis@ unsound)@]@]" Kernel_function.pretty kf pretty_call_stack (call_stack ()) Value_parameters.IgnoreRecursiveCalls.option_name; Value_parameters.not_yet_implemented "recursive call" end end) (call_stack ()); true with Recursive_call -> false (* Warn if [lv] changes during a call [lvret = kf()] *) let warn_modified_result_loc ~with_alarms kf locret state lvret = CilE.do_warn with_alarms.CilE.others (fun (_emit, suffix) -> match lvret with | Var _, NoOffset -> () (* Skip trivially constant l-values *) | _ -> (* Go through Db.Value to avoid recursivity between modules *) let locret' = !Db.Value.lval_to_loc_state state lvret in if not (Location.equal locret locret') then (* There might be a false warning if the location is partially invalid before the call, and is reduced to its valid part during the call *) let validlocret = valid_part ~for_writing:true locret in let validlocret' = valid_part ~for_writing:true locret' in if not (Location.equal validlocret validlocret') then let loc = Cil_datatype.Location.unknown in let exp = Cil.mkAddrOrStartOf ~loc lvret in Value_parameters.warning ~current:true ~once:true "@[possible@ side-effect@ modifying %a@ within@ call@ to %a@]%t" Printer.pp_exp exp Kernel_function.pretty kf suffix; ) 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 | Base.SetLattice.Top -> warning_once_current "locals escaping the scope of %t%a through %a" pretty_block Printer.pp_varinfo sv pretty_base k | Base.SetLattice.Set _ -> warning_once_current "locals %a escaping the scope of %t%a through %a" Base.SetLattice.pretty locals pretty_block Printer.pp_varinfo sv pretty_base k let warn_locals_escape_result fundec locals = let sv = fundec.svar in match locals with | Base.SetLattice.Top -> warning_once_current "locals escaping the scope of %a through \\result" Printer.pp_varinfo sv | Base.SetLattice.Set _ -> warning_once_current "locals %a escaping the scope of %a through \\result" Base.SetLattice.pretty locals Printer.pp_varinfo sv let warn_imprecise_lval_read ~with_alarms lv loc contents = if with_alarms.CilE.imprecision_tracing.CilE.a_log <> None then let pretty_param fmt param = match param with | Base.SetLattice.Top -> Format.fprintf fmt "is imprecise" | Base.SetLattice.Set _s -> Format.fprintf fmt "is a garbled mix of %a" Base.SetLattice.pretty param in let pretty_param_b fmt param = match param with | Base.SetLattice.Top -> Format.fprintf fmt "The contents@ are imprecise" | Base.SetLattice.Set _s -> Format.fprintf fmt "It contains@ a garbled@ mix@ of@ %a" Base.SetLattice.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 CilE.do_warn with_alarms.CilE.imprecision_tracing (fun _ -> Value_parameters.result ~current:true ~once:true "@[@[Reading left-value %a.@]@ %t%t%t@]" Printer.pp_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) (* Auxiliary function for [do_assign] below. When computing the result of [lv = exp], warn if the evaluation of [exp] results in an imprecision. [loc_lv] is the location pointed to by [lv]. [exp_val] is the part of the evaluation of [exp] that is imprecise. *) let warn_right_exp_imprecision ~with_alarms lv loc_lv exp_val = CilE.do_warn with_alarms.CilE.imprecision_tracing (fun _ -> match exp_val with | Location_Bytes.Top(_topparam,origin) -> Value_parameters.result ~once:true ~current:true "@[@[Assigning imprecise value to %a%t.@]%a%t@]" Printer.pp_lval lv (fun fmt -> match lv with | (Mem _, _) -> Format.fprintf fmt "@ (i.e. %a)" Locations.pretty loc_lv | (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 | Location_Bytes.Map _ -> if not (Got_Imprecise_Value.get ()) && not (Cvalue.V.cardinal_zero_or_one exp_val) 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) (* Auxiliary function for do_assign (currently), that warns when the left-hand side and the right-hand side of an assignment overlap *) let warn_overlap ~with_alarms (lv, left_loc) (exp_lv, right_loc) = if with_alarms.CilE.others.CilE.a_log <> None then match right_loc.size with | Int_Base.Value size when Integer.gt size (Integer.of_int (Cil.bitsSizeOf Cil.intType)) -> if Location_Bits.partially_overlaps size right_loc.loc left_loc.loc then begin CilE.set_syntactic_context (CilE.SySep (lv, exp_lv)); CilE.warn_overlap (left_loc, right_loc) with_alarms; end | _ -> () exception Got_imprecise of Cvalue.V.t let offsetmap_contains_imprecision offs = try Cvalue.V_Offsetmap.iter_on_values (fun v _ -> match Cvalue.V_Or_Uninitialized.get_v v with | Location_Bytes.Map _ -> () | Location_Bytes.Top _ as v -> raise (Got_imprecise v) ) offs; None with Got_imprecise v -> Some v let warn_float_addr ~with_alarms msg = CilE.do_warn with_alarms.CilE.imprecision_tracing (fun (_, pp) -> Value_parameters.result ~once:true ~current:true "@[float@ value@ contains@ addresses (%t)]%t" msg pp ); ;; let warn_float ~with_alarms ?(overflow=false) ?(addr=false) flkind msg = if addr then warn_float_addr ~with_alarms msg; if addr || overflow then CilE.warn_nan_infinite with_alarms flkind msg; ;; (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/library_functions.ml0000644000175000017500000001352012155630231021765 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Abstract_interp open Bit_utils open Cvalue module Retres = Kernel_function.Make_Table (Cil_datatype.Varinfo) (struct let name = "retres_variable" let size = 9 let dependencies = [Ast.self] end) let () = Ast.add_monotonic_state Retres.self let () = State_dependency_graph.add_dependencies ~from:Retres.self [ Db.Value.self ] 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 ~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) with SizeOfError _ -> Value_parameters.abort "library function return type size unknown. \ Please report" in 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" end) let () = Ast.add_monotonic_state Returned_Val.self let register_new_var v typ = if isFunctionType typ then Globals.Functions.replace_by_declaration (Cil.empty_funspec()) v v.vdecl else Globals.Vars.add_decl v let returned_value kf state = (* Process return of function *) let return_type = unrollType (Kernel_function.get_return_type kf) in match return_type with | TComp _ when is_fully_arithmetic return_type -> Cvalue.V.top_int, state | TPtr(typ,_) | (TComp _ as typ) -> begin let size = max_bit_size () in 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 ~generated:false (Cabs2cil.fresh_global ("alloced_return_" ^ Kernel_function.get_name kf)) typ in register_new_var new_varinfo typ; let validity = Base.Known (Int.zero, Int.pred size) in Base.create_logic new_varinfo validity ) kf in let initial_value = match Cil.unrollType typ with | TInt _ | TEnum _ -> V.top_int | TFloat (FFloat, _) -> V.top_single_precision_float | TFloat ((FDouble | FLongDouble), _) -> V.top_float | _ -> let origin = Origin.current Origin.K_Leaf in V.inject_top_origin origin (Base.Hptset.singleton new_base) in (* top_float is not isotropic, we need a size to initialize the offsetmap bound to [base] *) let size_v = try if isVoidType typ then Int.one else Int_Base.project (sizeof typ) with Int_Base.Error_Top -> assert (Cvalue.V.is_isotropic initial_value); Int.one in let returned_value = Location_Bytes.inject new_base (Ival.filter_ge_int (Some Int.zero) (Ival.create_all_values ~signed:true ~modu:size_v ~size:(sizeofpointer ()))) in let v = Cvalue.V_Or_Uninitialized.initialized initial_value in let offsm = Cvalue.V_Offsetmap.create ~size v ~size_v in (* TODO: this overwrites the entire previous states *) let state = Cvalue.Model.add_base new_base offsm state in returned_value, state end | TInt _ | TEnum _ -> Cvalue.V.top_int, state | TFloat _ -> Cvalue.V.top_float, state | TBuiltin_va_list _ -> Value_parameters.error ~current:true ~once:true "functions returning variadic arguments must be stubbed%t" Value_util.pp_callstack; V.top_int, state | TVoid _ -> Cvalue.V.top (* this value will never be used *), state | TFun _ | TNamed _ | TArray _ -> assert false (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/register_gui.mli0000644000175000017500000000336112155630231021074 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Extension of the GUI in order to support the value analysis. No function is exported. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/widen.mli0000644000175000017500000000341612155630231017513 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 getWidenHints: kernel_function -> stmt -> Base.Set.t * (Base.t -> Locations.Location_Bytes.widen_hint) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/widen.ml0000644000175000017500000002455612155630231017352 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 widen_visitor kf init_widen_hints init_enclosing_loop_info = object (* visit all sub-expressions from [kf] definition *) inherit Visitor.frama_c_inplace val widen_hints = init_widen_hints val enclosing_loop_info = init_enclosing_loop_info method vstmt (s:stmt) = begin let infer_widen_variables bl enclosing_loop_info = (* Look at the if-goto and if-break statements. The variables of the condition are added to the widening variable set for this loop. These variables may control the loop. That may be not the case ! *) (* Format.printf "Look at widening variables.\n" ; *) let visitor = new widen_visitor kf widen_hints enclosing_loop_info in ignore (Visitor.visitFramacBlock visitor bl); Cil.SkipChildren in begin match s.skind with | Loop (_, bl, _, _, _) -> let annot = Annotations.code_annot s in let l_pragma = Logic_utils.extract_loop_pragma annot in let widening_stmts = match bl.bstmts with | [] -> [ s] | x :: _ -> [ s; x ] in (* Look at the loop pragmas *) let is_pragma_widen_variables = ref false in let f p = match p with | Widen_variables l -> let f (lv, lt) t = match t with | { term_node= TLval (TVar {lv_origin = Some vi}, _)} -> let vid = Base.create_varinfo vi in (* Format.printf "Reading user pragma for widening variable: %a.\n" Base.pretty (Base.Var vi); *) (vid::lv, lt) | _ -> (lv, t::lt) in begin match List.fold_left f ([], []) l with | (lv, []) -> (* the annotation is empty or else, there are only variables *) let var_hints = List.fold_left (fun s x -> Base.Set.add x s) Base.Set.empty lv in List.iter (fun widening_stmt -> widen_hints := Widen_type.add_var_hints widening_stmt var_hints !widen_hints) widening_stmts; is_pragma_widen_variables := true | (_lv, _lt) -> Kernel.warning ~once:true ~current:true "could not interpret loop pragma relative to widening \ variables" end | Widen_hints l -> let f (lv, lnum, lt) t = match t with | { term_node= TLval (TVar { lv_origin = Some vi}, _)} -> let vid = Base.create_varinfo vi in (vid::lv, lnum, lt) | { term_node= TConst (Integer(v,_))} -> (lv, v::lnum, lt) | _ -> (lv, lnum, t::lt) in begin match List.fold_left f ([], [], []) l with | (lv, lnum, []) -> (* the annotation is empty or else, there are only variables *) let hints = List.fold_right Ival.Widen_Hints.add lnum Ival.Widen_Hints.empty in List.iter (fun key -> List.iter (fun widening_stmt -> widen_hints := Widen_type.add_num_hints (Some(widening_stmt)) (Widen_type.VarKey(key)) hints !widen_hints) widening_stmts) lv | _ -> Kernel.warning ~once:true ~current:true "could not interpret loop pragma relative to widening hint" end | _ -> () in List.iter f l_pragma ; if not !is_pragma_widen_variables then let loop = try Loop.get_loop_stmts kf s with Loop.No_such_while -> assert false in (* There is no Widen_variables pragma for this loop. *) infer_widen_variables bl (Some (widening_stmts, loop)) else Cil.DoChildren | If (exp, bl_then, bl_else, _) -> begin match enclosing_loop_info with | None -> () | Some (widening_stmts, loop_stmts) -> List.iter (fun bl -> match bl with | {bstmts = []} -> () | {bstmts = ({skind = Break _; succs = [stmt]}| {skind = Goto ({contents=stmt},_)})::_} when not (Stmt.Set.mem stmt loop_stmts) -> let varinfos = Cil.extract_varinfos_from_exp exp in let var_hints = Varinfo.Set.fold (fun vi lv -> (*Format.printf "Inferring pragma for widening variable: %a.\n" Base.pretty (Base.Var vi);*) Base.Set.add (Base.create_varinfo vi) lv) varinfos Base.Set.empty in List.iter (fun widening_stmt -> widen_hints := Widen_type.add_var_hints widening_stmt var_hints !widen_hints) widening_stmts | _ -> ()) [bl_then ; bl_else] end; Cil.DoChildren | _ -> Cil.DoChildren end ; end method vexpr (e:exp) = begin let with_succ v = [v ; Integer.succ v] and with_pred v = [Integer.pred v ; v ] and with_s_p_ v = [Integer.pred v; v; Integer.succ v] and default_visit e = match Cil.isInteger e with | Some _int64 -> (* let v = Ival.Widen_Hints.V.of_int64 int64 in widen_hints := Db.Widen_Hints.add_to_all v !widen_hints ; *) Cil.SkipChildren | _ -> Cil.DoChildren and comparison_visit add1 add2 e1 e2 = let add key set = let hints = List.fold_right Ival.Widen_Hints.add set Ival.Widen_Hints.empty in (*Format.printf "Adding widen hint %a for base %a@\n" Ival.Widen_Hints.pretty hints Base.pretty key;*) widen_hints := Widen_type.add_num_hints None (Widen_type.VarKey key) hints !widen_hints in begin let e1,e2 = Cil.constFold true e1, Cil.constFold true e2 in match (Cil.isInteger e1, Cil.isInteger e2, e1, e2) with | Some int64, _, _, {enode=(CastE(_, { enode=Lval (Var varinfo, _)}) | Lval (Var varinfo, _))}-> add (Base.create_varinfo varinfo) (add1 int64); Cil.SkipChildren | _, Some int64, {enode=(CastE(_, { enode=Lval (Var varinfo, _)}) | Lval (Var varinfo, _))}, _ -> add (Base.create_varinfo varinfo) (add2 int64); Cil.SkipChildren | _ -> Cil.DoChildren end in match e.enode with | BinOp (Lt, e1, e2, _) | BinOp (Gt, e2, e1, _) | BinOp (Le, e2, e1, _) | BinOp (Ge, e1, e2, _) -> comparison_visit with_succ with_pred e1 e2 | BinOp (Eq, e1, e2, _) | BinOp (Ne, e1, e2, _) -> comparison_visit with_s_p_ with_s_p_ e1 e2 | _ -> default_visit e end end let compute_widen_hints kf _s default_widen_hints = (* [s] isn't used yet *) let widen_hints = begin match kf.fundec with | Declaration _ -> default_widen_hints | Definition (fd,_) -> begin let widen_hints = ref default_widen_hints in let visitor = new widen_visitor kf widen_hints None in ignore (Visitor.visitFramacFunction visitor fd); !widen_hints end end in widen_hints module Hints = Kernel_function.Make_Table (Widen_type) (struct let name = "Widen.Hints" let size = 97 let dependencies = [ Ast.self ] end) let () = Ast.add_monotonic_state Hints.self let getWidenHints (kf:kernel_function) (s:stmt) = let widen_hints_map = Hints.memo (fun kf -> compute_widen_hints kf s Widen_type.default) kf in Widen_type.hints_from_keys s widen_hints_map (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/eval_terms.ml0000644000175000017500000015314012155630231020375 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Locations open Abstract_interp open Cvalue open Bit_utils (** 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 (* Type of possible errors during evaluation. See pretty-printer for details *) type logic_evaluation_error = | Unsupported of string | AstError of string | NoEnv of logic_label | NoResult | CAlarm let pretty_logic_evaluation_error fmt = function | Unsupported s -> Format.fprintf fmt "unsupported ACSL construct: %s" s | AstError s -> Format.fprintf fmt "error in AST: %s; please report" s | NoEnv (LogicLabel (_, s)) -> Format.fprintf fmt "no environment to evaluate \\at(%s,_)" s | NoEnv (StmtLabel _) -> Format.fprintf fmt "\\at() on a C label is unsupported" | NoResult -> Format.fprintf fmt "meaning of \\result not specified" | CAlarm -> Format.fprintf fmt "alarm during evaluation" exception LogicEvalError of logic_evaluation_error let unsupported s = raise (LogicEvalError (Unsupported s)) let ast_error s = raise (LogicEvalError (AstError s)) let no_env lbl = raise (LogicEvalError (NoEnv lbl)) let no_result () = raise (LogicEvalError NoResult) let c_alarm () = raise (LogicEvalError CAlarm) let display_evaluation_error = function | CAlarm -> () | pa -> Value_parameters.result ~once:true ~current:true "cannot evaluate ACSL term, %a" pretty_logic_evaluation_error pa let warn_raise_mode = { CilE.imprecision_tracing = CilE.a_ignore ; defined_logic = CilE.a_ignore; unspecified = {CilE.a_ignore with CilE.a_call=c_alarm}; others = {CilE.a_ignore with CilE.a_call=c_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 *) (* TODO: evaluating correctly Pat with the current Value domain is tricky, and only works reliably for the four labels below, that are either invariant during the course of the program, or fully local. The program below shows the problem: if (c) x = 1; else x = 3; L: x = 1; \assert \at(x == 1, L); A nave implementation of assertions involving C labels is likely to miss the fact that the assertion is false after the else branch. A good solution is to use a dummy edge that flows from L to the assertion, to force its re-evaluation. *) type labels_states = Cvalue.Model.t Logic_label.Map.t let join_label_states m1 m2 = let aux _ s1 s2 = match s1, s2 with | None, None -> None | Some s, None | None, Some s -> Some s | Some s1, Some s2 -> Some (Cvalue.Model.join s1 s2) in if m1 == m2 then m1 else Logic_label.Map.merge aux m1 m2 type eval_env = { e_cur: logic_label; e_states: labels_states; result: varinfo option; (* Variable in which \tresult values are taken *) } let join_env e1 e2 = { e_cur = (assert (Logic_label.equal e1.e_cur e2.e_cur); e1.e_cur); e_states = join_label_states e1.e_states e2.e_states; result = (assert (e1.result == e2.result); e1.result); } let env_state env lbl = try Logic_label.Map.find lbl env.e_states with Not_found -> no_env lbl let env_current_state e = env_state e e.e_cur let overwrite_state env state lbl = { env with e_states = Logic_label.Map.add lbl state env.e_states } let overwrite_current_state env state = overwrite_state env state env.e_cur let lbl_here = LogicLabel (None, "Here") let add_logic ll state states = Logic_label.Map.add (LogicLabel (None, ll)) state states let add_here = add_logic "Here" let add_pre = add_logic "Pre" let add_post = add_logic "Post" let add_old = add_logic "Old" let env_pre_f ?(c_labels=Logic_label.Map.empty) ~init () = { e_cur = lbl_here; e_states = add_here init (add_pre init c_labels); result = None (* Never useful in a pre *); } let env_post_f ?(c_labels=Logic_label.Map.empty) ~pre ~post ~result () = { e_cur = lbl_here; e_states = add_post post (add_here post (add_pre pre (add_old pre c_labels))); result = result; } let env_annot ?(c_labels=Logic_label.Map.empty) ~pre ~here () = { e_cur = lbl_here; e_states = add_here here (add_pre pre c_labels); result = None (* Never useful in a 'assert' *) (* TODO: will be needed for stmt contracts *); } let env_assigns ~init = { e_cur = lbl_here; (* YYY: is missing, but is too difficult in the current evaluation scheme *) e_states = add_old init (add_here init (add_pre init Logic_label.Map.empty)); result = None (* Treated in a special way in callers *) } let lop_to_cop op = match op with | Req -> Eq | Rneq -> Ne | Rle -> Le | Rge -> Ge | Rlt -> Lt | Rgt -> Gt (* Types currently understood in the evaluation of the logic: no arrays, structs, logic arrays or subtle ACSL types. Sets of sets seem to be flattened, so the current treatment of them is correct. *) let rec isLogicNonCompositeType t = match t with | Lvar _ | Larrow _ -> false | Ltype _ -> Logic_const.is_boolean_type t || (try isLogicNonCompositeType (Logic_const.type_of_element t) with Failure _ -> false) | Linteger | Lreal -> true | Ctype t -> match Cil.unrollType t with | TInt _ | TEnum _ | TFloat _ | TPtr _ -> true | _ -> false let rec infer_type = function | Ctype t -> (match t with | TInt _ -> Cil.intType | TFloat _ -> Cil.doubleType | _ -> t) | Lvar _ -> Cil.voidPtrType (* For polymorphic empty sets *) | Linteger -> Cil.intType | Lreal -> Cil.doubleType | Ltype _ | Larrow _ as t -> if Logic_const.is_plain_type t then unsupported (Pretty_utils.to_string Cil_datatype.Logic_type.pretty t) else Logic_const.plain_or_set infer_type t (* Best effort for compring the types currently understood by Value: ignore differences in integer and floating-point sizes, that are meaningless in the logic *) let same_etype t1 t2 = match Cil.unrollType t1, Cil.unrollType t2 with | (TInt _ | TEnum _), (TInt _ | TEnum _) -> true | TFloat _, TFloat _ -> true | TPtr (p1, _), TPtr (p2, _) -> Cil_datatype.Typ.equal p1 p2 | _, _ -> Cil_datatype.Typ.equal t1 t2 let real_mode = Ival.Float_abstract.Any let infer_binop_res_type op targ = match op with | PlusA | MinusA | Mult | Div -> targ | PlusPI | MinusPI | IndexPI -> assert (Cil.isPointerType targ); targ | MinusPP -> Cil.intType | Mod | Shiftlt | Shiftrt | BAnd | BXor | BOr -> (* can only be applied on integral arguments *) assert (Cil.isIntegralType targ); Cil.intType | Lt | Gt | Le | Ge | Eq | Ne | LAnd | LOr -> Cil.intType (* those operators always return a boolean *) type edeps = Zone.t Logic_label.Map.t let deps_at lbl (ed:edeps) = try Logic_label.Map.find lbl ed with Not_found -> Zone.bottom let add_deps lbl edeps deps = let prev_deps = deps_at lbl edeps in let deps = Zone.join prev_deps deps in let edeps : edeps = Logic_label.Map.add lbl deps edeps in edeps let join_edeps (ed1:edeps) (ed2: edeps) : edeps = let aux _ d1 d2 = match d1, d2 with | None as d, None | (Some _ as d), None | None, (Some _ as d) -> d | Some d1, Some d2 -> Some (Zone.join d1 d2) in Logic_label.Map.merge aux ed1 ed2 let empty_edeps = Logic_label.Map.empty (* Type holding the result of an evaluation. Currently, 'a is either [Location_Bytes.t] for eval_term, and [Location_Bits.t] for [eval_tlval_as_loc] *) type 'a eval_result = { etype: Cil_types.typ; evalue: 'a list; edeps: edeps; } let einteger v = { etype = Cil.intType; evalue = [v]; edeps = empty_edeps} let ereal v = { etype = Cil.doubleType; evalue = [v]; edeps = empty_edeps} let rec eval_term ~with_alarms env t = match t.term_node with | Tat (t, lab) -> eval_term ~with_alarms { env with e_cur = lab } t | TConst (Integer (v, _)) -> einteger (Cvalue.V.inject_int v) | TConst (LEnum e) -> (match (Cil.constFold true e.eival).enode with | Const (CInt64 (v, _, _)) -> einteger (Cvalue.V.inject_int v) | _ -> ast_error "non-evaluable constant") | TConst (LChr c) -> let i = match Cil.charConstToInt c with | CInt64 (i,_,_) -> i | _ -> assert false in einteger (Cvalue.V.inject_int i) | TConst (LReal { r_lower ; r_upper }) -> let f = Ival.inject_float_interval r_lower r_upper in ereal (Cvalue.V.inject_ival f) (* | TConst ((CStr | CWstr) Missing cases *) | TAddrOf (thost, toffs) -> let r = eval_thost_toffset ~with_alarms env thost toffs in { etype = TPtr (r.etype, []); edeps = r.edeps; evalue = List.map loc_bits_to_loc_bytes r.evalue } | TStartOf (thost, toffs) -> let r = eval_thost_toffset ~with_alarms env thost toffs in { etype = TPtr (Cil.typeOf_array_elem r.etype, []); edeps = r.edeps; evalue = List.map loc_bits_to_loc_bytes r.evalue } | TLval _ -> let lvals = eval_tlval ~with_alarms env t in let typ = lvals.etype in let size = Bit_utils.sizeof typ in let eval_lval (l, deps) loc = let loc = make_loc loc size in let v = Cvalue.Model.find ~conflate_bottom:true ~with_alarms (env_current_state env) loc in Eval_op.reinterpret ~with_alarms typ v :: l, add_deps env.e_cur deps (enumerate_valid_bits ~for_writing:false loc) in let l, deps = List.fold_left eval_lval ([], lvals.edeps) lvals.evalue in { etype = typ; edeps = deps; evalue = l } (* TBinOp ((LOr | LAnd), _t1, _t2) -> TODO: a special case would be useful. But this requires reducing the state after having evaluated t1 by a term that is in fact a predicate *) | TBinOp (op,t1,t2) -> eval_binop ~with_alarms env op t1 t2 | TUnOp (op, t) -> let r = eval_term ~with_alarms env t in let typ' = match op with | Neg -> r.etype | BNot -> r.etype (* can only be used on an integer type *) | LNot -> Cil.intType in let eval v = Eval_op.eval_unop ~check_overflow:false ~with_alarms v r.etype op in { etype = typ'; edeps = r.edeps; evalue = List.map eval r.evalue } | Trange (otlow, othigh) -> (* Eval one bound. `SureInf corresponds to an ACSL 'omitted bound', `MayInf to a value analysis approximation. There are subtle differences between, that are not completely exploited for now. *) let deps = ref empty_edeps in let eval = function | None -> `SureInf | Some t -> try let r = eval_term ~with_alarms env t in let v = match r.evalue with | [e] -> e | _ -> ast_error "found set in range bound" in if not (Cil.isIntegralType r.etype) then ast_error "non-integer range bound"; deps := join_edeps !deps r.edeps; try (match Ival.min_and_max (Cvalue.V.project_ival v) with | None, _ | _, None -> `MayInf | Some l, Some h -> `Finite (l, h) ) with Cvalue.V.Not_based_on_null -> `MayInf with LogicEvalError e -> if e <> CAlarm then Value_parameters.result ~current:true ~once:true "Cannot evaluate@ range bound %a@ (%a). Approximating" Printer.pp_term t pretty_logic_evaluation_error e; `MayInf in let range low high = V.inject_ival (Ival.inject_range low high) in let r = match eval otlow, eval othigh with | `Finite (ilowlow, ilow), `Finite (ihigh, ihighhigh) -> if Int.gt ilowlow ihighhigh then [] else if Int.equal ilowlow ihighhigh then if Int.equal ilowlow ilow && Int.equal ihigh ihighhigh then [V.inject_int ilow] else (* complicated case. Due to the imprecisions, the range might be empty, but the intersection is a single integer, which is considered precise by all the other functions *) c_alarm () (* TODO. (but what?) *) else let middle = (* Compute elements that are guaranteed to be in the range, if possible one by one *) if Int.ge ihigh ilow then let plevel = Value_parameters.ArrayPrecisionLevel.get ()in if Int.equal ilow ihigh then [V.inject_int ilow] else if Int.le (Int.sub ihigh ilow) (Int.of_int plevel) then let rec enum i acc = if Int.lt i ilow then acc else enum (Int.sub i Int.one) (V.inject_int i ::acc) in enum ihigh [] else [range (Some ilow) (Some ihigh)] else [] in if Int.equal ilowlow ilow && Int.equal ihigh ihighhigh then middle else range (Some ilowlow) (Some ihighhigh) :: middle (* TODO: improve. Returning middle kills a lot of possible reductions *) (* If an 'exact' flag is added to the evaluation of the logic, the code below must be rewritten as follows: `MayInf, `Finite (_h, hh) -> [(None, hh, inexact)] `SureInf, `Finite (h, hh) -> [(None, h, exact); (h, hh, inexact)]*) | (`MayInf | `SureInf), `Finite (_ihigh, ihighhigh) -> [range None (Some ihighhigh)] | `Finite (ilowlow, _ilow), (`MayInf | `SureInf) -> [range (Some ilowlow) None] | (`MayInf | `SureInf), (`MayInf | `SureInf) -> [range None None] in (*Value_parameters.debug "Range %a: %a@." d_term t (Pretty_utils.pp_list V.pretty) (List.map snd r);*) { etype = Cil.intType; edeps = !deps; evalue = r } | TCastE (typ, t) -> let r = eval_term ~with_alarms env t in let conv v = let msg fmt = Format.fprintf fmt "%a (%a)" Printer.pp_term t V.pretty v in Eval_op.do_promotion ~with_alarms Ival.Float_abstract.Any ~src_typ:r.etype ~dst_typ:typ v msg in { etype = typ; edeps = r.edeps; evalue = List.map conv r.evalue } | Tif (tcond, ttrue, tfalse) -> let r = eval_term ~with_alarms env tcond in let ctrue = List.exists (Cvalue.V.contains_non_zero) r.evalue and cfalse = List.exists (Cvalue.V.contains_zero) r.evalue in (match ctrue, cfalse with | true, true -> let vtrue = eval_term ~with_alarms env ttrue in let vfalse = eval_term ~with_alarms env tfalse in if not (same_etype vtrue.etype vfalse.etype) then Value_parameters.failure ~current:true "Incoherent types in conditional '%a': %a vs. %a. \ Please report" Printer.pp_term t Printer.pp_typ vtrue.etype Printer.pp_typ vfalse.etype; let lr = vtrue.evalue @ vfalse.evalue in let r = if Logic_const.is_plain_type t.term_type then [List.fold_left V.join V.bottom lr] else lr in { etype = vtrue.etype; edeps = join_edeps vtrue.edeps vfalse.edeps; evalue = r } | true, false -> eval_term ~with_alarms env ttrue | false, true -> eval_term ~with_alarms env tfalse | false, false -> assert false (* a logic alarm would have been raised*) ) | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ -> let e = Cil.constFoldTerm true t in let v = match e.term_node with | TConst (Integer (v, _)) -> Cvalue.V.inject_int v | _ -> V.top_int in einteger v | Tunion l -> let tres = infer_type t.term_type in let l, deps = List.fold_left (fun (accv, accdeps) t -> let r = eval_term ~with_alarms env t in r.evalue @ accv, join_edeps accdeps r.edeps) ([], empty_edeps) l in { etype = tres; edeps = deps; evalue = l } | Tempty_set -> { etype = infer_type t.term_type; evalue = []; edeps = empty_edeps } | Tnull -> { etype = Cil.voidPtrType; edeps = empty_edeps; evalue = [Cvalue.V.singleton_zero] } | TLogic_coerce(typ, t) -> let r = eval_term ~with_alarms env t in (match typ with | Linteger -> assert (Logic_typing.is_integral_type t.term_type); r | Lreal -> if Logic_typing.is_integral_type t.term_type then (* Needs to be converted to reals *) let conv v = let v, ok = V.cast_int_to_float real_mode v in if not ok then c_alarm (); v in { etype = Cil.doubleType; edeps = r.edeps; evalue = List.map conv r.evalue } else r (* already a floating-point number (hopefully) *) | _ -> unsupported (Pretty_utils.sfprintf "logic coercion %a -> %a@." Printer.pp_logic_type t.term_type Printer.pp_logic_type typ) ) (* TODO *) | Toffset _ -> unsupported "\\offset function" | Tbase_addr _ -> unsupported "\\base_addr function" | Tblock_length _ -> unsupported "\\block_length function" | Tinter _ -> unsupported "set intersection" | Tapp _ | Tlambda _ -> unsupported "logic functions or predicates" | TDataCons _ -> unsupported "logic inductive types" | TUpdate _ -> unsupported "functional updates" | TCoerce _ | TCoerceE _ -> unsupported "logic coercions" (* jessie *) | Ttype _ -> unsupported "\\type operator" | Ttypeof _ -> unsupported "\\typeof operator" | Tcomprehension _ -> unsupported "sets defined by comprehension" | Tlet _ -> unsupported "\\let bindings" | TConst (LStr _) -> unsupported "constant strings" | TConst (LWStr _) -> unsupported "wide constant strings" and eval_binop ~with_alarms env op t1 t2 = if isLogicNonCompositeType t1.term_type then let r1 = eval_term ~with_alarms env t1 in let r2 = eval_term ~with_alarms env t2 in let te1 = Cil.unrollType r1.etype in (* We use the type of t1 to determine whether we are performing an int or float operation.*) let kop = match te1 with | TInt _ | TPtr _ | TEnum _ -> (* Do not pass ~typ here. We want the operations to be performed on unbounded integers mode *) Eval_op.eval_binop_int ~with_alarms ~te1 ?typ:None | TFloat _ -> Eval_op.eval_binop_float ~with_alarms real_mode None | _ -> ast_error (Pretty_utils.sfprintf "binop on incorrect type %a" Printer.pp_typ te1) in let kop v1 v2 = kop v1 op v2 in let typ_res = infer_binop_res_type op te1 in let l1 = r1.evalue and l2 = r2.evalue in let r = match op, l1, l2 with | (PlusA | PlusPI | IndexPI | MinusA | MinusPI), _, _ -> List.fold_left (fun acc e1 -> List.fold_left (fun acc e2 -> kop e1 e2 :: acc) acc l2) [] l1 (* Sets are compared by joining all their elements. This is correct, although imprecise *) | (Eq | Ne), _ , _ -> (match l1, l2 with | [], [] -> [if op = Eq then V.singleton_one else V.singleton_zero] | [], _ :: _ | _ :: _, [] -> [if op = Eq then V.singleton_zero else V.singleton_one] | h1 :: q1, h2 :: q2 -> let e1 = List.fold_left V.join h1 q1 in let e2 = List.fold_left V.join h2 q2 in let r = kop e1 e2 in let contains_zero = V.contains_zero r in let contains_non_zero = V.contains_non_zero r in [V.interp_boolean ~contains_zero ~contains_non_zero] ) | _, [e1], [e2] -> [kop e1 e2] | _ -> ast_error "meaningless binop" in { etype = typ_res; edeps = join_edeps r1.edeps r2.edeps; evalue = r } else unsupported (Pretty_utils.sfprintf "%a operation on non-supported type %a" Printer.pp_binop op Printer.pp_logic_type t1.term_type) and eval_tlhost ~with_alarms env lv = match lv with | TVar { lv_origin = Some v } -> let loc = Location_Bits.inject (Base.find v) Ival.zero in { etype = v.vtype; edeps = empty_edeps; evalue = [loc] } | TResult typ -> (match env.result with | Some v -> let loc = Location_Bits.inject (Base.find v) Ival.zero in { etype = typ; edeps = empty_edeps; evalue = [loc] } | None -> no_result ()) | TVar { lv_origin = None } -> (* TODO: add an env for logic vars *) unsupported "evaluation of logic vars" | TMem t -> let r = eval_term ~with_alarms env t in let tres = match Cil.unrollType r.etype with | TPtr (t, _) -> t | _ -> ast_error "*p where p is not a pointer" in { etype = tres; edeps = r.edeps; evalue = List.map loc_bytes_to_loc_bits r.evalue } and eval_toffset ~with_alarms env typ toffset = match toffset with | TNoOffset -> { etype = typ; edeps = empty_edeps; evalue = [Ival.singleton_zero] } | TIndex (idx, remaining) -> let typ_pointed = match Cil.unrollType typ with | TArray (t, _, _, _) -> t | TPtr(t,_) -> (match Cil.unrollType t with | TArray (t, _,_,_) -> t | _ -> ast_error "index on a non-array") | _ -> ast_error "index on a non-array" in let idxs = eval_term ~with_alarms env idx in let offsrem = eval_toffset ~with_alarms env typ_pointed remaining in let aux idx = let offset = try Cvalue.V.project_ival idx with Cvalue.V.Not_based_on_null -> Ival.top in let shift v = let offset = Ival.scale_int64base (sizeof typ_pointed) offset in Ival.add_int offset v in List.map shift offsrem.evalue in { etype = offsrem.etype; edeps = join_edeps idxs.edeps offsrem.edeps; evalue = List.fold_left (fun r trm -> aux trm @ r) [] idxs.evalue; } | TField (fi, remaining) -> let current,_ = Cil.bitsOffset typ (Field(fi, NoOffset)) in let offsrem = eval_toffset ~with_alarms env fi.ftype remaining in { etype = offsrem.etype; edeps = offsrem.edeps; evalue = List.map (Ival.add_int (Ival.of_int current)) offsrem.evalue } | TModel _ -> unsupported "model fields" and eval_thost_toffset ~with_alarms env thost toffs = let rhost = eval_tlhost ~with_alarms env thost in let roffset = eval_toffset ~with_alarms env rhost.etype toffs in let shift l lochost = let shift offs = Location_Bits.shift offs lochost in List.map shift roffset.evalue @ l in { etype = roffset.etype; edeps = join_edeps rhost.edeps roffset.edeps; evalue = List.fold_left shift [] rhost.evalue } and eval_tlval ~with_alarms env t = match t.term_node with | TLval (thost, toffs) -> eval_thost_toffset ~with_alarms env thost toffs | Tunion l -> let aux (lr, deps) t = let r = eval_tlval ~with_alarms env t in r.evalue :: lr, join_edeps deps r.edeps in let l, deps = List.fold_left aux ([], empty_edeps) l in { etype = infer_type t.term_type; edeps = deps; evalue = List.concat l } | Tempty_set -> { etype = infer_type t.term_type; evalue = []; edeps = empty_edeps } | Tat (t, lab) -> eval_tlval ~with_alarms { env with e_cur = lab } t | _ -> ast_error "non-lval term" let eval_tlval_as_location ~with_alarms env t = let r = eval_tlval ~with_alarms env t in let s = Bit_utils.sizeof r.etype in let aux acc loc = 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 r.evalue let eval_tlval_as_locations ~with_alarms env t = let r = eval_tlval ~with_alarms env t in let s = Bit_utils.sizeof r.etype in List.map (fun loc -> make_loc loc s) r.evalue, r.edeps let eval_tlval_as_zone ~with_alarms ~for_writing env t = let r = eval_tlval ~with_alarms env t in let s = Bit_utils.sizeof r.etype in let aux acc loc = let loc = make_loc loc s in let z = enumerate_valid_bits ~for_writing loc in Zone.join acc z in List.fold_left aux Zone.bottom r.evalue (* If casting [trm] to [typ] has no effect in terms of the values contained in [trm], do nothing. Otherwise, raise [exn]. Adapted from [pass_cast] *) let pass_logic_cast exn typ trm = (* TODOBY: add checks for volatile? *) match Logic_utils.unroll_type typ, Logic_utils.unroll_type trm.term_type with | Linteger, Ctype (TInt _ | TEnum _) -> () (* Always inclusion *) | Ctype (TInt _ | TEnum _ as typ), Ctype (TInt _ | TEnum _ as typeoftrm) -> let sztyp = sizeof typ in let szexpr = sizeof typeoftrm in let styp, sexpr = match sztyp, szexpr with | Int_Base.Value styp, Int_Base.Value sexpr -> styp, sexpr | _ -> raise exn in let sityp = is_signed_int_enum_pointer typ in let sisexpr = is_signed_int_enum_pointer typeoftrm in if (Int.ge styp sexpr && sityp = sisexpr) (* larger, same signedness *) || (Int.gt styp sexpr && sityp) (* strictly larger and signed *) then () else raise exn | Lreal, Ctype (TFloat _) -> () (* Always inclusion *) | Ctype (TFloat (f1,_)), Ctype (TFloat (f2, _)) -> if Cil.frank f1 < Cil.frank f2 then raise exn | _ -> raise exn (* Not a scalar type *) exception Not_an_exact_loc let rec eval_term_as_exact_loc ~with_alarms env t = match t with | { term_node = TLval _ } -> let locs = eval_tlval ~with_alarms env t in let typ = locs.etype in (match locs.evalue with | [] | _ :: _ :: _ -> raise Not_an_exact_loc | [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 ) | { term_node = TLogic_coerce(_, t)} -> (* It is always ok to pass through a TLogic_coerce, as the destination type is always a supertype *) eval_term_as_exact_loc ~with_alarms env t | { term_node = TCastE (ctype, t') } -> pass_logic_cast Not_an_exact_loc (Ctype ctype) t'; eval_term_as_exact_loc ~with_alarms env t' | _ -> raise Not_an_exact_loc exception DoNotReduce let is_same_term_coerce t1 t2 = match t1.term_node, t2.term_node with | TLogic_coerce _, TLogic_coerce _ -> Logic_utils.is_same_term t1 t2 | TLogic_coerce (_,t1), _ -> Logic_utils.is_same_term t1 t2 | _, TLogic_coerce(_,t2) -> Logic_utils.is_same_term t1 t2 | _ -> Logic_utils.is_same_term t1 t2 let rec reduce_by_predicate env positive p = reduce_by_predicate_content env positive p.content and reduce_by_predicate_content env positive p_content = let with_alarms = warn_raise_mode in match positive,p_content with | true,Ptrue | false,Pfalse -> env | true,Pfalse | false,Ptrue -> overwrite_current_state env Cvalue.Model.bottom (* desugared form of a <= b <= c <= d *) | true, Pand ( {content=Prel ((Rlt | Rgt | Rle | Rge | Req as op),_ta,tb) as p1}, {content=Pand ( {content=Prel (op', tb',tc) as p2}, {content=Prel (op'',tc',_td) as p3})}) when op = op' && op' = op'' && is_same_term_coerce tb tb' && is_same_term_coerce tc tc' -> let red env p = reduce_by_predicate_content env positive p in let env = red env p1 in let env = red env p3 in let env = red env p2 in (*Not really useful in practice*) (*let env = red env (Prel (op, ta, tc)) in let env = red env (Prel (op, tb, td)) in *) env | true,Pand (p1,p2) | false,Por(p1,p2)-> let r1 = reduce_by_predicate env positive p1 in reduce_by_predicate r1 positive p2 | true,Por (p1,p2 ) | false,Pand (p1, p2) -> join_env (reduce_by_predicate env positive p1) (reduce_by_predicate env positive p2) | true,Pimplies (p1,p2) -> join_env (reduce_by_predicate env false p1) (reduce_by_predicate env true p2) | false,Pimplies (p1,p2) -> reduce_by_predicate (reduce_by_predicate env true p1) false p2 | _,Pnot p -> reduce_by_predicate env (not positive) p | true,Piff (p1, p2) -> let red1 = reduce_by_predicate_content env true (Pand (p1, p2)) in let red2 = reduce_by_predicate_content env false (Por (p1, p2)) in join_env red1 red2 | false,Piff (p1, p2) -> reduce_by_predicate 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 env (not positive) (Logic_const.piff(p1, p2)) | _,Prel (op,t1,t2) -> begin try let eval = match t1.term_type with | t when Cil.isLogicRealOrFloatType t -> Eval_op.reduce_rel_float (Value_parameters.AllRoundingModes.get ()) | t when Cil.isLogicIntegralType t -> Eval_op.reduce_rel_int | Ctype ct when Cil.isPtrType ct -> Eval_op.reduce_rel_int | _ -> raise DoNotReduce in reduce_by_relation eval env positive t1 op t2 with | DoNotReduce -> env | LogicEvalError ee -> display_evaluation_error ee; env | Eval_exprs.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 (_label,tsets) -> (* TODO: label should not be ignored. Instead, we should clear variables that are not in scope at the label. *) reduce_by_valid env positive ~for_writing:true tsets | _,Pvalid_read (_label,tsets) -> reduce_by_valid env positive ~for_writing:false tsets | _,Pinitialized (lbl_initialized,tsets) -> begin try let rlocb = eval_term ~with_alarms env tsets in let size = Bit_utils.sizeof_pointed rlocb.etype in let size = try Int_Base.project size with _ -> c_alarm () (* Not really an alarm, an imprecision *) in let state = env_state env lbl_initialized in let state_reduced = List.fold_left (fun state loc -> let loc_bits = loc_bytes_to_loc_bits loc in Model.reduce_by_initialized_defined_loc (Cvalue.V_Or_Uninitialized.change_initialized positive) loc_bits size state ) state rlocb.evalue in overwrite_state env state_reduced lbl_initialized with | LogicEvalError ee -> display_evaluation_error ee; env end | _,Pat (p, lbl) -> (try let env_at = { env with e_cur = lbl } in let env' = reduce_by_predicate env_at positive p in { env' with e_cur = env.e_cur } with LogicEvalError ee -> display_evaluation_error ee; env) | _,Papp _ | _,Pexists (_, _) | _,Pforall (_, _) | _,Plet (_, _) | _,Pif (_, _, _) | _,Pallocable (_,_) | _,Pfreeable (_,_) | _,Pfresh (_,_,_,_) | _,Psubtype _ | _, Pseparated _ -> env and reduce_by_valid env positive ~for_writing (tset: term) = let with_alarms = warn_raise_mode in (* Auxiliary function that reduces \valid(lvloc+offs), where lvloc is atomic (no more tsets), and offs is a bits-expressed constant offset. [offs_typ] is supposed to be the type of the pointed location after [offs] has been applied; it can be different from [typeOf_pointed lv_typ], for example if offset is a field access. *) let aux (lv_typ, lvloc) env (offs_typ, offs) = try if not (Location_Bits.is_relationable lvloc) || not (Ival.cardinal_zero_or_one offs) then raise DoNotReduce; let state = env_current_state env in let lvloc = make_loc lvloc (Bit_utils.sizeof lv_typ) in (* [p] is the range that we attempt to reduce *) let p_orig = Model.find ~with_alarms ~conflate_bottom:true state lvloc in let pb = Locations.loc_bytes_to_loc_bits p_orig in let shifted_p = Location_Bits.shift offs pb in let lshifted_p = make_loc shifted_p (Bit_utils.sizeof offs_typ) in let valid = (* reduce the shifted pointer to the wanted part *) if positive then Locations.valid_part ~for_writing lshifted_p else Locations.invalid_part lshifted_p in let valid = valid.loc in if Location_Bits.equal shifted_p valid then env else (* Shift back *) let shift = Ival.neg offs in let pb = Location_Bits.shift shift valid in let p = Locations.loc_bits_to_loc_bytes pb in (* Store the result *) let state = Model.reduce_previous_binding ~with_alarms state lvloc p in overwrite_current_state env state with | DoNotReduce | V.Not_based_on_null -> env | LogicEvalError ee -> display_evaluation_error ee; env in let rec do_one env t = match t.term_node with | Tunion l -> List.fold_left do_one env l | TLval _ -> let aux typ env lval = try let loc = make_loc lval (Bit_utils.sizeof typ) in if valid_cardinal_zero_or_one ~for_writing loc then let state = Eval_exprs.reduce_by_valid_loc ~positive ~for_writing loc typ (env_current_state env) in overwrite_current_state env state else env with LogicEvalError ee -> display_evaluation_error ee; env in (try let r = eval_tlval ~with_alarms env t in List.fold_left (aux r.etype) env r.evalue with LogicEvalError ee -> display_evaluation_error ee; env) | TAddrOf (TMem ({term_node = TLval _} as t), offs) -> (try let lt = eval_tlval ~with_alarms env t in let typ = lt.etype in List.fold_left (fun env lv -> (* Compute the offsets, that depend on the type of the lval. The computed list is exactly what [aux] requires *) let roffs = eval_toffset ~with_alarms env (Cil.typeOf_pointed typ) offs in List.fold_left (fun env offs -> aux (typ, lv) env (roffs.etype, offs)) env roffs.evalue ) env lt.evalue with LogicEvalError ee -> display_evaluation_error ee; env) | TBinOp ((PlusPI | MinusPI) as op, ({term_node = TLval _} as tlv), i) -> (try let rtlv = eval_tlval ~with_alarms env tlv in let ri = eval_term ~with_alarms env i in (* Convert offsets to a simpler form if [op] is [MinusPI] *) let li = List.fold_left (fun acc offs -> try let i = V.project_ival offs in let i = if op = PlusPI then i else Ival.neg i in (ri.etype, i) :: acc with V.Not_based_on_null -> acc ) [] ri.evalue in let typ_p = Cil.typeOf_pointed rtlv.etype in let sbits = Int.of_int (Cil.bitsSizeOf typ_p) in List.fold_left (fun env elv -> (* Compute the offsets expected by [aux], which are [i * 8 * sizeof( *tlv)] *) let li = List.map (fun (_, offs) -> typ_p, Ival.scale sbits offs) li in List.fold_left (aux (typ_p, elv)) env li ) env rtlv.evalue with LogicEvalError ee -> display_evaluation_error ee; env) | _ -> env in do_one env tset and reduce_by_relation eval env positive t1 rel t2 = let env = reduce_by_left_relation eval env positive t1 rel t2 in let inv_binop = match rel with | Rgt -> Rlt | Rlt -> Rgt | Rle -> Rge | Rge -> Rle | Req -> Req | Rneq -> Rneq in reduce_by_left_relation eval env positive t2 inv_binop t1 and reduce_by_left_relation eval env positive tl rel tr = let with_alarms = warn_raise_mode in try let debug = false in let state = env_current_state env in if debug then Format.printf "#Left term %a@." Printer.pp_term tl; let typ_loc, loc = eval_term_as_exact_loc ~with_alarms env tl in if debug then Format.printf "#Left term as lv loc %a, typ %a@." Locations.pretty loc Printer.pp_typ typ_loc; let v = Cvalue.Model.find ~conflate_bottom:true ~with_alarms state loc in if debug then Format.printf "#Val left lval %a@." V.pretty v; let v = Eval_op.reinterpret ~with_alarms typ_loc v in if debug then Format.printf "#Cast left lval %a@." V.pretty v; let rtl = eval_term ~with_alarms env tr in let cond_v = List.fold_left Location_Bytes.join Location_Bytes.bottom rtl.evalue in if debug then Format.printf "#Val right term %a@." V.pretty cond_v; let op = lop_to_cop rel in let v_sym = eval.Eval_op.reduce_rel_symetric positive op cond_v v in let v_asym = eval.Eval_op.reduce_rel_antisymetric ~typ_loc positive op cond_v v_sym in if debug then Format.printf "#Val reduced %a@." V.pretty v_asym; (* TODOBY: if loc is an int that has been silently cast to real, we end up reducing an int according to a float. Instead, we should convert v to real, then cast back v_asym to the good range *) if V.is_bottom v_asym then raise Eval_exprs.Reduce_to_bottom; if V.equal v_asym v then env else let state' = Cvalue.Model.reduce_previous_binding ~with_alarms state loc v_asym in overwrite_current_state env state' with | Not_an_exact_loc -> env | LogicEvalError ee -> display_evaluation_error ee; env let eval_predicate env pred = let with_alarms = warn_raise_mode in 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 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) Printer.pp_predicate_named p1; *) begin match val_p1 with | True -> True | False -> do_eval env p2 | Unknown -> begin let reduced_state = reduce_by_predicate env false p1 in (* Format.printf "Disjunction: reduced to %a to eval %a@." Cvalue.Model.pretty (env_current_state reduced_state) Printer.pp_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 try do_eval { env with e_cur = lbl } p with LogicEvalError ee -> display_evaluation_error ee; Unknown end | Pvalid (_label, tsets) | Pvalid_read (_label, tsets) -> begin (* TODO: see same constructor in reduce_by_predicate *) try let for_writing = (match p.content with Pvalid_read _ -> false | _ -> true) in let state = env_current_state env in let size = match Logic_utils.unroll_type tsets.term_type with | Ctype (TPtr _ | TArray _ as t) | Ltype ({lt_name = "set"},[Ctype t]) -> sizeof_pointed t | _ -> ast_error "valid on incorrect location %a" in (* Check that the given location is valid *) let valid locbytes = let loc = loc_bytes_to_loc_bits locbytes in let loc = Locations.make_loc loc size in if not (Locations.is_valid ~for_writing loc) then ( (* Maybe the location is guaranteed to be invalid? *) let valid = valid_part ~for_writing loc in if Location_Bits.equal Location_Bits.bottom valid.loc then raise Stop else raise DoNotReduce) in (match tsets.term_node with | TLval _ -> (* Evaluate the left-value, and check that it is initialized and not an escaping pointer *) List.iter (fun loc -> let v = Model.find_unspecified ~with_alarms state loc in let v, ok = match v with | Cvalue.V_Or_Uninitialized.C_uninit_esc v | Cvalue.V_Or_Uninitialized.C_uninit_noesc v | Cvalue.V_Or_Uninitialized.C_init_esc v -> v, false | Cvalue.V_Or_Uninitialized.C_init_noesc v -> v, true in if Cvalue.V.is_bottom v && not ok then raise Stop; valid v; if not ok then raise DoNotReduce ) (fst (eval_tlval_as_locations ~with_alarms env tsets)) | _ -> List.iter valid (eval_term ~with_alarms env tsets).evalue ); True with | DoNotReduce -> Unknown | LogicEvalError ee -> display_evaluation_error ee; Unknown | Stop -> False end | Pinitialized (label,tsets) -> begin try let locb = eval_term ~with_alarms env tsets in let state = env_state env label in let typ = locb.etype in if not (Cil.isPointerType typ) then ast_error "initialized on incorrect location"; fold_join_predicate List.fold_left (fun loc -> let locbi = loc_bytes_to_loc_bits loc in let loc = make_loc locbi (sizeof_pointed typ) in let value = Model.find_unspecified ~with_alarms state loc in match value with | V_Or_Uninitialized.C_uninit_esc v | V_Or_Uninitialized.C_uninit_noesc v -> if Location_Bytes.is_bottom v then False else Unknown | V_Or_Uninitialized.C_init_esc _ | V_Or_Uninitialized.C_init_noesc _ -> True ) locb.evalue with | Eval_exprs.Cannot_find_lv -> Unknown | LogicEvalError ee -> display_evaluation_error ee; Unknown end | Prel (op,t1,t2) -> begin try let r = eval_binop ~with_alarms env (lop_to_cop op) t1 t2 in (* if lop_to_cop op = Eq then Format.printf "## Logic deps for %a: @[%a@]@." Printer.pp_predicate_named p Zone.pretty r.edeps; *) if List.for_all (V.equal V.singleton_zero) r.evalue then False else if List.for_all (V.equal V.singleton_one) r.evalue then True else Unknown with | LogicEvalError ee -> display_evaluation_error ee; Unknown end | Pexists (varl, p1) | Pforall (varl, p1) -> let r = 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 ~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 | LogicEvalError ee -> display_evaluation_error ee; Unknown end in begin match p.content with | Pexists _ -> if r = False then False else Unknown | Pforall _ -> if r = 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 ltsets -> (try let to_locs tset = let rtset = eval_term ~with_alarms env tset in let typ = rtset.etype in if not (Cil.isPointerType typ) then ast_error "separated on non-pointers"; let size = sizeof_pointed typ in List.map (fun loc -> let loc = loc_bytes_to_loc_bits loc in Locations.make_loc loc size ) rtset.evalue in let locs = List.map to_locs ltsets in let to_zone = Locations.enumerate_bits in let lz = List.map (List.map (fun l -> l, to_zone l)) locs in let unknown = ref false in (* Are those two lists of locations separated? *) let do_two l1 l2 = let combine (loc1, z1) (loc2, z2) = if Zone.intersects z1 z2 then if Locations.cardinal_zero_or_one loc1 && Locations.cardinal_zero_or_one loc2 then raise Exit else unknown := true in List.iter (fun e1 -> List.iter (combine e1) l2) l1 in let rec aux = function | [] | [_] -> () | locs :: qlocs -> List.iter (do_two locs) qlocs; aux qlocs in aux lz; if !unknown then Unknown else True with | Exit -> False | LogicEvalError ee -> display_evaluation_error ee; Unknown) | Pfresh (_,_,_,_) | Papp _ | Pallocable _ | Pfreeable _ | Plet (_,_) | Pif (_, _, _) | Psubtype _ -> Unknown in do_eval env pred (* [JS 2013/04/11] unused, but only maintainers of this module could know if we have to keep this code ;-). *) (*let predicate_deps env pred = let with_alarms = CilE.warn_none_mode in let rec do_eval env p = match p.content with | Ptrue | Pfalse -> empty_edeps | Pand (p1, p2) | Por (p1, p2 ) | Pxor (p1, p2) | Piff (p1, p2 ) | Pimplies (p1, p2) -> join_edeps (do_eval env p1) (do_eval env p2) | Prel (_, t1, t2) -> join_edeps (eval_term ~with_alarms env t1).edeps (eval_term ~with_alarms env t2).edeps | Pif (c, p1, p2) -> join_edeps (eval_term ~with_alarms env c).edeps (join_edeps (do_eval env p1) (do_eval env p2)) | Pat (p, lbl) -> do_eval { env with e_cur = lbl } p | Pvalid (_, tsets) | Pvalid_read (_, tsets) -> (eval_tlval ~with_alarms env tsets).edeps | Pinitialized (lbl, tsets) -> let loc, deploc = eval_tlval_as_locations ~with_alarms env tsets in let zones = List.fold_left (fun z loc -> Zone.join (enumerate_valid_bits ~for_writing:false loc) z) Zone.bottom loc in Logic_label.Map.add lbl zones deploc | Pnot p -> do_eval env p | Pseparated ltsets -> let evaled = List.map (eval_tlval ~with_alarms env) ltsets in List.fold_left (fun acc e -> join_edeps acc e.edeps) empty_edeps evaled | Pexists (_, p) | Pforall (_, p) | Plet (_, p) -> do_eval env p | Pfresh (_,_,_,_) | Papp _ | Pallocable _ | Pfreeable _ | Psubtype _ -> assert false 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 (* If [always] is true, reduce in all cases. Otherwise, reduce only when [p] is a disjunction *) (* TODO: if would be great to have split [states] into those Valid (no reduction if not a disjunction) and the others (always reduce). This must be done in the callers, though *) let reduce_by_disjunction ~always ~env states slevel p = if State_set.is_empty states then states else let nb = count_disjunction p in if nb <= 1 && not always then states (* nothing to reduce *) else if (State_set.length states) * nb <= slevel then begin let treat_state acc state = let env = overwrite_current_state env state in let treat_pred pred acc = let r = reduce_by_predicate env true pred in if Cvalue.Model.equal (env_current_state r) state then raise Does_not_improve else State_set.add (env_current_state r) 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 (* Not enough slevel to have a noticeable effect. Just reduce the various states globally *) State_set.fold (fun acc state -> let env = overwrite_current_state env state in let reduced = reduce_by_predicate env true p in State_set.add (env_current_state reduced) acc) State_set.empty states let () = (* TODO: deprecate loc_to_loc, move loc_to_locs into Value *) Db.Properties.Interp.loc_to_loc := (fun ~result state t -> let env = env_post_f ~pre:state ~post:state ~result () in try eval_tlval_as_location ~with_alarms:CilE.warn_none_mode env t with LogicEvalError _ -> raise (Invalid_argument "not an lvalue") ); (* TODO: specify better evaluation environment *) Db.Properties.Interp.loc_to_locs := (fun ~result state t -> let env = env_post_f ~pre:state ~post:state ~result () in let with_alarms = CilE.warn_none_mode in try let r, deps = eval_tlval_as_locations ~with_alarms env t in r, deps_at lbl_here deps with LogicEvalError _ -> raise (Invalid_argument "not an lvalue") ); (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/current_table.mli0000644000175000017500000000506712155630231021242 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (** Internal state of the Value Analysis during analysis. *) (** State on one statement *) type record (** State for an entier function *) type t = record Cil_datatype.Stmt.Hashtbl.t val create : unit -> t val clear : t -> unit (* Not clear this is useful, as the table is garbage-collected *) (** Extraction *) val find_widening_info : t -> stmt -> int * Cvalue.Model.t val find_superposition : t -> stmt -> State_set.t (** Updating *) val update_current : t -> stmt -> State_set.t -> unit val update_and_tell_if_changed : t -> stmt -> State_set.t -> State_set.t val update_widening_info : t -> stmt -> int -> Cvalue.Model.t -> unit (** Export *) val superpositions : t -> Cvalue.Model.t list Stmt.Hashtbl.t val states : t -> Cvalue.Model.t Stmt.Hashtbl.t (** Merge the results of the current analysis with the global results. Honor [-no-results*] options *) val merge_db_table : Db.Value.state Stmt.Hashtbl.t Lazy.t -> Db.Value.callstack -> unit frama-c-Fluorine-20130601/src/value/value_parameters.ml0000644000175000017500000005020512155630231021571 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* Dependencies to kernel options *) let kernel_parameters_correctness = [ Kernel.MainFunction.parameter; Kernel.LibEntry.parameter; Kernel.AbsoluteValidRange.parameter; Kernel.SafeArrays.parameter; Kernel.UnspecifiedAccess.parameter; ] let parameters_correctness = ref [] let parameters_tuning = ref [] let add_dep p = State_dependency_graph.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 include Plugin.Register (struct let name = "value analysis" let shortname = "value" let help = "automatically computes variation domains for the variables of the program" end) module ForceValues = WithOutput (struct let option_name = "-val" let help = "compute values" let output_by_default = true end) let precision_tuning = add_group "Precision vs. time" let initial_context = add_group "Initial Context" let performance = add_group "Results memoization vs. time" let interpreter = add_group "Deterministic programs" let alarms = add_group "Propagation and alarms " (* -------------------------------------------------------------------------- *) (* --- Aux --- *) (* -------------------------------------------------------------------------- *) let check_c_function_exists ~f ~option ~arg = try ignore (Globals.Functions.find_by_name f) with Not_found -> warning "option '%s %s': function '%s' does not exist" option arg f (* -------------------------------------------------------------------------- *) (* --- Performance options --- *) (* -------------------------------------------------------------------------- *) let () = Plugin.argument_is_function_name () 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" end) let () = add_dep NoResultsFunctions.parameter let () = Plugin.set_group performance let () = Plugin.set_negative_option_name "-val-store-results" module NoResultsAll = False (struct let option_name = "-no-results" let help = "do not record values for any of the statements of the \ program" end) let () = add_dep NoResultsAll.parameter let () = Plugin.set_group performance module ResultsAfter = Bool (struct 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 ResultsCallstack = Bool (struct let option_name = "-val-callstack-results" let help = "record precisely the values obtained for each callstack leading to each statement" let default = false end) let () = add_dep ResultsCallstack.parameter let () = Plugin.set_group performance module MemoryFootprint = Int (struct let option_name = "-memory-footprint" 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" end) let () = MemoryFootprint.add_set_hook (fun _ x -> Binary_cache.MemoryFootprint.set x; Buckx.MemoryFootprint.set x); State_dependency_graph.add_dependencies ~from:MemoryFootprint.self [ Binary_cache.MemoryFootprint.self; Buckx.MemoryFootprint.self ] (* ------------------------------------------------------------------------- *) (* --- Non-standard alarms --- *) (* ------------------------------------------------------------------------- *) let () = Plugin.set_group alarms module AllRoundingModes = False (struct let option_name = "-all-rounding-modes" let help = "Take more target FPU and compiler behaviors into account" end) let () = add_correctness_dep AllRoundingModes.parameter let () = Plugin.set_group alarms 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 let () = Plugin.set_group alarms module LeftShiftNegative = True (struct let option_name = "-val-left-shift-negative-alarms" let help = "Emit alarms when left shifting negative integers" end) let () = add_correctness_dep LeftShiftNegative.parameter let () = Plugin.set_group alarms 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 = Int (struct let option_name = "-context-depth" let default = 2 let arg_name = "n" let help = "use as the depth of the default context for value analysis. (defaults to 2)" end) let () = add_correctness_dep AutomaticContextMaxDepth.parameter let () = Plugin.set_group initial_context module AutomaticContextMaxWidth = Int (struct let option_name = "-context-width" let default = 2 let arg_name = "n" let help = "use as the width of the default context for value analysis. (defaults to 2)" end) let () = AutomaticContextMaxWidth.set_range ~min:1 ~max:max_int let () = add_correctness_dep AutomaticContextMaxWidth.parameter let () = Plugin.set_group initial_context module AllocatedContextValid = False (struct let option_name = "-context-valid-pointers" let help = "only allocate valid pointers until context-depth, and then use NULL (defaults to false)" end) let () = add_correctness_dep AllocatedContextValid.parameter let () = Plugin.set_group initial_context let () = Plugin.set_negative_option_name "-uninitialized-padding-globals" module InitializedPaddingGlobals = True (struct let option_name = "-initialized-padding-globals" let help = "Padding in global variables is initialized to zero" end) let () = add_correctness_dep InitializedPaddingGlobals.parameter (* ------------------------------------------------------------------------- *) (* --- Tuning --- *) (* ------------------------------------------------------------------------- *) let () = Plugin.set_group precision_tuning module WideningLevel = Int (struct let default = 3 let option_name = "-wlevel" let arg_name = "n" let help = "do loop iterations before widening (defaults to 3)" end) let () = add_precision_dep WideningLevel.parameter let () = Plugin.set_group precision_tuning module ILevel = Int (struct let option_name = "-val-ilevel" let default = 8 let arg_name = "n" let help = "Sets of integers are represented as sets up to elements. \ Above, intervals with congruence information are used \ (defaults to 8; experimental)" end) let () = add_precision_dep ILevel.parameter let () = ILevel.add_update_hook (fun _ i -> Ival.set_small_cardinal i) let () = ILevel.set_range 4 64 let () = Plugin.set_group precision_tuning module SemanticUnrollingLevel = Zero (struct let option_name = "-slevel" let arg_name = "n" let help = "superpose up to states when unrolling control flow. The larger n, the more precise and expensive the analysis (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 = StringHashtbl (struct let option_name = "-slevel-function" let arg_name = "f:n" let help = "override slevel with when analyzing " end) (struct include Datatype.Int let parse s = try let f, n = split_option s in check_c_function_exists ~f:f ~option:"-slevel-function" ~arg:s; let n = int_of_string n in f, n with | Failure _ -> abort "Could not parse option \"-slevel-function %s\"" s let redefine_binding _k ~old:_ new_v = new_v let no_binding _ = SemanticUnrollingLevel.get () end) let () = add_precision_dep SlevelFunction.parameter let split_option_multiple = let rx = Str.regexp_string ":" in fun s -> try match Str.split rx s with | f :: q -> f, q | _ -> failwith "" with _ -> failwith "split_option" let () = Plugin.set_group precision_tuning module SplitReturnFunction = StringHashtbl (struct let option_name = "-val-split-return-function" let arg_name = "f:n" let help = "split return states of function according to \ \\result == n and \\result != n" end) (struct include Datatype.List(Datatype.Int) let parse s = try let f, l = split_option_multiple s in check_c_function_exists ~f:f ~option:"-val-split-return-function" ~arg:s; let l = List.map int_of_string l in f, l with Failure _ -> abort "Could not parse option \"-val-split-return %s\"" s let redefine_binding _k ~old:_ new_v = new_v let no_binding _ = raise Not_found end) let () = add_precision_dep SplitReturnFunction.parameter let () = Plugin.set_group precision_tuning module SplitReturnAuto = False (struct let option_name = "-val-split-return-auto" let help = "Automatically split states at the end of functions, \ according to the function return code" end) let () = add_precision_dep SplitReturnAuto.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 , try to use Frama-C builtin instead. Fall back to if cannot handle its arguments (experimental)." end) (struct include Datatype.String let parse s = try let (fc, focaml) as r = split_option s in if not (!Db.Value.mem_builtin focaml) then abort "option '-val-builtin %s': undeclared builtin '%s'" s focaml; check_c_function_exists ~f:fc ~option:"-val-builtin" ~arg:s; r with Failure _ -> abort "Could not parse option \"-val-builtin %s\"" s let redefine_binding _k ~old:_ new_v = new_v let no_binding _ = raise Not_found end) let () = add_precision_dep BuiltinsOverrides.parameter let () = Plugin.set_group precision_tuning module Subdivide_float_in_expr = Zero (struct let option_name = "-subdivide-float-var" let arg_name = "n" let help = "use 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.argument_is_function_name () let () = Plugin.set_group precision_tuning module UsePrototype = StringSet (struct let option_name = "-val-use-spec" let arg_name = "f1,..,fn" let help = "use the ACSL specification of the functions instead of their definitions" 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 let () = Plugin.set_group precision_tuning module MemExecAll = False (struct let option_name = "-memexec-all" let help = "(experimental) speed up analysis by not recomputing functions already analyzed in the same context. Incompatible with some plugins and callbacks" end) let () = MemExecAll.add_set_hook (fun _bold bnew -> if bnew then try Dynamic.Parameter.Bool.set "-inout-callwise" true with Dynamic.Unbound_value _ | Dynamic.Incompatible_type _ -> abort "Cannot set option -memexec-all. Is plugin Inout registered?" ) let () = Plugin.set_group precision_tuning module ArrayPrecisionLevel = Int (struct let default = 200 let option_name = "-plevel" let arg_name = "n" let help = "use 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)" end) let () = add_precision_dep ArrayPrecisionLevel.parameter let () = ArrayPrecisionLevel.add_update_hook (fun _ v -> Lattice_Interval_Set.plevel := v) let () = Plugin.set_group precision_tuning module SeparateStmtStart = StringSet (struct let option_name = "-separate-stmts" let arg_name = "n1,..,nk" let help = "" end) let () = add_correctness_dep SeparateStmtStart.parameter let () = Plugin.set_group precision_tuning module SeparateStmtWord = Int (struct let option_name = "-separate-n" let default = 0 let arg_name = "n" let help = "" end) let () = SeparateStmtWord.set_range ~min:0 ~max:1073741823 let () = add_correctness_dep SeparateStmtWord.parameter let () = Plugin.set_group precision_tuning module SeparateStmtOf = Int (struct let option_name = "-separate-of" let default = 0 let arg_name = "n" let help = "" end) let () = SeparateStmtOf.set_range ~min:0 ~max:1073741823 let () = add_correctness_dep SeparateStmtOf.parameter (* ------------------------------------------------------------------------- *) (* --- Messages --- *) (* ------------------------------------------------------------------------- *) let () = Plugin.set_group messages module ValShowProgress = True (struct let option_name = "-val-show-progress" let help = "Show progression messages during analysis" end) let () = Plugin.set_group messages module TimingStep = Int (struct let option_name = "-val-show-time" let default = 0 let arg_name = "n" let help = "Prints the time spent analyzing function calls, when it exceeds seconds" end) module FloatTimingStep = State_builder.Float_ref (struct let default () = Pervasives.infinity let name = "Value_parameters.FloatTimingStep" let dependencies = [TimingStep.self] end) let () = TimingStep.add_set_hook (fun _ x -> FloatTimingStep.set (float x)) let () = Plugin.set_group messages module ShowSlevel = Int (struct let option_name = "-val-show-slevel" let default = 100 let arg_name = "n" let help = "Period for showing consumption of the alloted slevel during 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 call stack" end) (* ------------------------------------------------------------------------- *) (* --- Interpreter mode --- *) (* ------------------------------------------------------------------------- *) let () = Plugin.set_group interpreter module InterpreterMode = False (struct let option_name = "-val-interpreter-mode" let help = "Stop at first call to a library function, if main() has \ arguments, on undecided branches" end) let () = Plugin.argument_is_function_name () let () = Plugin.set_group interpreter module ObviouslyTerminatesFunctions = StringSet (struct let option_name = "-obviously-terminates-function" let arg_name = "f" let help = "" end) let () = add_dep ObviouslyTerminatesFunctions.parameter let () = Plugin.set_group interpreter module ObviouslyTerminatesAll = False (struct 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 () = Plugin.set_group interpreter module StopAtNthAlarm = Int(struct let option_name = "-val-stop-at-nth-alarm" let default = max_int let arg_name = "n" let help = "" end) (* -------------------------------------------------------------------------- *) (* --- Ugliness required for correctness --- *) (* -------------------------------------------------------------------------- *) let () = Plugin.is_invisible () module InitialStateChanged = Int (struct let option_name = "-new-initial-state" let default = 0 let arg_name = "n" let help = "" end) (* Changing the user-supplied initial state (or the arguments of main) through the API of Db.Value does reset the state of Value, but *not* the property statuses that Value has positioned. Currently, statuses can only depend on a command-line parameter. We use the dummy one above to force a reset when needed. *) let () = add_correctness_dep InitialStateChanged.parameter; Db.Value.initial_state_changed := (fun () -> InitialStateChanged.set (InitialStateChanged.get () + 1)) let parameters_correctness = !parameters_correctness let parameters_tuning = !parameters_tuning (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/builtins.mli0000644000175000017500000000504012155630231020231 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 builtin shipped with Frama-C, more efficient than their equivalent in C *) (** Register the given OCaml function as a builtin, that will be used instead of the Cil C function of the same name *) val register_builtin: string -> Db.Value.builtin_sig -> unit (** Find a previously registered builtin. Raises [Not_found] if no such builtin exists. *) val find_builtin: string -> Db.Value.builtin_sig (** Does the builtin table contain an entry for [name]? *) val mem_builtin: string -> bool (** Should the given function be replaced by a call to a builtin *) val overridden_by_builtin: string -> bool (** Builtins with multiple names; the lookup is done using a distinctive prefix *) (* TODO: move the lookup mechanism into find_builtin *) val dump_state: Db.Value.builtin_sig val dump_args: string -> Db.Value.builtin_sig val dump_state_file: string -> Db.Value.builtin_sig (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/separate.mli0000644000175000017500000000343112155630231020206 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 prologue : unit -> unit val filter_if : Cil_types.stmt -> 'a Dataflow.guardaction * 'b Dataflow.guardaction -> 'a Dataflow.guardaction * 'b Dataflow.guardaction val epilogue : unit -> unit frama-c-Fluorine-20130601/src/value/split_return.mli0000644000175000017500000000401712155630231021135 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** This module is used to merge together the final states of a function according to a given strategy. Default is to merge all states together *) (** Join the given state_set. The strategy is defined according to the name of the function. *) val join_final_states: Cil_types.kernel_function -> return_lv:Cil_types.lval option -> State_set.t -> Cvalue.Model.t list (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/locals_scoping.mli0000644000175000017500000001120012155630231021372 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Auxiliary functions to mark invalid (more precisely 'escaping') the references to a variable whose scope ends. *) (** Set of bases that might contain a reference to a local or formal variable. Those references must be marked as dangling once we leave the scope of those local or formals. *) type clobbered_set = { mutable clob: Base.SetLattice.t } val bottom: unit -> clobbered_set val top: unit -> clobbered_set val remember_bases_with_locals: clobbered_set -> Base.SetLattice.t -> unit (** Add the given set of bases to an existing clobbered set *) val remember_if_locals_in_value: clobbered_set -> Locations.location -> Cvalue.V.t -> unit (** [remember_locals_in_value clob loc v] adds all bases pointed to by [loc] to [clob] if [v] contains the address of a local or formal *) val remember_if_locals_in_offsetmap: clobbered_set -> Locations.location -> Cvalue.V_Offsetmap.t -> unit (** Same as above with an entire offsetmap *) type topify_offsetmap = Cvalue.V_Offsetmap.t -> Base.SetLattice.t * Cvalue.V_Offsetmap.t (** Type of a function that topifies the references to a local in an offsetmap. It returns the cleared up offsetmap, and the of variables whose address was found *) type topify_offsetmap_approx = exact:bool -> topify_offsetmap (** Type of a function that partially topifies the references to a local in an offsetmap. If [exact] is false, references to locals are both kept and flagged as being escaping addresses. *) type topify_state = Cvalue.Model.t -> Cvalue.Model.t (** Type of a function that topifies a state. Introduced here by symmetry. *) val offsetmap_top_addresses_of_locals: (Base.t -> bool) -> topify_offsetmap_approx (** [offsetmap_top_addresses_of_locals is_local] returns a function that topifies all the parts of an offsetmap that contains a pointer verifying [is_local]. For efficicent reasons, this function is meant to be partially applied to its first argument. *) val state_top_addresses_of_locals: exact:bool -> (Base.t -> Base.SetLattice.t -> unit) -> topify_offsetmap_approx -> clobbered_set -> topify_state (** [state_top_addresses_of_locals exact warn topoffsm clob] generalizes [topoffsm] into a function that topifies a memory state. [topoffsm] is called only on the offsetmaps bound to the bases in [clob]. The [exact] argument is passed to [topoffsm]. If escaping locals [locals] are referenced in the offsetmap bound to [b], [warn b locals] is called. *) val top_addresses_of_locals: Cil_types.fundec -> clobbered_set -> topify_offsetmap * topify_state (** Return two functions that topifies all references to the locals and formals of the given function. For memory states, only the offsetmaps bound to the variables in the clobbered set are treated. *) val block_top_addresses_of_locals: Cil_types.fundec -> clobbered_set -> Cil_types.block list -> topify_state (** Return a function that topifies all references to the variables local to the given blocks. Only the offsetmaps bound to the variables in the clobbered set are treated. *) frama-c-Fluorine-20130601/src/value/state_imp.mli0000644000175000017500000000512112155630231020365 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Sets of Cvalue.Model.t implemented imperatively. Current implementation is optimized to detect similarities in the memory states *) type t val pretty : Format.formatter -> t -> unit (** Creation *) val empty : unit -> t val singleton : Cvalue.Model.t -> t (** Information *) val is_empty : t -> bool val length : t -> int (** Adding elements. *) exception Unchanged (** The three next functions raise [Unchanged] if the element(s) was already present. *) val add : Cvalue.Model.t -> t -> unit val merge_into : t -> t -> unit val merge_set_into : State_set.t -> t -> unit val merge_set_return_new : State_set.t -> t -> State_set.t (** Iterators *) val fold : ( Cvalue.Model.t -> 'a -> 'a) -> t -> 'a -> 'a val iter : (Cvalue.Model.t -> unit) -> t -> unit val exists : (Cvalue.Model.t -> bool) -> t -> bool (** Export *) val join : t -> Cvalue.Model.t val to_set : t -> State_set.t val to_list : t -> Cvalue.Model.t list (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/local_slevel_types.ml0000644000175000017500000000457412155630231022132 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* This type indicates to eval_stmt.mls computer what to do at a stmt * returned by determine_mode *) type mode = Normal | Split of local_slevel_info | Merge | MergeSplit of local_slevel_info (* This type contains all local_slevel infos needed in computer *) and local_slevel_info = { mutable prevmode : mode ; merges : Cil_datatype.Stmt.Hptset.t ; slevel : int option} let empty_info () = { prevmode = Normal ; merges = Cil_datatype.Stmt.Hptset.empty ; slevel = None } let d_mode ff mode = Format.fprintf ff "%s" (match mode with | Normal -> "Local_slevel.Normal" | Split _ -> "Local_slevel.Split" | Merge -> "Local_slevel.Merge" | MergeSplit _ -> "Local_slevel.MergeSplit") (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/non_linear.ml0000644000175000017500000001107712155630231020362 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 ] end) module Loc_hashtbl = Hashtbl.Make (Location_Bits) class do_non_linear_assignments = object(self) inherit Visitor.frama_c_inplace 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 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: *) frama-c-Fluorine-20130601/src/value/warn.mli0000644000175000017500000000601512155630231017352 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 val check_not_comparable : binop -> Location_Bytes.t -> Location_Bytes.t -> bool val check_no_recursive_call: kernel_function -> bool (** This function should be used to treat a call [lv = kf(...)]. [warn_modified_result_loc alarms loc state lv] checks that evaluating [lv] in [state] results in [location]. If it is not the case, a warning about a modification of [lv] during the call to [kf] is emitted *) val warn_modified_result_loc: with_alarms:CilE.warn_mode -> kernel_function -> location -> Cvalue.Model.t -> lval -> unit val warn_imprecise_lval_read: with_alarms:CilE.warn_mode -> lval -> location -> Location_Bytes.t -> unit val warn_locals_escape: bool -> fundec -> Base.t -> Base.SetLattice.t -> unit val warn_locals_escape_result: fundec -> Base.SetLattice.t -> unit val warn_right_exp_imprecision: with_alarms:CilE.warn_mode -> Cil_types.lval -> Locations.location -> Cvalue.V.t -> unit val warn_overlap: with_alarms:CilE.warn_mode -> lval * Locations.location -> lval * Locations.location -> unit val warn_float: with_alarms:CilE.warn_mode -> ?overflow:bool -> ?addr:bool -> fkind option -> (Format.formatter -> unit) -> unit val warn_float_addr: with_alarms:CilE.warn_mode -> (Format.formatter -> unit) -> unit (* Returns the first eventual imprecise part contained in an offsetmap *) val offsetmap_contains_imprecision: Cvalue.V_Offsetmap.t -> Cvalue.V.t option frama-c-Fluorine-20130601/src/value/eval_stmt.ml0000644000175000017500000005002012155630231020223 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Locations open Abstract_interp open Bit_utils open Cvalue open Value_util open Eval_exprs (* Forward reference to [Eval_funs.compute_call] *) let compute_call_ref = ref (fun _ -> assert false) 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 (** Precondition: the type of [v] and the type of [loc_lv] may be different only through 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 ~with_alarms state lv typ_lv loc_lv v = assert (not (Cvalue.V.is_bottom v)); (* 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 (* TODOBY: ignore this case*) try ignore (V.project_ival v); Eval_op.cast_lval_bitfield typ_lv loc_lv.size v 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.ge size (Int.of_int (sizeofpointer ())) || V.is_imprecise v then v 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 v end | Neither_Int_Nor_Enum_Nor_Pointer (* from [signof_typeof_lval] *) -> v with | Int_Base.Error_Top (* from Int_Base.project *) -> (* Imprecise location, handled below *) v in (match loc_lv.loc with | Location_Bits.Top (Base.SetLattice.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." Origin.pretty_as_reason orig; do_degenerate (Some lv) | Location_Bits.Top((Base.SetLattice.Set _) as param,orig) -> Value_parameters.result ~current:true ~once:true "writing somewhere in @[%a@]@[%a@]." Base.SetLattice.pretty param Origin.pretty_as_reason 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 exception Do_assign_imprecise_copy (* Assigns [exp] to [lv] in [state] *) let do_assign ~with_alarms clob state lv exp = assert (Cvalue.Model.is_reachable state); let state, left_loc, typ_lv = lval_to_loc_state ~with_alarms state lv in let lv_is_volatile = hasAttribute "volatile" (typeAttrs typ_lv) in let state, left_loc = Eval_exprs.warn_reduce_by_accessed_loc ~with_alarms ~for_writing:true state left_loc lv in if Location_Bits.is_bottom left_loc.loc then CilE.do_warn with_alarms.CilE.imprecision_tracing (fun _ -> Kernel.warning ~current:true ~once:true "@[@[all target addresses were invalid. This path is \ assumed to be dead.@]%t@]" pp_callstack); if not (Cvalue.Model.is_reachable state) then state else (* First mode, used when [exp] is not a lval, when a conversion is needed between [exp] and [lv], or as backup *) let default () = let state, _, v = eval_expr_with_deps_state_subdiv ~with_alarms None state exp in Locals_scoping.remember_if_locals_in_value clob left_loc v; Warn.warn_right_exp_imprecision ~with_alarms lv left_loc v; if Cvalue.V.is_bottom v || Location_Bits.equal left_loc.loc Location_Bits.bottom || not (Cvalue.Model.is_reachable state) then Cvalue.Model.bottom else begin CilE.set_syntactic_context (CilE.SyMem lv); let v = if lv_is_volatile then V.top_int else v in do_assign_abstract_value ~with_alarms state lv typ_lv left_loc v end in (* More precise copy, in case exp is in fact an lval (and has a known size). We copy the entire lval in one operation. This is typically useful for struct assignment *) let right_is_lval exp_lv = if Location_Bits.equal left_loc.loc Location_Bits.bottom || not (Cvalue.Model.is_reachable state) then Model.bottom else let state, right_loc, _ = lval_to_loc_state ~with_alarms state exp_lv in let state, right_loc = Eval_exprs.warn_reduce_by_accessed_loc ~with_alarms ~for_writing:false state right_loc exp_lv in (* Size mismatch between left and right size, or imprecise size. This cannot be done by copies, but require a conversion *) if not (Int_Base.equal right_loc.size left_loc.size) || Int_Base.is_top right_loc.size then raise Do_assign_imprecise_copy; (* Warn if right_loc is imprecise *) Warn.warn_imprecise_lval_read ~with_alarms exp_lv right_loc (* Dummy value:*)V.bottom; (* Warn if both sides overlap *) Warn.warn_overlap ~with_alarms (lv, left_loc) (exp_lv, right_loc); if Location_Bits.equal left_loc.loc Location_Bits.bottom || not (Cvalue.Model.is_reachable state) then Cvalue.Model.bottom else begin match right_loc.size with | Int_Base.Value size -> CilE.set_syntactic_context (CilE.SyMem exp_lv); let offsetmap = Cvalue.Model.copy_offsetmap ~with_alarms right_loc state in begin match offsetmap with | None -> Model.bottom | Some offsetmap -> assert (not (Cvalue.V_Offsetmap.is_empty offsetmap)); Locals_scoping.remember_if_locals_in_offsetmap clob left_loc offsetmap; (* TODO: message "assigning non deterministic value for the first time" *) (match Warn.offsetmap_contains_imprecision offsetmap with | Some v -> Warn.warn_right_exp_imprecision ~with_alarms lv left_loc v | _ -> ()); CilE.set_syntactic_context (CilE.SyMem lv); Cvalue.Model.paste_offsetmap with_alarms offsetmap left_loc.loc Int.zero size true state end | Int_Base.Top -> assert false (* tested, default mode is used *) end in try if lv_is_volatile || Eval_op.is_bitfield typ_lv then default () else (* An lval assignement might be hidden by a dummy cast *) let exp_lv = find_lv ~with_alarms state exp in right_is_lval exp_lv with Cannot_find_lv | Do_assign_imprecise_copy -> default () exception Too_linear let do_assign ~with_alarms clob old_state lv exp = if true then do_assign ~with_alarms clob old_state lv exp else (* Experimental code that performs automatic splitting when the expression is not linear *) let vars = get_influential_vars old_state exp in let rec try_sub vars = match vars with | [] | [ _ ] -> do_assign ~with_alarms clob 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 = Cvalue.Model.add_binding ~with_alarms:CilE.warn_none_mode ~exact:true old_state v subvalue in let sub_newstate = do_assign ~with_alarms clob 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 (* This functions stores the result of call, represented by offsetmap [return], into [lv]. It is not trivial because we must handle the possibility of casts between the type of the result [rettyp] and the type of [lv]. With option [-no-collapse-call-cast], we only need the first part of the function. *) let assign_return_to_lv ~with_alarms clob rettype (lv, loc, lvtyp) return state = let is_bitfield = Eval_op.is_bitfield lvtyp in if not (is_bitfield) && not (need_cast lvtyp rettype) then (* Direct paste *) let size = Int_Base.project loc.size in CilE.set_syntactic_context (CilE.SyMem lv); let result = Cvalue.Model.paste_offsetmap with_alarms return loc.loc Int.zero size true state in Locals_scoping.remember_if_locals_in_offsetmap clob loc return; result else (* Size mismatch. We read then cast the returned value *) let size = Int.of_int (bitsSizeOf rettype) in let validity = Base.Known (Int.zero, Int.pred size) in let value_with_init = V_Offsetmap.find ~conflate_bottom:false ~validity ~with_alarms:CilE.warn_none_mode ~offsets:Ival.zero ~size return 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 (* Cf. bts #997 and #1024 for the syntactic context below *) CilE.set_syntactic_context CilE.SyCallResult; let evaled_exp = Eval_op.reinterpret ~with_alarms rettype value 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 (* Type of [lv] and [return] might differ, perform a cast (bug #798) *) let evaled_exp = if is_bitfield then Eval_op.cast_lval_bitfield lvtyp loc.size evaled_exp else let msg fmt = Format.fprintf fmt "call result (%a)" V.pretty evaled_exp in Eval_op.do_promotion ~with_alarms (get_rounding_mode()) ~src_typ:rettype ~dst_typ:lvtyp evaled_exp msg in Locals_scoping.remember_if_locals_in_value clob loc evaled_exp; CilE.set_syntactic_context (CilE.SyMem lv); Cvalue.Model.add_binding ~with_alarms ~exact state loc evaled_exp let interp_call ~with_alarms clob stmt lval_to_assign funcexp argl state = let cacheable = ref Value_types.Cacheable in let call_site_loc = CurrentLoc.get () in try let functions, _ = resolv_func_vinfo ~with_alarms None state funcexp in let is_library_function kf = not (Kernel_function.is_definition kf || let name = Kernel_function.get_name kf in (name >= "Frama_C" && name < "Frama_D") || Builtins.mem_builtin name) in let calling_at_least_one_library_function = Kernel_function.Hptset.exists is_library_function functions in if calling_at_least_one_library_function && Value_parameters.InterpreterMode.get() then begin warning_once_current "Library function call. Stopping."; exit 0 end; let compute_actual = Function_args.compute_actual ~with_alarms calling_at_least_one_library_function in let actuals = List.map (compute_actual state) argl in let to_assign, state = match lval_to_assign with | None -> None, state | Some lv -> let state, loc, typlv = lval_to_loc_state ~with_alarms state lv in let state', loc' = Eval_exprs.warn_reduce_by_accessed_loc ~with_alarms ~for_writing:true state loc lv in if Model.is_reachable state' then Some (lv, loc', typlv), state' else (* Ignore reduction, attempt the call, which might result in a warning if the evaluation of lv changes *) Some (lv, loc, typlv), state in let caller = current_kf (), stmt in (* Remove bottom state from results, assigns result to retlv *) let treat_one_result kf res (return, state) = if not (Cvalue.Model.is_reachable state) then res else match to_assign with | None -> state :: res | Some (lvret, locret, _ as to_assign) -> Warn.warn_modified_result_loc with_alarms kf locret state lvret; let return = Extlib.the return in let rettype = getReturnType (typeOf funcexp) in let state = assign_return_to_lv ~with_alarms clob rettype to_assign return state in state :: res in let treat_one_function f acc_rt_res = try Kf_state.add_caller f ~caller; let call_kinstr = Kstmt stmt in let res = !compute_call_ref f ~call_kinstr state actuals in CurrentLoc.set call_site_loc; (* Changed by compute_call_ref *) if res.Value_types.c_cacheable = Value_types.NoCacheCallers then (* Propagate info that callers cannot be cached either *) cacheable := Value_types.NoCacheCallers; Locals_scoping.remember_bases_with_locals clob res.Value_types.c_clobbered; let treat_f = treat_one_result f in List.fold_left treat_f acc_rt_res res.Value_types.c_values with | Function_args.WrongFunctionType -> warning_once_current "Function type must match type at call site: \ assert(function type matches)"; Value_util.stop_if_stop_at_first_alarm_mode (); acc_rt_res in let results = Kernel_function.Hptset.fold treat_one_function functions [] in if results <> [] then Value_results.mark_call_terminating stmt; results, !cacheable with | Function_args.Actual_is_bottom -> (* from compute_actual *) CurrentLoc.set call_site_loc; [], !cacheable exception AlwaysOverlap let check_non_overlapping state lvs1 lvs2 = let conv lv = let loc = lval_to_loc ~with_alarms:CilE.warn_none_mode state lv in let loc = valid_part ~for_writing:false loc in let z = Locations.enumerate_valid_bits ~for_writing:false loc in lv, loc, z in let l1 = List.map conv lvs1 in let l2 = List.map conv lvs2 in List.iter (fun (lv1, loc1, z1) -> List.iter (fun (lv2, loc2, z2) -> if Locations.Zone.intersects z1 z2 then begin CilE.set_syntactic_context (CilE.SySep(lv1, lv2)); CilE.warn_separated warn_all_mode; if Locations.cardinal_zero_or_one loc1 && Locations.cardinal_zero_or_one loc2 then raise AlwaysOverlap end; ) l2) l1 (* Not currently taking advantage of calls information. But see plugin Undefined Order by VP. *) 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 = 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 (* Remove locals from the given, and extract the content of \result *) let externalize fundec ~return_lv clob = let offsetmap_top_addresses_of_locals, state_top_addresses_of_locals = Locals_scoping.top_addresses_of_locals fundec clob in fun state -> let _, state, ret_val = match return_lv with | Some lv -> Eval_exprs.offsetmap_of_lv ~with_alarms:(warn_all_quiet_mode ()) state lv | None -> Locations.loc_bottom, state, None in let state = Cvalue.Model.uninitialize_formals_locals fundec state in let ret_val = match ret_val with | None -> ret_val | Some ret_val -> let locals, r = offsetmap_top_addresses_of_locals ret_val in if not (Cvalue.V_Offsetmap.equal r ret_val) then Warn.warn_locals_escape_result fundec locals; Some r in ret_val, state_top_addresses_of_locals state (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/value_results.ml0000644000175000017500000000447212155630231021134 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (* This file will ultimately contain all the results computed by Value (which must be moved out of Db.Value), both per stack and globally. *) (* Does the given call statement terminate at least once. Filled only for [Instr (Call _)] stmts *) module Terminating_calls = Cil_state_builder.Stmt_hashtbl (Datatype.Bool) (struct let name = "Value_results.Terminating_calls" let size = 17 let dependencies = [ Db.Value.self ] end) let mark_call_terminating stmt = Terminating_calls.replace stmt true let is_non_terminating_call stmt = match stmt.skind with | Instr (Call _) -> not (Terminating_calls.mem stmt) | _ -> false (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/register.ml0000644000175000017500000002557412155630231020071 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Eval_exprs (** Main function of the value plugin for the kernel *) 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 -> 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.ForceValues.output display_results; end let () = Db.Main.extend main (** Functions to register in Db.Value *) let lval_to_loc_with_deps_state ~with_alarms state ~deps lv = let _state, deps, r, _ = lval_to_loc_deps_state ~with_alarms ~deps:(Some deps) ~reduce_valid_index:(Kernel.SafeArrays.get ()) state lv in Extlib.opt_conv Zone.bottom deps, r 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.enumerate_valid_bits ~for_writing:false (lval_to_loc_kinstr ~with_alarms kinstr lv) let lval_to_zone_state state lv = Locations.enumerate_valid_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 = let r, deps = resolv_func_vinfo ~with_alarms deps state exp in Extlib.opt_conv Zone.bottom deps, r 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 let expr_to_kernel_function_state = expr_to_kernel_function_state ~with_alarms:CilE.warn_none_mode let eval_error_reason fmt e = if e <> Eval_terms.CAlarm then Eval_terms.pretty_logic_evaluation_error fmt e let assigns_inputs_to_zone state assigns = let env = Eval_terms.env_pre_f ~init:state () in let treat_asgn acc (_,ins as asgn) = match ins with | FromAny -> Zone.top | From l -> try List.fold_left (fun acc t -> let z = Eval_terms.eval_tlval_as_zone ~with_alarms:CilE.warn_none_mode ~for_writing:false env t.it_content in Zone.join acc z) acc l with Eval_terms.LogicEvalError e -> Value_parameters.warning ~current:true ~once:true "Failed to interpret inputs in assigns clause '%a'%a" Printer.pp_from asgn eval_error_reason e; Zone.top in match assigns with | WritesAny -> Zone.top | Writes l -> List.fold_left treat_asgn Zone.bottom l let assigns_outputs_aux ~eval ~bot ~top ~join state ~result assigns = let env = Eval_terms.env_post_f state state result () in let treat_asgn acc ({it_content = out},_) = if Logic_utils.is_result out && result = None then acc else try let z = eval env out in join z acc with Eval_terms.LogicEvalError e -> Value_parameters.warning ~current:true ~once:true "Failed to interpret assigns clause '%a'%a" Printer.pp_term out eval_error_reason e; join top acc in match assigns with | WritesAny -> join top bot | Writes l -> List.fold_left treat_asgn bot l let assigns_outputs_to_zone = assigns_outputs_aux ~eval:(Eval_terms.eval_tlval_as_zone ~with_alarms:CilE.warn_none_mode ~for_writing:true) ~bot:Locations.Zone.bottom ~top:Locations.Zone.top ~join:Locations.Zone.join let assigns_outputs_to_locations = assigns_outputs_aux ~eval:(Eval_terms.eval_tlval_as_location ~with_alarms:CilE.warn_none_mode) ~bot:[] ~top:(Locations.make_loc Locations.Location_Bits.top Int_Base.top) ~join:(fun v l -> v :: l) 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 (* "access" functions (before and after evaluation) in Db.Value *) let access_value_of_lval kinstr lv = let state = Db.Value.get_state kinstr in snd (!Db.Value.eval_lval ~with_alarms:CilE.warn_none_mode None state lv) let access_value_of_expr kinstr e = let state = Db.Value.get_state kinstr in !Db.Value.eval_expr ~with_alarms:CilE.warn_none_mode state e let access_value_of_location kinstr loc = let state = Db.Value.get_state kinstr in Db.Value.find state loc let access_value_of_lval_after ki lv = match ki with | Cil_types.Kstmt {Cil_types.succs = (_::_ ) as l} -> let result = List.fold_left (fun acc s -> let ks = Cil_types.Kstmt s in Cvalue.V.join (access_value_of_lval ks lv) acc) Cvalue.V.bottom l in begin match Bit_utils.sizeof_lval lv with | Int_Base.Top -> result | Int_Base.Value size -> Cvalue.V.anisotropic_cast ~size result end | _ -> raise Not_found let access_offsetmap_of_lval_after ki lv = match ki with | Cil_types.Kstmt {Cil_types.succs = (_::_ ) as l} -> let result = List.fold_left (fun acc s -> let ks = Cil_types.Kstmt s in let state = Db.Value.get_state ks in let loc = Locations.valid_part ~for_writing:false (!Db.Value.lval_to_loc_state state lv) in let offsetmap = Cvalue.Model.copy_offsetmap ~with_alarms:CilE.warn_none_mode loc state in match acc, offsetmap with | None, x | x , None -> x | Some acc, Some offsetmap -> Some ((Cvalue.V_Offsetmap.join acc offsetmap))) None l in result | _ -> raise Not_found let access_value_of_location_after ki loc = match ki with | Cil_types.Kstmt {Cil_types.succs=(_::_ ) as l} -> List.fold_left (fun acc s -> let ks = Cil_types.Kstmt s in Cvalue.V.join (access_value_of_location ks loc) acc) Cvalue.V.bottom l | _ -> raise Not_found (* 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_outputs_to_zone := assigns_outputs_to_zone; Db.Value.assigns_outputs_to_locations := assigns_outputs_to_locations; Db.Value.assigns_inputs_to_zone := assigns_inputs_to_zone; 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.access := access_value_of_lval; Db.Value.access_after := access_value_of_lval_after; Db.Value.access_location_after := access_value_of_location_after; Db.Value.access_location := access_value_of_location; Db.Value.access_expr := access_value_of_expr; Db.Value.lval_to_offsetmap_after := access_offsetmap_of_lval_after (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/register_gui.ml0000644000175000017500000005531312155630231020727 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Db open Pretty_source open Gtk_helper type lval_or_absolute = TLVal of term | LVal of lval | AbsoluteMem let pretty_lval_or_absolute fmt = function | TLVal tlv -> Printer.pp_term fmt tlv | LVal lv -> Printer.pp_lval fmt lv | AbsoluteMem -> Format.pp_print_string fmt "[MEMORY]" let pretty_offsetmap lv fmt offsetmap = begin match offsetmap with | None -> Format.fprintf fmt "" | Some off -> let typ = match lv with | LVal lv -> Some (typeOfLval lv) | TLVal tlv -> Some (Logic_utils.logicCType tlv.term_type) | AbsoluteMem -> None in Format.fprintf fmt "%a%a" pretty_lval_or_absolute lv (Cvalue.V_Offsetmap.pretty_typ typ) off end (* special [with_alarms] value that log important alarms, but allow execution to continue *) let log_alarms () = let ok = ref true in let not_ok () = ok := false in let with_alarms = { CilE.others = {CilE.a_ignore with CilE.a_call=not_ok}; unspecified = {CilE.a_ignore with CilE.a_call=not_ok}; defined_logic = CilE.a_ignore; imprecision_tracing = CilE.a_ignore; } in with_alarms, ok let pp_eval_ok fmt ok = if not ok then Format.fprintf fmt " (evaluation may have failed in some cases) " let lval_or_absolute_to_offsetmap state lv = let with_alarms, ok = log_alarms () in let r = match lv with | LVal lv -> let loc = Eval_exprs.lval_to_loc ~with_alarms state lv in Cvalue.Model.copy_offsetmap ~with_alarms loc state | TLVal tlv -> let env = Eval_terms.env_annot ~pre:Cvalue.Model.top ~here:state () in let loc = Eval_terms.eval_tlval_as_location env ~with_alarms tlv in Cvalue.Model.copy_offsetmap ~with_alarms loc state | AbsoluteMem -> try Some (Cvalue.Model.find_base Base.null state) with Not_found -> None in r, !ok let pretty_lva_before_after (main_ui: Design.main_window) ~before ~after lva = let pp fmt = main_ui#pretty_information fmt in try let offbefore, okbef = lval_or_absolute_to_offsetmap before lva in pp "Before statement%a:@. %a@." pp_eval_ok okbef (pretty_offsetmap lva) offbefore; if Cvalue.Model.is_reachable before then Extlib.may (fun (after, precise_after) -> let offafter, okafter = lval_or_absolute_to_offsetmap after lva in pp "%s statement%a:@. %a@." (if precise_after then "After" else "At next") pp_eval_ok okafter (pretty_offsetmap lva) offafter ) after; with Eval_terms.LogicEvalError ee -> Value_parameters.debug "Cannot evaluate term (%a)" Eval_terms.pretty_logic_evaluation_error ee ;; let pretty_lva_callstacks (main_ui: Design.main_window) ~cbefore ~cafter lva = let pp fmt = main_ui#pretty_information fmt in let aux callstack before = let after = Extlib.opt_map (fun cafter -> try Value_types.Callstack.Hashtbl.find cafter callstack, true with Not_found -> Cvalue.Model.bottom, true ) cafter in pp "For callstack [%a]@." Value_util.pretty_call_stack callstack; pretty_lva_before_after main_ui ~before ~after lva in (* TODO: we should sort the callstacks by prefix *) Value_types.Callstack.Hashtbl.iter aux cbefore (* Compute an after state by picking the pre state of the successors *) let approximated_after_state = function | { Cil_types.succs = (_::_ as l) } -> List.fold_left (fun acc s -> let state = Db.Value.get_stmt_state s in Cvalue.Model.join acc state ) Cvalue.Model.bottom l | { skind = Return _ } as s -> Db.Value.get_stmt_state s | _ -> Cvalue.Model.bottom let pretty_lva_at_stmt main_ui stmt lva = (* Standard printing, without callstacks *) let default () = let before = Value.get_stmt_state stmt in let after = match stmt.skind with | Instr _ -> Some ((if Value_parameters.ResultsAfter.get () then try Value.AfterTable.find stmt with Not_found -> Cvalue.Model.bottom else approximated_after_state stmt), false (* mark that after state is not precise *)) | _ -> None in pretty_lva_before_after main_ui ~before ~after lva in let cbefore = Value.get_stmt_state_callstack ~after:false stmt in let cafter = Value.get_stmt_state_callstack ~after:true stmt in match cbefore with | Some cbefore -> if Value_types.Callstack.Hashtbl.length cbefore > 1 then default (); pretty_lva_callstacks main_ui ~cbefore ~cafter lva | None -> default () let pretty_formal_initial_state (main_ui: Design.main_window_extension_points) vi state = (* Callstack information not available yet *) let lval = LVal (Var vi, NoOffset) in let offsm,_ = lval_or_absolute_to_offsetmap state lval in let pp fmt = main_ui#pretty_information fmt in pp "Initial value (before preconditions):@.%a@." (pretty_offsetmap lval) offsm let gui_compute_values (main_ui:Design.main_window_extension_points) = if not (Db.Value.is_computed ()) then main_ui#launcher () let cleant_outputs kf s = let outs = Db.Outputs.kinstr (Kstmt s) in let accept = !Db.Semantic_Callgraph.accept_base ~with_formals:true ~with_locals:true kf in let filter = Locations.Zone.filter_base accept in Extlib.opt_map filter outs (* Evaluate the user-supplied term contained in the string [txt] *) let eval_user_term main_ui kf stmt txt = Cil.CurrentLoc.set (Cil_datatype.Stmt.loc stmt); try if txt = "[MEM]" then pretty_lva_at_stmt main_ui stmt AbsoluteMem else let term = !Db.Properties.Interp.expr kf stmt txt in let pre = Db.Value.get_initial_state kf in let here = Db.Value.get_stmt_state stmt in let open Cil_datatype in let c_labels = Db.Value.Table.fold (fun stmt -> Logic_label.Map.add (StmtLabel (ref stmt))) Logic_label.Map.empty in let env = Eval_terms.env_annot ~c_labels ~pre ~here () in begin match term.term_node with | TLval _ | TStartOf _ -> pretty_lva_at_stmt main_ui stmt (TLVal term) | _ -> let with_alarms, ok = log_alarms () in let evaled = Eval_terms.eval_term ~with_alarms env term in let v = List.fold_left Cvalue.V.join Cvalue.V.bottom evaled.Eval_terms.evalue in main_ui#pretty_information "Before the selected statement, all the values \ taken by the term %a are contained in %a%a@." Printer.pp_term term Cvalue.V.pretty v pp_eval_ok (!ok) end with | Logic_interp.Error (_, mess) -> main_ui#error "Invalid expression: %s" mess | Parsing.Parse_error -> main_ui#error "Invalid term: Parse error" | Eval_terms.LogicEvalError ee -> main_ui#error "Cannot evaluate term (%a)" Eval_terms.pretty_logic_evaluation_error ee | e -> main_ui#error "Invalid expression: %s" (Cmdline.protect e) let to_do_on_select (popup_factory:GMenu.menu GMenu.factory) (main_ui:Design.main_window_extension_points) button_nb selected = if button_nb = 1 then begin if Db.Value.is_computed () then begin match selected with | PStmt (kf,stmt) -> begin (* Is it an accessible statement ? *) if Db.Value.is_reachable_stmt stmt then begin if Value_results.is_non_terminating_call stmt then main_ui#pretty_information "This call never terminates@." else (* Out for this statement *) let outs = cleant_outputs kf stmt in match outs with | Some outs -> main_ui#pretty_information "Modifies @[%a@]@." Db.Outputs.pretty outs | _ -> () end else main_ui#pretty_information "This code is dead@."; end | PLval (_kf, Kstmt stmt,lv) -> if Db.Value.is_reachable_stmt stmt && not (isFunctionType (typeOfLval lv)) then pretty_lva_at_stmt main_ui stmt (LVal lv) | PTermLval (_kf, Kstmt stmt, tlv) -> if Db.Value.is_reachable_stmt stmt then let ltyp = Cil.typeOfTermLval tlv in let term = Logic_const.term (TLval tlv) ltyp in pretty_lva_at_stmt main_ui stmt (TLVal term) | PVDecl (Some kf, vi) when vi.vformal -> let state = Db.Value.get_initial_state kf in if Cvalue.Model.is_reachable state then pretty_formal_initial_state main_ui vi state | PLval (_, Kglobal, _) | PTermLval (_, Kglobal, _) -> () | 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 (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 -> () end | PStmt (kf,stmt) -> if Db.Value.is_computed () then let eval_expr () = 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 -> eval_user_term main_ui kf stmt txt in begin try ignore (popup_factory#add_item "_Evaluate ACSL term" ~callback:eval_expr) with Not_found -> () end else ignore (popup_factory#add_item "_Evaluate ACSL term ..." ~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 funs = if not (Kernel_function.Hptset.is_empty funs) then Kernel_function.Hptset.iter (fun kf -> try 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" Kernel_function.pretty kf)) ^ " (indirect)") ~callback: (fun () -> main_ui#select_or_display_global g)) with Not_found -> ()) funs; in (match lv with | Var _,NoOffset when isFunctionType ty -> (* simple literal calls are done by [Design]. *) () | Mem ({ enode = Lval _}), NoOffset -> if isFunctionType ty then (* Function pointers *) begin (* get the list of functions in the values *) let e = Cil.dummy_exp (Lval lv) in let funs, _ = Eval_exprs.resolv_func_vinfo ~with_alarms:CilE.warn_none_mode None (Db.Value.get_state ki) e in do_menu funs end | _ -> () ) end | PTermLval _ -> () (* No C function calls in logic *) | PGlobal _ -> () | PIP _ -> () end module UsedVarState = Cil_state_builder.Varinfo_hashtbl (Datatype.Bool) (struct let size = 17 let name = "Value.Gui.UsedVarState" let dependencies = [ !Db.Inputs.self_external; !Db.Outputs.self_external; ] end) 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 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 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 ()) ) 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 g = !hide_unused () && Value.is_computed () && (match g with | GFun ({svar = vi}, _) | GVarDecl (_, vi, _) -> (try let kf = Globals.Functions.get vi in not (!Value.is_called kf) with Not_found -> not (used_var vi)) | _ -> false ) module DegeneratedHighlighted = State_builder.Option_ref (Pretty_source.Localizable) (struct let name = "Value_gui.DegeneratedHighlightedState" let dependencies = [ Ast.self ] end) let value_panel (main_ui:Design.main_window_extension_points) = let box = GPack.vbox () in let run_button = GButton.button ~label:"Run" ~packing:(box#pack) () in let w = GPack.table ~packing:(box#pack ~expand:true ~fill:true) ~columns:2 () in let box_1_1 = GPack.hbox ~packing:(w#attach ~left:1 ~top:1) () in let slevel_refresh = Gtk_helper.on_int ~lower:0 ~upper:1000000 ~tooltip:(Pretty_utils.sfprintf "%s" Value_parameters.SemanticUnrollingLevel.parameter.Parameter.help) box_1_1 "slevel" Value_parameters.SemanticUnrollingLevel.get Value_parameters.SemanticUnrollingLevel.set in let box_1_2 = GPack.hbox ~packing:(w#attach ~left:1 ~top:2) () in let main_refresh = Gtk_helper.on_string ~tooltip:(Pretty_utils.sfprintf "%s" Kernel.MainFunction.parameter.Parameter.help) ~validator:(fun s->List.mem s (Kernel.MainFunction.get_possible_values ())) box_1_2 "main" Kernel.MainFunction.get Kernel.MainFunction.set in let refresh () = slevel_refresh (); main_refresh() in ignore (run_button#connect#pressed (fun () -> main_ui#protect ~cancelable:true (fun () -> refresh (); !Db.Value.compute (); main_ui#reset ()); )); "Value", box#coerce, Some refresh let main (main_ui:Design.main_window_extension_points) = (* Hide unused functions and variables. Must be registered only once *) let hide, _filter_menu = main_ui#file_tree#add_global_filter ~text:"Analyzed by Value only" ~key:"value_hide_unused" hide_unused_function_or_var in hide_unused := hide; 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 = to_do_on_select menu main_ui button localizable in main_ui#register_source_selector value_selector; let highlighter (buffer:GSourceView2.source_buffer) localizable ~start ~stop = (* highlight the degeneration point *) Extlib.may (fun loc -> if Pretty_source.Localizable.equal localizable loc then let orange_area = make_tag buffer ~name:"degeneration" [`BACKGROUND "orange" ] in apply_tag buffer orange_area start stop) (DegeneratedHighlighted.get_option ()); (* highlight dead code areas and non-terminating calls if Value has run.*) if Db.Value.is_computed () && (match localizable with PStmt _ -> true | _ -> false) then let ki = ki_of_localizable localizable in if Value.is_accessible ki then match ki with | Kstmt stmt when Value_results.is_non_terminating_call stmt -> let non_terminating = Gtk_helper.make_tag buffer ~name:"value_non_terminating" [`BACKGROUND "tomato"] in apply_tag buffer non_terminating (stop-1) stop | _ -> () else let dead_code_area = make_tag buffer "deadcode" [`BACKGROUND "tomato"; `STYLE `ITALIC;] in apply_tag buffer dead_code_area start stop in main_ui#register_source_highlighter highlighter; main_ui#register_panel value_panel let degeneration_occurred _ki _lv = (* Db.Value.mark_as_computed (); ignore (GtkMain.Main.init ()); let app = new Design.main_window () in app#main_window#set_title "Degeneration Occurred"; ignore (Glib.Idle.add ~prio:1000 (fun () -> let localizable = (match ki,lv with | Kstmt st, Some lv -> 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 = Kernel_function.find_englobing_kf st in select_kf app#file_tree kf; PStmt(kf,st) | Kglobal, Some lv -> PLval(None,ki,lv) | Kglobal, None -> assert false) in to_do_on_select (new GMenu.factory (GMenu.menu ())) app 1 localizable; DegeneratedHighlighted.set localizable; app#rehighlight (); app#scroll localizable (*match ki with | 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; Db.Value.degeneration_occurred := degeneration_occurred; ;; (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/eval_op.ml0000644000175000017500000004351712155630231017667 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Cvalue let pp_v v fmt = V.pretty fmt v open Cil_types open Abstract_interp open Cvalue let offsetmap_of_v ~typ v = let size = Int.of_int (Cil.bitsSizeOf typ) in let v = V_Or_Uninitialized.initialized v in V_Offsetmap.create ~size v ~size_v:size let wrap_int i = Some (offsetmap_of_v ~typ:Cil.intType i) let wrap_ptr p = Some (offsetmap_of_v ~typ:Cil.intPtrType p) let wrap_double d = Some (offsetmap_of_v ~typ:Cil.doubleType d) let is_bitfield typlv = match Cil.unrollType typlv with | TInt (_, attrs) | TEnum (_, attrs) -> (match Cil.findAttribute Cil.bitfield_attribute_name attrs with | [AInt _] -> true | _ -> false) | _ -> false let sizeof_lval_typ typlv = match Cil.unrollType typlv with | TInt (_, attrs) | TEnum (_, attrs) as t -> (match Cil.findAttribute Cil.bitfield_attribute_name attrs with | [AInt i] -> Int_Base.Value i | _ -> Bit_utils.sizeof t) | t -> Bit_utils.sizeof t (* TODO: this should probably be also put directly in reinterpret_int *) let cast_lval_bitfield typlv size v = match size with | Int_Base.Top -> v (* Bitfields have known sizes *) | Int_Base.Value size -> if is_bitfield typlv then let signed = Bit_utils.is_signed_int_enum_pointer typlv in let v, _ok = Cvalue.V.cast ~size ~signed v in v (* TODO: handle not ok case as a downcast *) else v let reinterpret_int ~with_alarms ikind v = let size = Int.of_int (Cil.bitsSizeOfInt ikind) in let signed = Cil.isSigned ikind in let v', ok = V.cast ~signed ~size v in if not ok then CilE.do_warn with_alarms.CilE.imprecision_tracing (fun _ -> Kernel.warning ~once:true ~current:true "@[casting address@ to a type@ smaller@ than sizeof(void*):@ \ @[%a@]@]" V.pretty v ); v' let reinterpret_float ~with_alarms fkind v = let conv = match fkind with | FFloat -> let rounding_mode = Value_util.get_rounding_mode () in Cvalue.V.cast_float ~rounding_mode | FDouble -> Cvalue.V.cast_double | FLongDouble -> let mach = Cil.theMachine.Cil.theMachine in if mach.sizeof_longdouble <> mach.sizeof_double then Value_parameters.error ~once:true "type long double not implemented. Using double instead"; Cvalue.V.cast_double in let addresses, overflow, r = conv v in if overflow || addresses then begin CilE.warn_nan_infinite with_alarms (Some fkind) (fun fmt -> V.pretty fmt v); end; r let reinterpret ~with_alarms t v = match Cil.unrollType t with | TInt (ikind, _) | TEnum ({ekind=ikind},_) -> reinterpret_int ~with_alarms ikind v | TPtr _ -> reinterpret_int ~with_alarms Cil.theMachine.Cil.upointKind v | TFloat (fkind, _) -> reinterpret_float ~with_alarms fkind v | TComp _ -> v (* see test [struct_call.c] *) | TBuiltin_va_list _ -> (CilE.do_warn with_alarms.CilE.imprecision_tracing (fun _ -> Value_util.warning_once_current "cast to __builtin_va_list is not precisely implemented yet%t" Value_util.pp_callstack) ); V.topify_arith_origin v | TFun _ -> v | TNamed _ -> assert false | TVoid _ -> assert false | TArray _ -> assert false let v_of_offsetmap ~with_alarms ~typ offsm = let size = Bit_utils.sizeof typ in match size with | Int_Base.Top -> assert false (* TODO *) | Int_Base.Value size -> let vuinit = V_Offsetmap.find ~with_alarms ~validity:(Base.Known (Integer.zero, Integer.pred size)) ~conflate_bottom:false ~offsets:(Ival.singleton_zero) ~size offsm in let v = V_Or_Uninitialized.get_v vuinit in reinterpret ~with_alarms typ v let do_promotion ~with_alarms rounding_mode ~src_typ ~dst_typ v msg = match Cil.unrollType dst_typ, Cil.unrollType src_typ with | TFloat _, TInt _ -> (* Cannot overflow with 32 bits float *) let v, _ok = Cvalue.V.cast_int_to_float rounding_mode v in v | TInt (kind,_), TFloat (fkind, _) -> let size = Cil.bitsSizeOf dst_typ in let signed = Cil.isSigned kind in let addr, top, overflow, r = Cvalue.V.cast_float_to_int ~signed ~size v in Warn.warn_float ~with_alarms ~overflow:top ~addr (Some fkind) msg; if overflow then begin let dst_range = Ival.create_all_values ~modu:Int.one ~signed ~size in let mn, mx = Ival.min_and_max dst_range in (* TODO: Currently, we always emit the alarm for both sides *) CilE.warn_float_to_int_overflow with_alarms mn mx msg; end; r | TInt (ikind, _), TInt _ -> reinterpret_int ~with_alarms ikind v | TFloat (fkind, _), TFloat _ -> reinterpret_float ~with_alarms fkind v | _, _ -> v let handle_overflow ~with_alarms typ interpreted_e = match Cil.unrollType typ with | TInt(kind, _) -> let signed = Cil.isSigned kind in let size = Cil.bitsSizeOf typ in let mn, mx = if signed then let b = Int.power_two (size-1) in Int.neg b, Int.pred b else Int.zero, Int.pred (Int.power_two size) 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 mn in let o = match imx with | Some bound when Int.le bound mx -> None | _ -> Some mx in u, o with V.Not_based_on_null -> Some mn, Some mx in (match warn_under, warn_over with | None, None -> interpreted_e | _ -> if (signed && Kernel.SignedOverflow.get ()) || (not signed && Kernel.UnsignedOverflow.get ()) then let all_values = Cvalue.V.inject_ival (Ival.inject_range (Some mn) (Some mx)) in CilE.warn_integer_overflow with_alarms ~signed ~min:warn_under ~max:warn_over; (* Take care of pointers addresses that may have crept in, as they may alias with the NULL base *) try ignore (V.project_ival interpreted_e); V.narrow all_values interpreted_e with V.Not_based_on_null -> interpreted_e else begin (* [interpreted_e] has been computed modulo [size] *) if signed then Value_util.warning_once_current "2's complement assumed for overflow"; interpreted_e; end) | _ -> interpreted_e let eval_binop_float ~with_alarms round flkind ev1 op ev2 = let conv v = try Ival.project_float (V.project_ival v) with | V.Not_based_on_null | Ival.Float_abstract.Nan_or_infinite -> Ival.Float_abstract.top in let f1 = conv ev1 in let f2 = conv ev2 in let binary_float_floats (_name: string) f = try let alarm, f = f round f1 f2 in if alarm then CilE.warn_nan_infinite with_alarms flkind (fun fmt -> Ival.Float_abstract.pretty fmt f); V.inject_ival (Ival.inject_float f) with | Ival.Float_abstract.Nan_or_infinite -> CilE.warn_nan_infinite with_alarms flkind (pp_v V.top_int); V.top_float | Ival.Float_abstract.Bottom -> CilE.warn_nan_infinite with_alarms flkind (pp_v V.bottom); V.bottom in 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) | _ -> assert false (* 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. [te1] is the type of [ev1]. [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 (Bit_utils.osizeof_pointed te1) ev1 ev2 | MinusPI -> V.add_untyped (Int_Base.neg (Bit_utils.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 (Bit_utils.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.mul ~with_alarms ev1 ev2 | BXor -> V.bitwise_xor ~with_alarms ev1 ev2 | BOr -> V.bitwise_or ~size:(Cil.bitsSizeOf te1) ev1 ev2 | BAnd -> let size = Cil.bitsSizeOf te1 in let signed = Bit_utils.is_signed_int_enum_pointer te1 in V.bitwise_and ~size ~signed ev1 ev2 | Eq | Ne | Ge | Le | Gt | Lt -> let warn = Warn.check_not_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 = Bit_utils.is_signed_int_enum_pointer(Cil.unrollType te1) in V.eval_comp ~signed op ev1 ev2 | Shiftrt | Shiftlt -> begin let f = if op = Shiftlt then V.shift_left else V.shift_right in let size = match typ with | None -> None | Some t -> let t = Cil.unrollType t in let warn_negative = Value_parameters.LeftShiftNegative.get() && Bit_utils.is_signed_int_enum_pointer t in Some (warn_negative, Cil.bitsSizeOf t) in f ~with_alarms ?size ev1 ev2 end (* Strict evaluation. The caller of this function is supposed to take into account the lazyness of those operators itself *) | LOr -> 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 -> 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) (* This function evaluates a unary minus, but does _not_ check for overflows. This is left to the caller *) and eval_uneg ~with_alarms v t = match Cil.unrollType t with | TFloat (fkind, _) -> (try let v = V.project_ival v 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 -> Warn.warn_float ~with_alarms ~addr:true (Some fkind) (pp_v v); V.topify_arith_origin v | Ival.Float_abstract.Nan_or_infinite -> Warn.warn_float ~with_alarms ~overflow:true (Some fkind) (pp_v v); V.top_float ) | _ -> try let v = V.project_ival v in V.inject_ival (Ival.neg v) with V.Not_based_on_null -> V.topify_arith_origin v let eval_unop ~check_overflow ~with_alarms v t op = match op with | Neg -> let r = eval_uneg ~with_alarms v t in if check_overflow then handle_overflow ~with_alarms t r else r | BNot -> (try let v = V.project_ival v in V.inject_ival (Ival.apply_set_unary "~" Int.lognot v) with V.Not_based_on_null -> V.topify_arith_origin v) | LNot -> (* TODO: on float, LNot is equivalent to == 0.0 *) let warn = Warn.check_not_comparable Eq V.singleton_zero v in if warn then CilE.warn_pointer_comparison with_alarms; if (warn && Value_parameters.UndefinedPointerComparisonPropagateAll.get ()) || not (Cil.isIntegralType t || Cil.isPointerType t) then V.zero_or_one else V.interp_boolean ~contains_zero:(V.contains_non_zero v) ~contains_non_zero:(V.is_included V.singleton_zero v) let reduce_rel_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 -> if (Value_parameters.UndefinedPointerComparisonPropagateAll.get()) && Warn.check_not_comparable binop value cond_expr then value else V.narrow value cond_expr | _,_ -> value let reduce_rel_symetric_float = reduce_rel_symetric_int let reduce_rel_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 reduce_rel_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 reduce_rel_int_float = { reduce_rel_symetric: bool -> binop -> V.t -> V.t -> V.t; reduce_rel_antisymetric: typ_loc:typ -> bool -> binop -> V.t -> V.t -> V.t; } let reduce_rel_int = { reduce_rel_symetric = reduce_rel_symetric_int; reduce_rel_antisymetric = reduce_rel_antisymetric_int; } let reduce_rel_float round = { reduce_rel_symetric = reduce_rel_symetric_float; reduce_rel_antisymetric = reduce_rel_antisymetric_float round; } let eval_float_constant ~with_alarms f fkind = let f = Ival.F.of_float f in try let overflow, af = Ival.Float_abstract.inject_r f f in let v = V.inject_ival (Ival.inject_float af) in if overflow then begin Warn.warn_float ~with_alarms ~overflow:true (Some fkind) (pp_v v) end; v with Ival.Float_abstract.Bottom -> Warn.warn_float ~with_alarms ~overflow:true (Some fkind) (fun fmt -> Format.pp_print_string fmt "INFINITY"); Value_parameters.result ~current:true "Floating-point literal (or constant expression) is not \ finite. This path is assumed to be dead."; V.bottom (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/value_parameters.mli0000644000175000017500000000641112155630231021742 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.S module ForceValues: Plugin.WithOutput module AutomaticContextMaxDepth: Plugin.Int module AutomaticContextMaxWidth: Plugin.Int module SeparateStmtStart: Plugin.String_set module SeparateStmtWord: Plugin.Int module SeparateStmtOf: Plugin.Int module AllRoundingModes: Plugin.Bool module NoResultsFunctions: Plugin.String_set module NoResultsAll: Plugin.Bool module ResultsAfter: Plugin.Bool module ResultsCallstack: Plugin.Bool module LeftShiftNegative: Plugin.Bool module IgnoreRecursiveCalls: Plugin.Bool module MemoryFootprint: Plugin.Int module SemanticUnrollingLevel: Plugin.Int module ArrayPrecisionLevel: Plugin.Int module AllocatedContextValid: Plugin.Bool module InitializedPaddingGlobals: Plugin.Bool module UndefinedPointerComparisonPropagateAll: Plugin.Bool module WideningLevel: Plugin.Int module SlevelFunction: Plugin.String_hashtbl with type value = 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 SplitReturnFunction: Plugin.String_hashtbl with type value = int list module SplitReturnAuto: Plugin.Bool module ValShowProgress: Plugin.Bool module FloatTimingStep: State_builder.Ref with type data = float module ShowSlevel: Plugin.Int module PrintCallstacks: Plugin.Bool module MemExecAll: Plugin.Bool module InterpreterMode: Plugin.Bool module ObviouslyTerminatesAll: Plugin.Bool module ObviouslyTerminatesFunctions: Plugin.String_set module StopAtNthAlarm: Plugin.Int val parameters_correctness: Parameter.t list val parameters_tuning: Parameter.t list (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/eval_funs.ml0000644000175000017500000005657212155630231020231 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 entire functions *) open Cil_types open Cil open Locations open Value_util let dkey = Value_parameters.register_category "callbacks" (** Compute [kf] in state [with_formals] according to the body [f] of [kf]. Checks the preconditions of [kf], assuming the call took place at [call_kinstr]. The postconditions are checked within the call to [Computer.compute]. *) let compute_using_body (kf, f) ~call_kinstr ~with_formals = 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 ab = Eval_annots.ActiveBehaviors.create with_locals kf in let with_locals = Eval_annots.check_fct_preconditions kf ab call_kinstr with_locals in let module Computer = Eval_slevel.Computer (struct let kf = kf let slevel = get_slevel kf let initial_states = with_locals (* for future reference *) let active_behaviors = ab let local_slevel_info = Local_slevel_types.empty_info () end) in let module Compute = Dataflow.Forwards(Computer) in let add_to_worklist stmt = Queue.add stmt Compute.worklist in Computer.add_to_worklist := add_to_worklist; let start = Kernel_function.find_first_stmt kf in (* Init the dataflow state for the first statement *) let dinit = { Computer.counter_unroll = 0; value = with_locals} in let dinit = Computer.computeFirstPredecessor start dinit in Computer.StmtStartData.add start dinit; begin try Compute.compute [start] with Db.Value.Aborted as e -> (* State_builder.was aborted: pop the call stack and inform the caller *) Computer.merge_results ~inform:false; raise e end; (* Merge consolidated results, call callbacks *) let result = Computer.results () in Computer.merge_results ~inform:true; (match result.Value_types.c_values with | _ :: _ when hasAttribute "noreturn" f.svar.vattr -> warning_once_current "function %a may terminate but has the noreturn attribute" Kernel_function.pretty kf; | _ -> ()); result (** Evaluate the assigns of [kf] active according to [active_behaviors] in the state [with_formals]. *) let compute_assigns kf ab ~with_formals = let with_alarms = CilE.warn_none_mode in let vi = Kernel_function.get_vi kf in if (not (Cvalue.Model.is_reachable with_formals)) || Cil.hasAttribute "noreturn" vi.vattr then None, Cvalue.Model.bottom, Base.SetLattice.bottom else let behaviors = Eval_annots.ActiveBehaviors.active_behaviors ab in let assigns = Ast_info.merge_assigns behaviors in let returned_value, with_formals = Library_functions.returned_value kf with_formals in let returned_value = ref returned_value in let clob = Locals_scoping.bottom () in let env = Eval_terms.env_assigns with_formals in (* Treat one assign ... \from ... clause. Update [state] accordingly, as well as [returned_value] and [clobbered_set] *) let pp_eval_error fmt e = if e <> Eval_terms.CAlarm then Format.fprintf fmt "@ (%a)" Eval_terms.pretty_logic_evaluation_error e in let treat_assign state ({it_content = out}, ins as asgn) = (* Evaluate the contents of one element of the from clause, topify them, and add them to the current state of the evaluation in acc *) let one_from_contents acc { it_content = t } = let r = Eval_terms.eval_term ~with_alarms env t in List.fold_left (fun acc v -> Cvalue.V.join acc (Cvalue.V.topify_arith_origin v)) acc r.Eval_terms.evalue in (* evaluation of the entire from clause *) let froms_contents = match ins with | FromAny -> Cvalue.V.top_int | From l -> try List.fold_left one_from_contents Cvalue.V.top_int l with Eval_terms.LogicEvalError e -> warning_once_current "cannot interpret@ 'from' clause@ \ '%a'@ of function %a%a" Printer.pp_from asgn Kernel_function.pretty kf pp_eval_error e; Cvalue.V.top in (* Treat one location coming from the evaluation of [out] *) let treat_output_loc acc loc = let valid = Locations.valid_part ~for_writing:true loc in if Location_Bits.equal Location_Bits.bottom valid.loc then (Value_parameters.warning ~current:true ~once:true "@[Completely invalid destination@ for assigns@ clause %a.@ \ Ignoring.@]" Printer.pp_term out; acc) else ( Locals_scoping.remember_if_locals_in_value clob loc froms_contents; let state' = Cvalue.Model.add_binding ~with_alarms ~exact:false acc loc froms_contents in if Cvalue.Model.equal Cvalue.Model.top state' 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." Printer.pp_term out Locations.pretty loc; acc) else state') in (* Treat the output part of the assigns clause *) if Logic_utils.is_result out then ( (* Special case for \result *) returned_value := Cvalue.V.join froms_contents !returned_value; state ) else try (* TODO: warn about errors during evaluation *) let locs, _deps = Eval_terms.eval_tlval_as_locations ~with_alarms env out in List.fold_left treat_output_loc state locs with | Eval_terms.LogicEvalError e -> warning_once_current "cannot interpret assigns %a@ in function %a%a; effects will be \ ignored" Printer.pp_term out Kernel_function.pretty kf pp_eval_error e; state in (* Treat all the assigns for the function *) let state = match assigns with | WritesAny -> warning_once_current "Cannot handle empty assigns clause. Assuming assigns \\nothing: be aware this is probably incorrect."; with_formals | Writes l -> List.fold_left treat_assign with_formals l in let retres_vi, state = let return_type = getReturnType vi.vtype in if isVoidType return_type then None, state else let offsetmap = Eval_op.offsetmap_of_v return_type !returned_value in let rvi, state = Library_functions.add_retres_to_state ~with_alarms kf offsetmap state in Some rvi, state in retres_vi, state, clob.Locals_scoping.clob (** Evaluate [kf] in state [with_formals], first by reducing by the preconditions, then by evaluating the assigns, then by reducing by the post-conditions. The resulting states contain formals only if [clear_formals] is false. *) let compute_using_specification (kf, spec) ?(clear_formals=true) ~call_kinstr ~with_formals () = Value_parameters.feedback ~once:true "@[using specification for function %a@]" Kernel_function.pretty kf; let ab = Eval_annots.ActiveBehaviors.create_from_spec with_formals spec in let stateset = Eval_annots.check_fct_preconditions kf ab call_kinstr with_formals in (* TODO: This is a hack. Use a function that checks preconditions without multiplying the states instead -- or compute_assigns several times, while taking behaviors into account *) let with_formals = State_set.join stateset in let retres_vi, result_state, sclob = compute_assigns kf ab ~with_formals in let result_state = Eval_annots.check_fct_postconditions kf ab ~result:retres_vi ~init_state:with_formals ~post_states:(State_set.singleton result_state) Normal in let aux state = let ret, state = match retres_vi with | None -> None, state | Some vi -> if not (Cvalue.Model.is_reachable state) then (* This test prevents the call to Model.find_base that would raise Not_found in this case. *) None, state else let retres_base = Base.create_varinfo vi in let without_ret = Cvalue.Model.remove_base retres_base state in (Some (Cvalue.Model.find_base retres_base state)), without_ret in if clear_formals then let formals = Kernel_function.get_formals kf in let without = Value_util.remove_formals_from_state formals state in ret, without else ret, state in { Value_types.c_values = List.map aux (State_set.to_list result_state); c_clobbered = sclob; c_cacheable = Value_types.Cacheable; } (** Compute a call to [kf] in the state [with_formals]. The evaluation will be done either using the body of [kf] or its specification, depending on whether the body exists and on option [-val-use-spec]. [call_kinstr] is the instruction at which the call takes place, and is used to update the statuses of the preconditions of [kf]. If [show_progress] is true, the callstack and additional information are printed. *) let compute_using_spec_or_body ~with_formals ~call_kinstr ~show_progress kf = Kf_state.mark_as_called kf; let pp = show_progress && Value_parameters.ValShowProgress.get() in let entry_time = if pp then Unix.time () else 0. in if pp then Value_parameters.feedback "@[computing for function %a.@\nCalled from %a.@]" pretty_call_stack_short (call_stack ()) Cil_datatype.Location.pretty (Cil_datatype.Kinstr.loc (CilE.current_stmt())); let use_spec = match kf.fundec with | Declaration (_,_,_,_) -> `Spec (Annotations.funspec kf) | Definition (def, _) -> if Datatype.String.Set.mem def.svar.vname (Value_parameters.UsePrototype.get ()) then `Spec (Annotations.funspec kf) else `Def def in let result = match use_spec with | `Spec spec -> compute_using_specification (kf, spec) ~call_kinstr ~with_formals () | `Def f -> compute_using_body (kf, f) ~call_kinstr ~with_formals in if pp then begin let compute_time = (Unix.time ()) -. entry_time in if compute_time > Value_parameters.FloatTimingStep.get () then Value_parameters.feedback "Done for function %a, in %a seconds." Kernel_function.pretty kf Datatype.Float.pretty compute_time else Value_parameters.feedback "Done for function %a" Kernel_function.pretty kf end; result (** Compute a call to the main function. The initial state is generated according to options such as [-lib-entry] and the options of Value governing the shape of this state. *) let compute_from_entry_point () = let kf, library = Globals.entry_point () in clear_call_stack (); Stop_at_nth.clear (); 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 "@[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 "@[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."; end else begin Mark_noresults.run(); let with_formals = match Db.Value.fun_get_args () with | None -> Function_args.main_initial_state_with_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 = (), Eval_op.offsetmap_of_v ~typ:f.vtype a in Function_args.actualize_formals kf initial_state_globals (List.map2 treat_one_formal formals actuals) in Db.Value.merge_initial_state kf with_formals; push_call_stack kf Kglobal; Db.Value.Call_Value_Callbacks.apply (with_formals, [ kf, Kglobal ]); ignore(compute_using_spec_or_body kf ~call_kinstr:Kglobal ~with_formals ~show_progress:false); Value_parameters.feedback "done for function %a" Kernel_function.pretty kf; Separate.epilogue(); end (** Compute a call to a possible builtin [kf] in state [state]. [actuals] are the arguments of [kf], and have not been bound to its formals. Returns [None] if the call must be computed using the Cil function for [kf]. *) let compute_maybe_builtin kf ~state actuals = (* Actuals for builtins include a Cvalue.V arg, which is more convenient than the entire offsetmap *) let conv_arg with_alarms (exp, offsm) = let typ = typeOf exp in CilE.set_syntactic_context (CilE.SyUnOp exp); let v = Eval_op.v_of_offsetmap ~with_alarms ~typ offsm in (exp, v, offsm) in let actuals = lazy ( let with_alarms = warn_all_quiet_mode () in List.map (conv_arg with_alarms) actuals ) in let (!!) = Lazy.force in 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 (* This is an interesting C function. Mark it as called, otherwise it would get skipped, eg. from the Gui. *) 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 state !!actuals) with Db.Value.Outside_builtin_possibilities -> if override then None else ( Value_parameters.warning ~once:true ~current:true "Call to builtin %s failed, aborting." name; 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 state !!actuals) else if Ast_info.is_cea_function name then Some (Builtins.dump_args name state !!actuals) else if Ast_info.is_cea_dump_file_function name then Some (Builtins.dump_state_file name state !!actuals) else None else None (** Compute a call to [kf] from [call_kinstr], assuming [kf] is not yet present in the callstack. In [state], the value of actuals in [actuals] are not yet bound to formals.*) let compute_non_recursive_call kf ~call_kinstr state actuals = let with_formals = Function_args.actualize_formals ~check:Function_args.check_arg_size kf state actuals in push_call_stack kf call_kinstr; (* Store the initial state, but do not called mark_as_called. Uninteresting Value builtins are intentionally skipped *) Db.Value.merge_initial_state kf with_formals; try let stack_with_call = call_stack () in Db.Value.Call_Value_Callbacks.apply (with_formals, stack_with_call); let default () = let r = compute_maybe_builtin kf ~state actuals in match r with | Some r -> r | None -> compute_using_spec_or_body kf ~with_formals ~call_kinstr ~show_progress:true in let r = if Value_parameters.MemExecAll.get () then match Mem_exec.reuse_previous_call (kf, call_kinstr) with_formals with | None -> let res = default () in if not (!Db.Value.use_spec_instead_of_definition kf) then Mem_exec.store_computed_call (kf, call_kinstr) with_formals res; res | Some (res, i) -> if Value_parameters.ValShowProgress.get () then begin Value_parameters.feedback ~current:true "Reusing old results for call to %a" Kernel_function.pretty kf; Value_parameters.debug ~dkey "calling Record_Value_New callbacks on saved previous result"; end; Db.Value.Record_Value_Callbacks_New.apply (stack_with_call, Value_types.Reuse i); res else default () in pop_call_stack (); r with Db.Value.Aborted as e -> pop_call_stack (); raise e let compute_recursive_call kf ~call_kinstr state actuals = push_call_stack kf call_kinstr; (* Update formals. For formals that might be referenced, we must perform a join with the previous values *) let exact vi = not vi.vaddrof in let with_formals = Function_args.actualize_formals ~check:Function_args.check_arg_size ~exact kf state actuals in Db.Value.merge_initial_state kf with_formals; let initial_spec = Annotations.funspec ~populate:false kf in let assigns_spec () = let assigns = Infer_annotations.assigns_from_prototype kf in let bhv = Cil.mk_behavior ~assigns:(Writes assigns) () in { (Cil.empty_funspec ()) with spec_behavior = [bhv] }, assigns in let spec = match Cil.find_default_behavior initial_spec with | Some bhv when bhv.b_assigns <> WritesAny -> initial_spec | _ -> let spec, assigns = assigns_spec () in Value_parameters.error ~once:true "@[Recursive@ call@ on@ an unspecified@ \ function.@ Using@ potentially@ invalid@ inferred assigns '%t'@]" (fun fmt -> match assigns with | [] -> Format.pp_print_string fmt "assigns \\nothing" | _ :: _ -> Pretty_utils.pp_list ~sep:"@ " Printer.pp_from fmt assigns); (* Merge existing spec into our custom one with assigns *) Logic_utils.merge_funspec ~silent_about_merging_behav:true spec initial_spec; spec in let r = compute_using_specification (kf, spec) ~clear_formals:false ~call_kinstr ~with_formals () in pop_call_stack (); (* Restore one formal of [kf] to a correct value: either the value before the call if the variable cannot have been modified during this call, or a sound approximation *) let restore_formal post_state vi = let b = Base.create_varinfo vi in let old = Cvalue.Model.find_base b state (* Value in previous calls *) in let offsm = if vi.vaddrof then (* Any copy of the formal may have been modified by the call, join the possible values *) let post = Cvalue.Model.find_base b post_state in let r = Cvalue.V_Offsetmap.join old post in r else old in Cvalue.Model.add_base b offsm post_state in let formals = Kernel_function.get_formals kf in let restore_formals state = List.fold_left restore_formal state formals in let restore = List.map (fun (retres, state) -> (retres, restore_formals state)) in { r with Value_types.c_values = restore r.Value_types.c_values } (** Compute a call to [kf], called from [call_kinstr], in the state [state]. In this state, the value of actuals in [actuals] are not yet bound to formals.*) let compute_call kf ~call_kinstr state actuals = if Warn.check_no_recursive_call kf then compute_non_recursive_call kf ~call_kinstr state actuals else compute_recursive_call kf ~call_kinstr state actuals let () = Eval_stmt.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 options_ok () = let check f = try ignore (f "") with Not_found -> () in check Value_parameters.SplitReturnFunction.find; check Value_parameters.BuiltinsOverrides.find; check Value_parameters.SlevelFunction.find; ;; (* Preliminary checks before Value starts *) let check () = assert (floats_ok ()); options_ok (); ;; let cleanup () = StmtCanReachCache.clear (); Mem_exec.cleanup_results (); ;; let force_compute () = Ast.compute (); check (); try ignore (compute_from_entry_point ()); Db.Value.mark_as_computed (); cleanup (); (* Remove redundant alarms *) if Value_parameters.RmAssert.get() then !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 (); cleanup (); Value_parameters.result "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 ()); (* Mark unreachable annotations here, independently of whether Value has just computed something. This way, if a plugin dynamically add dead annotations, Value will flag them as such *) (* Eval_annots.mark_unreachable (); *) (* Eval_annots.mark_rte (); *) ) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/locals_scoping.ml0000644000175000017500000001543612155630231021240 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 type clobbered_set = { mutable clob: Base.SetLattice.t } let bottom () = { clob = Base.SetLattice.bottom } let top () = { clob = Base.SetLattice.top } let remember_bases_with_locals clob new_clob = clob.clob <- Base.SetLattice.join new_clob clob.clob let remember_if_locals_in_value clob left_loc v = if Cvalue.V.contains_addresses_of_any_locals v then let new_clob = Location_Bits.get_bases left_loc.loc in remember_bases_with_locals clob new_clob let remember_if_locals_in_offsetmap clob left_loc offm = try Cvalue.V_Offsetmap.iter_on_values (fun v _ -> if Cvalue.V.contains_addresses_of_any_locals (Cvalue.V_Or_Uninitialized.get_v v) then let new_clob = Location_Bits.get_bases left_loc.loc in remember_bases_with_locals clob new_clob; raise Exit ) offm with Exit -> () type topify_offsetmap = Cvalue.V_Offsetmap.t -> Base.SetLattice.t * Cvalue.V_Offsetmap.t type topify_offsetmap_approx = exact:bool -> topify_offsetmap type topify_state = Cvalue.Model.t -> Cvalue.Model.t (* For all bindings [v] of [offsm] that verify [test], replace them by [snd (topify v)], and gather [fst (topify v)] within [acc_locals] *) let top_gather_locals test topify join acc_locals : topify_offsetmap = fun offsm -> assert (not (Cvalue.V_Offsetmap.is_empty offsm)); Cvalue.V_Offsetmap.fold (fun (_,_ as i) (v, m, r) (acc_locals, acc_o as acc) -> if test v then let locals, topified_v = topify v in (join acc_locals locals), Cvalue.V_Offsetmap.add i (topified_v, m, r) acc_o else acc) offsm (acc_locals, offsm) (* Return a function that topifies all parts of an offsetmap that contains a pointer that verifying [is_local]. *) let offsetmap_top_addresses_of_locals is_local : topify_offsetmap_approx = (* Partial application is important, this function has a cache *) let is_local_bytes = Location_Bytes.contains_addresses_of_locals is_local in fun ~exact offsetmap -> if Cvalue.V_Offsetmap.is_empty offsetmap then Base.SetLattice.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 = top_gather_locals loc_contains_addresses_of_locals (Cvalue.V_Or_Uninitialized.unspecify_escaping_locals ~exact is_local) Base.SetLattice.join Base.SetLattice.bottom offsetmap in locals, result (* Topify the locals in the offsetmaps bound to [bases] in [state]. *) let state_top_addresses_of_locals ~exact fwarn_escape (topify_offsetmap:topify_offsetmap_approx) bases state = (* Assumes [offsm] is bound to [base] in [state]. Remove locals from [offsm], and bind it again to [base] in the result. *) let aux base offsm state = let locals, offsm' = topify_offsetmap ~exact offsm in let found_locals = not (Cvalue.V_Offsetmap.equal offsm' offsm) in if found_locals then ((fwarn_escape base locals : unit); Cvalue.Model.add_base base offsm' state) else state in (* Clean the locals in the offsetmap bound to [base] in [state] *) let aux' base state = try let offsm = Cvalue.Model.find_base base state in aux base offsm state with Not_found -> state in try (* Iterate on all the bases that might contain a local, and clean them*) Base.SetLattice.fold aux' bases.clob (aux' Base.null state) with Base.SetLattice.Error_Top -> begin (* [bases] is too imprecise. Iterate on the entire memory state instead, which is much slower *) try Cvalue.Model.fold_base_offsetmap aux state state with Cvalue.Model.Error_Bottom -> Cvalue.Model.bottom end (* Topifies all references to the locals and formals of [fdec]*) let top_addresses_of_locals fdec clob = let entry_point = Globals.entry_point () in if snd entry_point (* lib *) || not (Cil_datatype.Varinfo.equal fdec.svar (Kernel_function.get_vi (fst entry_point)) (* not entry point *)) then let offsetmap_top_addresses_of_locals = offsetmap_top_addresses_of_locals (Extlib.swap Base.is_formal_or_local fdec) in let state_top_addresses_of_locals = state_top_addresses_of_locals (Warn.warn_locals_escape false fdec) offsetmap_top_addresses_of_locals clob in (offsetmap_top_addresses_of_locals ~exact:true, state_top_addresses_of_locals ~exact:true) else (fun x -> Base.SetLattice.bottom, x),(fun x -> x) (* Topifies all the references to the variables local to [blocks] *) let block_top_addresses_of_locals fdec clob blocks = (* no need to topify references to [v] if it is not referenced, or if it a Cil temporary *) let safe_var v = v.vgenerated || not v.vreferenced in if List.for_all (fun b -> List.for_all safe_var b.blocals) blocks then fun x -> x 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 (Warn.warn_locals_escape true fdec) offsetmap_top_addresses_of_locals clob in state_top_addresses_of_locals ~exact:true frama-c-Fluorine-20130601/src/value/eval_slevel.ml0000644000175000017500000006112012155630231020531 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Cvalue open Value_util open Eval_exprs let dkey_callbacks = Value_parameters.register_category "callbacks" module Computer (AnalysisParam:sig val kf: kernel_function val slevel: int val initial_states : State_set.t val active_behaviors: Eval_annots.ActiveBehaviors.t val local_slevel_info : Local_slevel_types.local_slevel_info end) = struct let debug = ref false let name = "Values analysis" let current_kf = AnalysisParam.kf let current_fundec = Kernel_function.get_definition current_kf let return = Kernel_function.find_return current_kf let return_lv = match return.skind with | Return (Some ({enode = Lval lv}),_) -> Some lv | Return (None,_) -> None | _ -> assert false (* Cil invariant *) let stmt_can_reach = Value_util.stmt_can_reach current_kf let is_natural_loop = Loop.is_natural current_kf let obviously_terminates = Value_parameters.ObviouslyTerminatesAll.get() (* TODO: by function *) let slevel = if obviously_terminates then max_int else AnalysisParam.slevel let initial_state = State_set.join AnalysisParam.initial_states 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 either the following conditions is met ([succ] being a successor of [s]) - [s] is an instr (the control flow statements such as [goto] and [if] do not change the state (union of the states in the case of if)) AND there is a control-flow join on [succ] - [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 s = Stmt.Hashtbl.find superposed return in Stmt.Hashtbl.add states_after return s with Kernel_function.No_Statement | Not_found -> () ); states_after ) (* Merging of 'after statement' states in the global table *) let merge_after after_full callstack = Cil_datatype.Stmt.Hashtbl.iter (fun stmt st -> begin 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 end; if Value_parameters.ResultsCallstack.get () then Db.Value.update_callstack_table ~after:true stmt callstack 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_results ~inform = if inform && Value_parameters.ValShowProgress.get() then Value_parameters.feedback "Recording results for %a" Kernel_function.pretty current_kf; let superposed = lazy (Current_table.states current_table) in let after_full = local_after_states superposed in let stack_for_callbacks = call_stack () in Current_table.merge_db_table superposed stack_for_callbacks; Db.Value.merge_conditions conditions_table; if Value_parameters.ResultsAfter.get () then merge_after after_full stack_for_callbacks; 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.debug ~dkey:dkey_callbacks "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.debug ~dkey:dkey_callbacks "now calling Record_Value callbacks"; Db.Value.Record_Value_Callbacks.apply (stack_for_callbacks, superposed) end; if not (Db.Value.Record_Value_Callbacks_New.is_empty ()) then begin if Value_parameters.ValShowProgress.get () then Value_parameters.debug ~dkey:dkey_callbacks "now calling Record_Value_New callbacks"; Db.Value.Record_Value_Callbacks_New.apply (stack_for_callbacks, Value_types.NormalStore (superposed, (Mem_exec.new_counter ()))) end; if not (Db.Value.Record_Value_After_Callbacks.is_empty ()) then begin if Value_parameters.ValShowProgress.get () then Value_parameters.debug ~dkey:dkey_callbacks "now calling Record_After_Value callbacks"; Db.Value.Record_Value_After_Callbacks.apply (stack_for_callbacks, after_full); end; ;; 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 = let v = state.value in { counter_unroll = State_set.length v; value = v;} let counter_unroll_target = ref (Value_parameters.ShowSlevel.get()) let is_return s = match s.skind with Return _ -> true | _ -> false let combinePredecessors (s: stmt) ~old new_ = let new_v = new_.value in if State_set.is_empty new_v then None else begin let old_counter = old.counter_unroll in (* Do not perform merge on return instructions. This needelessly degrades precision for postconditions and option -split-return.*) if old_counter >= slevel && not (is_return s) then let sum = Cvalue.Model.join (State_set.join new_v) (State_set.join old.value) in Some {counter_unroll = old_counter ; value = State_set.singleton sum;} else begin try let merged = State_set.merge_into new_v old.value in let length_new = State_set.length new_v in let new_counter_unroll = old_counter + length_new in if new_counter_unroll >= !counter_unroll_target then begin let period = Value_parameters.ShowSlevel.get() in let reached = new_counter_unroll / period * period in Value_parameters.result ~once:true "Semantic level unrolling superposing up to %d states" reached; counter_unroll_target := reached + period; end; let result = Some { value = merged ; counter_unroll = new_counter_unroll } in result with State_set.Unchanged -> None end end (** Clobbered list for bases containing addresses of local variables. *) let clob = Locals_scoping.bottom () let cacheable = ref Value_types.Cacheable let interp_call stmt lval_to_assign funcexp argl d_value = let with_alarms = warn_all_quiet_mode () in let aux = Eval_stmt.interp_call ~with_alarms clob stmt lval_to_assign funcexp argl in State_set.fold (fun acc state -> let results, call_cacheable = aux state in if call_cacheable = Value_types.NoCacheCallers then (* Propagate info that the current call cannot be cached either *) cacheable := Value_types.NoCacheCallers; List.fold_left (fun acc state -> State_set.add state acc) acc results) 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 with_alarms = warn_all_quiet_mode () in 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 -> Eval_stmt.do_assign ~with_alarms clob state_value lv exp) (* TODOBY: this should be transferred as a builtin. However, this is not possible for va_arg currently *) | Call (_, {enode = Lval (Var {vname=("__builtin_va_start"| "__builtin_va_end")},NoOffset)}, [{enode = Lval lv}],_loc) -> apply_each_state (fun state -> let loc = Eval_exprs.lval_to_loc ~with_alarms state lv in CilE.set_syntactic_context (CilE.SyMem lv); Model.add_binding ~with_alarms ~exact:true state loc V.top_int ) | Call (_, {enode = Lval (Var {vname=("__builtin_va_arg")},NoOffset)}, [_; size; dst],_loc) -> apply_each_state (fun state -> let vsize = eval_expr ~with_alarms state size in let size = try let i = V.project_ival vsize in let i = Ival.project_int i in let ibytes = Integer.mul i (Bit_utils.sizeofchar ()) in Int_Base.inject ibytes with V.Not_based_on_null | Ival.Not_Singleton_Int -> Int_Base.top in let locbytes = eval_expr ~with_alarms state dst in let locbits = Locations.loc_bytes_to_loc_bits locbytes in let loc = Locations.make_loc locbits size in Model.add_binding ~with_alarms ~exact:true state loc 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 (* This function is later used to insert a stmt to the worklist manually. * Needed for manual split/merge zones * Will be filled by Local_slevel_compute.compute_sub_function * after Dataflow.Forwards initialization *) let add_to_worklist = ((ref (fun _ -> assert false)) : (stmt -> unit) ref) let doStmtSpecific s d states = match s.skind with | Loop _ -> if d.counter_unroll >= slevel then Value_parameters.result ~level:1 ~once:true ~current:true "entering loop for the first time"; states | UnspecifiedSequence seq -> (try if Kernel.UnspecifiedAccess.get () then begin State_set.iter (fun state -> Eval_stmt.check_unspecified_sequence state seq) states; end; states with Eval_stmt.AlwaysOverlap -> State_set.empty ) | _ -> states (* This is an auxiliary function to handle local_slevel, to be enabled below*) let ret_local_slevel s states dataflow_result = match Local_slevel.determine_mode current_kf s AnalysisParam.local_slevel_info with | Local_slevel_types.Normal -> dataflow_result | Local_slevel_types.Merge -> Dataflow.SDone (* FIXME [SCM] strict mode only - will have to work in split mode as * well f.e. while(1) { foo() } as split and merge stmt *) | Local_slevel_types.MergeSplit _ -> assert false | Local_slevel_types.Split info -> let new_state, clobbered_set = Local_slevel.compute_sub_function current_kf s info states in Locals_scoping.remember_bases_with_locals clob clobbered_set; (* FIXME [SCM] strict mode *) List.iter (fun stmt -> StmtStartData.add stmt { counter_unroll = 0; value = State_set.singleton new_state }; !add_to_worklist stmt) (Cil_datatype.Stmt.Hptset.elements info.Local_slevel_types.merges); Dataflow.SDone let doStmt (s: stmt) (d: t) = let states = d.value in d.value <- State_set.empty; CilE.start_stmt (Kstmt s); let ret result = CilE.end_stmt (); if false (* set to true for local slevel *) then result else ret_local_slevel s states result in if State_set.is_empty states then ret Dataflow.SDefault else let states = (* Remove states already present *) if obviously_terminates then states else Current_table.update_and_tell_if_changed current_table s states in if State_set.is_empty states then ret Dataflow.SDefault else (* We do not interpret annotations that come from statement contracts and everything previously emitted by Value (currently, alarms) *) let annots = Annotations.fold_code_annot (fun e ca acc -> if Logic_utils.is_contract ca || Emitter.equal e Value_util.emitter then acc else ca :: acc ) s [] in let interp_annot record states annot = Eval_annots.interp_annot current_kf AnalysisParam.active_behaviors initial_state slevel states s annot record in let states = List.fold_left (interp_annot true) states annots in if State_set.is_empty states then ret Dataflow.SDefault else let is_return = is_return s in let new_states = if (d.counter_unroll >= slevel && not is_return) || (is_return && obviously_terminates) then (* No slevel left, perform some join and/or widening *) 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 Model.equal joined curr_wstate then State_set.empty (* [state] is included in the last propagated state. Nothing remains to do *) else if obviously_terminates then begin Current_table.update_widening_info current_table s 0 joined; states end else let r = if is_natural_loop s && curr_wcounter = 0 then let wh_key_set, wh_hints = Widen.getWidenHints current_kf 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_wcounter = 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_wcounter r; new_state) else begin (* Try to correct over-widenings *) 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 (interp_annot false) new_state annots in let new_joined = State_set.join new_states in Current_table.update_widening_info current_table s new_wcounter new_joined; State_set.singleton new_joined end else states in let states = doStmtSpecific s d new_states in ret (Dataflow.SUse { d with value = states }) 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 -> (* Partial application is useful, do not inline *) let block_top = Locals_scoping.block_top_addresses_of_locals current_fundec clob closed_blocks in State_set.fold (fun set state -> let state = Cvalue.Model.uninitialize_blocks_locals closed_blocks state in State_set.add (block_top state) set) State_set.empty states; in CilE.end_stmt (); { d with value = states } let filterStmt _stmt = true (* Get access to current_table in case of split/merge zone. * Without explicit merging, this is done via externalize *) let getStateSet stmt = Current_table.find_superposition current_table stmt (* Check that the dataflow is indeed finished *) let checkConvergence () = StmtStartData.iter (fun k v -> if not (State_set.is_empty (v.value)) then Value_parameters.fatal "sid:%d@\n%a@\n" k.sid State_set.pretty v.value) (* Final states of the function, reduced by the post-condition *) let final_states () = let states = Current_table.find_superposition current_table return in (* Reduce final states according to the function postcondition *) let result = match return_lv with | Some (Var v, NoOffset) -> Some v | Some _ -> assert false | None -> None in Eval_annots.check_fct_postconditions current_kf AnalysisParam.active_behaviors ~result ~init_state:initial_state ~post_states:states Normal (* termination kind*) let externalize states = (* Partial application is useful, do not inline *) let externalize = Eval_stmt.externalize current_fundec ~return_lv clob in let states = Split_return.join_final_states current_kf ~return_lv states in List.map externalize states let results () = if !debug then checkConvergence (); let final_states = final_states () in let externalized = externalize final_states in { Value_types.c_values = externalized; c_clobbered = clob.Locals_scoping.clob; c_cacheable = !cacheable; } let doGuardOneCond stmt context 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 state, _, test = eval_expr_with_deps_state None ~with_alarms state exp in CilE.set_syntactic_context context; let warn = Warn.check_not_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 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 mask_both = mask_then lor 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 = let context = CilE.SyUnOp exp in doGuardOneCond stmt context exp t, doGuardOneCond stmt context not_exp t in let th_reachable = match th with Dataflow.GUse _ | Dataflow.GDefault -> mask_then | Dataflow.GUnreachable -> 0 in let el_reachable = match el with Dataflow.GUse _ | Dataflow.GDefault -> mask_else | Dataflow.GUnreachable -> 0 in let reachable = th_reachable lor el_reachable in if Value_parameters.InterpreterMode.get() && (reachable = mask_both) then begin warning_once_current "Do not know which branch to take. Stopping."; exit 0 end; let current_condition_status = try Cil_datatype.Stmt.Hashtbl.find conditions_table stmt with Not_found -> 0 in let new_status = current_condition_status lor reachable 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: *) frama-c-Fluorine-20130601/src/value/split_return.ml0000644000175000017500000002736512155630231020777 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp open Cvalue type split_strategy = | NoSplit | SplitEqList of Datatype.Big_int.t list (* To be completed with more involved strategies *) module SplitStrategy = Datatype.Make_with_collections(struct type t = split_strategy let name = "Value.Split_return.split_strategy" let rehash = Datatype.identity let structural_descr = Structural_descr.Abstract let reprs = [NoSplit] let compare s1 s2 = match s1, s2 with | NoSplit, NoSplit -> 0 | SplitEqList l1, SplitEqList l2 -> Extlib.list_compare Int.compare l1 l2 | NoSplit, SplitEqList _ -> -1 | SplitEqList _, NoSplit -> 1 let equal = Datatype.from_compare let hash = function | NoSplit -> 17 | SplitEqList l -> List.fold_left (fun acc i -> acc * 13 + 57 * Int.hash i) 1 l let copy = Datatype.identity let internal_pretty_code = Datatype.undefined let pretty fmt = function | NoSplit -> Format.pp_print_string fmt "no split" | SplitEqList l -> Format.fprintf fmt "Split on \\result == %a" (Pretty_utils.pp_list ~sep:",@ " Datatype.Big_int.pretty) l let varname _ = "v" let mem_project _ _ = false end) (* Auxiliary module for inference of split criterion. We collect all the usages of a function call, and all places where they are compared against an integral constant *) module ReturnUsage = struct let debug = false module MapLval = Cil_datatype.Lval.Map (* Uses of a given lvalue *) type return_usage_by_lv = { ret_callees: Kernel_function.Hptset.t (* all the functions that put their results in this lvalue *); ret_compared: Datatype.Big_int.Set.t (* all the constant values this lvalue is compared against *); } (* Per-function usage: all interesting lvalues are mapped to the way they are used *) and return_usage_per_fun = return_usage_by_lv MapLval.t (* Per-program usage. Lvalues are no longer used, functions are mapped to the values their return code is compared against *) and return_usage = Datatype.Big_int.Set.t Kernel_function.Map.t module RUDatatype = Kernel_function.Map.Make(Datatype.Big_int.Set) let find_or_default uf lv = try MapLval.find lv uf with Not_found -> { ret_callees = Kernel_function.Hptset.empty; ret_compared = Datatype.Big_int.Set.empty; } (* Treat a [Call] instruction. Immediate calls (no functions pointers) are added to the current usage store *) let add_call (uf: return_usage_per_fun) lv_opt e_fun = match e_fun.enode, lv_opt with | Lval (Var vi, NoOffset), Some lv when Cil.isIntegralType (Cil.typeOfLval lv) -> let kf = Globals.Functions.get vi in let u = find_or_default uf lv in let funs = Kernel_function.Hptset.add kf u.ret_callees in let u = { u with ret_callees = funs } in if debug then Format.printf "[Usage] %a returns %a@." Kernel_function.pretty kf Printer.pp_lval lv; MapLval.add lv u uf | _ -> uf (* Treat a [Set] instruction [lv = (cast) lv']. Useful for return codes that are stored inside values of a slightly different type *) let add_alias (uf: return_usage_per_fun) lv_dest e = match e.enode with | CastE (typ, { enode = Lval lve }) when Cil.isIntegralType typ && Cil.isIntegralType (Cil.typeOfLval lve) -> let u = find_or_default uf lve in MapLval.add lv_dest u uf | _ -> uf (* Treat an expression [lv == ct], [lv != ct] or [!lv], possibly with some cast. [ct] is added to the store of usages. *) let add_compare (uf: return_usage_per_fun) cond = (* add a comparison with the integer [i] to the lvalue [lv] *) let add_ct i lv = if Cil.isIntegralType (Cil.typeOfLval lv) then let u = find_or_default uf lv in let v = Datatype.Big_int.Set.add i u.ret_compared in let u = { u with ret_compared = v } in if debug then Format.printf "[Usage] Comparing %a to %a@." Printer.pp_lval lv Int.pretty i; MapLval.add lv u uf else uf in (* if [ct] is an integer constant, memoize it is compared to [lv] *) let add ct lv = (match (Cil.constFold true ct).enode with | Const (CInt64 (i, _, _)) -> add_ct i lv | _ -> uf) in match cond.enode with | BinOp ((Eq | Ne), {enode = Lval lv}, ct, _) | BinOp ((Eq | Ne), ct, {enode = Lval lv}, _) -> add ct lv | BinOp ((Eq | Ne), {enode = CastE (typ, {enode = Lval lv})}, ct, _) | BinOp ((Eq | Ne), ct, {enode = CastE (typ, {enode = Lval lv})}, _) when Cil.isIntegralType typ && Cil.isIntegralType (Cil.typeOfLval lv) -> add ct lv | UnOp (LNot, {enode = Lval lv}, _) -> add_ct Int.zero lv | UnOp (LNot, {enode = CastE (typ, {enode = Lval lv})}, _) when Cil.isIntegralType typ && Cil.isIntegralType (Cil.typeOfLval lv) -> add_ct Int.zero lv | _ -> uf (* Extract global usage: map functions to integers their return values are tested against *) let summarize (uf: return_usage_per_fun) = let aux _lv u acc = if Datatype.Big_int.Set.is_empty u.ret_compared then acc else let aux' kf (acc:return_usage) : return_usage = let cur = try Kernel_function.Map.find kf acc with Not_found -> Datatype.Big_int.Set.empty in let s = Datatype.Big_int.Set.union cur u.ret_compared in Kernel_function.Map.add kf s acc in Kernel_function.Hptset.fold aux' u.ret_callees acc in MapLval.fold aux uf Kernel_function.Map.empty class visitorVarUsage = object inherit Visitor.frama_c_inplace val mutable usage = MapLval.empty method vinst i = (match i with | Set (lv, e, _) -> usage <- add_alias usage lv e | Call (lv_opt, e, _, _) -> usage <- add_call usage lv_opt e | _ -> () ); Cil.DoChildren method vexpr e = usage <- add_compare usage e; Cil.DoChildren method result () = summarize usage end let compute file = let vis = new visitorVarUsage in Visitor.visitFramacFileSameGlobals (vis:> Visitor.frama_c_visitor) file; vis#result () let pretty_usage fmt u = let pp_set = Pretty_utils.pp_iter ~sep:",@ " Datatype.Big_int.Set.iter Int.pretty in let pp kf s = Format.fprintf fmt "@[\\return(%a) == %a@]@ " Kernel_function.pretty kf pp_set s in Format.fprintf fmt "@["; Kernel_function.Map.iter pp u; Format.fprintf fmt "@]" end module AutoStrategy = State_builder.Option_ref (ReturnUsage.RUDatatype) (struct let name = "Value.Split_return.Autostrategy" let dependencies = [Ast.self; Value_parameters.SplitReturnAuto.self] end) module KfStrategy = Kernel_function.Make_Table(SplitStrategy) (struct let size = 17 let dependencies = [Value_parameters.SplitReturnFunction.self; AutoStrategy.self] let name = "Value.Split_return.Kfstrategy" end) let strategy = KfStrategy.memo (fun kf -> let name = Kernel_function.get_name kf in try let l = Value_parameters.SplitReturnFunction.find name in if l = [] then raise Not_found (* use automatic detection *); SplitEqList (List.map Abstract_interp.Int.of_int l) with Not_found -> let auto = match AutoStrategy.get_option () with | None -> let v = if Value_parameters.SplitReturnAuto.get () then let ast = Ast.get () in let v = ReturnUsage.compute ast in Value_parameters.result "Splitting return states on:@.%a" ReturnUsage.pretty_usage v; v else Kernel_function.Map.empty in AutoStrategy.set v; v | Some v -> v in try let set = Kernel_function.Map.find kf auto in let li = Datatype.Big_int.Set.fold (fun i acc -> i :: acc) set [] in SplitEqList li with Not_found -> NoSplit) let default states = let joined = State_set.join states in if Model.is_reachable joined then [joined] else [] let split_eq_aux kf return_lv i states = let with_alarms = CilE.warn_none_mode in let loc = Eval_exprs.lval_to_loc ~with_alarms Model.top return_lv in let v_i = V.inject_int i in let (eq, neq, mess) = List.fold_left (fun (eq, neq, mess) state -> if Model.is_reachable state then let v = Model.find_unspecified ~with_alarms state loc in let v' = V_Or_Uninitialized.get_v v in (*Format.printf "## vi %a, v %a@." V.pretty v_i V.pretty v'; *) if V.equal v_i v' then (Model.join state eq, neq, mess) else let v'' = V.diff_if_one v' v_i in if V.equal v'' v' then (eq, state :: neq, mess) else (eq, state :: neq, true) else (eq, neq, mess) ) (Model.bottom, [], false) states in if mess then Value_parameters.result ~once:true ~current:true "%a: cannot properly split on \\result == %a" Kernel_function.pretty kf Abstract_interp.Int.pretty i; (eq, neq) let split_eq_multiple kf_name return_lv li states = let rec aux states li = match li with | [] -> (match states with | [] -> [] | e :: q -> [List.fold_left Model.join e q]) | i :: qli -> let eq, neq = split_eq_aux kf_name return_lv i states in let rq = aux neq qli in if Model.is_reachable eq then eq :: rq else rq in aux (State_set.to_list states) li let join_final_states kf ~return_lv states = let split i = match return_lv with | None -> default states | Some (Var v, NoOffset as lv) -> if Cil.isIntegralType v.vtype then split_eq_multiple kf lv i states else default states | Some _ -> assert false (* Cil invariant *) in match strategy kf with | NoSplit -> default states | SplitEqList i -> split i (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/mem_exec.mli0000644000175000017500000000605612155630231020172 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** This module memorizes the analysis of entire calls to a function, so that those analyzes can be reused later on. *) (** Counter that must be used each time a new call is analyzed, in order to refer to it later *) val new_counter : unit -> int (** Subtype of {!Value_types.call_res} *) module ValueOutputs: Datatype.S with type t = (Cvalue.V_Offsetmap.t option * Cvalue.Model.t) list (** states *) * Base.SetLattice.t (** cloberred set for local variables *) (** [store_computed_call (kf, ki) init_state outputs] memoizes the fact that calling [kf] at statement [ki], with initial state [init_state], resulted in the states [outputs]. Those information are intended to be reused in subsequent calls *) val store_computed_call : Value_types.call_site -> Cvalue.Model.t -> Value_types.call_result -> unit (** [reuse_previous_call (kf, ki) init_state] searches amongst the previous analyzes of [kf] one that matches the initial state [init_state]. If none is found, [None] is returned. Otherwise, the results of the analysis are returned, together with the index of the matching call. (This last information is intended to be used by the plugins that have registered Value callbacks.) *) val reuse_previous_call : Value_types.call_site -> Cvalue.Model.t -> (Value_types.call_result * int) option (** Clean all previously stored results *) val cleanup_results: unit -> unit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/eval_stmt.mli0000644000175000017500000000473212155630231020405 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Cvalue val compute_call_ref : (kernel_function -> call_kinstr:kinstr -> Model.t -> (exp * V_Offsetmap.t) list -> Value_types.call_result) ref val do_assign : with_alarms:CilE.warn_mode -> Locals_scoping.clobbered_set -> Model.t -> lval -> exp -> Model.t val interp_call : with_alarms:CilE.warn_mode -> Locals_scoping.clobbered_set -> stmt -> lval option -> exp -> exp list -> Model.t -> Model.t list * Value_types.cacheable exception AlwaysOverlap val check_non_overlapping : Model.t -> lval list -> lval list -> unit val check_unspecified_sequence : Model.t -> (stmt * lval list * lval list * lval list * stmt ref list) list -> unit val externalize : fundec -> return_lv:lval option -> Locals_scoping.clobbered_set -> Model.t -> V_Offsetmap.t option * Model.t (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/value_util.mli0000644000175000017500000000740212155630231020555 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (** A call_stack is a list, telling which function was called at which site. The head of the list tells about the latest call. *) type call_site = (kernel_function * kinstr) type callstack = call_site list (** Functions dealing with call stacks. *) val clear_call_stack : unit -> unit val pop_call_stack : unit -> unit val push_call_stack : kernel_function -> kinstr -> unit (** The current function is the one on top of the call stack. *) val current_kf : unit -> kernel_function val call_stack : unit -> callstack (** Print a call stack. The first one does not display the call sites. *) val pretty_call_stack_short : Format.formatter -> callstack -> unit val pretty_call_stack : Format.formatter -> callstack -> unit (** Prints the current callstack. *) val pp_callstack : Format.formatter -> unit (* TODO: Document the rest of this file. *) val get_rounding_mode : unit -> Ival.Float_abstract.rounding_mode val do_degenerate : lval option -> unit val stop_if_stop_at_first_alarm_mode : unit -> unit val emitter : Emitter.t val warn_all_mode : CilE.warn_mode val with_alarm_stop_at_first : CilE.warn_mode val with_alarms_raise_exn : exn -> CilE.warn_mode val warn_all_quiet_mode : unit -> CilE.warn_mode val get_slevel : Kernel_function.t -> Value_parameters.SlevelFunction.value val set_loc : kinstr -> unit module Got_Imprecise_Value : State_builder.Ref with type data = Datatype.Bool.t val pretty_actuals : Format.formatter -> ('a * Cvalue.V.t * 'b) list -> unit val pretty_current_cfunction_name : Format.formatter -> unit val warning_once_current : ('a, Format.formatter, unit) format -> 'a module StmtCanReachCache : State_builder.Hashtbl with type key = Kernel_function.t and type data = stmt -> stmt -> Datatype.Bool.t val stmt_can_reach : StmtCanReachCache.key -> StmtCanReachCache.data val debug_result : Kernel_function.t -> Cvalue.V_Offsetmap.t option * 'a * Base.SetLattice.t -> unit val map_outputs : (Cvalue.Model.t -> 'a) -> (Cvalue.V_Offsetmap.t option * Cvalue.Model.t) list -> (Cvalue.V_Offsetmap.t option * 'a) list val remove_formals_from_state : varinfo list -> Cvalue.Model.t -> Cvalue.Model.t (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/kf_state.mli0000644000175000017500000000351212155630231020202 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Keep information attached to kernel functions. *) open Cil_types val mark_as_called: kernel_function -> unit val add_caller: caller:kernel_function*stmt -> kernel_function -> unit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/Value.mli0000644000175000017500000000340512155630231017457 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* $Id: Value.mli,v 1.5 2008-04-01 09:25:22 uid568 Exp $ *) (** Analysis for values and pointers *) (** No function is directly exported: they are registered in {!Db.Value}. *) frama-c-Fluorine-20130601/src/value/state_set.ml0000644000175000017500000000530112155630231020222 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) type t = Cvalue.Model.t list let obviously_terminates = false let fold = List.fold_left let of_list l = l let iter = List.iter let empty = [] let is_empty t = t = empty let exists = List.exists let length = List.length exception Unchanged let pretty fmt s = iter (fun state -> Format.fprintf fmt "set contains %a@\n" Cvalue.Model.pretty state) s let add_to_list v s = if (not (Cvalue.Model.is_reachable v)) || ((not obviously_terminates) && (List.exists (fun e -> Cvalue.Model.is_included v e) s)) then raise Unchanged; v :: s let add_exn v s = add_to_list v s let merge_into sa sb = let unchanged = ref true in let f acc e = try let r = add_exn e acc in unchanged := false; r with Unchanged -> acc in let result = fold f sb sa in if !unchanged then raise Unchanged; result let add v s = try add_exn v s with Unchanged -> s let singleton v = add v empty let join s = fold Cvalue.Model.join Cvalue.Model.bottom s let to_list l = l (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/eval_op.mli0000644000175000017500000001033412155630231020027 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Numeric evaluation. Factored with evaluation in the logic. *) open Cil_types open Cvalue (** Transformation a value into an offsetmap of size [sizeof(typ)] bytes. *) val offsetmap_of_v: typ:Cil_types.typ -> V.t -> V_Offsetmap.t (** Specialization of the function above for standard types *) val wrap_int: V.t -> V_Offsetmap.t option val wrap_ptr: V.t -> V_Offsetmap.t option val wrap_double: V.t -> V_Offsetmap.t option (** Reads the contents of the offsetmap (assuming it contains) [sizeof(typ)] bytes as a value of type V.t, then convert the result to type [typ] *) val v_of_offsetmap: with_alarms:CilE.warn_mode -> typ:Cil_types.typ -> V_Offsetmap.t -> V.t (** Bitfields *) val is_bitfield: typ -> bool val cast_lval_bitfield : typ -> Int_Base.t -> Cvalue.V.t -> Cvalue.V.t val sizeof_lval_typ: typ -> Int_Base.t (** Size of the type of a lval, taking into account that the lval might have been a bitfield. *) val reinterpret_int: with_alarms:CilE.warn_mode -> Cil_types.ikind -> V.t -> V.t (** Read the given value value as an int of the given [ikind]. Warn if the value contains an address. *) val reinterpret_float: with_alarms:CilE.warn_mode -> Cil_types.fkind -> V.t -> V.t (** Read the given value value as a float int of the given [fkind]. Warn if the value contains an address, or is not representable as a finite float. *) val reinterpret: with_alarms:CilE.warn_mode -> Cil_types.typ -> V.t -> V.t val eval_binop_float : with_alarms:CilE.warn_mode -> Ival.Float_abstract.rounding_mode -> Cil_types.fkind option -> 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: check_overflow:bool -> with_alarms:CilE.warn_mode -> Cvalue.V.t -> typ (** Type of the expression under the unop *) -> Cil_types.unop -> Cvalue.V.t val handle_overflow: with_alarms:CilE.warn_mode -> Cil_types.typ -> Cvalue.V.t -> Cvalue.V.t val do_promotion: with_alarms:CilE.warn_mode -> Ival.Float_abstract.rounding_mode -> src_typ:Cil_types.typ -> dst_typ:Cil_types.typ -> Cvalue.V.t -> (Format.formatter -> unit) -> Cvalue.V.t type reduce_rel_int_float = { reduce_rel_symetric : bool -> binop -> Cvalue.V.t -> Cvalue.V.t -> Cvalue.V.t; reduce_rel_antisymetric : typ_loc:typ -> bool -> binop -> Cvalue.V.t -> Cvalue.V.t -> Cvalue.V.t; } val reduce_rel_int : reduce_rel_int_float val reduce_rel_float : bool -> reduce_rel_int_float val eval_float_constant: with_alarms:CilE.warn_mode -> float -> fkind -> Cvalue.V.t (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/value_util.ml0000644000175000017500000001465412155630231020413 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (** Callstacks related types and functions *) type call_site = (kernel_function * kinstr) type callstack = call_site list let call_stack : callstack ref = ref [] (* let call_stack_for_callbacks : (kernel_function * kinstr) list ref = ref [] *) let clear_call_stack () = call_stack := [] let pop_call_stack () = call_stack := List.tl !call_stack let push_call_stack kf ki = call_stack := (kf,ki) :: !call_stack let current_kf () = let (kf,_) = (List.hd !call_stack) in kf;; let call_stack () = !call_stack let pretty_call_stack_short fmt callstack = Pretty_utils.pp_flowlist ~left:"" ~sep:" <- " ~right:"" (fun fmt (kf,_) -> Kernel_function.pretty fmt kf) fmt callstack let pretty_call_stack fmt callstack = Format.fprintf fmt "@["; 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_call_stack (call_stack()) ;; (** 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 = !Db.Value.degeneration_occurred (CilE.current_stmt ()) lv let stop_if_stop_at_first_alarm_mode () = if Stop_at_nth.incr() then begin Value_parameters.log "Stopping at nth alarm" ; do_degenerate None; raise Db.Value.Aborted end (** Assertions emitted during the analysis *) let emitter = Emitter.create "Value" [ Emitter.Property_status; Emitter.Alarm ] ~correctness:Value_parameters.parameters_correctness ~tuning:Value_parameters.parameters_tuning let warn_all_mode = CilE.warn_all_mode emitter pp_callstack let with_alarm_stop_at_first = let stop = {warn_all_mode.CilE.others with CilE.a_call = stop_if_stop_at_first_alarm_mode} in { CilE.imprecision_tracing = CilE.a_ignore; defined_logic = stop; unspecified = stop; others = stop; } let with_alarms_raise_exn exn = let raise_exn () = raise exn in let stop = { CilE.a_log = None; CilE.a_call = raise_exn } in { CilE.imprecision_tracing = CilE.a_ignore; defined_logic = stop; unspecified = stop; others = stop; } let warn_all_quiet_mode () = if Value_parameters.StopAtNthAlarm.get () <> max_int then with_alarm_stop_at_first else if Value_parameters.verbose_atleast 1 then warn_all_mode else { warn_all_mode with CilE.imprecision_tracing = CilE.a_ignore } 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 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 (* Cached versions of [Stmts_graph.stmt_can_reach] *) 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 size = 17 let dependencies = [ Ast.self ] end) let stmt_can_reach_memo = StmtCanReachCache.memo Stmts_graph.stmt_can_reach let stmt_can_reach kf = if Value_parameters.MemoryFootprint.get () >= 3 then stmt_can_reach_memo kf else Stmts_graph.stmt_can_reach kf let debug_result kf (last_ret,_,last_clob) = Value_parameters.debug "@[RESULT FOR %a <-%a:@\n\\result -> %t@\nClobered set:%a@]" Kernel_function.pretty kf pretty_call_stack (call_stack ()) (fun fmt -> match last_ret with | None -> () | Some v -> Cvalue.V_Offsetmap.pretty fmt v) Base.SetLattice.pretty last_clob let map_outputs f = List.map (fun ((res: Cvalue.V_Offsetmap.t option), (out: Cvalue.Model.t)) -> (res, f out)) let remove_formals_from_state formals state = if formals != [] then let formals = List.map Base.create_varinfo formals in let cleanup acc v = Cvalue.Model.remove_base v acc in List.fold_left cleanup state formals else state (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/eval_exprs.ml0000644000175000017500000014350412155630231020407 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp open Locations open Cvalue open Bit_utils open Value_util exception Not_an_exact_loc exception Reduce_to_bottom exception Offset_not_based_on_Null of Locations.Zone.t option * Location_Bytes.t * typ exception Cannot_find_lv exception Too_linear type cond = { exp: exp; (* The condition of the branch*) positive: bool; (* true: normal false: negated *)} let do_promotion_c ~with_alarms ~src_typ ~dst_typ v e_src = let rounding_mode = get_rounding_mode() in let msg fmt = Format.fprintf fmt "%a (%a)" Printer.pp_exp e_src Cvalue.V.pretty v in CilE.set_syntactic_context (CilE.SyUnOp e_src); Eval_op.do_promotion ~with_alarms rounding_mode ~src_typ ~dst_typ v msg let rec lval_to_loc ~with_alarms state lv = let _, r, _typ = lval_to_loc_state ~with_alarms state lv in r and lval_to_loc_state ~with_alarms state lv = let state,_,r, typ = lval_to_loc_deps_state ~with_alarms ~deps:None ~reduce_valid_index:(Kernel.SafeArrays.get ()) state lv in state, r, typ and lval_to_loc_deps_state ~with_alarms ~deps state ~reduce_valid_index (host,offset as lv) = if not (Cvalue.Model.is_reachable state) then state, deps, loc_bottom, typeOfLval lv else let typ = match host with | Var host -> host.vtype | Mem x -> typeOf_pointed (typeOf x) in try let state, deps, offs, typ_offs = eval_offset ~with_alarms ~reduce_valid_index deps typ state offset in let state, deps, loc = eval_host ~with_alarms ~deps state host offs in let size = Eval_op.sizeof_lval_typ typ_offs in state, deps, make_loc loc size, typ_offs with Offset_not_based_on_Null(deps,offset,typ_offs) -> let state, deps, loc_if_no_offset = eval_host ~with_alarms ~deps state host Ival.zero in let loc = Location_Bits.join (loc_bytes_to_loc_bits offset) loc_if_no_offset in let size = Eval_op.sizeof_lval_typ typ_offs in state, deps, make_loc loc size, typ_offs (* Evaluation of the right part of an lval (an host) to a location *) and eval_host ~with_alarms ~deps state host offs = if Ival.is_bottom offs then Cvalue.Model.bottom, Some Zone.bottom, Location_Bits.bottom else match host with | Var host -> let base = Base.find host in state, deps, 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.shift offs (loc_bytes_to_loc_bits loc_lv)in state, deps, loc_bits (** 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 cannot. 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 state exn typ e = 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; (* Format.printf "pass_cast %a as %a@." Printer.pp_exp e Printer.pp_typ typ; *) match unrollType typ, unrollType typeofe with | (TInt _ | TEnum _), (TInt _ | TEnum _) -> let sztyp = sizeof typ in let szexpr = sizeof typeofe in let styp, sexpr = match sztyp, szexpr with | Int_Base.Value styp, Int_Base.Value sexpr -> styp, sexpr | _ -> raise exn in let sityp = is_signed_int_enum_pointer typ in let sisexpr = is_signed_int_enum_pointer typeofe in if (Int.ge styp sexpr && sityp = sisexpr) (* larger, same signedness *) || (Int.gt styp sexpr && sityp) (* strictly larger and signed *) then () else (* try to ignore the cast if it acts as identity on the value [e] *) let size = bitsSizeOf typ in let all_values = V.create_all_values ~size ~signed:sityp ~modu:Integer.one in let with_alarms = Value_util.with_alarms_raise_exn exn in if not (V.is_included (eval_expr ~with_alarms state e) all_values) then raise exn | TFloat (f1,_), TFloat (f2, _) -> if Cil.frank f1 < Cil.frank f2 then raise exn (* TODO: check value inclusion as in the integer case *) | _ -> raise exn (* Not a scalar type *) 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) -> pass_cast state Cannot_find_lv typ e; find_lv ~with_alarms state e | _ -> raise Cannot_find_lv (** If possible, decomposes [e] into [lval+offset]; where [lval] is a Cil expression, and [offset] is an Ival.t, in bytes. @raises Cannot_find_lv if the expression cannot be decomposed *) and find_lv_plus_offset ~with_alarms state e = let acc = ref None in let rec aux e current_offs = try let lv = find_lv ~with_alarms state e in if not (hasAttribute "volatile" (typeAttrs (Cil.typeOfLval lv))) then acc := Some (lv,current_offs) with Cannot_find_lv -> match e.enode with | BinOp((MinusPI|PlusPI|IndexPI as op), p, offs, typ) -> let offs = eval_expr ~with_alarms state offs in (try let offs = V.project_ival offs in let offs = Ival.scale (Int_Base.project (osizeof_pointed typ)) offs in let offs = if op = MinusPI then Ival.neg offs else offs in aux p (Ival.add_int current_offs offs) with V.Not_based_on_null | Int_Base.Error_Top-> ()); | _ -> () in aux e Ival.zero; (* Extlib.may (fun (lv,ival) -> Format.printf "find_lv_plus %a=%a+%a\n" Printer.pp_exp e !d_lval lv Ival.pretty ival ) !acc; *) match !acc with | None -> raise Cannot_find_lv | Some (lv, offs) -> lv, offs (* Find locations on which it is interesting to proceed by case disjunction to evaluate the expression *) and get_influential_vars state exp = let with_alarms = CilE.warn_none_mode in (* Format.printf "get_influential cond:%a@.state:%a@." Printer.pp_exp cond Cvalue.Model.pretty state; *) let rec get_vars acc exp = let eval_offset off t = try let _, _, offset, _ = eval_offset ~reduce_valid_index:true ~with_alarms None t state off in offset with Offset_not_based_on_Null _ -> Ival.top in match exp.enode with | Lval (Var v, off as lv) -> let offset = eval_offset off v.vtype in if Ival.cardinal_zero_or_one offset then (* no variable in offset can be influential. Check the contents of the location, on which we might want to enumerate *) 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 acc (* small cardinal: not influential *) else loc :: acc else (* A variable in offset may be influential. The contents themselves are not influential, because we would need to split both by offset and by content in sync. *) get_vars_offset acc off | Lval (Mem e, off as lv) -> let t = typeOf_pointed (typeOf e) in let offset = eval_offset off t in if Ival.cardinal_zero_or_one offset then let v = eval_expr ~with_alarms state e in if Location_Bytes.cardinal_zero_or_one v then let locbi = loc_bytes_to_loc_bits v in let locbi' = Location_Bits.shift offset locbi in let loc = Locations.make_loc locbi' (sizeof_lval lv) in loc :: acc else get_vars acc e else (* variables in expr or offset can be influential *) 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 [] exp 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_previous_binding ~with_alarms:CilE.warn_none_mode 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 (fkind, _) -> CilE.set_syntactic_context (CilE.SyUnOp e); let r = Eval_op.eval_binop_float ~with_alarms (get_rounding_mode ()) (Some fkind) ev1 op ev2 in state, deps, r | TInt _ | TPtr (_, _) | _ as te1 -> CilE.set_syntactic_context (CilE.SyBinOp(e, op, e1, e2)); let v = Eval_op.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 -> Eval_op.handle_overflow ~with_alarms typ v | _ -> v in state, deps, v end end | _ -> assert false and eval_expr ~with_alarms state e = let _, _, r = eval_expr_with_deps_state ~with_alarms None state e in 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 (* TODO: missing checks for overflow *) | CChr c -> (match charConstToInt c with | CInt64 (i,_,_) -> V.inject_int i | _ -> assert false) | CReal (f, fkind, _) -> CilE.set_syntactic_context (CilE.SyUnOp e); Eval_op.eval_float_constant ~with_alarms f fkind | 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_and_convert ~with_alarms deps state (e, lv) | AddrOf v | StartOf v -> let state, deps, r, _ = lval_to_loc_deps_state ~with_alarms ~deps state v ~reduce_valid_index:false in state, deps, loc_to_loc_without_size r | CastE (typ, e) -> let state, deps, evaled_expr = eval_expr_with_deps_state ~with_alarms deps state e in let r = do_promotion_c ~with_alarms ~dst_typ:typ ~src_typ:(typeOf e) 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 | _ -> CilE.do_warn with_alarms.CilE.imprecision_tracing (fun _ -> Value_parameters.result ~current:true "cannot interpret sizeof or alignof (incomplete type)" ); V.top_int in state, deps, r | UnOp (op, e, _t_res) -> let state, deps, expr = eval_expr_with_deps_state ~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.SyUnOp e (* Can raise a pointer comparison. CilE needs [e] there *) in let t = unrollType (typeOf e) in CilE.set_syntactic_context syntactic_context; let result = Eval_op.eval_unop ~check_overflow:true ~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 CilE.set_syntactic_context (CilE.SyUnOp e); (* TODO: the functions called above should respect the destination type. Calling reinterpret should be useless *) let rr = Eval_op.reinterpret ~with_alarms typ r in (if Cvalue.V.is_bottom rr then Cvalue.Model.bottom else state), deps, rr 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 (Location_Bytes.is_included result_without_subdiv 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 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" Printer.pp_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" Printer.pp_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 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 bound1, bound2 = Cvalue.V.min_and_max_float v_value in let compute subvalue = let substate = 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.debug ~current:true "subdivfloatvar: computed var=%a expr=%a" V.pretty subvalue V.pretty subexpr; *) subexpr in let r1 = compute (Cvalue.V.inject_float bound1) in let r2 = compute (Cvalue.V.inject_float bound2) in let wont_find_better = ref (if compare_min r2 r1 >= 0 then r1 else r2) in (* Value_parameters.debug ~current:true "subdivfloatvar: wont initial %a" V.pretty !wont_find_better; *) let had_bottom = ref false in let size = if Value_parameters.AllRoundingModes.get () then 0 else Int.to_int (Int_Base.project v.Locations.size) in let subdiv_for_bound better_bound = let insert_subvalue_in_list (_, exp_value as p) l = let wont = !wont_find_better in let bound_to_test = if better_bound exp_value wont <= 0 then exp_value else wont in let rec aux l = match l with [] -> [p] | (_, exp_value1 as p1) :: tail -> if better_bound exp_value1 bound_to_test >= 0 then p :: l else p1 :: (aux tail) in aux l in let exp_subvalue subvalue l = let subexpr = compute subvalue in if Cvalue.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.V.subdiv_float_interval ~size value in (* let rmid = compute middlepoint1 in if better_bound !wont_find_better rmid > 0 then begin wont_find_better := rmid; (* Value_parameters.debug ~current:true "subdivfloatvar: improved wont %a" V.pretty !wont_find_better; *) end; *) if better_bound !wont_find_better exp_value = 0 then begin (* Value_parameters.debug ~current:true "subdivfloatvar: optimum reached"; *) raise Ival.Can_not_subdiv end; 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 ; wont_find_better := if compare_max r2 r1 >= 0 then r1 else r2; (* 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; Value_parameters.debug "subdivfloatvar: wont %a" V.pretty !wont_find_better; *) 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 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 (* [loc] is the location pointed to by [lv]. If [lv] is precise enough, we reduce it to the parts of [loc] that are valid for a read/write operation *) and reduce_by_accessed_loc ~for_writing state lv loc = let with_alarms = CilE.warn_none_mode in let valid_loc = Locations.valid_part ~for_writing loc in let state = if Location_Bits.equal loc.loc valid_loc.loc then state else try match lv with | Mem (exp_mem), offs -> let state = if Cil.isConstantOffset offs then (* offset coming from [offs] *) let offs = match offs with | NoOffset -> Ival.zero | _ -> let typ_exp = Cil.typeOf_pointed (typeOf exp_mem) in let offs_bytes = fst (Cil.bitsOffset typ_exp offs) / 8 in Ival.inject_singleton (Int.of_int offs_bytes) in (try (* Decompose [exp_mem] into a base lvalue and an offset *) let lv_mem, plus = find_lv_plus_offset ~with_alarms state exp_mem in (* Total offset, still in bytes *) let plus = Ival.add_int plus offs in let state, loc_mem, _typ_plus = lval_to_loc_state ~with_alarms state lv_mem in let loc_mem = Locations.valid_part ~for_writing loc_mem in if Location_Bits.is_relationable loc_mem.Locations.loc then (* is_relationable guarantees that [loc_mem] is a single binding, that can be safely reduced. The valid (reduced) value the original location shifted by [-plus] *) let new_val = Location_Bytes.shift (Ival.neg plus) (loc_bits_to_loc_bytes valid_loc.loc) in (* [new_val] is not necessarily included in previous binding, use [reduce_binding] *) Cvalue.Model.reduce_binding ~with_alarms state loc_mem new_val else state with Cannot_find_lv (* find_lval_plus_offset *) -> state) else state in let rec aux e = ( match e.enode with | BinOp((PlusPI|IndexPI), p, exp_index , typ) -> let base_pointer = eval_expr ~with_alarms state p in if Cvalue.V.cardinal_zero_or_one base_pointer then begin let lv_index = find_lv ~with_alarms state exp_index in let loc_index = lval_to_loc state ~with_alarms lv_index in if Location_Bits.is_relationable loc_index.Locations.loc then let old_index_val = Cvalue.Model.find ~conflate_bottom:true ~with_alarms state loc_index in if Cvalue.V.is_included old_index_val Cvalue.V.top_int then let size_pointed = Int.of_int ((bitsSizeOf (Cil.typeOf_pointed typ))) in let size_pointed_bytes = Int.div size_pointed (Bit_utils.sizeofchar()) in let old_index_ival = Cvalue.V.project_ival old_index_val in let old_index_ival = Ival.scale size_pointed_bytes old_index_ival in let accessed_loc = Location_Bytes.shift old_index_ival base_pointer in let accessed_loc = Locations.make_loc (loc_bytes_to_loc_bits accessed_loc) (Int_Base.inject size_pointed) in let valid_accessed_loc = Locations.valid_part ~for_writing accessed_loc in if not (Location_Bits.equal valid_accessed_loc.loc accessed_loc.loc) then if Location_Bits.equal Location_Bits.bottom valid_accessed_loc.loc then Cvalue.Model.bottom else let new_index_val = (* in bytes *) V.add_untyped Int_Base.minus_one (loc_bits_to_loc_bytes valid_accessed_loc.Locations.loc) base_pointer in let new_index_val = ( try let i = Cvalue.V.project_ival new_index_val in let mi, ma = Ival.min_and_max i in let mi = match mi with None -> None | Some mi -> Some (Int.pos_div (Int.add mi (Int.pred size_pointed_bytes)) size_pointed_bytes) in let ma = match ma with None -> None | Some ma -> Some (Int.pos_div ma size_pointed_bytes) in Ival.inject_range mi ma with Cvalue.V.Not_based_on_null -> Value_parameters.fatal ~current:true "REDUCE by ACCESSED LOC: loc %a, lv %a, \ for_writing: %b,state@ %a, new_index_val %a" Locations.pretty loc Printer.pp_lval lv for_writing Cvalue.Model.pretty state Cvalue.V.pretty new_index_val; ) in let new_index_val = Cvalue.V.inject_ival new_index_val in Cvalue.Model.reduce_previous_binding ~with_alarms state loc_index new_index_val else state else state else state end else state | CastE(typ,e) -> pass_cast state Cannot_find_lv typ e; aux e | _ -> state) in if offs = NoOffset (* TODO: improve *) then ( try aux exp_mem with Cannot_find_lv -> state) else state | _ -> state with Cil.SizeOfError _ (* from Cil.bits... and others *) -> state in state, valid_loc and eval_lval ~conflate_bottom ~with_alarms deps state lv = let state, deps, loc, typ_lv = lval_to_loc_deps_state ~with_alarms ~deps state lv ~reduce_valid_index:(Kernel.SafeArrays.get ()) in CilE.set_syntactic_context (CilE.SyMem lv); let state, result = if conflate_bottom then Cvalue.Model.find_and_reduce_indeterminate ~with_alarms state loc else state, (Cvalue.Model.find ~conflate_bottom ~with_alarms state loc) in let result = Eval_op.cast_lval_bitfield typ_lv loc.size result in let state, loc = warn_reduce_by_accessed_loc ~with_alarms ~for_writing:false state loc lv in Warn.warn_imprecise_lval_read ~with_alarms lv loc result; let new_deps = match deps with | None -> None | Some deps -> Some (Zone.join deps (enumerate_valid_bits ~for_writing:false loc)) in state, new_deps, result, typ_lv and eval_lval_and_convert ~with_alarms deps state (e, lv) = let state, deps, result, typ_lv = eval_lval ~conflate_bottom:true ~with_alarms deps state lv in CilE.set_syntactic_context (CilE.SyUnOp e); let result_conv = Eval_op.reinterpret ~with_alarms typ_lv result in let state' = if not (V.equal result result_conv) then try let loc, _v, _ = eval_as_exact_loc ~with_alarms state e in Cvalue.Model.reduce_previous_binding ~with_alarms:CilE.warn_none_mode state loc result_conv with Not_an_exact_loc -> state else state in state', deps, result_conv and eval_offset ~with_alarms ~reduce_valid_index deps typ state offset = match offset with | NoOffset -> state, deps, Ival.singleton_zero, typ | Index (exp,remaining) -> let typ_pointed,array_size = match (unrollType typ) with | TArray (t,size,_,_) -> t, size | t -> Value_parameters.fatal ~current:true "Got type '%a'" Printer.pp_typ t in let state, deps, current = eval_expr_with_deps_state ~with_alarms deps state exp in if V.is_bottom current then let typ_offset = typeOffset typ_pointed remaining in Cvalue.Model.bottom, (Some Zone.bottom), Ival.bottom, typ_offset 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 (Integer.pred array_siz))) v in let new_state = if Ival.equal new_v v then state else begin begin CilE.do_warn with_alarms.CilE.others (fun _ -> let range = Pretty_utils.sfprintf "%a" V.pretty current in let positive = match Ival.min_int v with | None -> false | Some min -> Int.ge min Int.zero in CilE.set_syntactic_context (CilE.SyBinOp (exp (* useless *), IndexPI, exp, Extlib.the array_size)); CilE.warn_index with_alarms ~positive ~range) end; begin try let loc,_,_= eval_as_exact_loc ~with_alarms state exp in Cvalue.Model.reduce_previous_binding ~with_alarms:CilE.warn_none_mode state loc (V.inject_ival new_v) with Not_an_exact_loc -> state end 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 let typ_offset = typeOffset typ_pointed remaining in raise (Offset_not_based_on_Null (deps, offset, typ_offset)) in let state, deps, r, typ_offs = 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_int offset r, typ_offs | Field (fi,remaining) -> let attrs = filter_qualifier_attributes (typeAttr typ) in let typ_fi = typeAddAttributes attrs fi.ftype in let current,_ = bitsOffset typ (Field(fi,NoOffset)) in let state, deps, r, typ = eval_offset ~with_alarms ~reduce_valid_index deps typ_fi state remaining in state, deps, Ival.add_int (Ival.of_int current) r, typ 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_state ~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 and eval_as_exact_loc ~with_alarms state e = try let lv = find_lv ~with_alarms state e in let _, loc, typ = lval_to_loc_state ~with_alarms state lv in let loc = Locations.valid_part ~for_writing:false loc in if not (cardinal_zero_or_one loc) then raise Not_an_exact_loc; CilE.set_syntactic_context (CilE.SyMem lv); let v = 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. *) CilE.set_syntactic_context (CilE.SyUnOp e); let v' = Eval_op.reinterpret ~with_alarms typ v in let v' = Eval_op.cast_lval_bitfield typ loc.size v' in if Cvalue.V.has_sign_problems v && not (Cvalue.V.equal v v') then raise Not_an_exact_loc; loc, v', typ with Cannot_find_lv -> raise Not_an_exact_loc and warn_reduce_by_accessed_loc ~with_alarms ~for_writing state loc lv = let warn = not (Locations.is_valid ~for_writing loc) in if warn then begin CilE.set_syntactic_context (CilE.SyMem lv); (if for_writing then CilE.warn_mem_write else CilE.warn_mem_read) with_alarms; (* The call is is_valid and to reduce_by_accessed_loc below cannot be fused because of bases with validity unkwnown *) reduce_by_accessed_loc ~for_writing state lv loc end else state, loc let reduce_rel_from_type t = if isIntegralType t || isPointerType t then Eval_op.reduce_rel_int else Eval_op.reduce_rel_float (Value_parameters.AllRoundingModes.get ()) (** 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_abstract eval pos expl binop expr state = let with_alarms = CilE.warn_none_mode in try let loc, val_for_loc, invert, val_compared, typ_loc = try let loc, value, typ = eval_as_exact_loc ~with_alarms state expl in loc, value, (fun x -> x), value, typ with Not_an_exact_loc -> let invert_cast e1 typ_loc = let loc, val_for_loc, typ_for_loc = eval_as_exact_loc ~with_alarms state e1 in ( match Cil.unrollType typ_for_loc with | TFloat ((FDouble|FFloat) as fk, _) -> let single_precision = fk = FFloat in let size = bitsSizeOf typ_loc in let signed = isSignedInteger typ_loc in let _, _, _, val_compared = V.cast_float_to_int ~signed ~size val_for_loc in loc, val_for_loc, (V.cast_float_to_int_inverse ~single_precision), val_compared, typ_loc | _ -> raise Not_an_exact_loc) in ( match expl.enode with | CastE (typ_larger, { enode = CastE(typ_loc,e1) } ) when isIntegralType typ_loc && isIntegralType typ_larger && ( bitsSizeOf typ_larger > bitsSizeOf typ_loc && isSignedInteger typ_loc ) (* TODOBY: this should be implemented using pass_cast *) -> invert_cast e1 typ_loc | CastE (typ_loc, e1) when isIntegralType typ_loc -> invert_cast e1 typ_loc | _ -> raise Not_an_exact_loc) in let cond_v = expr in let v_sym = eval.Eval_op.reduce_rel_symetric pos binop cond_v val_compared in let v_asym = eval.Eval_op.reduce_rel_antisymetric ~typ_loc pos binop cond_v v_sym in (* Format.printf "reduce_by_left %a -> %a -> %a@." Cvalue.V.pretty val_for_loc Cvalue.V.pretty val_compared Cvalue.V.pretty v_asym; *) if V.equal v_asym V.bottom then raise Reduce_to_bottom; if V.equal v_asym val_compared then state else ( let new_val_for_loc = invert v_asym in let new_val_for_loc = V.narrow new_val_for_loc val_for_loc in if V.equal new_val_for_loc val_for_loc then state else begin (* Format.printf "reduce_by_left %a -> %a -> %a -> %a@." Cvalue.V.pretty val_for_loc Cvalue.V.pretty val_compared Cvalue.V.pretty v_asym Cvalue.V.pretty new_val_for_loc; *) Cvalue.Model.reduce_previous_binding ~with_alarms:CilE.warn_none_mode state loc new_val_for_loc end ) with Not_an_exact_loc -> state let reduce_by_left_comparison eval pos expl binop expr state = let expr = eval_expr ~with_alarms:CilE.warn_none_mode state expr in reduce_by_left_comparison_abstract eval pos expl binop expr state (** Reduce the state for comparisons of the form 'v Rel k', 'k Rel v' or 'v = w' *) let reduce_by_comparison reduce_rel pos exp1 binop exp2 state = (* Format.printf "red_by_comparison %a@." Cvalue.Model.pretty state; *) let state = reduce_by_left_comparison reduce_rel pos exp1 binop exp2 state in let inv_binop = match binop with | Gt -> Lt | Lt -> Gt | Le -> Ge | Ge -> Le | _ -> binop in reduce_by_left_comparison reduce_rel pos exp2 inv_binop exp1 state (* Try to make the condition true by evaluating important locations, proceeding by case disjunction on them, and removing values that make the condition false. Raises [Reduce_to_bottom] instead of returning [Model.bottom] *) let reduce_by_cond_enumerate state cond locs = let with_alarms = CilE.warn_none_mode in let condition_may_still_be_true_in_state state = let vcond = eval_expr ~with_alarms state cond.exp in if cond.positive then V.contains_non_zero vcond else if Value_parameters.UndefinedPointerComparisonPropagateAll.get() then V.contains_zero vcond else V.is_included V.singleton_zero vcond in let is_enumerable loc = let v = Cvalue.Model.find ~conflate_bottom:true ~with_alarms state loc in let upto = succ (Ival.get_small_cardinal()) in ignore (Location_Bytes.cardinal_less_than v upto); v in let rec enumerate_one_var l = match l with | [] -> raise Not_found | loc :: q -> try let v = is_enumerable loc in loc, v, q with Abstract_interp.Not_less_than -> enumerate_one_var q in try let loc, vloc, _tail = enumerate_one_var locs in (* Format.printf "enumerate %a %a@." pretty_loc v1 V.pretty v_interp1; *) let f one_val acc = (* interpret cond in an environment where v -> one_val *) let env = Cvalue.Model.reduce_previous_binding ~with_alarms:CilE.warn_none_mode state loc one_val in let stays = condition_may_still_be_true_in_state env in (* Format.printf "enumerate %a stays:%B@." V.pretty one_val stays; *) if stays then Location_Bytes.join one_val acc else acc in let newv = Location_Bytes.fold_enum ~split_non_enumerable:2 f vloc Location_Bytes.bottom in if V.is_bottom newv then raise Reduce_to_bottom else if V.equal newv vloc then state else Cvalue.Model.reduce_previous_binding ~with_alarms:CilE.warn_none_mode state loc newv with Not_found -> state (** raises [Reduce_to_bottom] and never returns [Cvalue.Model.bottom]*) let reduce_by_cond 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 rec aux cond state = (*Format.printf "eval_cond_aux %B %a@." cond.positive Printer.pp_exp cond.exp;*) match cond.positive,cond.exp.enode with | _positive, BinOp ((Le|Ne|Eq|Gt|Lt|Ge as binop), exp1, exp2, _typ) -> let reduce_rel = reduce_rel_from_type (unrollType (typeOf exp1)) in reduce_by_comparison reduce_rel cond.positive exp1 binop exp2 state (* Strict or lazy operators can be handled uniformly here: there are no side effects inside expressions, and alarms should have been emitted prior to reducing *) | true, ( BinOp (LAnd, exp1, exp2, _) | BinOp (BAnd, (* 'cond1 & cond2' can be treated as 'e1 && e2' *) ({ enode = BinOp ((Le|Ne|Eq|Gt|Lt|Ge), _, _, _)} as exp1), ({ enode = BinOp ((Le|Ne|Eq|Gt|Lt|Ge), _, _, _)} as exp2), _)) | false, ( BinOp (LOr, exp1, exp2, _) | BinOp (BOr, (* '!(cond1 | cond2)' can be treated as '!(e1 || e2)' *) ({ enode = BinOp ((Le|Ne|Eq|Gt|Lt|Ge), _, _, _)} as exp1), ({ enode = BinOp ((Le|Ne|Eq|Gt|Lt|Ge), _, _, _)} as 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 | _, CastE (typ, e) -> (try pass_cast state Exit typ e; aux { cond with exp = e} state with Exit -> if isIntegralType typ || isPointerType typ then reduce_by_left_comparison_abstract Eval_op.reduce_rel_int cond.positive cond.exp Ne V.singleton_zero state else state) | _, Lval _ when (let t = typeOf cond.exp in isIntegralType t || isPointerType t) -> (* "if (c)" is equivalent to "if(!(c==0))" *) reduce_by_left_comparison_abstract Eval_op.reduce_rel_int cond.positive cond.exp Ne V.singleton_zero state | _ -> state in let result = aux cond state in (* If the condition does not evaluate exactly to true (or false if [cond] is negative), we reduce more agressively by splitting on some variables *) let evaled = eval_expr ~with_alarms:CilE.warn_none_mode result cond.exp in let reduce_more = if cond.positive then V.contains_zero evaled else V.contains_non_zero evaled in if reduce_more then let split_on = get_influential_vars result cond.exp in reduce_by_cond_enumerate result cond split_on else result (* Test that two functions types are compatible; used to verify that a call through a function pointer is ok. In theory, we could only check that both types are compatible as defined by C99, 6.2.7. However, some industrial codes do not strictly follow the norm, and we must be more lenient. Thus, we emit a warning on undefined code, but we also return true if Value can ignore more or less safely the incompatibleness in the types. *) let compatible_functions ~with_alarms vi typ_pointer typ_fun = try ignore (Cabs2cil.compatibleTypes typ_pointer typ_fun); true with Failure _ -> if with_alarms.CilE.others.CilE.a_log <> None then warning_once_current "@[Function pointer@ and@ pointed function@ '%a' @ have@ incompatible \ types:@ %a@ vs.@ %a.@ assert(function type matches)@]" Printer.pp_varinfo vi Printer.pp_typ typ_pointer Printer.pp_typ typ_fun; match Cil.unrollType typ_pointer, Cil.unrollType typ_fun with | TFun (ret1, args1, var1, _), TFun (ret2, args2, var2, _) -> (* Either both functions are variadic, or none. Otherwise, it will be too complicated to make the argument match *) var1 = var2 && (* Both functions return something of the same size, or nothing*) (match Cil.unrollType ret1, Cil.unrollType ret2 with | TVoid _, TVoid _ -> true (* let's avoid relying on the size of void *) | TVoid _, _ | _, TVoid _ -> false | t1, t2 -> bitsSizeOf t1 = bitsSizeOf t2 ) && (* Argument lists of the same length, with compatible sizes between the arguments, or unspecified argument lists *) (match args1, args2 with | None, None | None, Some _ | Some _, None -> true | Some l1, Some l2 -> List.length l1 = List.length l2 && List.for_all2 (fun (_, t1, _) (_, t2, _) -> bitsSizeOf t1 = bitsSizeOf t2) l1 l2 ) | _ -> false let resolv_func_vinfo ~with_alarms deps state funcexp = let warning_once_current fmt = let w = with_alarms.CilE.defined_logic in w.CilE.a_call (); match w.CilE.a_log with | None -> Format.ifprintf Format.std_formatter fmt | Some _ -> warning_once_current fmt in 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_state ~with_alarms deps state v in let typ_pointer = typeOf funcexp in let pp_assert fmt = Format.fprintf fmt "assert(\\valid_fun_pointer(%a))" Printer.pp_exp funcexp in let fundecs = match loc with | Location_Bytes.Map _ -> Location_Bytes.fold_i (fun base offs acc -> match base with | Base.String (_,_) -> warning_once_current "Function pointer call at string position in memory: \ ignoring this particular value: %t" pp_assert; acc | Base.Null -> warning_once_current "Function pointer call at absolute position in memory: \ ignoring this particular value: %t" pp_assert; acc | Base.Var (v,_) | Base.Initialized_Var (v,_) -> if Cil.isFunctionType v.vtype then ( if Ival.contains_non_zero offs then warning_once_current "Function pointer evaluates to function address plus \ offset: ignoring this particular value: %t" pp_assert; if Ival.contains_zero offs then ( if compatible_functions ~with_alarms v typ_pointer v.vtype then Kernel_function.Hptset.add (Globals.Functions.get v) acc else acc ) else acc ) else ( warning_once_current "Function pointer evaluates to non-function: \ ignoring this particular value: %t" pp_assert; acc) ) loc Kernel_function.Hptset.empty | Location_Bytes.Top (set, _) -> warning_once_current "Function pointer for call is imprecise: %t" pp_assert; Base.SetLattice.fold (fun b acc -> match b with | Base.Var (v,_) | Base.Initialized_Var (v,_) when Cil.isFunctionType v.vtype -> if compatible_functions ~with_alarms v typ_pointer v.vtype then Kernel_function.Hptset.add (Globals.Functions.get v) acc else acc | _ -> acc ) set Kernel_function.Hptset.empty in fundecs, deps | _ -> assert false let offsetmap_of_lv ~with_alarms state lv = let state, loc_to_read, _typ = lval_to_loc_state ~with_alarms state lv in CilE.set_syntactic_context (CilE.SyMem lv); loc_to_read, state, Cvalue.Model.copy_offsetmap ~with_alarms loc_to_read state (* -------------------------------------------------------------------------- *) (* --- Registration inside Db --- *) (* -------------------------------------------------------------------------- *) let () = Db.Value.find_lv_plus := (fun ~with_alarms state e -> try [find_lv_plus_offset ~with_alarms state e] with Cannot_find_lv -> []); ;; (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/local_slevel_compute.mli0000644000175000017500000000346112155630231022605 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 virtual functions for local slevel feature. Nothing is exported, but this module fills [Local_slevel.compute_sub_function_ref] *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/eval_exprs.mli0000644000175000017500000001247112155630231020556 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (* -------------------------------------------------------------------------- *) (* --- Evaluation to values --- *) (* -------------------------------------------------------------------------- *) val eval_expr : with_alarms:CilE.warn_mode -> Cvalue.Model.t -> exp -> 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 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 * typ (* -------------------------------------------------------------------------- *) (* --- Evaluation to locations --- *) (* -------------------------------------------------------------------------- *) val lval_to_loc : with_alarms:CilE.warn_mode -> Cvalue.Model.t -> lval -> location val lval_to_loc_state : with_alarms:CilE.warn_mode -> Cvalue.Model.t -> lval -> Cvalue.Model.t * location * typ val lval_to_loc_deps_state : 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 * typ (* -------------------------------------------------------------------------- *) (* --- Reduction --- *) (* -------------------------------------------------------------------------- *) (** Reduction by operators condition *) type cond = { exp : exp; positive : bool; } exception Reduce_to_bottom val reduce_by_cond : Cvalue.Model.t -> cond -> Cvalue.Model.t (** Never returns [Model.bottom]. Instead, raises [Reduce_to_bottom] *) (** Reduction by accesses *) val reduce_by_valid_loc : positive:bool -> for_writing:bool -> location -> typ -> Cvalue.Model.t -> Cvalue.Model.t val reduce_by_accessed_loc : for_writing:bool -> Cvalue.Model.t -> Cil_types.lval -> Locations.location -> Cvalue.Model.t * Locations.location (** Misc functions related to reduction *) exception Cannot_find_lv val find_lv : with_alarms:CilE.warn_mode -> Cvalue.Model.t -> exp -> lval val get_influential_vars : Cvalue.Model.t -> exp -> location list (* -------------------------------------------------------------------------- *) (* --- Alarms and imprecision --- *) (* -------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------- *) (* --- Alarms and reduction --- *) (* -------------------------------------------------------------------------- *) val warn_reduce_by_accessed_loc: with_alarms:CilE.warn_mode -> for_writing:bool -> Cvalue.Model.t -> Locations.location -> Cil_types.lval -> Cvalue.Model.t * Locations.location (* -------------------------------------------------------------------------- *) (* --- Misc --- *) (* -------------------------------------------------------------------------- *) val resolv_func_vinfo : with_alarms:CilE.warn_mode -> Zone.t option -> Cvalue.Model.t -> exp -> Kernel_function.Hptset.t * Zone.t option val offsetmap_of_lv: with_alarms:CilE.warn_mode -> Cvalue.Model.t -> lval -> Location.t * Cvalue.Model.t * Cvalue.V_Offsetmap.t option (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/value/stop_at_nth.ml0000644000175000017500000000334312155630231020555 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let n = ref 0 let clear () = n := 0 let incr () = let new_n = succ !n in n := new_n; new_n = Value_parameters.StopAtNthAlarm.get () frama-c-Fluorine-20130601/src/aorai/0000755000175000017500000000000012155634043015662 5ustar mehdimehdiframa-c-Fluorine-20130601/src/aorai/promelalexer_withexps.mll0000644000175000017500000001542112155630222023020 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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: promelalexer_withexps.mll,v 1.2 2008-10-02 13:33:29 uid588 Exp $ *) (* from http://www.ltl2dstar.de/down/ltl2dstar-0.4.2.zip *) { open Promelaparser_withexps open Lexing exception Error of (Lexing.position * Lexing.position) * string let loc lexbuf = (lexeme_start_p lexbuf, lexeme_end_p lexbuf) let raise_located loc e = raise (Error (loc, e)) let buf = Buffer.create 1024 let newline lexbuf = let pos = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum } } let rD = ['0'-'9'] let rL = ['a'-'z' 'A'-'Z' '_'] rule token = parse | "true" { PROMELA_TRUE } | "never" { PROMELA_NEVER } | "if" { PROMELA_IF } | "fi" { PROMELA_FI } | "goto" { PROMELA_GOTO } | "skip" { PROMELA_SKIP } | "::" { PROMELA_DOUBLE_COLON } | ':' { PROMELA_COLON } | ';' { PROMELA_SEMICOLON } | "()" { PROMELA_FUNC } | '(' { PROMELA_LPAREN } | ')' { PROMELA_RPAREN } | '{' { PROMELA_LBRACE } | '}' { PROMELA_RBRACE } | "->" { PROMELA_RIGHT_ARROW } | "false" { PROMELA_FALSE } | "||" { PROMELA_OR } | "&&" { PROMELA_AND } | '!' { PROMELA_NOT } | [' ' '\t' '\012' '\r']+ { token lexbuf } | '\n' { newline lexbuf; token lexbuf } | "/*" { comment lexbuf; token lexbuf } | "//" [^ '\n']* '\n' { newline lexbuf; token lexbuf } | "callof_" rL* (rL | rD)* { let s=(lexeme lexbuf) in let s=String.sub s 7 ((String.length s)-7) in PROMELA_CALLOF s } | "returnof_" rL* (rL | rD)* { let s=(lexeme lexbuf) in let s=String.sub s 9 ((String.length s)-9) in PROMELA_RETURNOF s } | "callorreturnof_" rL* (rL | rD)* { let s=(lexeme lexbuf) in let s=String.sub s 15 ((String.length s)-15) in PROMELA_CALLORRETURNOF s } | "callof_" { raise_located (loc lexbuf) "Illegal fonction name in Promela file." } | "returnof_" { raise_located (loc lexbuf) "Illegal fonction name in Promela file." } | "callorreturnof_" { raise_located (loc lexbuf) "Illegal fonction name in Promela file." } | rD+ | '-' rD+ { PROMELA_INT (lexeme lexbuf) } (* Logic relations *) | "==" { PROMELA_EQ } | "<" { PROMELA_LT } | ">" { PROMELA_GT } | "<=" { PROMELA_LE } | ">=" { PROMELA_GE } | "!=" { PROMELA_NEQ } (* Arithmetic relations *) | '+' { PROMELA_PLUS } | '-' { PROMELA_MINUS } | '/' { PROMELA_DIV } | '*' { PROMELA_STAR } | '%' { PROMELA_MODULO} (* Access *) (* | "->" { LTL_RIGHT_ARROW }*) | '.' { PROMELA_DOT } | '[' { PROMELA_LEFT_SQUARE} | ']' { PROMELA_RIGHT_SQUARE} (* | '&' { PROMELA_ADRESSE }*) | rL (rL | rD)* { let s = lexeme lexbuf in PROMELA_LABEL s } | eof { EOF } | "1" { PROMELA_TRUE } | _ { Aorai_option.error "Illegal_character : '%s'\n" (lexeme lexbuf); raise Parsing.Parse_error} and comment = parse | "*/" { () } | eof { Aorai_option.warning "Unterminated_comment\n" (*lex_error lexbuf "Unterminated_comment"*) } | '\n' { newline lexbuf; comment lexbuf } | _ { comment lexbuf } { let parse c = let lb = from_channel c in try Promelaparser_withexps.promela token lb with Parsing.Parse_error | Invalid_argument _ -> let (a,b)=(loc lb) in Aorai_option.error "Syntax error (l%d c%d -> l%dc%d)" a.pos_lnum (a.pos_cnum-a.pos_bol) b.pos_lnum (b.pos_cnum-b.pos_bol); (* Format.print_string "Syntax error (" ; *) (* Format.print_string "l" ; *) (* Format.print_int a.pos_lnum ; *) (* Format.print_string "c" ; *) (* Format.print_int (a.pos_cnum-a.pos_bol) ;*) (* Format.print_string " -> l" ; *) (* Format.print_int b.pos_lnum ; *) (* Format.print_string "c" ; *) (* Format.print_int (b.pos_cnum-b.pos_bol) ;*) (* Format.print_string ")\n" ; *) raise_located (loc lb) "Syntax error" } frama-c-Fluorine-20130601/src/aorai/aorai_dataflow.mli0000644000175000017500000000363512155630222021343 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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). *) (* *) (**************************************************************************) (** Compute the set of possible set at each function call and return. *) val compute: unit -> unit frama-c-Fluorine-20130601/src/aorai/bool3.mli0000644000175000017500000000400612155630222017376 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 t = | True | False | Undefined val bool3and: t -> t -> t val bool3or: t -> t -> t val bool3not: t -> t val bool3_of_bool: bool -> t (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/yaparser.ml0000444000175000017500000011465612155634032020053 0ustar mehdimehditype token = | CALL_OF | RETURN_OF | CALLORRETURN_OF | IDENTIFIER of (string) | INT of (string) | LCURLY | RCURLY | LPAREN | RPAREN | LSQUARE | RSQUARE | LBRACELBRACE | RBRACERBRACE | RARROW | TRUE | FALSE | NOT | DOT | AMP | COLON | SEMI_COLON | COMMA | PIPE | CARET | QUESTION | COLUMNCOLUMN | EQ | LT | GT | LE | GE | NEQ | PLUS | MINUS | SLASH | STAR | PERCENT | OR | AND | OTHERWISE | EOF open Parsing;; let _ = parse_error;; # 30 "src/aorai/yaparser.mly" open Logic_ptree open Promelaast open Bool3 let to_seq c = [{ condition = Some c; nested = []; min_rep = Some Data_for_aorai.cst_one; max_rep = Some Data_for_aorai.cst_one; }] let is_no_repet (min,max) = let is_one c = Extlib.may_map Data_for_aorai.is_cst_one ~dft:false c in is_one min && is_one max let observed_states = Hashtbl.create 1 let prefetched_states = Hashtbl.create 1 let fetch_and_create_state name = Hashtbl.remove prefetched_states name ; try Hashtbl.find observed_states name with Not_found -> let s = Data_for_aorai.new_state name in Hashtbl.add observed_states name s; s ;; let prefetch_and_create_state name = if (Hashtbl.mem prefetched_states name) or not (Hashtbl.mem observed_states name) then begin let s= fetch_and_create_state name in Hashtbl.add prefetched_states name name; s end else (fetch_and_create_state name) ;; type pre_cond = Behavior of string | Pre of Promelaast.condition # 91 "src/aorai/yaparser.ml" let yytransl_const = [| 257 (* CALL_OF *); 258 (* RETURN_OF *); 259 (* CALLORRETURN_OF *); 262 (* LCURLY *); 263 (* RCURLY *); 264 (* LPAREN *); 265 (* RPAREN *); 266 (* LSQUARE *); 267 (* RSQUARE *); 268 (* LBRACELBRACE *); 269 (* RBRACERBRACE *); 270 (* RARROW *); 271 (* TRUE *); 272 (* FALSE *); 273 (* NOT *); 274 (* DOT *); 275 (* AMP *); 276 (* COLON *); 277 (* SEMI_COLON *); 278 (* COMMA *); 279 (* PIPE *); 280 (* CARET *); 281 (* QUESTION *); 282 (* COLUMNCOLUMN *); 283 (* EQ *); 284 (* LT *); 285 (* GT *); 286 (* LE *); 287 (* GE *); 288 (* NEQ *); 289 (* PLUS *); 290 (* MINUS *); 291 (* SLASH *); 292 (* STAR *); 293 (* PERCENT *); 294 (* OR *); 295 (* AND *); 296 (* OTHERWISE *); 0 (* EOF *); 0|] let yytransl_block = [| 260 (* IDENTIFIER *); 261 (* INT *); 0|] let yylhs = "\255\255\ \001\000\002\000\002\000\004\000\005\000\005\000\006\000\006\000\ \003\000\003\000\007\000\008\000\008\000\009\000\009\000\009\000\ \011\000\011\000\012\000\012\000\013\000\013\000\013\000\013\000\ \013\000\015\000\015\000\016\000\016\000\010\000\017\000\017\000\ \017\000\017\000\017\000\017\000\017\000\017\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\018\000\ \018\000\018\000\020\000\020\000\020\000\020\000\021\000\021\000\ \021\000\021\000\022\000\022\000\022\000\023\000\023\000\023\000\ \023\000\000\000" let yylen = "\002\000\ \002\000\002\000\001\000\004\000\000\000\002\000\003\000\001\000\ \002\000\001\000\004\000\003\000\001\000\005\000\003\000\002\000\ \001\000\003\000\000\000\001\000\001\000\003\000\006\000\005\000\ \004\000\002\000\003\000\000\000\003\000\002\000\000\000\001\000\ \001\000\001\000\005\000\003\000\004\000\004\000\004\000\004\000\ \004\000\001\000\001\000\002\000\003\000\003\000\003\000\001\000\ \003\000\003\000\003\000\003\000\003\000\003\000\001\000\003\000\ \003\000\001\000\003\000\003\000\003\000\001\000\001\000\002\000\ \001\000\003\000\003\000\004\000\001\000\002\000\005\000\001\000\ \003\000\002\000" let yydefred = "\000\000\ \000\000\000\000\000\000\074\000\000\000\003\000\000\000\000\000\ \000\000\002\000\010\000\000\000\000\000\000\000\009\000\008\000\ \000\000\004\000\000\000\000\000\000\000\000\000\013\000\000\000\ \000\000\000\000\000\000\000\000\063\000\000\000\000\000\042\000\ \043\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \048\000\000\000\062\000\000\000\069\000\016\000\000\000\011\000\ \000\000\007\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\044\000\ \064\000\000\000\000\000\000\000\000\000\034\000\032\000\033\000\ \030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \015\000\012\000\000\000\000\000\000\000\000\000\000\000\000\000\ \026\000\000\000\000\000\047\000\066\000\073\000\000\000\022\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\049\000\ \050\000\051\000\052\000\053\000\054\000\056\000\057\000\059\000\ \060\000\061\000\000\000\067\000\040\000\041\000\039\000\000\000\ \000\000\025\000\000\000\027\000\020\000\000\000\000\000\018\000\ \014\000\000\000\000\000\036\000\000\000\068\000\000\000\071\000\ \024\000\000\000\038\000\037\000\000\000\029\000\023\000\035\000" let yydgoto = "\002\000\ \004\000\005\000\009\000\006\000\013\000\017\000\011\000\022\000\ \023\000\062\000\133\000\134\000\038\000\039\000\057\000\130\000\ \073\000\040\000\041\000\042\000\043\000\044\000\045\000" let yysindex = "\004\000\ \006\255\000\000\069\255\000\000\003\255\000\000\012\255\073\255\ \076\255\000\000\000\000\096\255\088\255\253\254\000\000\000\000\ \105\255\000\000\080\255\127\255\121\255\252\254\000\000\129\255\ \131\255\135\255\137\255\010\255\000\000\102\255\080\255\000\000\ \000\000\102\255\156\255\025\255\160\255\251\254\048\255\208\255\ \000\000\078\255\000\000\005\255\000\000\000\000\138\255\000\000\ \253\254\000\000\166\255\171\255\173\255\055\255\102\255\175\255\ \191\255\193\255\036\255\208\255\005\255\182\255\194\255\000\000\ \000\000\025\255\005\255\192\255\008\255\000\000\000\000\000\000\ \000\000\102\255\102\255\168\255\168\255\168\255\168\255\168\255\ \168\255\168\255\168\255\168\255\168\255\168\255\168\255\203\255\ \000\000\000\000\201\255\202\255\204\255\050\255\220\255\028\255\ \000\000\080\255\222\255\000\000\000\000\000\000\080\255\000\000\ \016\255\237\255\168\255\168\255\255\254\048\255\048\255\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\233\255\000\000\000\000\000\000\000\000\102\255\ \241\255\000\000\235\255\000\000\000\000\224\255\245\255\000\000\ \000\000\002\000\010\000\000\000\161\255\000\000\063\255\000\000\ \000\000\235\255\000\000\000\000\011\000\000\000\000\000\000\000" let yyrindex = "\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\244\255\000\000\ \019\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\153\255\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\113\255\112\000\033\000\ \000\000\255\255\000\000\187\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\119\255\000\000\060\255\046\000\083\255\000\000\000\000\ \000\000\000\000\221\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\121\000\000\000\000\000\ \000\000\014\000\000\000\000\000\000\000\000\000\112\255\000\000\ \000\000\000\000\000\000\000\000\000\000\080\000\089\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\121\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\121\000\000\000\000\000\000\000\000\000\000\000\000\000" let yygindex = "\000\000\ \000\000\000\000\000\000\020\001\000\000\000\000\024\001\000\000\ \241\000\017\001\229\255\194\000\000\000\236\255\000\000\134\255\ \000\000\226\255\000\000\000\000\185\000\228\255\000\000" let yytablesize = 413 let yytable = "\060\000\ \069\000\061\000\019\000\063\000\001\000\140\000\008\000\067\000\ \145\000\059\000\020\000\058\000\029\000\064\000\087\000\107\000\ \048\000\054\000\049\000\070\000\141\000\055\000\088\000\151\000\ \102\000\087\000\095\000\071\000\058\000\108\000\072\000\012\000\ \066\000\088\000\096\000\056\000\021\000\105\000\109\000\003\000\ \132\000\035\000\003\000\036\000\100\000\112\000\113\000\114\000\ \115\000\116\000\117\000\118\000\119\000\110\000\111\000\025\000\ \026\000\027\000\028\000\029\000\036\000\128\000\030\000\094\000\ \031\000\074\000\075\000\129\000\055\000\032\000\033\000\034\000\ \007\000\074\000\075\000\150\000\138\000\139\000\061\000\008\000\ \025\000\026\000\027\000\028\000\029\000\074\000\075\000\030\000\ \035\000\031\000\036\000\017\000\014\000\017\000\032\000\033\000\ \034\000\055\000\055\000\016\000\074\000\075\000\025\000\026\000\ \027\000\058\000\029\000\143\000\018\000\030\000\149\000\083\000\ \084\000\035\000\086\000\036\000\032\000\033\000\034\000\031\000\ \019\000\031\000\019\000\031\000\072\000\072\000\024\000\072\000\ \072\000\072\000\046\000\072\000\050\000\031\000\047\000\035\000\ \072\000\036\000\051\000\072\000\072\000\089\000\052\000\072\000\ \053\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \065\000\072\000\072\000\072\000\058\000\029\000\068\000\148\000\ \107\000\091\000\072\000\058\000\029\000\072\000\092\000\107\000\ \093\000\072\000\097\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \065\000\065\000\035\000\065\000\036\000\065\000\098\000\065\000\ \099\000\035\000\103\000\036\000\104\000\106\000\124\000\065\000\ \065\000\125\000\126\000\065\000\127\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\070\000\070\000\131\000\070\000\135\000\070\000\ \146\000\070\000\076\000\077\000\078\000\079\000\080\000\081\000\ \137\000\070\000\070\000\142\000\144\000\070\000\128\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\058\000\058\000\129\000\058\000\ \005\000\058\000\101\000\058\000\120\000\121\000\122\000\123\000\ \147\000\152\000\001\000\058\000\058\000\006\000\019\000\058\000\ \010\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \015\000\090\000\058\000\037\000\058\000\058\000\055\000\055\000\ \136\000\055\000\000\000\055\000\000\000\055\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\055\000\065\000\000\000\ \000\000\055\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\055\000\000\000\000\000\055\000\000\000\055\000\055\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\046\000\046\000\000\000\ \046\000\000\000\046\000\000\000\046\000\000\000\045\000\045\000\ \000\000\045\000\000\000\045\000\046\000\045\000\000\000\000\000\ \046\000\000\000\000\000\000\000\000\000\045\000\000\000\000\000\ \046\000\045\000\000\000\046\000\000\000\021\000\021\000\000\000\ \021\000\045\000\021\000\000\000\045\000\000\000\028\000\028\000\ \000\000\028\000\000\000\028\000\021\000\000\000\000\000\000\000\ \021\000\000\000\000\000\000\000\000\000\028\000\000\000\000\000\ \021\000\028\000\000\000\021\000\000\000\000\000\000\000\000\000\ \000\000\028\000\000\000\000\000\028\000" let yycheck = "\030\000\ \006\001\030\000\006\001\031\000\001\000\007\001\004\001\036\000\ \131\000\030\000\014\001\004\001\005\001\034\000\010\001\008\001\ \021\001\008\001\023\001\025\001\022\001\012\001\018\001\146\000\ \009\001\010\001\054\000\033\001\004\001\022\001\036\001\020\001\ \008\001\018\001\055\000\026\001\040\001\066\000\069\000\037\001\ \013\001\034\001\037\001\036\001\009\001\076\000\077\000\078\000\ \079\000\080\000\081\000\082\000\083\000\074\000\075\000\001\001\ \002\001\003\001\004\001\005\001\036\001\012\001\008\001\009\001\ \010\001\038\001\039\001\018\001\009\001\015\001\016\001\017\001\ \004\001\038\001\039\001\013\001\107\000\108\000\107\000\004\001\ \001\001\002\001\003\001\004\001\005\001\038\001\039\001\008\001\ \034\001\010\001\036\001\009\001\020\001\011\001\015\001\016\001\ \017\001\038\001\039\001\004\001\038\001\039\001\001\001\002\001\ \003\001\004\001\005\001\128\000\021\001\008\001\141\000\034\001\ \035\001\034\001\037\001\036\001\015\001\016\001\017\001\007\001\ \009\001\009\001\011\001\011\001\006\001\007\001\022\001\009\001\ \010\001\011\001\004\001\013\001\004\001\021\001\014\001\034\001\ \018\001\036\001\008\001\021\001\022\001\004\001\008\001\025\001\ \008\001\027\001\028\001\029\001\030\001\031\001\032\001\033\001\ \034\001\035\001\036\001\037\001\038\001\039\001\006\001\007\001\ \005\001\009\001\010\001\011\001\004\001\005\001\007\001\007\001\ \008\001\004\001\018\001\004\001\005\001\021\001\004\001\008\001\ \004\001\025\001\004\001\027\001\028\001\029\001\030\001\031\001\ \032\001\033\001\034\001\035\001\036\001\037\001\038\001\039\001\ \006\001\007\001\034\001\009\001\036\001\011\001\008\001\013\001\ \008\001\034\001\021\001\036\001\011\001\014\001\004\001\021\001\ \022\001\009\001\009\001\025\001\009\001\027\001\028\001\029\001\ \030\001\031\001\032\001\033\001\034\001\035\001\036\001\037\001\ \038\001\039\001\006\001\007\001\009\001\009\001\009\001\011\001\ \009\001\013\001\027\001\028\001\029\001\030\001\031\001\032\001\ \004\001\021\001\022\001\011\001\004\001\025\001\012\001\027\001\ \028\001\029\001\030\001\031\001\032\001\033\001\034\001\035\001\ \036\001\037\001\038\001\039\001\006\001\007\001\018\001\009\001\ \021\001\011\001\009\001\013\001\084\000\085\000\086\000\087\000\ \007\001\007\001\000\000\021\001\022\001\021\001\009\001\025\001\ \005\000\027\001\028\001\029\001\030\001\031\001\032\001\033\001\ \009\000\049\000\036\001\019\000\038\001\039\001\006\001\007\001\ \103\000\009\001\255\255\011\001\255\255\013\001\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\021\001\009\001\255\255\ \255\255\025\001\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\033\001\255\255\255\255\036\001\255\255\038\001\039\001\ \027\001\028\001\029\001\030\001\031\001\032\001\033\001\034\001\ \035\001\036\001\037\001\038\001\039\001\006\001\007\001\255\255\ \009\001\255\255\011\001\255\255\013\001\255\255\006\001\007\001\ \255\255\009\001\255\255\011\001\021\001\013\001\255\255\255\255\ \025\001\255\255\255\255\255\255\255\255\021\001\255\255\255\255\ \033\001\025\001\255\255\036\001\255\255\006\001\007\001\255\255\ \009\001\033\001\011\001\255\255\036\001\255\255\006\001\007\001\ \255\255\009\001\255\255\011\001\021\001\255\255\255\255\255\255\ \025\001\255\255\255\255\255\255\255\255\021\001\255\255\255\255\ \033\001\025\001\255\255\036\001\255\255\255\255\255\255\255\255\ \255\255\033\001\255\255\255\255\036\001" let yynames_const = "\ CALL_OF\000\ RETURN_OF\000\ CALLORRETURN_OF\000\ LCURLY\000\ RCURLY\000\ LPAREN\000\ RPAREN\000\ LSQUARE\000\ RSQUARE\000\ LBRACELBRACE\000\ RBRACERBRACE\000\ RARROW\000\ TRUE\000\ FALSE\000\ NOT\000\ DOT\000\ AMP\000\ COLON\000\ SEMI_COLON\000\ COMMA\000\ PIPE\000\ CARET\000\ QUESTION\000\ COLUMNCOLUMN\000\ EQ\000\ LT\000\ GT\000\ LE\000\ GE\000\ NEQ\000\ PLUS\000\ MINUS\000\ SLASH\000\ STAR\000\ PERCENT\000\ OR\000\ AND\000\ OTHERWISE\000\ EOF\000\ " let yynames_block = "\ IDENTIFIER\000\ INT\000\ " let yyact = [| (fun _ -> failwith "parser") ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'options) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'states) in Obj.repr( # 104 "src/aorai/yaparser.mly" ( List.iter (fun(key, ids) -> match key with "init" -> List.iter (fun id -> try (Hashtbl.find observed_states id).init <- True with Not_found -> Aorai_option.abort "Error: no state '%s'\n" id) ids | "accept" -> List.iter (fun id -> try (Hashtbl.find observed_states id).acceptation <- True with Not_found -> Aorai_option.abort "no state '%s'\n" id) ids | "deterministic" -> Aorai_option.Deterministic.set true; | oth -> Aorai_option.abort "unknown option '%s'\n" oth ) _1; let states= Hashtbl.fold (fun _ st l -> if st.acceptation=Undefined or st.init=Undefined then begin Aorai_option.abort "Error: the state '%s' is used but never defined.\n" st.name end; st::l) observed_states [] in (try Hashtbl.iter (fun _ st -> if st.init=True then raise Exit) observed_states; Aorai_option.abort "Automaton does not declare an initial state" with Exit -> ()); if Hashtbl.length prefetched_states >0 then begin let r = Hashtbl.fold (fun s n _ -> s^"Error: the state '"^n^"' is used but never defined.\n") prefetched_states "" in Aorai_option.abort "%s" r end; (states, _2) ) # 449 "src/aorai/yaparser.ml" : Promelaast.parsed_automaton)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'options) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'option) in Obj.repr( # 158 "src/aorai/yaparser.mly" ( _1@[_2] ) # 457 "src/aorai/yaparser.ml" : 'options)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'option) in Obj.repr( # 159 "src/aorai/yaparser.mly" ( [_1] ) # 464 "src/aorai/yaparser.ml" : 'options)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 2 : string) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_identifiers) in Obj.repr( # 163 "src/aorai/yaparser.mly" ( (_2, _3) ) # 472 "src/aorai/yaparser.ml" : 'option)) ; (fun __caml_parser_env -> Obj.repr( # 167 "src/aorai/yaparser.mly" ( [] ) # 478 "src/aorai/yaparser.ml" : 'opt_identifiers)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'id_list) in Obj.repr( # 168 "src/aorai/yaparser.mly" ( _2 ) # 485 "src/aorai/yaparser.ml" : 'opt_identifiers)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'id_list) in let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 172 "src/aorai/yaparser.mly" ( _1@[_3] ) # 493 "src/aorai/yaparser.ml" : 'id_list)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 173 "src/aorai/yaparser.mly" ( [_1] ) # 500 "src/aorai/yaparser.ml" : 'id_list)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'states) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'state) in Obj.repr( # 177 "src/aorai/yaparser.mly" ( _1@_2 ) # 508 "src/aorai/yaparser.ml" : 'states)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'state) in Obj.repr( # 178 "src/aorai/yaparser.mly" ( _1 ) # 515 "src/aorai/yaparser.ml" : 'states)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'transitions) in Obj.repr( # 182 "src/aorai/yaparser.mly" ( let start_state = fetch_and_create_state _1 in let (_, transitions) = List.fold_left (fun (otherwise, transitions) (cross,stop_state) -> if otherwise then Aorai_option.abort "'other' directive in definition of %s \ transitions is not the last one" start_state.name else begin let trans = { start=start_state; stop=stop_state; cross=cross; numt=(-1) }::transitions in let otherwise = match cross with | Otherwise -> true | Seq _ -> false in otherwise, trans end) (false,[]) _3 in List.rev transitions ) # 546 "src/aorai/yaparser.ml" : 'state)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'transitions) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'transition) in Obj.repr( # 208 "src/aorai/yaparser.mly" ( _1@[_3] ) # 554 "src/aorai/yaparser.ml" : 'transitions)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'transition) in Obj.repr( # 209 "src/aorai/yaparser.mly" ( [_1] ) # 561 "src/aorai/yaparser.ml" : 'transitions)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 3 : 'seq_elt) in let _5 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 215 "src/aorai/yaparser.mly" ( (Seq _2, prefetch_and_create_state _5) ) # 569 "src/aorai/yaparser.ml" : 'transition)) ; (fun __caml_parser_env -> let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 216 "src/aorai/yaparser.mly" ((Otherwise, prefetch_and_create_state _3) ) # 576 "src/aorai/yaparser.ml" : 'transition)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 217 "src/aorai/yaparser.mly" ( (Seq (to_seq PTrue), prefetch_and_create_state _2) ) # 583 "src/aorai/yaparser.ml" : 'transition)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'seq_elt) in Obj.repr( # 221 "src/aorai/yaparser.mly" ( _1 ) # 590 "src/aorai/yaparser.ml" : 'non_empty_seq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'seq_elt) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'seq) in Obj.repr( # 222 "src/aorai/yaparser.mly" ( _1 @ _3 ) # 598 "src/aorai/yaparser.ml" : 'non_empty_seq)) ; (fun __caml_parser_env -> Obj.repr( # 226 "src/aorai/yaparser.mly" ( [] ) # 604 "src/aorai/yaparser.ml" : 'seq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'non_empty_seq) in Obj.repr( # 227 "src/aorai/yaparser.mly" ( _1 ) # 611 "src/aorai/yaparser.ml" : 'seq)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'single_cond) in Obj.repr( # 231 "src/aorai/yaparser.mly" ( to_seq _1 ) # 618 "src/aorai/yaparser.ml" : 'guard)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'non_empty_seq) in Obj.repr( # 232 "src/aorai/yaparser.mly" ( _2 ) # 625 "src/aorai/yaparser.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 5 : string) in let _2 = (Parsing.peek_val __caml_parser_env 4 : 'pre_cond) in let _4 = (Parsing.peek_val __caml_parser_env 2 : 'seq) in let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_cond) in Obj.repr( # 234 "src/aorai/yaparser.mly" ( let pre_cond = match _2 with | Behavior b -> PCall(_1,Some b) | Pre c -> PAnd (PCall(_1,None), c) in let post_cond = match _6 with | None -> PReturn _1 | Some c -> PAnd (PReturn _1,c) in (to_seq pre_cond) @ _4 @ to_seq post_cond ) # 646 "src/aorai/yaparser.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 4 : string) in let _3 = (Parsing.peek_val __caml_parser_env 2 : 'non_empty_seq) in let _5 = (Parsing.peek_val __caml_parser_env 0 : 'post_cond) in Obj.repr( # 247 "src/aorai/yaparser.mly" ( let post_cond = match _5 with | None -> PReturn _1 | Some c -> PAnd (PReturn _1,c) in (to_seq (PCall (_1, None))) @ _3 @ to_seq post_cond ) # 661 "src/aorai/yaparser.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_cond) in Obj.repr( # 255 "src/aorai/yaparser.mly" ( let post_cond = match _4 with | None -> PReturn _1 | Some c -> PAnd (PReturn _1,c) in (to_seq (PCall (_1, None))) @ to_seq post_cond ) # 675 "src/aorai/yaparser.ml" : 'guard)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 265 "src/aorai/yaparser.mly" ( Behavior _2 ) # 682 "src/aorai/yaparser.ml" : 'pre_cond)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'single_cond) in Obj.repr( # 266 "src/aorai/yaparser.mly" ( Pre _2 ) # 689 "src/aorai/yaparser.ml" : 'pre_cond)) ; (fun __caml_parser_env -> Obj.repr( # 270 "src/aorai/yaparser.mly" ( None ) # 695 "src/aorai/yaparser.ml" : 'post_cond)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'single_cond) in Obj.repr( # 271 "src/aorai/yaparser.mly" ( Some _2 ) # 702 "src/aorai/yaparser.ml" : 'post_cond)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'guard) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'repetition) in Obj.repr( # 275 "src/aorai/yaparser.mly" ( let min, max = _2 in match _1 with | [ s ] when Data_for_aorai.is_single s -> [ { s with min_rep = min; max_rep = max } ] | l -> if is_no_repet (min,max) then l (* [ a; [b;c]; d] is equivalent to [a;b;c;d] *) else [ { condition = None; nested = l; min_rep = min; max_rep = max } ] ) # 719 "src/aorai/yaparser.ml" : 'seq_elt)) ; (fun __caml_parser_env -> Obj.repr( # 289 "src/aorai/yaparser.mly" ( Some Data_for_aorai.cst_one, Some Data_for_aorai.cst_one ) # 725 "src/aorai/yaparser.ml" : 'repetition)) ; (fun __caml_parser_env -> Obj.repr( # 290 "src/aorai/yaparser.mly" ( Some Data_for_aorai.cst_one, None) # 731 "src/aorai/yaparser.ml" : 'repetition)) ; (fun __caml_parser_env -> Obj.repr( # 291 "src/aorai/yaparser.mly" ( None, None ) # 737 "src/aorai/yaparser.ml" : 'repetition)) ; (fun __caml_parser_env -> Obj.repr( # 292 "src/aorai/yaparser.mly" ( None, Some Data_for_aorai.cst_one ) # 743 "src/aorai/yaparser.ml" : 'repetition)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 3 : 'arith_relation) in let _4 = (Parsing.peek_val __caml_parser_env 1 : 'arith_relation) in Obj.repr( # 293 "src/aorai/yaparser.mly" ( Some _2, Some _4 ) # 751 "src/aorai/yaparser.ml" : 'repetition)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'arith_relation) in Obj.repr( # 294 "src/aorai/yaparser.mly" ( Some _2, Some _2 ) # 758 "src/aorai/yaparser.ml" : 'repetition)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in Obj.repr( # 295 "src/aorai/yaparser.mly" ( Some _2, None ) # 765 "src/aorai/yaparser.ml" : 'repetition)) ; (fun __caml_parser_env -> let _3 = (Parsing.peek_val __caml_parser_env 1 : 'arith_relation) in Obj.repr( # 296 "src/aorai/yaparser.mly" ( None, Some _3 ) # 772 "src/aorai/yaparser.ml" : 'repetition)) ; (fun __caml_parser_env -> let _3 = (Parsing.peek_val __caml_parser_env 1 : string) in Obj.repr( # 300 "src/aorai/yaparser.mly" ( POr (PCall (_3,None), PReturn _3) ) # 779 "src/aorai/yaparser.ml" : 'single_cond)) ; (fun __caml_parser_env -> let _3 = (Parsing.peek_val __caml_parser_env 1 : string) in Obj.repr( # 301 "src/aorai/yaparser.mly" ( PCall (_3,None) ) # 786 "src/aorai/yaparser.ml" : 'single_cond)) ; (fun __caml_parser_env -> let _3 = (Parsing.peek_val __caml_parser_env 1 : string) in Obj.repr( # 302 "src/aorai/yaparser.mly" ( PReturn _3 ) # 793 "src/aorai/yaparser.ml" : 'single_cond)) ; (fun __caml_parser_env -> Obj.repr( # 303 "src/aorai/yaparser.mly" ( PTrue ) # 799 "src/aorai/yaparser.ml" : 'single_cond)) ; (fun __caml_parser_env -> Obj.repr( # 304 "src/aorai/yaparser.mly" ( PFalse ) # 805 "src/aorai/yaparser.ml" : 'single_cond)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'single_cond) in Obj.repr( # 305 "src/aorai/yaparser.mly" ( PNot _2 ) # 812 "src/aorai/yaparser.ml" : 'single_cond)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'single_cond) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'single_cond) in Obj.repr( # 306 "src/aorai/yaparser.mly" ( PAnd (_1,_3) ) # 820 "src/aorai/yaparser.ml" : 'single_cond)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'single_cond) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'single_cond) in Obj.repr( # 307 "src/aorai/yaparser.mly" ( POr (_1,_3) ) # 828 "src/aorai/yaparser.ml" : 'single_cond)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'single_cond) in Obj.repr( # 308 "src/aorai/yaparser.mly" ( _2 ) # 835 "src/aorai/yaparser.ml" : 'single_cond)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'logic_relation) in Obj.repr( # 309 "src/aorai/yaparser.mly" ( _1 ) # 842 "src/aorai/yaparser.ml" : 'single_cond)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 313 "src/aorai/yaparser.mly" ( PRel(Eq, _1, _3) ) # 850 "src/aorai/yaparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 314 "src/aorai/yaparser.mly" ( PRel(Lt, _1, _3) ) # 858 "src/aorai/yaparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 315 "src/aorai/yaparser.mly" ( PRel(Gt, _1, _3) ) # 866 "src/aorai/yaparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 316 "src/aorai/yaparser.mly" ( PRel(Le, _1, _3) ) # 874 "src/aorai/yaparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 317 "src/aorai/yaparser.mly" ( PRel(Ge, _1, _3) ) # 882 "src/aorai/yaparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 318 "src/aorai/yaparser.mly" ( PRel(Neq, _1, _3) ) # 890 "src/aorai/yaparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 319 "src/aorai/yaparser.mly" ( PRel (Neq, _1, PCst(IntConstant "0")) ) # 897 "src/aorai/yaparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 323 "src/aorai/yaparser.mly" ( PBinop(Badd,_1,_3) ) # 905 "src/aorai/yaparser.ml" : 'arith_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 324 "src/aorai/yaparser.mly" ( PBinop(Bsub,_1,_3) ) # 913 "src/aorai/yaparser.ml" : 'arith_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation_mul) in Obj.repr( # 325 "src/aorai/yaparser.mly" ( _1 ) # 920 "src/aorai/yaparser.ml" : 'arith_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'access_or_const) in Obj.repr( # 329 "src/aorai/yaparser.mly" ( PBinop(Bdiv,_1,_3) ) # 928 "src/aorai/yaparser.ml" : 'arith_relation_mul)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'access_or_const) in Obj.repr( # 330 "src/aorai/yaparser.mly" ( PBinop(Bmul, _1, _3) ) # 936 "src/aorai/yaparser.ml" : 'arith_relation_mul)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'access_or_const) in Obj.repr( # 331 "src/aorai/yaparser.mly" ( PBinop(Bmod, _1, _3) ) # 944 "src/aorai/yaparser.ml" : 'arith_relation_mul)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'access_or_const) in Obj.repr( # 332 "src/aorai/yaparser.mly" ( _1 ) # 951 "src/aorai/yaparser.ml" : 'arith_relation_mul)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 337 "src/aorai/yaparser.mly" ( PCst (IntConstant _1) ) # 958 "src/aorai/yaparser.ml" : 'access_or_const)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 338 "src/aorai/yaparser.mly" ( PUnop (Uminus, PCst (IntConstant _2)) ) # 965 "src/aorai/yaparser.ml" : 'access_or_const)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'access) in Obj.repr( # 339 "src/aorai/yaparser.mly" ( _1 ) # 972 "src/aorai/yaparser.ml" : 'access_or_const)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'arith_relation) in Obj.repr( # 340 "src/aorai/yaparser.mly" ( _2 ) # 979 "src/aorai/yaparser.ml" : 'access_or_const)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'access) in let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 345 "src/aorai/yaparser.mly" ( PField(_1,_3) ) # 987 "src/aorai/yaparser.ml" : 'access)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'access) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'access_or_const) in Obj.repr( # 346 "src/aorai/yaparser.mly" ( PArrget(_1,_3) ) # 995 "src/aorai/yaparser.ml" : 'access)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'access_leaf) in Obj.repr( # 347 "src/aorai/yaparser.mly" (_1) # 1002 "src/aorai/yaparser.ml" : 'access)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'access) in Obj.repr( # 351 "src/aorai/yaparser.mly" ( PUnop (Ustar,_2) ) # 1009 "src/aorai/yaparser.ml" : 'access_leaf)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 4 : string) in let _5 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 352 "src/aorai/yaparser.mly" ( PPrm(_1,_5) ) # 1017 "src/aorai/yaparser.ml" : 'access_leaf)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 353 "src/aorai/yaparser.mly" ( PVar _1 ) # 1024 "src/aorai/yaparser.ml" : 'access_leaf)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'access) in Obj.repr( # 354 "src/aorai/yaparser.mly" ( _2 ) # 1031 "src/aorai/yaparser.ml" : 'access_leaf)) (* Entry main *) ; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) |] let yytables = { Parsing.actions=yyact; Parsing.transl_const=yytransl_const; Parsing.transl_block=yytransl_block; Parsing.lhs=yylhs; Parsing.len=yylen; Parsing.defred=yydefred; Parsing.dgoto=yydgoto; Parsing.sindex=yysindex; Parsing.rindex=yyrindex; Parsing.gindex=yygindex; Parsing.tablesize=yytablesize; Parsing.table=yytable; Parsing.check=yycheck; Parsing.error_function=parse_error; Parsing.names_const=yynames_const; Parsing.names_block=yynames_block } let main (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = (Parsing.yyparse yytables 1 lexfun lexbuf : Promelaast.parsed_automaton) frama-c-Fluorine-20130601/src/aorai/data_for_aorai.mli0000644000175000017500000003666512155630222021332 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 Promelaast (** Module of data management used in all the plugin Aorai. Operations are mainly accessors for data. The use of this module is mainly done through the ltl_utils module. *) (* ************************************************************************* *) (** {2 LTL/Promela primitives} *) (* ************************************************************************* *) (** Here are some operations used for generation of LTL AST or Promela AST. *) module Aorai_state: Datatype.S_with_collections with type t = Promelaast.state module Aorai_typed_trans: Datatype.S_with_collections with type t = (Promelaast.typed_condition * Promelaast.action) Promelaast.trans (** Initializes some tables according to data from Cil AST. *) val setCData : unit -> unit (** *) val add_logic : string -> Cil_types.logic_info -> unit (** *) val get_logic : string -> Cil_types.logic_info (** *) val add_predicate : string -> Cil_types.logic_info -> unit (** *) val get_predicate : string -> Cil_types.logic_info (** Given a logic info representing a set of pebbles and a label, returns the term corresponding to evaluating the set at the label. *) val pebble_set_at: Cil_types.logic_info -> Cil_types.logic_label -> Cil_types.term (** Global auxiliary variables generated during type-checking of transitions *) val aux_variables: unit -> Cil_types.varinfo list (** Global logic info generated during type-checking (mostly encoding of ghost variables having a logic type) *) val abstract_logic_info: unit -> Cil_types.logic_info list (** {2 Smart constructors for conditions} *) (**/**) val pand: condition -> condition -> condition val por: condition -> condition -> condition val pnot: condition -> condition val cst_one: expression val cst_zero: expression (** {2 Utilities for parsed_conditions } *) (** [true] iff the expression is 1 *) val is_cst_one: expression -> bool val is_cst_zero: expression -> bool (** [true] if the element is not repeating itself ([min_rep = max_rep = 1]) *) val is_single: seq_elt -> bool (* ************************************************************************* *) (**{b Constants} Some constant names used for generation. *) (** Returns a string guaranteed not to clash with C/ACSL keywords or an existing global. @since Nitrogen-20111001 *) val get_fresh: string -> string (* Logic variables *) (** Name of TransStart logic generated variable *) val transStart : string (** Name of transStop logic generated variable *) val transStop : string (** Name of transCond logic generated variable *) val transCond : string (** Name of transCondP logic generated variable *) val transCondP : string (** Name of the fresh loopInit logic generated variable *) val loopInit : string (** C variables *) (** Name of curOp C generated variable (Name of the curent operation) *) val curOp : string (** Name of curOpStatus C generated variable (Status Return or Call of the curent operation) *) val curOpStatus : string (** Name of curState C generated variable (Table of states that can be synchronized with the program) *) val curState : string (** Name of curStateOld C generated variable (Last value of curState) *) val curStateOld : string (** Name of curTrans C generated variable (Last transitions that can be crossed) *) val curTrans : string (*val curTransTmp : string DEPRECATED *) (** Name of acceptSt C generated variable (List of acceptation States) *) val acceptSt : string (* C constants #define -- DEPRECATED ?*) (** DEPRECATED ?*) val nbOp : string (** DEPRECATED ?*) val nbStates : string (** DEPRECATED ?*) val nbAcceptSt : string (** DEPRECATED ?*) val nbTrans : string (* C Macros *) (** DEPRECATED ?*) val macro_ligth : string (** DEPRECATED ?*) val macro_full : string (** DEPRECATED ?*) val macro_pure : string (** returns the C variable associated to a given state (non-deterministic mode only). *) val get_state_var: state -> varinfo (** returns the logic variable associated to a given state. (non-deterministic mode only). *) val get_state_logic_var: state -> logic_var (* C enumeration *) (** Name of listOp C generated enumeration (List of operation names prefixed with 'op_') *) val listOp : string (** Name of listStatus C generated enumeration (Status are Call or Return) *) val listStatus : string (** Name of callStatus C generated enumeration (Name of the Call status) *) val callStatus : string (** Name of termStatus C generated enumeration (Name of the return status) *) val termStatus : string (** Name of the enum type representing states *) val states : string (* C function -- DEPRECATED *) (** DEPRECATED ?*) val buch_sync : string (* ************************************************************************* *) (**{b Buchi automata management}*) val new_state: string -> state val new_trans: state -> state -> 'a -> 'a trans (** Return the buchi automata as stored after parsing *) val getAutomata : unit -> Promelaast.typed_automaton (** Type-checks the parsed automaton and stores the result. This might introduce new global variables in case of sequences. *) val setAutomata: Promelaast.parsed_automaton -> unit (** return the number of transitions of the automata *) val getNumberOfTransitions : unit -> int (** return the number of states of the automata *) val getNumberOfStates : unit -> int (** Return the list of all function name observed in the C file. *) val getFunctions_from_c : unit -> string list (** Return the list of all variables name observed in the C file. *) val getVariables_from_c : unit -> string list (** Return the list of names of all ignored functions. A function is ignored if it is used in C file and if its declaration is unavailable. *) val getIgnoredFunctions : unit -> string list (** Return the list of names of all ignored functions. A function is ignored if it is used in C file and if its declaration is unavailable. *) val addIgnoredFunction : string -> unit (** Return true if and only if the given string fname denotes an ignored function. *) val isIgnoredFunction : string -> bool (** returns the state of given index. @since Nitrogen-20111001 *) val getState: int -> Promelaast.state val getStateName : int -> string (** [true] iff the given state is the rejection state for automaton with sequences. *) val is_reject_state: state -> bool (** returns the transition having the corresponding id. @raise Not_found if this is not the case. *) val getTransition: int -> (Promelaast.typed_condition * Promelaast.action) Promelaast.trans (* ************************************************************************* *) (**{b Variables information} Usually it seems very useful to access to varinfo structure of a variable by using only its name. These functions allow that. In practice it contains all variables (from promela and globals from C file) and only variables. *) (** Add a new variable into the association table name -> varinfo *) val set_varinfo : string -> Cil_types.varinfo -> unit (** Given a variable name, it returns its associated varinfo. If the variable is not found then an error message is print and an assert false is raised. *) val get_varinfo : string -> Cil_types.varinfo (** Same as get_varinfo, but the result is an option. Hence, if the variable is not found then None is return. *) val get_varinfo_option : string -> Cil_types.varinfo option (** get the logic variable corresponding to its C counterpart. @since Nitrogen-20111001 *) val get_logic_var: string -> Cil_types.logic_var (** Add a new param into the association table (funcname,paramname) -> varinfo *) val set_paraminfo : string -> string -> Cil_types.varinfo -> unit (** Given a function name and a param name, it returns the varinfo associated to the given param. If the variable is not found then an error message is print and an assert false is raised. *) val get_paraminfo : string -> string -> Cil_types.varinfo (** Add a new param into the association table (funcname,paramname) -> varinfo *) val set_returninfo : string -> Cil_types.varinfo -> unit (** Given a function name and a param name, it returns the varinfo associated to the given param. If the variable is not found then an error message is print and an assert false is raised. *) val get_returninfo : string -> Cil_types.varinfo (** Given the representation of an auxiliary counter (found in a {!Promelaast.Counter_incr}), returns the maximal value that it can take according to the automaton. *) val find_max_value: Cil_types.term -> Cil_types.term option (** information we have about the range of values that an auxiliary variable can take. *) type range = | Fixed of int (** constant value *) | Interval of int * int (** range of values *) | Bounded of int * Cil_types.term (** range bounded by a logic term (depending on program parameter). *) | Unbounded of int (** only the lower bound is known, there is no upper bound *) module Range: Datatype.S_with_collections with type t = range module Intervals: Datatype.S with type t = range Cil_datatype.Term.Map.t module Vals: Datatype.S with type t = Intervals.t Cil_datatype.Term.Map.t (** Given a term and a minimal value, returns the absolute range of variation of the corresponding auxiliary variable, depending on its usage in the instrumentation of the code. *) val absolute_range: Cil_types.term -> int -> Range.t (** Given an auxiliary variable, a base for its variations and two ranges of variations, returns a range that encompasses both. *) val merge_range: Cil_types.term -> Cil_types.term -> Range.t -> Range.t -> Range.t (** {2 Dataflow analysis} *) val tlval: Cil_types.term_lval -> Cil_types.term (** The propagated state: Mapping from possible start states to reachable states, with - set of states for the initial transition leading to the corresponding reachable state. - set of states for the last transition. - possible values for intermediate variables. *) type end_state = (Aorai_state.Set.t * Aorai_state.Set.t * Vals.t) Aorai_state.Map.t module Case_state: Datatype.S with type t = end_state Aorai_state.Map.t type state = Case_state.t val pretty_state: Format.formatter -> state -> unit (** [included_state st1 st2] is [true] iff [st1] is included in [st2], i.e: - possible start states of [st1] are included in [st2] - for each possible start state, reachable states in [st1] are included in the one of [st2] - for each possible path in [st1], range of possible values for intermediate variables are included in the corresponding one in [st2]. *) val included_state: state -> state -> bool (** merges two sets of possible bindings for aux variables *) val merge_bindings: Vals.t -> Vals.t -> Vals.t val merge_end_state: end_state -> end_state -> end_state (** Merges two state: union of possible start states, of possible paths, and merge of ranges of possible values. *) val merge_state: state -> state -> state (** Register a new init state for kernel function. If there is already an init state registered, the new one is merged with the old. *) val set_kf_init_state: Kernel_function.t -> state -> unit (** Register a new end state for kernel function. If there is already an end state registered, the new one is merged with the old. *) val set_kf_return_state: Kernel_function.t -> state -> unit (** sets the initial state when entering a loop (merging it if a state is already present. *) val set_loop_init_state: Cil_types.stmt -> state -> unit (** sets the invariant of a loop. *) val set_loop_invariant_state: Cil_types.stmt -> state -> unit val replace_kf_init_state: Kernel_function.t -> state -> unit val replace_kf_return_state: Kernel_function.t -> state -> unit val replace_loop_init_state: Cil_types.stmt -> state -> unit val replace_loop_invariant_state: Cil_types.stmt -> state -> unit val get_kf_init_state: Kernel_function.t -> state val get_kf_return_state: Kernel_function.t -> state val get_loop_init_state: Cil_types.stmt -> state val get_loop_invariant_state: Cil_types.stmt -> state val debug_computed_state: unit -> unit (** Pretty-prints all computed states. Depends on dataflow debug category. *) (* ************************************************************************* *) (**{b Enumeration management}*) (** Given the name of an enumeration element, this function returns the associated cenum structure. This function is not efficient. Thus if the enumeration is known it is recommended to use one of the following functions.*) val get_cenum_option : string -> Cil_types.constant option val func_enum_type: unit -> Cil_types.typ val status_enum_type: unit -> Cil_types.typ (** Given the name of a C operation, this function returns the associated cenum structure. *) val func_to_cenum : string -> Cil_types.constant (** Given the name of a C operation status (Call or Return), this function returns the associated cenum structure. *) val op_status_to_cenum : Promelaast.funcStatus -> Cil_types.constant (** Given the name of a function, it return the name of the associated element in the operation list. *) val func_to_op_func : string -> string (** These functions are direct accesses to the table memorizing the enuminfo data associated to the name of an enumeration structure, from which cenum info are computed.*) val set_usedinfo : string -> Cil_types.enuminfo -> unit (** These functions are direct accesses to the table memorizing the enuminfo data associated to the name of an enumeration structure, from which cenum info are computed.*) val get_usedinfo : string -> Cil_types.enuminfo val removeUnusedTransitionsAndStates : unit -> unit (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/ltllexer.ml0000444000175000017500000020610312155634032020045 0ustar mehdimehdi# 30 "src/aorai/ltllexer.mll" open Ltlparser open Lexing let loc lexbuf = (lexeme_start_p lexbuf, lexeme_end_p lexbuf) (*let lex_error lexbuf s = ()*) (* Creport.raise_located (loc lexbuf) (AnyMessage ("lexical error: " ^ s)) *) let buf = Buffer.create 1024 let newline lexbuf = let pos = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum } (* Update the current location with file name and line number. *) (* let update_loc lexbuf file line absolute chars = let pos = lexbuf.lex_curr_p in let new_file = match file with | None -> pos.pos_fname | Some s -> s in lexbuf.lex_curr_p <- { pos with pos_fname = new_file; pos_lnum = if absolute then line else pos.pos_lnum + line; pos_bol = pos.pos_cnum - chars; } *) exception Error of (Lexing.position * Lexing.position) * string let raise_located loc e = raise (Error (loc, e)) # 41 "src/aorai/ltllexer.ml" let __ocaml_lex_tables = { Lexing.lex_base = "\000\000\215\255\216\255\077\000\152\000\219\255\002\000\162\000\ \237\000\227\255\228\255\229\255\231\255\232\255\016\000\056\001\ \235\255\003\000\071\001\031\000\001\000\011\000\033\000\075\000\ \252\255\253\255\146\001\221\001\040\002\115\002\190\002\009\003\ \084\003\159\003\234\003\241\255\251\255\034\000\250\255\249\255\ \248\255\236\255\053\004\128\004\203\004\022\005\097\005\172\005\ \247\005\066\006\141\006\216\006\237\255\035\007\230\255\129\000\ \222\255\221\255\045\007\120\007\195\007\014\008\089\008\164\008\ \239\008\058\009\133\009\208\009\027\010\102\010\177\010\252\010\ \071\011\146\011\221\011\040\012\131\000\252\255\253\255\254\255\ \012\000\255\255"; Lexing.lex_backtrk = "\255\255\255\255\255\255\038\000\037\000\255\255\035\000\038\000\ \038\000\255\255\255\255\255\255\255\255\255\255\022\000\021\000\ \255\255\016\000\038\000\008\000\029\000\040\000\015\000\040\000\ \255\255\255\255\038\000\038\000\038\000\038\000\000\000\038\000\ \038\000\038\000\001\000\255\255\255\255\017\000\255\255\255\255\ \255\255\255\255\038\000\038\000\038\000\038\000\038\000\009\000\ \010\000\011\000\012\000\013\000\255\255\037\000\255\255\255\255\ \255\255\255\255\038\000\038\000\030\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\032\000\038\000\ \038\000\038\000\038\000\031\000\255\255\255\255\255\255\255\255\ \003\000\255\255"; Lexing.lex_default = "\001\000\000\000\000\000\255\255\255\255\000\000\255\255\255\255\ \255\255\000\000\000\000\000\000\000\000\000\000\255\255\255\255\ \000\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \000\000\000\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\000\000\000\000\255\255\000\000\000\000\ \000\000\000\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\000\000\255\255\000\000\055\000\ \000\000\000\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\077\000\000\000\000\000\000\000\ \255\255\000\000"; Lexing.lex_trans = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\006\000\005\000\006\000\006\000\006\000\006\000\006\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \006\000\019\000\006\000\000\000\000\000\012\000\020\000\040\000\ \025\000\024\000\013\000\016\000\000\000\015\000\011\000\014\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\056\000\081\000\022\000\023\000\017\000\055\000\ \052\000\003\000\003\000\008\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\007\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\010\000\041\000\009\000\037\000\018\000\ \038\000\003\000\003\000\003\000\003\000\003\000\026\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\027\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\021\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\039\000\ \035\000\036\000\000\000\057\000\000\000\078\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\003\000\080\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\003\000\003\000\003\000\003\000\071\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \002\000\003\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\058\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\003\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\000\000\000\000\000\000\000\000\054\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\255\255\000\000\079\000\000\000\000\000\000\000\000\000\ \003\000\003\000\003\000\003\000\003\000\045\000\046\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\043\000\003\000\003\000\044\000\003\000\003\000\042\000\ \003\000\003\000\000\000\000\000\000\000\000\000\003\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\003\000\000\000\031\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\003\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\028\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\003\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\029\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\003\000\000\000\003\000\003\000\003\000\003\000\ \030\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\003\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \003\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\032\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\003\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\033\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\003\000\000\000\ \003\000\003\000\003\000\003\000\034\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\003\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\051\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\050\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\049\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\048\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \047\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\003\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\003\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\003\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\003\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\003\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\059\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\003\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\060\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\003\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\061\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\062\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\003\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\063\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \003\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\064\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\065\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\003\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\003\000\003\000\003\000\003\000\066\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\003\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\067\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\003\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\068\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\003\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\069\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\003\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\070\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\003\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \003\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \072\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\003\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\073\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\003\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\074\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\003\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\075\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\003\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\003\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\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\006\000\000\000\000\000\006\000\006\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\ \000\000\000\000\006\000\255\255\255\255\000\000\000\000\020\000\ \000\000\000\000\000\000\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\014\000\080\000\000\000\000\000\000\000\014\000\ \017\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \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\000\000\022\000\000\000\ \037\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\021\000\ \023\000\023\000\255\255\055\000\255\255\076\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \255\255\255\255\255\255\255\255\003\000\076\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\007\000\007\000\007\000\007\000\007\000\007\000\ \007\000\007\000\007\000\007\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\007\000\007\000\007\000\007\000\007\000\ \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ \007\000\007\000\007\000\007\000\007\000\255\255\255\255\255\255\ \000\000\007\000\255\255\007\000\007\000\007\000\007\000\007\000\ \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ \007\000\007\000\007\000\007\000\007\000\008\000\008\000\008\000\ \008\000\008\000\008\000\008\000\008\000\008\000\008\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\008\000\008\000\ \008\000\008\000\008\000\008\000\008\000\008\000\008\000\008\000\ \008\000\008\000\008\000\008\000\008\000\008\000\008\000\008\000\ \008\000\008\000\008\000\008\000\008\000\008\000\008\000\008\000\ \255\255\255\255\255\255\255\255\008\000\255\255\008\000\008\000\ \008\000\008\000\008\000\008\000\008\000\008\000\008\000\008\000\ \008\000\008\000\008\000\008\000\008\000\008\000\008\000\008\000\ \008\000\008\000\008\000\008\000\008\000\008\000\008\000\008\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\255\255\255\255\255\255\255\255\015\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\055\000\255\255\076\000\255\255\255\255\255\255\255\255\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\255\255\255\255\255\255\255\255\018\000\255\255\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\255\255\255\255\255\255\ \255\255\026\000\255\255\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \255\255\255\255\255\255\255\255\027\000\255\255\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\255\255\255\255\255\255\255\255\028\000\ \255\255\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\255\255\255\255\ \255\255\255\255\029\000\255\255\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\255\255\255\255\255\255\255\255\030\000\255\255\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\255\255\255\255\255\255\255\255\ \031\000\255\255\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\255\255\ \255\255\255\255\255\255\032\000\255\255\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\255\255\255\255\255\255\255\255\033\000\255\255\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\255\255\255\255\255\255\ \255\255\034\000\255\255\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \255\255\255\255\255\255\255\255\042\000\255\255\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\255\255\255\255\255\255\255\255\043\000\ \255\255\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\255\255\255\255\ \255\255\255\255\044\000\255\255\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\255\255\255\255\255\255\255\255\045\000\255\255\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\255\255\255\255\255\255\255\255\ \046\000\255\255\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\255\255\ \255\255\255\255\255\255\047\000\255\255\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\255\255\255\255\255\255\255\255\048\000\255\255\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\255\255\255\255\255\255\ \255\255\049\000\255\255\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \255\255\255\255\255\255\255\255\050\000\255\255\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\255\255\255\255\255\255\255\255\051\000\ \255\255\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \255\255\255\255\255\255\255\255\058\000\255\255\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\255\255\255\255\255\255\255\255\059\000\ \255\255\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\255\255\255\255\ \255\255\255\255\060\000\255\255\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\061\000\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ \061\000\255\255\255\255\255\255\255\255\061\000\255\255\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ \061\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\255\255\255\255\255\255\255\255\ \062\000\255\255\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\063\000\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\063\000\063\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\063\000\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\063\000\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\063\000\063\000\063\000\255\255\ \255\255\255\255\255\255\063\000\255\255\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\063\000\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\063\000\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\063\000\063\000\063\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\255\255\255\255\255\255\255\255\064\000\255\255\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\255\255\255\255\255\255\ \255\255\065\000\255\255\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \255\255\255\255\255\255\255\255\066\000\255\255\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\255\255\255\255\255\255\255\255\067\000\ \255\255\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\255\255\255\255\ \255\255\255\255\068\000\255\255\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\255\255\255\255\255\255\255\255\069\000\255\255\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\255\255\255\255\255\255\255\255\ \070\000\255\255\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\255\255\ \255\255\255\255\255\255\071\000\255\255\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\255\255\255\255\255\255\255\255\072\000\255\255\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\255\255\255\255\255\255\ \255\255\073\000\255\255\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \255\255\255\255\255\255\255\255\074\000\255\255\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\255\255\255\255\255\255\255\255\075\000\ \255\255\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\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\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 -> # 77 "src/aorai/ltllexer.mll" ( LTL_TRUE ) # 946 "src/aorai/ltllexer.ml" | 1 -> # 78 "src/aorai/ltllexer.mll" ( LTL_FALSE ) # 951 "src/aorai/ltllexer.ml" | 2 -> # 79 "src/aorai/ltllexer.mll" ( LTL_LPAREN ) # 956 "src/aorai/ltllexer.ml" | 3 -> # 80 "src/aorai/ltllexer.mll" ( LTL_RPAREN ) # 961 "src/aorai/ltllexer.ml" | 4 -> # 83 "src/aorai/ltllexer.mll" ( LTL_IMPLIES ) # 966 "src/aorai/ltllexer.ml" | 5 -> # 84 "src/aorai/ltllexer.mll" ( LTL_LEFT_RIGHT_ARROW ) # 971 "src/aorai/ltllexer.ml" | 6 -> # 85 "src/aorai/ltllexer.mll" ( LTL_OR ) # 976 "src/aorai/ltllexer.ml" | 7 -> # 86 "src/aorai/ltllexer.mll" ( LTL_AND ) # 981 "src/aorai/ltllexer.ml" | 8 -> # 87 "src/aorai/ltllexer.mll" ( LTL_NOT ) # 986 "src/aorai/ltllexer.ml" | 9 -> # 88 "src/aorai/ltllexer.mll" ( LTL_GLOBALLY ) # 991 "src/aorai/ltllexer.ml" | 10 -> # 89 "src/aorai/ltllexer.mll" ( LTL_FATALLY ) # 996 "src/aorai/ltllexer.ml" | 11 -> # 90 "src/aorai/ltllexer.mll" ( LTL_UNTIL ) # 1001 "src/aorai/ltllexer.ml" | 12 -> # 91 "src/aorai/ltllexer.mll" ( LTL_RELEASE ) # 1006 "src/aorai/ltllexer.ml" | 13 -> # 92 "src/aorai/ltllexer.mll" ( LTL_NEXT ) # 1011 "src/aorai/ltllexer.ml" | 14 -> # 96 "src/aorai/ltllexer.mll" ( LTL_EQ ) # 1016 "src/aorai/ltllexer.ml" | 15 -> # 97 "src/aorai/ltllexer.mll" ( LTL_LT ) # 1021 "src/aorai/ltllexer.ml" | 16 -> # 98 "src/aorai/ltllexer.mll" ( LTL_GT ) # 1026 "src/aorai/ltllexer.ml" | 17 -> # 99 "src/aorai/ltllexer.mll" ( LTL_LE ) # 1031 "src/aorai/ltllexer.ml" | 18 -> # 100 "src/aorai/ltllexer.mll" ( LTL_GE ) # 1036 "src/aorai/ltllexer.ml" | 19 -> # 101 "src/aorai/ltllexer.mll" ( LTL_NEQ ) # 1041 "src/aorai/ltllexer.ml" | 20 -> # 104 "src/aorai/ltllexer.mll" ( LTL_PLUS ) # 1046 "src/aorai/ltllexer.ml" | 21 -> # 105 "src/aorai/ltllexer.mll" ( LTL_MINUS ) # 1051 "src/aorai/ltllexer.ml" | 22 -> # 106 "src/aorai/ltllexer.mll" ( LTL_DIV ) # 1056 "src/aorai/ltllexer.ml" | 23 -> # 107 "src/aorai/ltllexer.mll" ( LTL_STAR ) # 1061 "src/aorai/ltllexer.ml" | 24 -> # 108 "src/aorai/ltllexer.mll" ( LTL_MODULO) # 1066 "src/aorai/ltllexer.ml" | 25 -> # 111 "src/aorai/ltllexer.mll" ( LTL_RIGHT_ARROW ) # 1071 "src/aorai/ltllexer.ml" | 26 -> # 112 "src/aorai/ltllexer.mll" ( LTL_DOT ) # 1076 "src/aorai/ltllexer.ml" | 27 -> # 113 "src/aorai/ltllexer.mll" ( LTL_LEFT_SQUARE) # 1081 "src/aorai/ltllexer.ml" | 28 -> # 114 "src/aorai/ltllexer.mll" ( LTL_RIGHT_SQUARE) # 1086 "src/aorai/ltllexer.ml" | 29 -> # 115 "src/aorai/ltllexer.mll" ( LTL_ADRESSE ) # 1091 "src/aorai/ltllexer.ml" | 30 -> # 116 "src/aorai/ltllexer.mll" ( LTL_CALL ) # 1096 "src/aorai/ltllexer.ml" | 31 -> # 117 "src/aorai/ltllexer.mll" ( LTL_RETURN ) # 1101 "src/aorai/ltllexer.ml" | 32 -> # 118 "src/aorai/ltllexer.mll" ( LTL_CALL_OR_RETURN ) # 1106 "src/aorai/ltllexer.ml" | 33 -> # 121 "src/aorai/ltllexer.mll" ( comment lexbuf; token lexbuf ) # 1111 "src/aorai/ltllexer.ml" | 34 -> # 122 "src/aorai/ltllexer.mll" ( newline lexbuf; token lexbuf ) # 1116 "src/aorai/ltllexer.ml" | 35 -> # 125 "src/aorai/ltllexer.mll" ( token lexbuf ) # 1121 "src/aorai/ltllexer.ml" | 36 -> # 126 "src/aorai/ltllexer.mll" ( newline lexbuf; token lexbuf ) # 1126 "src/aorai/ltllexer.ml" | 37 -> # 129 "src/aorai/ltllexer.mll" ( LTL_INT (lexeme lexbuf) ) # 1131 "src/aorai/ltllexer.ml" | 38 -> # 130 "src/aorai/ltllexer.mll" ( LTL_LABEL (lexeme lexbuf) ) # 1136 "src/aorai/ltllexer.ml" | 39 -> # 133 "src/aorai/ltllexer.mll" ( EOF ) # 1141 "src/aorai/ltllexer.ml" | 40 -> # 134 "src/aorai/ltllexer.mll" ( raise_located (loc lexbuf) (Format.sprintf "Illegal_character %s\n" (lexeme lexbuf)) ) # 1149 "src/aorai/ltllexer.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_token_rec lexbuf __ocaml_lex_state and comment lexbuf = __ocaml_lex_comment_rec lexbuf 76 and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 140 "src/aorai/ltllexer.mll" ( () ) # 1160 "src/aorai/ltllexer.ml" | 1 -> # 141 "src/aorai/ltllexer.mll" ( raise_located (loc lexbuf) "Unterminated_comment\n" ) # 1165 "src/aorai/ltllexer.ml" | 2 -> # 142 "src/aorai/ltllexer.mll" ( newline lexbuf; comment lexbuf ) # 1170 "src/aorai/ltllexer.ml" | 3 -> # 143 "src/aorai/ltllexer.mll" ( comment lexbuf ) # 1175 "src/aorai/ltllexer.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_comment_rec lexbuf __ocaml_lex_state ;; # 146 "src/aorai/ltllexer.mll" let parse c = let lb = from_channel c in try Ltlparser.ltl token lb with Parsing.Parse_error | Invalid_argument _ -> raise_located (loc lb) "Syntax error" # 1191 "src/aorai/ltllexer.ml" frama-c-Fluorine-20130601/src/aorai/aorai_utils.mli0000644000175000017500000001533612155630222020703 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 Promelaast (** Given a transition a function and a function status (call or return) it returns if the cross condition can be statisfied with only function status. *) val isCrossable: (typed_condition * action) trans -> kernel_function -> funcStatus -> bool (** Given a transition and the main entry point it returns if the cross condition can be statisfied at the beginning of the program. *) val isCrossableAtInit: (typed_condition * action) trans -> kernel_function -> bool (** This function rewrites a cross condition into an ACSL expression. Moreover, by giving current operation name and its status (call or return) the generation simplifies the generated expression. *) val crosscond_to_pred: typed_condition -> kernel_function -> funcStatus -> Cil_types.predicate Cil_types.named (** {b Globals management} *) (** Copy the file pointer locally in the class in order to easiest globals management and initializes some tables. *) val initFile : Cil_types.file -> unit (** Given the name of the main function, this function computes all newly introduced globals (variables, enumeration structure, invariants, etc.) *) val initGlobals : Cil_types.kernel_function -> bool -> unit (* ************************************************************************* *) (** {b Pre/post management} *) (**{b Pre and post condition of C functions} In our point of view, the pre or the post condition of a C function are defined by the set of states authorized just before/after the call, as such as the set of crossable transitions. The following functions generates abstract pre and post-conditions by using only informations deduced from the buchi automata. *) (** base lhost corresponding to curState. *) val host_state_term: unit -> Cil_types.term_lval (** returns the predicate saying that automaton is in corresponding state. *) val is_state_pred: state -> Cil_types.predicate Cil_types.named (** returns the predicate saying that automaton is NOT in corresponding state. *) val is_out_of_state_pred: state -> Cil_types.predicate Cil_types.named (** returns assigns clause corresponding to updating automaton's state. @since Nitrogen-20111001 *) val aorai_assigns: Cil_types.location -> Cil_types.identified_term Cil_types.assigns (** returns the list of predicates expressing that for each current state the automaton currently is in, there is at least one transition that is crossed. *) val force_transition: Cil_types.location -> kernel_function -> Promelaast.funcStatus -> Data_for_aorai.state -> Cil_types.identified_predicate list (** return list of preconditions for the given auxiliary function (f_pre_func or f_post_func). *) val auto_func_preconditions: Cil_types.location -> kernel_function -> Promelaast.funcStatus -> Data_for_aorai.state -> Cil_types.identified_predicate list (** auto_func_behaviors f st (st_status, tr_status) generates behaviors corresponding to the transitions authorized by tr_status for function f in status st @since Nitrogen-20111001 *) val auto_func_behaviors: Cil_types.location -> kernel_function -> Promelaast.funcStatus -> Data_for_aorai.state -> Cil_types.funbehavior list val get_preds_pre_wrt_params : kernel_function -> Cil_types.predicate Cil_types.named val get_preds_post_bc_wrt_params : kernel_function -> Cil_types.predicate Cil_types.named (** Returns a list of predicate giving for each possible start state the disjunction of possible current states *) val possible_states_preds: Data_for_aorai.state -> Cil_types.predicate Cil_types.named list (** Possible values of the given auxiliary variable under the current path. *) val update_to_pred: pre_state:Promelaast.state -> post_state:Promelaast.state -> Cil_types.term -> Data_for_aorai.Intervals.t -> predicate named (** for a given starting and ending state, returns the post-conditions related to the possible values of the auxiliary variables at the exit of the function, guarded by the fact that we have followed this path. *) val action_to_pred: pre_state:Promelaast.state -> post_state:Promelaast.state -> Data_for_aorai.Vals.t -> predicate named list (** All actions that might have been performed on aux variables from the start of the function, guarded by the path followed. *) val all_actions_preds: Data_for_aorai.state -> predicate named list (** Return an integer constant term with the 0 value. *) val zero_term : unit -> Cil_types.term (** Given an lval term 'host' and an integer value 'off', it returns a lval term host[off]. *) val mk_offseted_array : Cil_types.term_lval -> int -> Cil_types.term val mk_offseted_array_states_as_enum : Cil_types.term_lval -> int -> Cil_types.term (** Returns a term representing the given logic variable (usually a fresh quantified variable). *) val mk_term_from_vi : Cil_types.varinfo -> Cil_types.term val make_enum_states: unit -> unit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/yaparser.mly0000644000175000017500000002524612155630222020237 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Aorai plug-in of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat a l'nergie atomique et aux nergies */ /* alternatives) */ /* INRIA (Institut National de Recherche en Informatique et en */ /* Automatique) */ /* INSA (Institut National des Sciences Appliquees) */ /* */ /* 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: promelaparser_withexps.mly,v 1.2 2008-10-02 13:33:29 uid588 Exp $ */ /* Originated from http://www.ltl2dstar.de/down/ltl2dstar-0.4.2.zip */ %{ open Logic_ptree open Promelaast open Bool3 let to_seq c = [{ condition = Some c; nested = []; min_rep = Some Data_for_aorai.cst_one; max_rep = Some Data_for_aorai.cst_one; }] let is_no_repet (min,max) = let is_one c = Extlib.may_map Data_for_aorai.is_cst_one ~dft:false c in is_one min && is_one max let observed_states = Hashtbl.create 1 let prefetched_states = Hashtbl.create 1 let fetch_and_create_state name = Hashtbl.remove prefetched_states name ; try Hashtbl.find observed_states name with Not_found -> let s = Data_for_aorai.new_state name in Hashtbl.add observed_states name s; s ;; let prefetch_and_create_state name = if (Hashtbl.mem prefetched_states name) or not (Hashtbl.mem observed_states name) then begin let s= fetch_and_create_state name in Hashtbl.add prefetched_states name name; s end else (fetch_and_create_state name) ;; type pre_cond = Behavior of string | Pre of Promelaast.condition %} %token CALL_OF RETURN_OF CALLORRETURN_OF %token IDENTIFIER %token INT %token LCURLY RCURLY LPAREN RPAREN LSQUARE RSQUARE LBRACELBRACE RBRACERBRACE %token RARROW %token TRUE FALSE %token NOT DOT AMP %token COLON SEMI_COLON COMMA PIPE CARET QUESTION COMMA COLUMNCOLUMN %token EQ LT GT LE GE NEQ PLUS MINUS SLASH STAR PERCENT OR AND %token OTHERWISE %token EOF %nonassoc highest %left LPAREN RPAREN %left LCURLY %right EQ LT GT LE GE NEQ PLUS MINUS SLASH STAR PERCENT OR AND /* [VP] priorities taken from cparser.mly */ %left LSQUARE RSQUARE %left DOT %nonassoc NOT TRUE FALSE %nonassoc QUESTION %right SEMICOLON %nonassoc lowest %type main %start main %% main : options states { List.iter (fun(key, ids) -> match key with "init" -> List.iter (fun id -> try (Hashtbl.find observed_states id).init <- True with Not_found -> Aorai_option.abort "Error: no state '%s'\n" id) ids | "accept" -> List.iter (fun id -> try (Hashtbl.find observed_states id).acceptation <- True with Not_found -> Aorai_option.abort "no state '%s'\n" id) ids | "deterministic" -> Aorai_option.Deterministic.set true; | oth -> Aorai_option.abort "unknown option '%s'\n" oth ) $1; let states= Hashtbl.fold (fun _ st l -> if st.acceptation=Undefined or st.init=Undefined then begin Aorai_option.abort "Error: the state '%s' is used but never defined.\n" st.name end; st::l) observed_states [] in (try Hashtbl.iter (fun _ st -> if st.init=True then raise Exit) observed_states; Aorai_option.abort "Automaton does not declare an initial state" with Exit -> ()); if Hashtbl.length prefetched_states >0 then begin let r = Hashtbl.fold (fun s n _ -> s^"Error: the state '"^n^"' is used but never defined.\n") prefetched_states "" in Aorai_option.abort "%s" r end; (states, $2) } ; options : options option { $1@[$2] } | option { [$1] } ; option : PERCENT IDENTIFIER opt_identifiers SEMI_COLON { ($2, $3) } ; opt_identifiers : /* empty */ { [] } | COLON id_list { $2 } ; id_list : id_list COMMA IDENTIFIER { $1@[$3] } | IDENTIFIER { [$1] } ; states : states state { $1@$2 } | state { $1 } ; state : IDENTIFIER COLON transitions SEMI_COLON { let start_state = fetch_and_create_state $1 in let (_, transitions) = List.fold_left (fun (otherwise, transitions) (cross,stop_state) -> if otherwise then Aorai_option.abort "'other' directive in definition of %s \ transitions is not the last one" start_state.name else begin let trans = { start=start_state; stop=stop_state; cross=cross; numt=(-1) }::transitions in let otherwise = match cross with | Otherwise -> true | Seq _ -> false in otherwise, trans end) (false,[]) $3 in List.rev transitions } transitions /*=> [transition; ...] */ : transitions PIPE transition { $1@[$3] } | transition { [$1] } ; transition: /*=> (guard, state) */ | LCURLY seq_elt RCURLY RARROW IDENTIFIER { (Seq $2, prefetch_and_create_state $5) } | OTHERWISE RARROW IDENTIFIER {(Otherwise, prefetch_and_create_state $3) } | RARROW IDENTIFIER { (Seq (to_seq PTrue), prefetch_and_create_state $2) } ; non_empty_seq: | seq_elt { $1 } | seq_elt SEMI_COLON seq { $1 @ $3 } ; seq: | /* epsilon */ { [] } | non_empty_seq { $1 } ; guard: | single_cond { to_seq $1 } | LSQUARE non_empty_seq RSQUARE { $2 } | IDENTIFIER pre_cond LPAREN seq RPAREN post_cond { let pre_cond = match $2 with | Behavior b -> PCall($1,Some b) | Pre c -> PAnd (PCall($1,None), c) in let post_cond = match $6 with | None -> PReturn $1 | Some c -> PAnd (PReturn $1,c) in (to_seq pre_cond) @ $4 @ to_seq post_cond } | IDENTIFIER LPAREN non_empty_seq RPAREN post_cond { let post_cond = match $5 with | None -> PReturn $1 | Some c -> PAnd (PReturn $1,c) in (to_seq (PCall ($1, None))) @ $3 @ to_seq post_cond } | IDENTIFIER LPAREN RPAREN post_cond { let post_cond = match $4 with | None -> PReturn $1 | Some c -> PAnd (PReturn $1,c) in (to_seq (PCall ($1, None))) @ to_seq post_cond } ; pre_cond: | COLUMNCOLUMN IDENTIFIER { Behavior $2 } | LBRACELBRACE single_cond RBRACERBRACE { Pre $2 } ; post_cond: | /* epsilon */ { None } | LBRACELBRACE single_cond RBRACERBRACE { Some $2 } ; seq_elt: | guard repetition { let min, max = $2 in match $1 with | [ s ] when Data_for_aorai.is_single s -> [ { s with min_rep = min; max_rep = max } ] | l -> if is_no_repet (min,max) then l (* [ a; [b;c]; d] is equivalent to [a;b;c;d] *) else [ { condition = None; nested = l; min_rep = min; max_rep = max } ] } ; repetition: | /* empty */ %prec lowest { Some Data_for_aorai.cst_one, Some Data_for_aorai.cst_one } | PLUS { Some Data_for_aorai.cst_one, None} | STAR { None, None } | QUESTION { None, Some Data_for_aorai.cst_one } | LCURLY arith_relation COMMA arith_relation RCURLY { Some $2, Some $4 } | LCURLY arith_relation RCURLY { Some $2, Some $2 } | LCURLY arith_relation COMMA RCURLY { Some $2, None } | LCURLY COMMA arith_relation RCURLY { None, Some $3 } single_cond: | CALLORRETURN_OF LPAREN IDENTIFIER RPAREN { POr (PCall ($3,None), PReturn $3) } | CALL_OF LPAREN IDENTIFIER RPAREN { PCall ($3,None) } | RETURN_OF LPAREN IDENTIFIER RPAREN { PReturn $3 } | TRUE { PTrue } | FALSE { PFalse } | NOT single_cond { PNot $2 } | single_cond AND single_cond { PAnd ($1,$3) } | single_cond OR single_cond { POr ($1,$3) } | LPAREN single_cond RPAREN { $2 } | logic_relation { $1 } ; logic_relation : arith_relation EQ arith_relation { PRel(Eq, $1, $3) } | arith_relation LT arith_relation { PRel(Lt, $1, $3) } | arith_relation GT arith_relation { PRel(Gt, $1, $3) } | arith_relation LE arith_relation { PRel(Le, $1, $3) } | arith_relation GE arith_relation { PRel(Ge, $1, $3) } | arith_relation NEQ arith_relation { PRel(Neq, $1, $3) } | arith_relation %prec TRUE { PRel (Neq, $1, PCst(IntConstant "0")) } ; arith_relation : arith_relation_mul PLUS arith_relation { PBinop(Badd,$1,$3) } | arith_relation_mul MINUS arith_relation { PBinop(Bsub,$1,$3) } | arith_relation_mul %prec lowest { $1 } ; arith_relation_mul : arith_relation_mul SLASH access_or_const { PBinop(Bdiv,$1,$3) } | arith_relation_mul STAR access_or_const { PBinop(Bmul, $1, $3) } | arith_relation_mul PERCENT access_or_const { PBinop(Bmod, $1, $3) } | access_or_const { $1 } ; /* returns a Lval exp or a Const exp*/ access_or_const : INT { PCst (IntConstant $1) } | MINUS INT { PUnop (Uminus, PCst (IntConstant $2)) } | access %prec TRUE { $1 } | LPAREN arith_relation RPAREN { $2 } ; /* returns a lval */ access : access DOT IDENTIFIER { PField($1,$3) } | access LSQUARE access_or_const RSQUARE { PArrget($1,$3) } | access_leaf {$1} ; access_leaf : STAR access { PUnop (Ustar,$2) } | IDENTIFIER LPAREN RPAREN DOT IDENTIFIER { PPrm($1,$5) } | IDENTIFIER { PVar $1 } | LPAREN access RPAREN { $2 } ; frama-c-Fluorine-20130601/src/aorai/ltlparser.mli0000444000175000017500000000132412155634032020371 0ustar mehdimehditype token = | LTL_TRUE | LTL_FALSE | LTL_LPAREN | LTL_RPAREN | LTL_OR | LTL_IMPLIES | LTL_LEFT_RIGHT_ARROW | LTL_AND | LTL_NOT | LTL_GLOBALLY | LTL_FATALLY | LTL_UNTIL | LTL_RELEASE | LTL_NEXT | LTL_EQ | LTL_LT | LTL_GT | LTL_LE | LTL_GE | LTL_NEQ | LTL_PLUS | LTL_MINUS | LTL_DIV | LTL_STAR | LTL_MODULO | LTL_RIGHT_ARROW | LTL_DOT | LTL_LEFT_SQUARE | LTL_RIGHT_SQUARE | LTL_ADRESSE | LTL_CALL | LTL_RETURN | LTL_CALL_OR_RETURN | LTL_INT of (string) | LTL_LABEL of (string) | EOF val ltl : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Ltlast.formula * (string, (Logic_ptree.relation * Promelaast.expression * Promelaast.expression)) Hashtbl.t) frama-c-Fluorine-20130601/src/aorai/aorai_option.mli0000644000175000017500000000521412155630222021045 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 Plugin include Plugin.S module Ltl_File : String module To_Buchi: String module Buchi: String module Ya: String module Output_Spec : Bool module Output_C_File : String module Dot : Bool module DotSeparatedLabels: Bool module AbstractInterpretation : Bool module Axiomatization : Bool module ConsiderAcceptance : Bool module AutomataSimplification : Bool module Test : Int module AddingOperationNameAndStatusInSpecification:Bool (** [true] if the user declares that its ya automaton is deterministic. *) module Deterministic: State_builder.Ref with type data = bool val is_on : unit -> bool val promela_file: unit -> string val advance_abstract_interpretation: unit -> bool val emitter: Emitter.t (** The emitter which emits Aorai annotations. @since Oxygen-20120901 *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/ltlparser.mly0000644000175000017500000001361412155630222020415 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Aorai plug-in of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat a l'nergie atomique et aux nergies */ /* alternatives) */ /* INRIA (Institut National de Recherche en Informatique et en */ /* Automatique) */ /* INSA (Institut National des Sciences Appliquees) */ /* */ /* 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: ltlparser.mly,v 1.3 2009-02-13 07:59:29 uid562 Exp $ */ /* Originated from http://www.ltl2dstar.de/down/ltl2dstar-0.4.2.zip */ %{ open Promelaast open Logic_ptree let observed_expressions=Hashtbl.create 97 let ident_count=ref 0 let get_fresh_ident () = ident_count:=!ident_count+1; ("buchfreshident"^(string_of_int !ident_count)) %} %token LTL_TRUE LTL_FALSE LTL_LPAREN LTL_RPAREN /* Logic operators */ %token LTL_OR LTL_IMPLIES LTL_LEFT_RIGHT_ARROW %token LTL_AND %token LTL_NOT %token LTL_GLOBALLY LTL_FATALLY LTL_UNTIL LTL_RELEASE LTL_NEXT %right LTL_OR LTL_IMPLIES LTL_LEFT_RIGHT_ARROW %right LTL_AND %nonassoc LTL_NOT %right LTL_GLOBALLY LTL_FATALLY LTL_UNTIL LTL_RELEASE LTL_NEXT /* Logic relations */ %token LTL_EQ LTL_LT LTL_GT LTL_LE LTL_GE LTL_NEQ %right LTL_EQ LTL_LT LTL_GT LTL_LE LTL_GE LTL_NEQ /* Arithmetic relations */ %token LTL_PLUS LTL_MINUS %token LTL_DIV LTL_STAR LTL_MODULO %right LTL_PLUS LTL_MINUS LTL_DIV LTL_STAR LTL_MODULO /* Access */ %token LTL_RIGHT_ARROW LTL_DOT LTL_LEFT_SQUARE LTL_RIGHT_SQUARE LTL_ADRESSE %token LTL_CALL LTL_RETURN LTL_CALL_OR_RETURN /* Variables and constants */ %token LTL_INT %token LTL_LABEL /* Others */ %token EOF %type <(Ltlast.formula * (string, (Logic_ptree.relation * Promelaast.expression * Promelaast.expression)) Hashtbl.t)> ltl %start ltl %% ltl : formula EOF {($1,observed_expressions)} ; formula : LTL_TRUE {Ltlast.LTrue} | LTL_FALSE {Ltlast.LFalse} | LTL_LPAREN formula LTL_RPAREN { $2 } | LTL_GLOBALLY formula { Ltlast.LGlobally($2) } | LTL_FATALLY formula { Ltlast.LFatally($2) } | formula LTL_UNTIL formula { Ltlast.LUntil($1,$3) } | formula LTL_RELEASE formula { Ltlast.LRelease($1,$3) } | LTL_NEXT formula { Ltlast.LNext($2) } | formula LTL_OR formula { Ltlast.LOr($1,$3) } | formula LTL_AND formula { Ltlast.LAnd($1,$3) } | LTL_NOT formula { Ltlast.LNot($2) } | formula LTL_IMPLIES formula { Ltlast.LImplies($1,$3) } | formula LTL_LEFT_RIGHT_ARROW formula { Ltlast.LIff($1,$3) } | LTL_CALL LTL_LPAREN LTL_LABEL LTL_RPAREN { Ltlast.LCall($3)} | LTL_RETURN LTL_LPAREN LTL_LABEL LTL_RPAREN { Ltlast.LReturn($3)} | LTL_CALL_OR_RETURN LTL_LPAREN LTL_LABEL LTL_RPAREN { Ltlast.LCallOrReturn($3)} /* returns a string identifer associated, through observed_expressions table, to the represented expression */ | logic_relation { let id = get_fresh_ident () in Hashtbl.add observed_expressions id $1; Ltlast.LIdent(id) } ; logic_relation : arith_relation LTL_EQ arith_relation { Eq, $1 , $3} | arith_relation LTL_LT arith_relation { Lt, $1, $3 } | arith_relation LTL_GT arith_relation { Gt, $1, $3 } | arith_relation LTL_LE arith_relation { Le, $1, $3 } | arith_relation LTL_GE arith_relation { Ge, $1, $3 } | arith_relation LTL_NEQ arith_relation { Neq, $1, $3 } | arith_relation { Neq, $1, PCst (IntConstant "0") } ; arith_relation : arith_relation_mul LTL_PLUS arith_relation { PBinop(Badd,$1,$3) } | arith_relation_mul LTL_MINUS arith_relation { PBinop(Bsub,$1,$3) } | arith_relation_mul { $1 } ; arith_relation_mul : arith_relation_mul LTL_DIV access_or_const { PBinop(Bdiv,$1,$3) } | arith_relation_mul LTL_STAR access_or_const { PBinop(Bmul,$1,$3) } | arith_relation_mul LTL_MODULO access_or_const { PBinop(Bmod,$1,$3)} | access_or_const { $1 } ; /* returns a Lval exp or a Const exp*/ access_or_const : LTL_INT { PCst (IntConstant $1) } | LTL_MINUS LTL_INT { PUnop (Uminus,PCst (IntConstant $2)) } | access { $1 } | LTL_LPAREN arith_relation LTL_RPAREN { $2 } ; /* returns a lval */ access : access LTL_RIGHT_ARROW LTL_LABEL { PField (PUnop(Ustar,$1),$3) } | access LTL_DOT LTL_LABEL { PField($1,$3) } | access_array {$1} access_array : access_array LTL_LEFT_SQUARE access_or_const LTL_RIGHT_SQUARE { PArrget($1,$3) } | access_leaf {$1} access_leaf : LTL_ADRESSE access { PUnop (Uamp,$2) } | LTL_STAR access { PUnop (Ustar, $2 ) } | LTL_LABEL { PVar $1 } | LTL_LPAREN access LTL_RPAREN { $2 } ; frama-c-Fluorine-20130601/src/aorai/promelalexer.mll0000644000175000017500000001354512155630222021072 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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: promelalexer.mll,v 1.2 2008-10-02 13:33:29 uid588 Exp $ *) (* from http://www.ltl2dstar.de/down/ltl2dstar-0.4.2.zip *) { open Promelaparser open Lexing exception Error of (Lexing.position * Lexing.position) * string let loc lexbuf = (lexeme_start_p lexbuf, lexeme_end_p lexbuf) let raise_located loc e = raise (Error (loc, e)) let buf = Buffer.create 1024 let newline lexbuf = let pos = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum } } let rD = ['0'-'9'] let rL = ['a'-'z' 'A'-'Z' '_'] rule token = parse | "true" { PROMELA_TRUE } | "never" { PROMELA_NEVER } | "if" { PROMELA_IF } | "fi" { PROMELA_FI } | "goto" { PROMELA_GOTO } | "skip" { PROMELA_SKIP } | "::" { PROMELA_DOUBLE_COLON } | ':' { PROMELA_COLON } | ';' { PROMELA_SEMICOLON } | '(' { PROMELA_LPAREN } | ')' { PROMELA_RPAREN } | '{' { PROMELA_LBRACE } | '}' { PROMELA_RBRACE } | "->" { PROMELA_RIGHT_ARROW } | "false" { PROMELA_FALSE } | "||" { PROMELA_OR } | "&&" { PROMELA_AND } | '!' { PROMELA_NOT } | [' ' '\t' '\012' '\r']+ { token lexbuf } | '\n' { newline lexbuf; token lexbuf } | "/*" { comment lexbuf; token lexbuf } | "//" [^ '\n']* '\n' { newline lexbuf; token lexbuf } | "callof_" rL* (rL | rD)* { let s=(lexeme lexbuf) in let s=String.sub s 7 ((String.length s)-7) in PROMELA_CALLOF s } | "returnof_" rL* (rL | rD)* { let s=(lexeme lexbuf) in let s=String.sub s 9 ((String.length s)-9) in PROMELA_RETURNOF s } | "callorreturnof_" rL* (rL | rD)* { let s=(lexeme lexbuf) in let s=String.sub s 15 ((String.length s)-15) in PROMELA_CALLORRETURNOF s } | "callof_" { raise_located (loc lexbuf) "Illegal fonction name in Promela file." } | "returnof_" { raise_located (loc lexbuf) "Illegal fonction name in Promela file." } | "callorreturnof_" { raise_located (loc lexbuf) "Illegal fonction name in Promela file." } | rL (rL | rD)* { let s = lexeme lexbuf in PROMELA_LABEL s } | eof { EOF } | "1" { PROMELA_TRUE } | _ { Aorai_option.error "Illegal_character : '%s'\n" (lexeme lexbuf); raise Parsing.Parse_error} and comment = parse | "*/" { () } | eof { Aorai_option.error "Unterminated_comment\n" (*lex_error lexbuf "Unterminated_comment"*) } | '\n' { newline lexbuf; comment lexbuf } | _ { comment lexbuf } { let parse c = let lb = from_channel c in try Promelaparser.promela token lb with Parsing.Parse_error | Invalid_argument _ -> let (a,b)=(loc lb) in Aorai_option.error "Syntax error (l%d c%d -> l%dc%d)" a.pos_lnum (a.pos_cnum-a.pos_bol) b.pos_lnum (b.pos_cnum-b.pos_bol); (* Format.print_string "Syntax error (" ; *) (* Format.print_string "l" ; *) (* Format.print_int a.pos_lnum ; *) (* Format.print_string "c" ; *) (* Format.print_int (a.pos_cnum-a.pos_bol) ;*) (* Format.print_string " -> l" ; *) (* Format.print_int b.pos_lnum ; *) (* Format.print_string "c" ; *) (* Format.print_int (b.pos_cnum-b.pos_bol) ;*) (* Format.print_string ")\n" ; *) raise_located (loc lb) "Syntax error" } frama-c-Fluorine-20130601/src/aorai/logic_simplification.ml0000644000175000017500000004056112155630222022404 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 Promelaast let pretty_clause fmt l = Format.fprintf fmt "@[<2>[%a@]]@\n" (Pretty_utils.pp_list ~sep:",@ " Promelaoutput.print_condition) l let pretty_dnf fmt l = Format.fprintf fmt "@[<2>[%a@]]@\n" (Pretty_utils.pp_list pretty_clause) l let opposite_rel = function | Rlt -> Rge | Rgt -> Rle | Rge -> Rlt | Rle -> Rgt | Req -> Rneq | Rneq -> Req let rec condToDNF cond = (*Typage : condition --> liste de liste de termes (disjonction de conjonction de termes) DNF(terme) = {{terme}} DNF(a or b) = DNF(a) \/ DNF(b) DNF(a and b) = Composition (DNF(a),DNF(b)) DNF(not a) = tmp = DNF(a) composition (tmp) negation de chaque terme *) match cond with | TOr (c1, c2) -> (condToDNF c1)@(condToDNF c2) | TAnd (c1, c2) -> let d1,d2=(condToDNF c1), (condToDNF c2) in List.fold_left (fun lclause clauses2 -> (List.map (fun clauses1 -> clauses1@clauses2) d1) @ lclause ) [] d2 | TNot (c) -> begin match c with | TOr (c1, c2) -> condToDNF (TAnd(TNot(c1),TNot(c2))) | TAnd (c1, c2) -> condToDNF (TOr (TNot(c1),TNot(c2))) | TNot (c1) -> condToDNF c1 | TTrue -> condToDNF TFalse | TFalse -> condToDNF TTrue | TRel(rel,t1,t2) -> [[TRel(opposite_rel rel,t1,t2)]] | _ as t -> [[TNot(t)]] end | TTrue -> [[TTrue]] | TFalse -> [] | _ as t -> [[t]] let removeTerm term lterm = List.fold_left (fun treated t -> match term,t with | TCall (kf1,None), TCall (kf2,_) | TReturn kf1, TReturn kf2 when Kernel_function.equal kf1 kf2 -> treated | TCall(kf1,Some b1), TCall(kf2, Some b2) when Kernel_function.equal kf1 kf2 && Datatype.String.equal b1.b_name b2.b_name -> treated | _ -> t::treated) [] lterm (** Given a list of terms (representing a conjunction), if a positive call or return is present, then all negative ones are obvious and removed *) let positiveCallOrRet clause = try (* Step 1: find a positive information TCall or TReturn. *) let positive, computePositive= List.fold_left (fun (positive,treated as res) term -> match term with | TCall (kf1,None) -> begin match positive with | None -> (Some term, term::treated) | Some (TCall (kf2,None)) -> if Kernel_function.equal kf1 kf2 then res else raise Exit | Some (TReturn _) -> raise Exit | Some(TCall (kf2,Some _) as term2) -> if Kernel_function.equal kf1 kf2 then Some term, term :: removeTerm term2 treated else raise Exit | _ -> Aorai_option.fatal "inconsistent environment in positiveCallOrRet" end | TCall (kf1, Some b1) -> begin match positive with | None -> (Some term, term::treated) | Some (TCall (kf2,None)) -> if Kernel_function.equal kf1 kf2 then res else raise Exit | Some (TReturn _) -> raise Exit | Some(TCall (kf2,Some b2)) -> if Kernel_function.equal kf1 kf2 then if Datatype.String.equal b1.b_name b2.b_name then res else positive, term :: treated else raise Exit | _ -> Aorai_option.fatal "inconsistent environment in positiveCallOrRet" end | TReturn kf1 -> begin match positive with | None -> (Some term, term::treated) | Some (TReturn kf2) -> if Kernel_function.equal kf1 kf2 then res else raise Exit | Some (TCall _) -> raise Exit | _ -> Aorai_option.fatal "inconsistent environment in positiveCallOrRet" end | _ -> positive, term::treated ) (None, []) clause in (* Step 2 : Remove negatives not enough expressive *) match positive with | None -> computePositive | Some (TCall (kf1,None)) -> List.fold_left (fun treated term -> match term with | TNot(TCall (kf2,_)) -> if Kernel_function.equal kf1 kf2 then raise Exit (* Positive information more specific than negative *) else treated | TNot(TReturn _) -> treated | _ -> term::treated ) [] computePositive | Some (TCall (kf1, Some b1)) -> List.fold_left (fun treated term -> match term with | TNot(TCall (kf2,None)) -> if Kernel_function.equal kf1 kf2 then raise Exit (* Positive information more specific than negative *) else treated | TNot(TCall(kf2, Some b2)) -> if Kernel_function.equal kf1 kf2 then if Datatype.String.equal b1.b_name b2.b_name then raise Exit else term :: treated else treated | TNot(TReturn _) -> treated | _ -> term::treated ) [] computePositive | Some (TReturn kf1) -> List.fold_left (fun treated term -> match term with | TNot(TCall _) -> treated | TNot(TReturn kf2) -> (* Two opposite information *) if Kernel_function.equal kf1 kf2 then raise Exit else treated | _ -> term::treated ) [] computePositive | _ -> Aorai_option.fatal "inconsistent environment in positiveCallOrRet" with Exit -> [TFalse] (* contradictory requirements for current event. *) let rel_are_equals (rel1,t11,t12) (rel2,t21,t22) = rel1 = rel2 && Logic_utils.is_same_term t11 t21 && Logic_utils.is_same_term t12 t22 let swap_rel (rel,t1,t2) = let rel = match rel with | Rlt -> Rgt | Rle -> Rge | Rge -> Rle | Rgt -> Rlt | Req -> Req | Rneq -> Rneq in (rel,t2,t1) let contradict_rel r1 (rel2,t21,t22) = rel_are_equals r1 (opposite_rel rel2, t21,t22) || rel_are_equals (swap_rel r1) (opposite_rel rel2, t21, t22) (** Simplify redundant relations. *) let simplify clause = try List.fold_left (fun clause term -> match term with | TTrue | TNot(TFalse) -> clause | TFalse | TNot(TTrue) -> raise Exit | TRel(rel1,t11,t12) -> if List.exists (fun term -> match term with | TRel(rel2,t21,t22) when contradict_rel (rel1,t11,t12) (rel2, t21,t22) -> raise Exit | TRel(rel2,t21,t22) -> rel_are_equals (rel1,t11,t12) (rel2,t21,t22) | TNot(TRel(rel2,t21,t22)) when (rel_are_equals (rel1,t11,t12) (rel2,t21,t22)) -> raise Exit | TNot(TRel(rel2,t21,t22)) -> contradict_rel (rel1,t11,t12) (rel2,t21,t22) | _ -> false) clause then clause else term::clause | TNot(TRel(rel1,t11,t12)) -> if List.exists (fun term -> match term with | TNot(TRel(rel2,t21,t22)) when contradict_rel (rel1,t11,t12) (rel2, t21,t22) -> raise Exit | TNot(TRel(rel2,t21,t22)) -> rel_are_equals (rel1,t11,t12) (rel2,t21,t22) | TRel(rel2,t21,t22) when (rel_are_equals (rel1,t11,t12) (rel2,t21,t22)) -> raise Exit | TRel(rel2,t21,t22) -> contradict_rel (rel1,t11,t12) (rel2,t21,t22) | _ -> false) clause then clause else term::clause | _ -> term :: clause) [] clause with Exit -> [TFalse] let rec termsAreEqual term1 term2 = match term1,term2 with | TTrue,TTrue | TFalse,TFalse -> true | TCall (a,None), TCall (b,None) | TReturn a, TReturn b -> Kernel_function.equal a b | TCall (f1,Some b1), TCall(f2, Some b2) -> Kernel_function.equal f1 f2 && Datatype.String.equal b1.b_name b2.b_name | TNot(TRel(rel1,t11,t12)), TRel(rel2,t21,t22) | TRel(rel1,t11,t12), TNot(TRel(rel2,t21,t22)) -> contradict_rel (rel1,t11,t12) (rel2,t21,t22) | TNot(a),TNot(b) -> termsAreEqual a b | TRel(rel1,t11,t12), TRel(rel2,t21,t22) -> rel_are_equals (rel1,t11,t12) (rel2,t21,t22) | _ -> false (** true iff clause1 <: clause2*) let clausesAreSubSetEq clause1 clause2 = (List.for_all (fun t1 ->List.exists ( fun t2 -> termsAreEqual t1 t2) clause2) clause1) (** true iff clause1 <: clause2 and clause2 <: clause1 *) let clausesAreEqual clause1 clause2 = clausesAreSubSetEq clause1 clause2 && clausesAreSubSetEq clause2 clause1 (** return the clauses list named lclauses without any clause c such as cl <: c *) let removeClause lclauses cl = List.filter (fun c -> not (clausesAreSubSetEq cl c)) lclauses (* Obvious version. *) let negativeClause clause = List.map (fun term -> match term with | TNot(c) -> c | TCall _ | TReturn _ | TRel _ -> TNot term | TTrue -> TFalse | TFalse -> TTrue | TAnd (_,_) | TOr (_,_) -> Aorai_option.fatal "not a DNF clause" ) clause let simplifyClauses clauses = try List.fold_left (fun acc c -> (* If 2 clauses are C and not C then their disjunction implies true *) if List.exists (clausesAreEqual (negativeClause c)) acc then raise Exit (* If an observed clause c2 is included inside the current clause then the current is not added *) else if (List.exists (fun c2 -> clausesAreSubSetEq c2 c) acc) then acc (* If the current clause is included inside an observed clause c2 then the current is add and c2 is removed *) else if (List.exists (fun c2 -> clausesAreSubSetEq c c2) acc) then c::(removeClause acc c) (* If no simplification then c is add to the list *) else c::acc ) [] clauses with Exit -> [[]] let tor t1 t2 = match t1,t2 with TTrue,_ | _,TTrue -> TTrue | TFalse,t | t,TFalse -> t | _,_ -> TOr(t1,t2) let tand t1 t2 = match t1,t2 with TTrue,t | t,TTrue -> t | TFalse,_ | _,TFalse -> TFalse | _,_ -> TAnd(t1,t2) let tnot t = match t with TTrue -> TFalse | TFalse -> TTrue | TNot t -> t | TRel(rel,t1,t2) -> TRel(opposite_rel rel, t1, t2) | _ -> TNot t let tands l = List.fold_left tand TTrue l let tors l = List.fold_left tor TFalse l (** Given a DNF condition, it returns a condition in Promelaast.condition form. WARNING : empty lists not supported *) let dnfToCond d = tors (List.map tands d) let simplClause dnf clause = match clause with | [] | [TTrue] | [TNot TFalse]-> [[]] | [TFalse] | [TNot TTrue] -> dnf | _ -> clause :: dnf (** Given a condition, this function does some logical simplifications. It returns both the simplified condition and a disjunction of conjunctions of parametrized call or return. *) let simplifyCond condition = Aorai_option.debug "initial condition: %a" Promelaoutput.print_condition condition; (* Step 1 : Condition is translate into Disjunctive Normal Form *) let res1 = condToDNF condition in Aorai_option.debug "initial dnf: %a" pretty_dnf res1; (* Step 2 : Positive Call/Ret are used to simplify negative ones *) let res = List.fold_left (fun lclauses clause -> simplClause lclauses (positiveCallOrRet clause)) [] res1 in Aorai_option.debug "after step 2: %a" pretty_dnf res; (* Step 3 : simplification between exprs inside a clause *) let res = List.fold_left (fun lclauses clause -> simplClause lclauses (simplify clause)) [] res in Aorai_option.debug "after step 3: %a" pretty_dnf res; (* Step 4 : simplification between clauses *) let res = simplifyClauses res in Aorai_option.debug "after step 4: %a" pretty_dnf res; ((dnfToCond res), res) (** Given a list of transitions, this function returns the same list of transition with simplifyCond done on its cross condition *) let simplifyTrans transl = List.fold_left (fun (ltr,lpcond) tr -> let (crossCond , pcond ) = simplifyCond (tr.cross) in (* pcond stands for parametrized condition : disjunction of conjunctions of parametrized call/return *) let tr'={ start = tr.start ; stop = tr.stop ; cross = crossCond ; numt = tr.numt } in Aorai_option.debug "condition is %a, dnf is %a" Promelaoutput.print_condition crossCond pretty_dnf pcond; if tr'.cross <> TFalse then (tr'::ltr,pcond::lpcond) else (ltr,lpcond) ) ([],[]) (List.rev transl) (** Given a DNF condition, it returns the same condition simplified according to the context (function name and status). Hence, the returned condition is without any Call/Return stmts. *) let simplifyDNFwrtCtx dnf kf1 status = Aorai_option.debug "Before simplification: %a" pretty_dnf dnf; let rec simplCondition c = match c with | TCall (kf2, None) -> if Kernel_function.equal kf1 kf2 && status = Promelaast.Call then TTrue else TFalse | TCall (kf2, Some _) -> if Kernel_function.equal kf1 kf2 && status = Promelaast.Call then c else TFalse | TReturn kf2 -> if Kernel_function.equal kf1 kf2 && status = Promelaast.Return then TTrue else TFalse | TNot c -> tnot (simplCondition c) | TAnd(c1,c2) -> tand (simplCondition c1) (simplCondition c2) | TOr (c1,c2) -> tor (simplCondition c1) (simplCondition c2) | TTrue | TFalse | TRel _ -> c in let simplCNFwrtCtx cnf = tands (List.map simplCondition cnf) in let res = tors (List.map simplCNFwrtCtx dnf) in Aorai_option.debug "After simplification: %a" Promelaoutput.print_condition res; res (* Tests : Marchent : ========== simplifyCond(PAnd(POr(PTrue,PIndexedExp("a")),PNot(PAnd(PFalse,PIndexedExp("b")))));; - : condition = PTrue simplifyCond(POr(PAnd(PNot(PIndexedExp("b")),POr(PTrue,PIndexedExp("a"))),PAnd(PIndexedExp("a"),PNot(PFalse))));; - : condition = POr (PIndexedExp "a", PNot (PIndexedExp "b")) simplifyCond(PAnd(PAnd(PCall("a"),PIndexedExp "a"),PAnd(PNot(PCall("a")),PNot(PIndexedExp "a"))));; - : condition = PFalse simplifyCond(PAnd(PIndexedExp "a",PNot(PIndexedExp "a")));; - : condition = PFalse simplifyCond(PAnd(PCall("a"),PCall("a")));; - : condition = PCall "a" simplifyCond(PAnd(PIndexedExp("a"),PNot(PIndexedExp("a"))));; - : condition = PFalse simplifyCond(POr(PCall("a"),PNot(PCall("a"))));; - : condition = PTrue simplifyCond(PAnd(POr(PCall("a"),PCall("b")),POr(PNot(PCall("a")),PCall("b")))) ;; - : condition = PCall "b" simplifyCond(POr (PCall "b", PCall "b"));; - : condition = PCall "b" Simplifications a faire : ========================= *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/aorai_utils.ml0000644000175000017500000017155712155630222020542 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 open Logic_const open Logic_utils open Data_for_aorai open Cil_types open Cil_datatype open Promelaast open Bool3 let rename_pred v1 v2 p = let r = object inherit Visitor.frama_c_copy (Project.current()) method vlogic_var_use v = if Cil_datatype.Logic_var.equal v v1 then Cil.ChangeTo v2 else Cil.JustCopy end in Visitor.visitFramacPredicateNamed r p (** Given a transition a function name and a function status (call or return) it returns if the cross condition can be statisfied with only function status. *) let isCrossable tr func st = let rec isCross p = match p with | TOr (c1, c2) -> bool3or (isCross c1) (isCross c2) | TAnd (c1, c2) -> bool3and (isCross c1) (isCross c2) | TNot c1 -> bool3not (isCross c1) | TCall (kf,None) when Kernel_function.equal func kf && st=Call -> True | TCall (kf, Some _) when Kernel_function.equal func kf && st=Call -> Undefined | TCall _ -> False | TReturn kf when Kernel_function.equal func kf && st=Return -> True | TReturn _ -> False | TTrue -> True | TFalse -> False | TRel _ -> Undefined in let cond,_ = tr.cross in let res = isCross cond <> False in Aorai_option.debug ~level:2 "Function %a %s-state, \ transition %s -> %s is%s possible" Kernel_function.pretty func (if st=Call then "pre" else "post") tr.start.Promelaast.name tr.stop.Promelaast.name (if res then "" else " NOT"); res (* ************************************************************************* *) let find_enum, set_enum = let module H = State_builder.Int_hashtbl (Cil_datatype.Enumitem) (struct let name = "ltl_states_enum" let size = 17 let dependencies = (* TODO: projectify the automata and depend on it. *) [ Ast.self; Aorai_option.Ltl_File.self; Aorai_option.Buchi.self; Aorai_option.Ya.self ] end) in (fun n -> try H.find n with Not_found -> Aorai_option.fatal "Could not find the enum item corresponding to a state"), (List.iter (fun (n,item) -> H.add n item)) (* ************************************************************************* *) (** Given a transition a function name and a function status (call or return) it returns if the cross condition can be statisfied with only function status. *) let isCrossableAtInit tr func = (* When in doubt, return true anyway. More clever plug-ins will take care of analysing the instrumented code if needed. *) let eval_term_at_init t = if Kernel.LibEntry.get() then t else begin let bool_res test = if test then Cil.lconstant Integer.one else Cil.lzero () in let bool3_res dft test = match test with | True -> bool_res true | False -> bool_res false | Undefined -> dft in let is_true t = match t with | TConst(Integer(i,_)) -> Bool3.bool3_of_bool (not (Integer.is_zero i)) | TConst(LChr c) -> Bool3.bool3_of_bool (not (Char.code c <> 0)) | TConst(LReal r) -> Bool3.bool3_of_bool (not (r.r_nearest <> 0.)) | TConst(LStr _ | LWStr _) -> Bool3.True | _ -> Bool3.Undefined in let rec aux t = match t.term_node with | TConst (LEnum ei) -> aux (Logic_utils.expr_to_term ~cast:false ei.eival) | TLval lv -> (match aux_lv lv with | Some t -> t | None -> t) | TUnOp(op,t1) -> let t1 = aux t1 in (match op,t1.term_node with | Neg, TConst(Integer(i,_)) -> { t with term_node = TConst(Integer(Integer.neg i,None)) } | Neg, TConst(LReal r) -> let f = ~-. (r.r_nearest) in let r = { r_literal = string_of_float f ; r_nearest = f ; r_upper = ~-. (r.r_lower) ; r_lower = ~-. (r.r_upper) ; } in { t with term_node = TConst(LReal r) } | LNot, t1 -> bool3_res t (is_true t1) | _ -> t) | TBinOp(op,t1,t2) -> let t1 = aux t1 in let t2 = aux t2 in let rec comparison comp t1 t2 = match t1.term_node,t2.term_node with | TConst (Integer(i1,_)), TConst (Integer(i2,_)) -> bool_res (comp (Integer.compare i1 i2)) | TConst (LChr c1), TConst (LChr c2) -> bool_res (comp (Char.compare c1 c2)) | TConst(LReal r1), TConst (LReal r2) -> bool_res (comp (compare r1.r_nearest r2.r_nearest)) | TCastE(ty1,t1), TCastE(ty2,t2) when Cil_datatype.Typ.equal ty1 ty2 -> comparison comp t1 t2 | _ -> t in (match op, t1.term_node, t2.term_node with | PlusA, TConst(Integer(i1,_)), TConst(Integer(i2,_)) -> { t with term_node = TConst(Integer(Integer.add i1 i2,None))} | MinusA, TConst(Integer(i1,_)), TConst(Integer(i2,_)) -> { t with term_node = TConst(Integer(Integer.sub i1 i2,None)) } | Mult, TConst(Integer(i1,_)), TConst(Integer(i2,_)) -> { t with term_node = TConst(Integer(Integer.mul i1 i2,None)) } | Div, TConst(Integer(i1,_)), TConst(Integer(i2,_)) -> (try { t with term_node = TConst(Integer(Integer.c_div i1 i2,None)) } with Division_by_zero -> t) | Mod, TConst(Integer(i1,_)), TConst(Integer(i2,_)) -> (try { t with term_node = TConst(Integer(Integer.c_rem i1 i2,None)) } with Division_by_zero -> t) | Shiftlt, TConst(Integer(i1,_)), TConst(Integer(i2,_)) -> { t with term_node = TConst(Integer(Integer.shift_left i1 i2,None)) } | Shiftrt, TConst(Integer(i1,_)), TConst(Integer(i2,_)) -> { t with term_node = TConst(Integer(Integer.shift_right i1 i2,None)) } | Lt, _, _ -> comparison ((<) 0) t1 t2 | Gt, _, _ -> comparison ((>) 0) t1 t2 | Le, _, _ -> comparison ((<=) 0) t1 t2 | Ge, _, _ -> comparison ((>=) 0) t1 t2 | Eq, _, _ -> comparison ((=) 0) t1 t2 | Ne, _, _ -> comparison ((<>) 0) t1 t2 | LAnd, t1, t2 -> bool3_res t (Bool3.bool3and (is_true t1) (is_true t2)) | LOr, t1, t2 -> bool3_res t (Bool3.bool3or (is_true t1) (is_true t2)) | _ -> t) | TCastE(ty,t1) -> let t1 = aux t1 in (match t1.term_type with Ctype ty1 when Cil_datatype.Typ.equal ty ty1 -> t1 | _ -> { t with term_node = TCastE(ty,t1) }) | _ -> t and aux_lv (base,off) = match base with | TVar v -> (try Extlib.opt_bind (fun v -> let init = Globals.Vars.find v in let init = match init.Cil_types.init with None -> Cil.makeZeroInit ~loc:v.vdecl v.vtype | Some i -> i in aux_init off init) v.lv_origin with Not_found -> None) | TMem t -> (match (aux t).term_node with | TAddrOf lv -> aux_lv (Logic_const.addTermOffsetLval off lv) | _ -> None) | TResult _ -> None and aux_init off initinfo = match off, initinfo with | TNoOffset, SingleInit e -> Some (aux (Logic_utils.expr_to_term ~cast:false e)) | TIndex(t,oth), CompoundInit (ct,initl) -> (match (aux t).term_node with | TConst(Integer(i1,_)) -> Cil.foldLeftCompound ~implicit:true ~doinit: (fun o i _ t -> match o with | Index({ enode = Const(CInt64(i2,_,_))},_) when Integer.equal i1 i2 -> aux_init oth i | _ -> t) ~ct ~initl ~acc:None | _ -> None) | TField(f1,oth), CompoundInit(ct,initl) -> Cil.foldLeftCompound ~implicit:true ~doinit: (fun o i _ t -> match o with | Field(f2,_) when Cil_datatype.Fieldinfo.equal f1 f2 -> aux_init oth i | _ -> t) ~ct ~initl ~acc:None | _ -> None in aux t end in let eval_rel_at_init rel t1 t2 = let t1 = eval_term_at_init (Cil.constFoldTerm true t1) in let t2 = eval_term_at_init (Cil.constFoldTerm true t2) in let comp = match rel with | Req -> ((=) 0) | Rneq -> ((<>) 0) | Rge -> ((>=) 0) | Rgt -> ((>) 0) | Rle -> ((<=) 0) | Rlt -> ((<) 0) in let rec comparison t1 t2 = match t1.term_node,t2.term_node with | TConst (Integer(i1,_)), TConst (Integer(i2,_)) -> Bool3.bool3_of_bool (comp (Integer.compare i1 i2)) | TConst (LChr c1), TConst (LChr c2) -> Bool3.bool3_of_bool (comp (Char.compare c1 c2)) | TConst(LReal r1), TConst (LReal r2) -> Bool3.bool3_of_bool (comp (compare r1.r_nearest r2.r_nearest)) | TCastE(ty1,t1), TCastE(ty2,t2) when Cil_datatype.Typ.equal ty1 ty2 -> comparison t1 t2 | _ -> Bool3.Undefined in comparison t1 t2 in let rec isCross = function | TOr (c1, c2) -> Bool3.bool3or (isCross c1) (isCross c2) | TAnd (c1, c2) -> Bool3.bool3and (isCross c1) (isCross c2) | TNot (c1) -> Bool3.bool3not (isCross c1) | TCall (s,None) -> Bool3.bool3_of_bool (Kernel_function.equal s func) | TCall (s, Some _) when Kernel_function.equal s func -> Undefined | TCall _ -> Bool3.False | TReturn _ -> Bool3.False | TTrue -> Bool3.True | TFalse -> Bool3.False | TRel(rel,t1,t2) -> eval_rel_at_init rel t1 t2 in let (cond,_) = tr.cross in match isCross cond with | Bool3.True | Bool3.Undefined -> true | Bool3.False -> false (* ************************************************************************* *) (** {b Expressions management} *) (** Returns an int constant expression which represents the given int value. *) let mk_int_exp value = new_exp ~loc:Cil_datatype.Location.unknown (Const(CInt64(Integer.of_int value,IInt,Some(string_of_int value)))) (** This function rewrites a cross condition into an ACSL expression. Moreover, by giving current operation name and its status (call or return) the generation simplifies the generated expression. *) let crosscond_to_pred cross curr_f curr_status = let check_current_event f status pred = if Kernel_function.equal curr_f f && curr_status = status then pred else (Bool3.False, pfalse) in let rec convert = function (* Lazy evaluation of logic operators if the result can be statically computed *) | TOr (c1, c2) -> (*BinOp(LOr,convert c1,convert c2,Cil.intType)*) begin let (c1_val,c1_pred) = convert c1 in match c1_val with | Bool3.True -> (c1_val,c1_pred) | Bool3.False -> convert c2 | Undefined -> let (c2_val,c2_pred) = convert c2 in match c2_val with | Bool3.True -> (c2_val,c2_pred) | Bool3.False -> (c1_val,c1_pred) | Undefined -> (Undefined,Logic_const.por(c1_pred, c2_pred)) end | TAnd (c1, c2) -> (*BinOp(LAnd,convert c1,convert c2,Cil.intType)*) begin let (c1_val,c1_pred) = convert c1 in match c1_val with | Bool3.True -> convert c2 | Bool3.False -> (c1_val,c1_pred) | Undefined -> let (c2_val,c2_pred) = convert c2 in match c2_val with | Bool3.True -> (c1_val,c1_pred) | Bool3.False -> (c2_val,c2_pred) | Undefined -> (Undefined,Logic_const.pand(c1_pred, c2_pred)) end | TNot (c1) -> (*UnOp(LNot,convert c1,Cil.intType)*) begin let (c1_val,c1_pred) = convert c1 in match c1_val with | Bool3.True -> (Bool3.False,pfalse) | Bool3.False -> (Bool3.True,ptrue) | Undefined -> (c1_val,Logic_const.pnot(c1_pred)) end | TCall (f,b) -> let pred = match b with None -> Bool3.True, ptrue | Some b -> (Bool3.Undefined, Logic_const.pands (List.map Logic_utils.named_of_identified_predicate b.b_assumes)) in check_current_event f Promelaast.Call pred | TReturn f -> check_current_event f Promelaast.Return (Bool3.True, ptrue) (* Other expressions are left unchanged *) | TTrue -> (Bool3.True, ptrue) | TFalse -> (Bool3.False, pfalse) | TRel(rel,t1,t2) -> (Bool3.Undefined, Logic_const.prel (rel,t1,t2)) in snd (convert cross) (* ************************************************************************* *) (** {b Globals management} *) (** Local copy of the file pointer *) let file = ref Cil.dummyFile (** Copy the file pointer locally in the class in order to ease globals management and initializes some tables. *) let initFile f = file := f; Data_for_aorai.setCData (); (* Adding C variables into our hashtable *) Globals.Vars.iter (fun vi _ -> set_varinfo vi.vname vi); Globals.Functions.iter (fun kf -> let fname = Kernel_function.get_name kf in List.iter (fun vi -> set_paraminfo fname vi.vname vi) (Kernel_function.get_formals kf); if not (Data_for_aorai.isIgnoredFunction fname) then begin try let ret = Kernel_function.find_return kf in match ret.skind with | Cil_types.Return (Some e,_) -> (match e.enode with | Lval (Var vi,NoOffset) -> set_returninfo fname vi (* Add the vi of return stmt *) | _ -> () (* function without returned value *)) | _ -> () (* function without returned value *) with Kernel_function.No_Statement -> Aorai_option.fatal "Don't know what to do with a function declaration" end) (** List of globals awaiting for adding into C file globals *) let globals_queue = ref [] (** Flush all queued globals declarations into C file globals. *) let flush_globals () = let before, after = List.fold_left (fun (b,a) elem -> match elem with | GFun(f,loc) as func -> (* [VP] if address of function is taken, it might be used in a global initializer: keep a declaration at this point to ensure ending up with a compilable C file in the end... *) let b = if f.svar.vaddrof then GVarDecl(Cil.empty_funspec(),f.svar,loc) :: b else b in b, func :: a | other -> other :: b, a) ([], []) !file.globals in !file.globals <- List.rev before @ List.rev !globals_queue @ List.rev after; Kernel_function.clear_sid_info (); globals_queue := [] let mk_global glob = globals_queue := glob :: !globals_queue (* Utilities for global variables *) let mk_global_c_initialized_vars name ty ini= let vi = (Cil.makeGlobalVar name ty) in vi.vghost<-true; mk_global (GVar(vi,ini,vi.vdecl)); Globals.Vars.add vi ini; set_varinfo name vi let mk_global_var_init vi ini = vi.vghost<-true; mk_global (GVar(vi,ini,vi.vdecl)); Globals.Vars.add vi ini; set_varinfo vi.vname vi let mk_global_var vi = let ini = {Cil_types.init=Some(Cil.makeZeroInit ~loc:(CurrentLoc.get()) vi.vtype)} in mk_global_var_init vi ini let mk_global_c_vars name ty = let vi = (Cil.makeGlobalVar name ty) in mk_global_var vi let mk_global_c_var_init name init = let ty = Cil.typeOf init in let vi = Cil.makeGlobalVar name ty in vi.vghost <- true; let ini = { Cil_types.init = Some(SingleInit init) } in mk_global(GVar(vi,ini,vi.vdecl)); Globals.Vars.add vi ini; set_varinfo name vi let mk_int_const value = new_exp ~loc:(CurrentLoc.get()) (Const( CInt64( Integer.of_int (value), IInt, Some(string_of_int(value)) ))) (* Utilities for global enumerations *) let mk_global_c_enum_type_tagged name elements_l = let einfo = { eorig_name = name; ename = name; eitems = []; eattr = []; ereferenced = true; ekind = IInt; } in let l = List.map (fun (e,i) -> { eiorig_name = e; einame = e; eival = mk_int_const i; eiloc = Location.unknown; eihost = einfo}) elements_l in einfo.eitems <- l; set_usedinfo name einfo; mk_global (GEnumTag(einfo, Location.unknown)); einfo let mk_global_c_enum_type name elements = let _,elements = List.fold_left (fun (i,l) x -> (i+1,(x,i)::l)) (0,[]) elements in (* no need to rev the list, as the elements got their value already *) ignore (mk_global_c_enum_type_tagged name elements) let mk_global_c_initialized_enum name name_enuminfo ini = mk_global_c_initialized_vars name (TEnum(get_usedinfo name_enuminfo,[])) ini (* ************************************************************************* *) (** {b Terms management / computation} *) (** Return an integer constant term from the given value. *) let mk_int_term value = Cil.lconstant (Integer.of_int value) (** Return an integer constant term with the 0 value. @deprecated use directly Cil.lzero *) let zero_term() = Cil.lzero () let one_term () = Cil.lconstant Integer.one (** Returns a term representing the variable associated to the given varinfo *) let mk_term_from_vi vi = Logic_const.term (TLval((Logic_utils.lval_to_term_lval ~cast:true (Cil.var vi)))) (Ctype Cil.intType) (** Given an lval term 'host' and an integer value 'off', it returns a lval term host[off]. *) let mk_offseted_array host off = Logic_const.term (TLval(Logic_const.addTermOffsetLval (TIndex(mk_int_term (off),TNoOffset)) host)) (Ctype Cil.intType) let int2enumstate nums = let enum = find_enum nums in Logic_const.term (TConst (LEnum enum)) (Ctype (TEnum (enum.eihost,[]))) (** Given an lval term 'host' and an integer value 'off', it returns a lval term host[off]. *) let mk_offseted_array_states_as_enum host off = let enum = find_enum off in Logic_const.term (TLval (Logic_const.addTermOffsetLval (TIndex(Logic_const.term (TConst(LEnum enum)) (Ctype (TEnum (enum.eihost,[]))), TNoOffset)) host)) (Ctype Cil.intType) (** Returns a lval term associated to the curState generated variable. *) let host_state_term() = lval_to_term_lval ~cast:true (Cil.var (get_varinfo curState)) (* (** Returns a lval term associated to the curStateOld generated variable. *) let host_stateOld_term () = lval_to_term_lval ~cast:true (Cil.var (get_varinfo curStateOld)) (** Returns a lval term associated to the curTrans generated variable. *) let host_trans_term () = lval_to_term_lval ~cast:true (Cil.var (get_varinfo curTrans)) *) let state_term () = Logic_const.tvar (Cil.cvar_to_lvar (get_varinfo curState)) (* let stateOld_term () = Logic_const.tvar (Cil.cvar_to_lvar (get_varinfo curStateOld)) let trans_term () = Logic_const.tvar (Cil.cvar_to_lvar (get_varinfo curTrans)) *) let is_state_pred state = if Aorai_option.Deterministic.get () then Logic_const.prel (Req,state_term(),int2enumstate state.nums) else Logic_const.prel (Req,one_term(), Logic_const.tvar (Data_for_aorai.get_state_logic_var state)) let is_out_of_state_pred state = if Aorai_option.Deterministic.get () then Logic_const.prel (Rneq,state_term(),int2enumstate state.nums) else Logic_const.prel (Req,zero_term(), Logic_const.tvar (Data_for_aorai.get_state_logic_var state)) (* Utilities for other globals *) let mk_global_comment txt = mk_global (GText (txt)) (* ************************************************************************* *) (** {b Initialization management / computation} *) let mk_global_states_init root = let (states,_ as auto) = Data_for_aorai.getAutomata () in let states = List.sort Data_for_aorai.Aorai_state.compare states in let is_possible_init state = state.Promelaast.init = Bool3.True && (let trans = Path_analysis.get_transitions_of_state state auto in List.exists (fun tr -> isCrossableAtInit tr root) trans) in List.iter (fun state -> let init = if is_possible_init state then mk_int_exp 1 else mk_int_exp 0 in let init = SingleInit init in let var = Data_for_aorai.get_state_var state in mk_global_var_init var { Cil_types.init = Some init}) states let func_to_init name = {Cil_types.init= Some(SingleInit( new_exp ~loc:(CurrentLoc.get()) (Const(func_to_cenum (name)))))} let funcStatus_to_init st = {Cil_types.init=Some(SingleInit(new_exp ~loc:(CurrentLoc.get()) (Const(op_status_to_cenum (st)))))} class visit_decl_loops_init () = object (*(self) *) inherit Visitor.frama_c_inplace method vstmt_aux stmt = begin match stmt.skind with | Loop _ -> mk_global_c_vars (Data_for_aorai.loopInit^"_"^(string_of_int stmt.sid)) (TInt(IInt,[])) | _ -> () end; Cil.DoChildren end let mk_decl_loops_init () = let visitor = new visit_decl_loops_init () in Cil.visitCilFile (visitor :> Cil.cilVisitor) !file let change_vars subst subst_res kf label pred = let add_label t = ChangeDoChildrenPost(t,fun t -> tat(t,label)) in let visitor = object inherit Visitor.frama_c_copy (Project.current()) method vterm t = match t.term_node with TLval (TVar { lv_origin = Some v},_) when v.vglob -> add_label t | TLval (TMem _,_) -> add_label t | _ -> DoChildren method vterm_lhost = function | TResult ty -> (match kf with None -> Aorai_option.fatal "found \\result without being at a Return event" | Some kf -> (try ChangeTo (TVar (Kernel_function.Hashtbl.find subst_res kf)) with Not_found -> let new_lv = Cil_const.make_logic_var_quant ("__retres_" ^ (Kernel_function.get_name kf)) (Ctype ty) in Kernel_function.Hashtbl.add subst_res kf new_lv; ChangeTo (TVar new_lv))) | TMem _ | TVar _ -> DoChildren method vlogic_var_use lv = match lv.lv_origin with | Some v when not v.vglob -> (try ChangeTo (Cil_datatype.Logic_var.Hashtbl.find subst lv) with Not_found -> let new_lv = Cil_const.make_logic_var_quant lv.lv_name lv.lv_type in Cil_datatype.Logic_var.Hashtbl.add subst lv new_lv; ChangeTo new_lv) | Some _ | None -> DoChildren end in Visitor.visitFramacPredicate visitor pred let pred_of_condition subst subst_res label cond = let mk_func_event f = let op = tat (mk_term_from_vi (get_varinfo curOp),label) in (* [VP] TODO: change int to appropriate enum type. Also true elsewhere. *) let f = term (TConst (constant_to_lconstant (func_to_cenum f))) (Ctype (func_enum_type ())) in prel (Req,op,f) in let mk_func_status f status = let curr = tat (mk_term_from_vi (get_varinfo curOpStatus),label) in let call = term (TConst (constant_to_lconstant (op_status_to_cenum status))) (Ctype (status_enum_type())) in Logic_const.pand (mk_func_event f, prel(Req,curr,call)) in let mk_func_start f = mk_func_status f Promelaast.Call in let mk_func_return f = mk_func_status f Promelaast.Return in let rec aux kf pos = function | TOr(c1,c2) -> kf, Logic_const.por (snd (aux kf pos c1), snd (aux kf pos c2)) | TAnd(c1,c2) -> let kf, c1 = aux kf pos c1 in let kf, c2 = aux kf pos c2 in kf, Logic_const.pand (c1, c2) | TNot c -> let kf, c = aux kf (not pos) c in kf, Logic_const.pnot c | TCall (s,b) -> let pred = mk_func_start (Kernel_function.get_name s) in let pred = match b with | None -> pred | Some b -> Logic_const.pands (pred :: (List.map Logic_utils.named_of_identified_predicate b.b_assumes)) in kf, pred | TReturn s -> let kf = if pos then Some s else kf in kf, mk_func_return (Kernel_function.get_name s) | TTrue -> kf, ptrue | TFalse -> kf, pfalse | TRel(rel,t1,t2) -> kf, unamed (change_vars subst subst_res kf label (prel (rel,t1,t2)).content) in snd (aux None true cond) let mk_deterministic_lemma () = let automaton = Data_for_aorai.getAutomata () in let make_one_lemma state = let label = Cil_types.LogicLabel(None, "L") in let disjoint_guards acc trans1 trans2 = if trans1.numt <= trans2.numt then acc (* don't need to repeat the same condition twice*) else let subst = Cil_datatype.Logic_var.Hashtbl.create 5 in let subst_res = Kernel_function.Hashtbl.create 5 in let guard1 = pred_of_condition subst subst_res label (fst trans1.cross) in let guard2 = pred_of_condition subst subst_res label (fst trans2.cross) in let pred = Logic_const.pnot (Logic_const.pand (guard1, guard2)) in let quants = Cil_datatype.Logic_var.Hashtbl.fold (fun _ lv acc -> lv :: acc) subst [] in let quants = Kernel_function.Hashtbl.fold (fun _ lv acc -> lv :: acc) subst_res quants in (* [VP] far from perfect, but should give oracles for regression tests that stay relatively stable across vid changes. *) let quants = List.sort (fun v1 v2 -> String.compare v1.lv_name v2.lv_name) quants in Logic_const.pand (acc, (pforall (quants, pred))) in let trans = Path_analysis.get_transitions_of_state state automaton in let prop = Extlib.product_fold disjoint_guards ptrue trans trans in let name = state.Promelaast.name ^ "_deterministic_trans" in let lemma = Dlemma (name, false, [label],[],prop,Cil_datatype.Location.unknown) in Annotations.add_global Aorai_option.emitter lemma in List.iter make_one_lemma (fst automaton) let make_enum_states () = let state_list =fst (Data_for_aorai.getAutomata()) in let state_list = List.map (fun x -> (x.Promelaast.name, x.Promelaast.nums)) state_list in let state_list = if not (Aorai_option.Deterministic.get ()) then state_list else (*[VP] Strictly speaking this is not needed, but Jessie tends to consider that a value of enum type can only be one of the tags, so that we must add this dummy state that is always a possible value, even when a contract concludes that curState is none of the others. Note that ISO C does not impose this limitation to values of enum types. *) (get_fresh "aorai_reject_state", -2)::state_list in let enum = mk_global_c_enum_type_tagged states state_list in let mapping = List.map (fun (name,id) -> let item = List.find (fun y -> y.einame = name) enum.eitems in (id, item)) state_list in set_enum mapping let getInitialState () = let loc = Cil_datatype.Location.unknown in let states = fst (Data_for_aorai.getAutomata()) in let s = List.find (fun x -> x.Promelaast.init = Bool3.True) states in Cil.new_exp ~loc (Const (CEnum (find_enum s.nums))) (** This function computes all newly introduced globals (variables, enumeration structure, invariants, etc. *) let initGlobals root complete = mk_global_comment "//****************"; mk_global_comment "//* BEGIN Primitives generated for LTL verification"; mk_global_comment "//* "; mk_global_comment "//* "; mk_global_comment "//* Some constants"; if Aorai_option.Deterministic.get () then make_enum_states (); (* non deterministic mode uses one variable for each possible state *) mk_global_c_enum_type listOp (List.map (fun e -> func_to_op_func e) (getFunctions_from_c())); mk_global_c_initialized_enum curOp listOp (func_to_init (Kernel_function.get_name root)); mk_global_c_enum_type listStatus (callStatus::[termStatus]); mk_global_c_initialized_enum curOpStatus listStatus (funcStatus_to_init Promelaast.Call); mk_global_comment "//* "; mk_global_comment "//* States and Trans Variables"; if Aorai_option.Deterministic.get () then mk_global_c_var_init curState (getInitialState()) else mk_global_states_init root; if complete then begin mk_global_comment "//* "; mk_global_comment "//* Loops management"; mk_decl_loops_init (); end; if Aorai_option.Deterministic.get () then begin (* must flush now previous globals which are used in the lemmas in order to be able to put these last ones in the right places in the AST. *) flush_globals (); mk_global_comment "//* "; mk_global_comment "//**************** "; mk_global_comment "//* Proof that the automaton is deterministic"; mk_global_comment "//* "; mk_deterministic_lemma (); end; mk_global_comment "//* "; mk_global_comment "//****************** "; mk_global_comment "//* Auxiliary variables used in transition conditions"; mk_global_comment "//*"; List.iter mk_global_var (Data_for_aorai.aux_variables()); (match Data_for_aorai.abstract_logic_info () with | [] -> () | l -> let annot = Daxiomatic ("Aorai_pebble_axiomatic", List.map (fun li -> Dfun_or_pred(li,Cil_datatype.Location.unknown)) l, Cil_datatype.Location.unknown) in Annotations.add_global Aorai_option.emitter annot); mk_global_comment "//* "; mk_global_comment "//* END Primitives generated for LTL verification"; mk_global_comment "//****************"; flush_globals () (* ************************************************************************* *) (** {b Pre/post management} *) (* assigns curState, curOp and curOpStatus *) let aorai_assigns loc = let from_state = if Aorai_option.Deterministic.get () then [ Logic_const.new_identified_term (state_term()), FromAny ] else List.map (fun state -> Logic_const.new_identified_term (Logic_const.tvar (Data_for_aorai.get_state_logic_var state)), FromAny) (fst (Data_for_aorai.getAutomata())) in Writes (* mk_from (host_stateOld_term ()); mk_from (host_trans_term ()); *) ((Logic_const.new_identified_term (Logic_const.tvar ~loc (Data_for_aorai.get_logic_var Data_for_aorai.curOpStatus)), FromAny) :: (Logic_const.new_identified_term (Logic_const.tvar ~loc (Data_for_aorai.get_logic_var Data_for_aorai.curOp)), FromAny) :: from_state) let action_assigns trans = let add_if_needed v lv (known_vars, assigns as acc) = if Cil_datatype.Varinfo.Set.mem v known_vars then acc else Cil_datatype.Varinfo.Set.add v known_vars, (Logic_const.new_identified_term lv, FromAny)::assigns in let treat_one_action acc = function | Counter_init (host,off) | Counter_incr (host,off) | Copy_value ((host,off),_) -> let my_var = match host with | TVar ({ lv_origin = Some v}) -> v | _ -> Aorai_option.fatal "Auxiliary variable is not a C global" in let my_off = match off with | TNoOffset -> TNoOffset | TIndex _ -> TIndex(Logic_const.trange (None,None), TNoOffset) | TField _ | TModel _ -> Aorai_option.fatal "Unexpected offset in auxiliary variable" in add_if_needed my_var (Logic_const.term (TLval(host,my_off)) (Cil.typeOfTermLval (host,my_off))) acc | Pebble_init(_,v,c) -> let cc = Extlib.the c.lv_origin in let cv = Extlib.the v.lv_origin in add_if_needed cv (Logic_const.tvar v) (add_if_needed cc (Logic_const.tvar c) acc) | Pebble_move(_,v1,_,v2) -> let cv1 = Extlib.the v1.lv_origin in let cv2 = Extlib.the v2.lv_origin in add_if_needed cv1 (Logic_const.tvar v1) (add_if_needed cv2 (Logic_const.tvar v2) acc) in let empty = (Cil_datatype.Varinfo.Set.empty,[]) in let empty_pebble = match trans.start.multi_state, trans.stop.multi_state with | Some(_,aux), None -> let caux = Extlib.the aux.lv_origin in add_if_needed caux (Logic_const.tvar aux) empty | _ -> empty in let _,res = List.fold_left treat_one_action empty_pebble (snd trans.cross) in Writes res let get_reachable_trans state st auto current_state = match st with | Promelaast.Call -> (try let reach = Data_for_aorai.Aorai_state.Map.find state current_state in let treat_one_state end_state _ l = Path_analysis.get_edges state end_state auto @ l in Data_for_aorai.Aorai_state.Map.fold treat_one_state reach [] with Not_found -> []) | Promelaast.Return -> let treat_one_state end_state (_,last,_) l = if Data_for_aorai.Aorai_state.Set.mem state last then Path_analysis.get_edges state end_state auto @ l else l in let treat_one_start _ map l = Data_for_aorai.Aorai_state.Map.fold treat_one_state map l in Data_for_aorai.Aorai_state.Map.fold treat_one_start current_state [] let get_reachable_trans_to state st auto current_state = match st with | Promelaast.Call -> let treat_one_start start map acc = if Data_for_aorai.Aorai_state.Map.mem state map then Path_analysis.get_edges start state auto @ acc else acc in Data_for_aorai.Aorai_state.Map.fold treat_one_start current_state [] | Promelaast.Return -> let treat_one_state _ map acc = try let (_,last,_) = Data_for_aorai.Aorai_state.Map.find state map in Data_for_aorai.Aorai_state.Set.fold (fun start acc -> Path_analysis.get_edges start state auto @ acc) last acc with Not_found -> acc in Data_for_aorai.Aorai_state.Map.fold treat_one_state current_state [] (* force that we have a crossable transition for each state in which the automaton might be at current event. *) let force_transition loc f st current_state = let (states, _ as auto) = Data_for_aorai.getAutomata () in let aux (impossible_states,possible_states,has_crossable_trans) state = let reachable_trans = get_reachable_trans state st auto current_state in let add_one_trans (has_crossable_trans, crossable_non_reject) trans = let has_crossable_trans = Logic_simplification.tor has_crossable_trans (fst trans.cross) in let crossable_non_reject = crossable_non_reject || (isCrossable trans f st && not (Data_for_aorai.is_reject_state trans.stop)) in has_crossable_trans, crossable_non_reject in let cond, crossable_non_reject = List.fold_left add_one_trans (Promelaast.TFalse, false) reachable_trans in let cond = fst (Logic_simplification.simplifyCond cond) in let cond = crosscond_to_pred cond f st in let start = is_state_pred state in if Logic_utils.is_trivially_false cond then begin let not_start = is_out_of_state_pred state in Logic_const.pand ~loc (impossible_states,not_start), possible_states, has_crossable_trans end else begin let has_crossable_trans = if Logic_utils.is_trivially_true cond then has_crossable_trans else Logic_const.new_predicate (pimplies ~loc (start,cond)) :: has_crossable_trans in let possible_states = (* reject_state must not be the only possible state *) match st with | Promelaast.Return -> if Data_for_aorai.is_reject_state state then possible_states else Logic_const.por ~loc (possible_states,start) | Promelaast.Call -> if crossable_non_reject then Logic_const.por ~loc (possible_states, start) else possible_states in impossible_states, possible_states, has_crossable_trans end in let impossible_states, possible_states, crossable_trans = List.fold_left aux (ptrue, pfalse,[]) states in let states = if Aorai_option.Deterministic.get() then possible_states (* We're always in exactly one state, among the possible ones, no need to list the impossible ones. *) else (* requires that the cells for impossible states be '0' *) Logic_const.pand ~loc (possible_states, impossible_states) in Logic_const.new_predicate states :: (List.rev crossable_trans) let partition_action trans = let add_state t st map = let old = try Cil_datatype.Term_lval.Map.find t map with Not_found -> Data_for_aorai.Aorai_state.Set.empty in let new_set = Data_for_aorai.Aorai_state.Set.add st old in Cil_datatype.Term_lval.Map.add t new_set map in let treat_one_action st acc = function | Counter_init t | Counter_incr t | Copy_value (t,_) -> add_state t st acc | Pebble_init _ | Pebble_move _ -> acc (* moving pebbles can occur at the same time (but not for same pebbles) *) in let treat_one_trans acc tr = List.fold_left (treat_one_action tr.start) acc (snd tr.cross) in List.fold_left treat_one_trans Cil_datatype.Term_lval.Map.empty trans (* TODO: this must be refined to take pebbles into account: in that case, disjointness condition is on pebble set for each state. *) let disjoint_states loc _ states precond = let states = Data_for_aorai.Aorai_state.Set.elements states in let rec product acc l = match l with | [] -> acc | hd::tl -> let pairs = List.map (fun x -> (hd,x)) tl in product (pairs @ acc) tl in let disjoint = product [] states in List.fold_left (fun acc (st1, st2) -> Logic_const.new_predicate (Logic_const.por ~loc (is_out_of_state_pred st1,is_out_of_state_pred st2)) :: acc) precond disjoint (* forces that parent states of a state with action are mutually exclusive, at least at pebble level. *) let incompatible_states loc st current_state = let (states,_ as auto) = Data_for_aorai.getAutomata () in let aux precond state = let trans = get_reachable_trans_to state st auto current_state in let actions = partition_action trans in Cil_datatype.Term_lval.Map.fold (disjoint_states loc) actions precond in List.fold_left aux [] states let auto_func_preconditions loc f st current_state = force_transition loc f st current_state @ incompatible_states loc st current_state let find_pebble_origin lab actions = let rec aux = function | [] -> Aorai_option.fatal "Transition to multi-state has no pebble action" | Pebble_init (_,_,count) :: _ -> Logic_const.term (TLval (TVar count, TNoOffset)) (Logic_const.make_set_type count.lv_type) | Pebble_move (_,_,set,_) :: _-> Data_for_aorai.pebble_set_at set lab | _ :: tl -> aux tl in aux actions let mk_sub ~loc pebble_set v = let sub = List.hd (Logic_env.find_all_logic_functions "\\subset") in Logic_const.papp ~loc (sub,[], [Logic_const.term ~loc (TLval (TVar v,TNoOffset)) pebble_set.term_type; pebble_set]) let pebble_guard ~loc pebble_set aux_var guard = let v = Cil_const.make_logic_var_quant aux_var.lv_name aux_var.lv_type in let g = rename_pred aux_var v guard in let g = Logic_const.pand ~loc (mk_sub ~loc pebble_set v, g) in Logic_const.pexists ~loc ([v], g) let pebble_guard_neg ~loc pebble_set aux_var guard = let v = Cil_const.make_logic_var_quant aux_var.lv_name aux_var.lv_type in let g = rename_pred aux_var v guard in let g = Logic_const.pimplies ~loc (mk_sub ~loc pebble_set v, Logic_const.pnot ~loc g) in Logic_const.pforall ~loc ([v], g) let pebble_post ~loc pebble_set aux_var guard = let v = Cil_const.make_logic_var_quant aux_var.lv_name aux_var.lv_type in let g = rename_pred aux_var v guard in let g = Logic_const.pimplies ~loc (mk_sub ~loc pebble_set v, g) in Logic_const.pforall ~loc ([v], g) (* behavior is the list of all behaviors related to the given state, trans the list of potentially active transitions ending in this state. If the state is a multi-state, we have one behavior whose assumes is the disjunction of these assumes *) let add_behavior_pebble_actions ~loc f st behaviors state trans = match state.multi_state with | None -> behaviors | Some (set,aux) -> let name = Printf.sprintf "pebble_%s" state.name in let assumes = List.fold_left (fun acc b -> let assumes = List.map pred_of_id_pred b.b_assumes in Logic_const.por ~loc (acc, Logic_const.pands assumes)) pfalse behaviors in let assumes = [ Logic_const.new_predicate assumes ] in let set = Data_for_aorai.pebble_set_at set Logic_const.here_label in let treat_action guard res action = match action with | Copy_value _ | Counter_incr _ | Counter_init _ -> res | Pebble_init (_,_,v) -> let a = Cil_const.make_logic_var_quant aux.lv_name aux.lv_type in let guard = rename_pred aux a guard in let guard = Logic_const.pand ~loc (Logic_const.prel ~loc (Req,Logic_const.tvar a,Logic_const.tvar v), guard) in Logic_const.term ~loc (Tcomprehension (Logic_const.tvar a,[a], Some guard)) set.term_type :: res | Pebble_move(_,_,s1,_) -> let a = Cil_const.make_logic_var_quant aux.lv_name aux.lv_type in let guard = rename_pred aux a guard in let in_s = mk_sub ~loc (Data_for_aorai.pebble_set_at s1 Logic_const.pre_label) a in let guard = Logic_const.pand ~loc (in_s,guard) in Logic_const.term ~loc (Tcomprehension (Logic_const.tvar a,[a], Some guard)) set.term_type :: res in let treat_one_trans acc tr = let guard = crosscond_to_pred (fst tr.cross) f st in let guard = Logic_const.pold guard in List.fold_left (treat_action guard) acc (snd tr.cross) in let res = List.fold_left treat_one_trans [] trans in let res = Logic_const.term (Tunion res) set.term_type in let post_cond = [ Normal, Logic_const.new_predicate (Logic_const.prel (Req,set,res))] in Cil.mk_behavior ~name ~assumes ~post_cond () :: behaviors let mk_action ~loc a = let term_lval lv = Logic_const.term ~loc (TLval lv) (Cil.typeOfTermLval lv) in match a with | Counter_init lv -> [Logic_const.prel ~loc (Req, term_lval lv, Logic_const.tinteger ~loc 1)] | Counter_incr lv -> [Logic_const.prel ~loc (Req, term_lval lv, Logic_const.term ~loc (TBinOp (PlusA, Logic_const.told ~loc (term_lval lv), Logic_const.tinteger ~loc 1)) (Cil.typeOfTermLval lv))] | Pebble_init _ | Pebble_move _ -> [] (* Treated elsewhere *) | Copy_value (lv,t) -> [Logic_const.prel ~loc (Req, term_lval lv, Logic_const.told t)] let is_reachable state status = let treat_one_state _ map = Data_for_aorai.Aorai_state.Map.mem state map in Data_for_aorai.Aorai_state.Map.exists treat_one_state status let concat_assigns a1 a2 = match a1,a2 with | WritesAny, _ -> a2 | _, WritesAny -> a1 | Writes l1, Writes l2 -> Writes (List.fold_left (fun acc (loc,_ as elt) -> if List.exists (fun (x,_) -> Cil_datatype.Term.equal x.it_content loc.it_content) l2 then acc else elt :: acc) l2 l1) let get_accessible_transitions auto state status = let treat_one_state curr_state (_,last,_) acc = if Data_for_aorai.Aorai_state.equal curr_state state then Data_for_aorai.Aorai_state.Set.union last acc else acc in let treat_start_state _ map acc = Data_for_aorai.Aorai_state.Map.fold treat_one_state map acc in let previous_set = Data_for_aorai.Aorai_state.Map.fold treat_start_state status Data_for_aorai.Aorai_state.Set.empty in Data_for_aorai.Aorai_state.Set.fold (fun s acc -> Path_analysis.get_edges s state auto @ acc) previous_set [] (* Assumes that we don't have a multi-state here. pebbles are handled elsewhere *) let mk_unchanged_aux_vars trans = let my_aux_vars = Cil_datatype.Term_lval.Set.empty in let add_one_action acc = function | Counter_init lv | Counter_incr lv | Copy_value (lv,_) -> Cil_datatype.Term_lval.Set.add lv acc | Pebble_init _ | Pebble_move _ -> acc in let add_one_trans acc tr = let (_,actions) = tr.cross in List.fold_left add_one_action acc actions in let my_aux_vars = List.fold_left add_one_trans my_aux_vars trans in let treat_lval lv acc = let t = Data_for_aorai.tlval lv in let ot = Logic_const.told t in let p = Logic_const.prel (Req,t,ot) in (Normal, Logic_const.new_predicate p) :: acc in Cil_datatype.Term_lval.Set.fold treat_lval my_aux_vars [] let mk_behavior ~loc auto kf e status state = Aorai_option.debug "analysis of state %s (%d)" state.Promelaast.name state.nums; if is_reachable state status then begin Aorai_option.debug "state %s is reachable" state.Promelaast.name; let my_trans = get_accessible_transitions auto state status in let rec treat_trans ((in_assumes, out_assumes, assigns, action_bhvs) as acc) l = match l with | [] -> acc | trans :: tl -> let consider, others = List.partition (fun x -> x.start.nums = trans.start.nums) tl in let start = is_state_pred trans.start in let not_start = is_out_of_state_pred trans.start in let in_guard, out_guard, assigns, my_action_bhvs = List.fold_left (fun (in_guard, out_guard, all_assigns, action_bhvs) trans -> Aorai_option.debug "examining transition %d" trans.numt; let (cond,actions) = trans.cross in Aorai_option.debug "transition %d is active" trans.numt; let guard = crosscond_to_pred cond kf e in let my_in_guard,my_out_guard = match state.multi_state with | None -> guard, Logic_const.pnot ~loc guard | Some (_,aux) -> let set = find_pebble_origin Logic_const.here_label actions in pebble_guard ~loc set aux guard, pebble_guard_neg ~loc set aux guard in let out_guard = Logic_const.pand ~loc (out_guard, my_out_guard) in let in_guard, all_assigns, action_bhvs = match actions with | [] -> (Logic_const.por ~loc (in_guard,my_in_guard), all_assigns, action_bhvs) | _ -> let name = Printf.sprintf "buch_state_%s_in_%d" state.name (List.length action_bhvs) in Aorai_option.debug "Name is %s" name; let assumes = [ Logic_const.new_predicate (Logic_const.pand ~loc (start,my_in_guard)) ] in let post_cond = Normal, Logic_const.new_predicate (is_state_pred state) in let treat_one_action acc a = let posts = mk_action ~loc a in match state.multi_state with | None -> acc @ List.map (fun x -> (Normal, Logic_const.new_predicate x)) posts | Some (_,aux) -> let set = find_pebble_origin Logic_const.pre_label actions in acc @ List.map (fun x -> (Normal, Logic_const.new_predicate (pebble_post ~loc set aux x))) posts in let post_cond = List.fold_left treat_one_action [post_cond] actions in let assigns = action_assigns trans in let all_assigns = concat_assigns assigns all_assigns in let bhv = Cil.mk_behavior ~name ~assumes ~post_cond () in in_guard, all_assigns, bhv :: action_bhvs in in_guard, out_guard, all_assigns, action_bhvs) (pfalse,ptrue,assigns, action_bhvs) (trans::consider) in treat_trans (Logic_const.por ~loc (in_assumes, (Logic_const.pand ~loc (start, in_guard))), Logic_const.pand ~loc (out_assumes, (Logic_const.por ~loc (not_start, out_guard))), assigns, my_action_bhvs ) others in let my_trans = List.filter (fun x -> isCrossable x kf e) my_trans in let in_assumes, out_assumes, assigns, action_behaviors = treat_trans (pfalse, ptrue, WritesAny, []) my_trans in let behaviors = if Logic_utils.is_trivially_false in_assumes then action_behaviors else begin let behavior_in = Cil.mk_behavior ~name:(Printf.sprintf "buch_state_%s_in" state.Promelaast.name) ~assumes:[Logic_const.new_predicate in_assumes] ~post_cond: [Normal, Logic_const.new_predicate (is_state_pred state)] () in behavior_in :: action_behaviors end in let behaviors = add_behavior_pebble_actions ~loc kf e behaviors state my_trans in let behaviors = if Logic_utils.is_trivially_false out_assumes then behaviors else begin let post_cond = match state.multi_state with | None -> mk_unchanged_aux_vars my_trans | Some (set,_) -> let set = Data_for_aorai.pebble_set_at set Logic_const.here_label in [Normal, Logic_const.new_predicate (Logic_const.prel ~loc (Req,set, Logic_const.term ~loc Tempty_set set.term_type))] in let post_cond = (Normal, (Logic_const.new_predicate (is_out_of_state_pred state))) :: post_cond in let behavior_out = Cil.mk_behavior ~name:(Printf.sprintf "buch_state_%s_out" state.Promelaast.name) ~assumes:[Logic_const.new_predicate out_assumes] ~post_cond () in behavior_out :: behaviors end in assigns, behaviors end else begin Aorai_option.debug "state %s is not reachable" state.Promelaast.name; (* We know that we'll never end up in this state. *) let name = Printf.sprintf "buch_state_%s_out" state.Promelaast.name in let post_cond = match state.multi_state with | None -> [] | Some (set,_) -> let set = Data_for_aorai.pebble_set_at set Logic_const.here_label in [Normal, Logic_const.new_predicate (Logic_const.prel ~loc (Req,set, Logic_const.term ~loc Tempty_set set.term_type))] in let post_cond = (Normal, Logic_const.new_predicate (is_out_of_state_pred state)) ::post_cond in WritesAny,[mk_behavior ~name ~post_cond ()] end let auto_func_behaviors loc f st state = let call_or_ret = match st with | Promelaast.Call -> "call" | Promelaast.Return -> "return" in Aorai_option.debug "func behavior for %a (%s)" Kernel_function.pretty f call_or_ret; let (states, _) as auto = Data_for_aorai.getAutomata() in (* requires is not needed for pre_func, as it is enforced by the requires of the original C function itself (and the call to pre_func by definition the first instruction of the function). *) let post_cond = let called_pre = Logic_const.new_predicate (Logic_const.prel ~loc (Req, Logic_const.tvar ~loc (Data_for_aorai.get_logic_var Data_for_aorai.curOpStatus), (Logic_utils.mk_dummy_term (TConst (constant_to_lconstant (Data_for_aorai.op_status_to_cenum st))) Cil.intType))) in let called_pre_2 = Logic_const.new_predicate (Logic_const.prel ~loc (Req, Logic_const.tvar ~loc (Data_for_aorai.get_logic_var Data_for_aorai.curOp), (Logic_utils.mk_dummy_term (TConst((constant_to_lconstant (Data_for_aorai.func_to_cenum (Kernel_function.get_name f))))) Cil.intType))) in (* let old_pred = Aorai_utils.mk_old_state_pred loc in *) [(Normal, called_pre); (Normal, called_pre_2)] in let requires = if st = Promelaast.Call then [] else auto_func_preconditions loc f st state in let mk_behavior (assigns, behaviors) status = let new_assigns, new_behaviors = mk_behavior ~loc auto f st state status in concat_assigns new_assigns assigns, new_behaviors @ behaviors in let assigns = aorai_assigns loc in let assigns, behaviors = (List.fold_left mk_behavior (assigns,[]) states) in let global_behavior = Cil.mk_behavior ~requires ~post_cond ~assigns () in (* Keep behaviors ordered according to the states they describe *) global_behavior :: (List.rev behaviors) let get_preds_wrt_params_reachable_states state f status = let auto = Data_for_aorai.getAutomata () in let treat_one_trans acc tr = Logic_simplification.tor acc (fst tr.cross) in let find_trans state prev tr = Path_analysis.get_edges prev state auto @ tr in let treat_one_state state (_,last,_) acc = let my_trans = Data_for_aorai.Aorai_state.Set.fold (find_trans state) last [] in let cond = List.fold_left treat_one_trans TFalse my_trans in let (_,dnf) = Logic_simplification.simplifyCond cond in let cond = Logic_simplification.simplifyDNFwrtCtx dnf f status in let pred = crosscond_to_pred cond f status in Logic_const.pand (acc, pimplies (is_state_pred state, pred)) in Data_for_aorai.Aorai_state.Map.fold treat_one_state state ptrue let get_preds_wrt_params_reachable_states state f status = let merge_reachable_state _ = Data_for_aorai.merge_end_state in let reachable_states = Data_for_aorai.Aorai_state.Map.fold merge_reachable_state state Data_for_aorai.Aorai_state.Map.empty in get_preds_wrt_params_reachable_states reachable_states f status let get_preds_pre_wrt_params f = let pre = Data_for_aorai.get_kf_init_state f in get_preds_wrt_params_reachable_states pre f Promelaast.Call let get_preds_post_bc_wrt_params f = let post = Data_for_aorai.get_kf_return_state f in get_preds_wrt_params_reachable_states post f Promelaast.Return let dkey = Aorai_option.register_category "action" let treat_val loc base range pred = let add term = if Cil.isLogicZero base then term else Logic_const.term (TBinOp (PlusA, Logic_const.tat (base,Logic_const.pre_label), term)) Linteger in let add_cst i = add (Logic_const.tinteger i) in let res = match range with | Fixed i -> Logic_const.prel (Req,loc, add_cst i) | Interval(min,max) -> let min = Logic_const.prel (Rle, add_cst min, loc) in let max = Logic_const.prel (Rle, loc, add_cst max) in Logic_const.pand (min,max) | Bounded (min,max) -> let min = Logic_const.prel (Rle, add_cst min, loc) in let max = Logic_const.prel (Rle, loc, add max) in Logic_const.pand (min,max) | Unbounded min -> Logic_const.prel (Rle, add_cst min, loc) in Aorai_option.debug ~dkey "Action predicate: %a" Printer.pp_predicate_named res; Logic_const.por(pred,res) let possible_states_preds state = let treat_one_state start map acc = let make_possible_state state _ acc = Logic_const.por (acc,is_state_pred state) in let possible_states = Data_for_aorai.Aorai_state.Map.fold make_possible_state map pfalse in Logic_const.pimplies (Logic_const.pat (is_state_pred start,Logic_const.pre_label), possible_states) :: acc in Data_for_aorai.Aorai_state.Map.fold treat_one_state state [] let update_to_pred ~pre_state ~post_state location bindings = let loc = Cil_datatype.Location.unknown in let intv = Cil_datatype.Term.Map.fold (treat_val location) bindings Logic_const.pfalse in let pred = match post_state.multi_state with | None -> intv | Some(set,aux) -> (* [VP 2011-09-05] In fact, not all the pebble come from the considered pre-state. Will this lead to too strong post-conditions? *) let set = Data_for_aorai.pebble_set_at set Logic_const.here_label in pebble_post ~loc set aux intv in let guard = Logic_const.pand ~loc (Logic_const.pat ~loc (is_state_pred pre_state, Logic_const.pre_label), is_state_pred post_state) in Logic_const.pimplies ~loc (guard, pred) let action_to_pred ~pre_state ~post_state bindings = let treat_one_loc loc vals acc = update_to_pred ~pre_state ~post_state loc vals :: acc in Cil_datatype.Term.Map.fold treat_one_loc bindings [] let all_actions_preds state = let treat_current_state pre_state post_state (_,_,bindings) acc = let my_bindings = action_to_pred ~pre_state ~post_state bindings in my_bindings @ acc in let treat_start_state pre_state map acc = Data_for_aorai.Aorai_state.Map.fold (treat_current_state pre_state) map acc in Data_for_aorai.Aorai_state.Map.fold treat_start_state state [] (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/yaparser.mli0000444000175000017500000000106412155634032020210 0ustar mehdimehditype token = | CALL_OF | RETURN_OF | CALLORRETURN_OF | IDENTIFIER of (string) | INT of (string) | LCURLY | RCURLY | LPAREN | RPAREN | LSQUARE | RSQUARE | LBRACELBRACE | RBRACERBRACE | RARROW | TRUE | FALSE | NOT | DOT | AMP | COLON | SEMI_COLON | COMMA | PIPE | CARET | QUESTION | COLUMNCOLUMN | EQ | LT | GT | LE | GE | NEQ | PLUS | MINUS | SLASH | STAR | PERCENT | OR | AND | OTHERWISE | EOF val main : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Promelaast.parsed_automaton frama-c-Fluorine-20130601/src/aorai/path_analysis.ml0000644000175000017500000001424712155630222021056 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 Promelaast (*open Graph.Pack.Digraph let st_array = ref (Array.make 1 (V.create 0)) ;; let auto2digraph (stl,trl) = Aorai_option.feedback "auto2digraph:" ; let digraph = create () in st_array:= Array.make (List.length stl) (V.create 0); Aorai_option.feedback " array : ok\n" ; let _ = List.iter (fun st -> (!st_array).(st.nums)<-(V.create st.nums); add_vertex digraph (!st_array).(st.nums) ) stl in Aorai_option.feedback " array remplissage : ok\n" ; List.iter (fun tr -> add_edge digraph (V.create tr.start.nums) (V.create tr.stop.nums)) trl; digraph ;; let existing_path auto st1 st2 = Aorai_option.feedback "existing path ..\n" ; let digraph = auto2digraph auto in let start = (!st_array).(st1.nums) in let stop = (!st_array).(st2.nums) in Aorai_option.feedback "%s" ("test : Etats choisis ("^(string_of_int (V.label start))^","^(string_of_int (V.label stop))^")\n") ; display_with_gv digraph; Aorai_option.feedback " affichage : ok\n" ; Aorai_option.feedback "shortest path : " ; let path=shortest_path digraph start stop in Aorai_option.feedback "done.\n" ; path ;; let test (stl,trl) = let st2 = List.hd stl in let st1 = List.hd (List.tl stl) in let _ = existing_path (stl,trl) st1 st2 in Aorai_option.feedback "Fini.\n" ; () ;; *) let voisins (_,trans_l) st = List.fold_left (fun vl tr -> if tr.start.nums=st.nums then (tr.stop,1)::vl else vl) [] trans_l let empty () = [] ;; let is_empty heap = (List.length heap)=0 ;; let add (length,(st,path)) heap = (length,(st,path))::heap ;; let extract_min heap = let (min,h) = List.fold_left (fun ((lmin,min),h) (lcur,cur) -> if lmin<=lcur then ((lmin,min),(lcur,cur)::h) else ((lcur,cur),(lmin,min)::h) ) ((List.hd heap),[]) (List.tl heap) in (min,h) (* Source : wikipedia*) (* l'adjacence est donnee sous la forme d'une fonction : adj v est la liste des voisins de v, avec leur distance ; la fonction suivante cherche le plus court chemin de v1 a v2 *) let dijkstra (adj: 'a -> ('a * int) list) (v1:'a) (v2:'a) = let visited = Hashtbl.create 97 in let rec loop h = if is_empty h then raise Not_found; let (w,(v,p)),h = extract_min h in if v = v2 then List.rev p, w else let h = if not (Hashtbl.mem visited v) then begin Hashtbl.add visited v (); List.fold_left (fun h (e,d) -> add (w+d, (e, e::p)) h) h (adj v) end else h in loop h in loop (add (0,(v1,[])) (empty())) let existing_path (stl,_ as auto) stn1 stn2 = let st1 = ref (List.hd stl) in let st2 = ref (List.hd stl) in List.iter (fun st -> if st.nums=stn1 then st1:=st; if st.nums=stn2 then st2:=st; ) stl; try let _ = dijkstra (voisins auto) !st1 !st2 in true with | Not_found -> false ;; (** since Nitrogen-20111001 *) let get_transitions_of_state st (_,tr) = List.fold_left (fun acc tr -> if tr.start.nums = st.nums then tr::acc else acc) [] tr let get_transitions_to_state st (_,tr) = List.fold_left (fun acc tr -> if tr.stop.nums = st.nums then tr::acc else acc) [] tr let get_edges st1 st2 (_,tr) = List.find_all (fun tr -> tr.start.nums = st1.nums && tr.stop.nums = st2.nums) tr let get_init_states (st,_) = List.filter (fun x -> x.init = Bool3.True) st let at_most_one_path (states,transitions as auto) st1 st2 = try let path,_ = dijkstra (voisins auto) st1 st2 in match path with | [] | [ _ ] -> true | x::y::_ -> let (trans1,trans2) = List.partition (fun t -> t.start.nums = x.nums && t.stop.nums = y.nums) transitions in let transitions = (List.tl trans1) @ trans2 in let auto = states, transitions in ignore (dijkstra (voisins auto) st1 st2); false with Not_found -> true let test (stl,_ as auto) = let st2 = List.hd stl in let st1 = List.hd (List.tl stl) in Aorai_option.feedback "test : Etats choisis (%d,%d)" st1.nums st2.nums; let (res,_) = dijkstra (voisins auto) st1 st2 in Aorai_option.feedback "Fini.@\n%a" (Pretty_utils.pp_list ~pre:"@[[" ~sep:",@ " ~suf:"@]]" (fun fmt st -> Format.fprintf fmt "%d" st.nums)) res (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/configure0000755000175000017500000030200112155634041017563 0ustar mehdimehdi#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME= PACKAGE_TARNAME= PACKAGE_VERSION= PACKAGE_STRING= PACKAGE_BUGREPORT= PACKAGE_URL= ac_unique_file="Makefile.in" ac_subst_vars='LTLIBOBJS LIBOBJS LTLTOBA HAS_LTLTOBA DYNAMIC_AORAI ENABLE_AORAI ENABLE_GUI FRAMAC_VERSION 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_aorai with_aorai_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= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures this package to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then cat <<\_ACEOF 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-aorai support for Aorai 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-aorai-static link aorai 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.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu 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 FRAMAC_VERSION=`frama-c -version | sed -n -e "s|^Version: *\(.*\)$|\1|p"` # 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 ${ac_cv_prog_ENABLE_GUI+:} false; 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 as_fn_executable_p "$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 ${ac_cv_file_Makefile_in+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "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" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-aorai was given. if test "${enable_aorai+set}" = set; then : enableval=$enable_aorai; 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 $? "aorai is not available" "$LINENO" 5 fi FORCE_AORAI=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_AORAI ENABLE_AORAI=$ENABLE NAME_AORAI=aorai if test "$default" = "no" -a "$FORCE" = "no"; then INFO_AORAI=" (not available by default)" fi # Dynamic plug-ins configuration # Check whether --with-aorai-static was given. if test "${with_aorai_static+set}" = set; then : withval=$with_aorai_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_AORAI=$is_static if test "$is_static" != "yes"; then USE_NATIVE_DYNLINK="${USE_NATIVE_DYNLINK} aorai" DYNAMIC_AORAI=yes else DYNAMIC_AORAI=no fi echo "aorai... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) if test "$ENABLE_AORAI" != "no"; then USE_LTLTOBA=$USE_LTLTOBA" "aorai # ltl2ba library for file in ltl2ba; do HAS_LTLTOBA= # 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 ${ac_cv_prog_HAS_LTLTOBA+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$HAS_LTLTOBA"; then ac_cv_prog_HAS_LTLTOBA="$HAS_LTLTOBA" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_HAS_LTLTOBA="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_LTLTOBA" && ac_cv_prog_HAS_LTLTOBA="no" fi fi HAS_LTLTOBA=$ac_cv_prog_HAS_LTLTOBA if test -n "$HAS_LTLTOBA"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $HAS_LTLTOBA" >&5 $as_echo "$HAS_LTLTOBA" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$HAS_LTLTOBA" = "yes"; then SELECTED_VAR=$file break; fi done if test -n "$REQUIRE_LTLTOBA" -o -n "$USE_LTLTOBA" -o "$no" = "yes"; then if test "$HAS_LTLTOBA" = "no"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: ltl2ba not found." >&5 $as_echo "$as_me: WARNING: ltl2ba not found." >&2;} reason="ltl2ba missing" for p in $REQUIRE_LTLTOBA; 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\ ltl2ba\)" { $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_LTLTOBA; 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\ ltl2ba\)" { $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 LTLTOBA=ltl2ba 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 if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\[/\\&/g s/\]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "./Makefile") 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= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" eval set X " :F $CONFIG_FILES " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac 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 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi frama-c-Fluorine-20130601/src/aorai/yalexer.mll0000644000175000017500000001134012155630222020033 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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). *) (* *) (**************************************************************************) (* File yalexer.mll *) { open Yaparser open Lexing exception Eof let new_line lexbuf = let lcp = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { lcp with pos_lnum = lcp.pos_lnum + 1; pos_bol = lcp.pos_cnum; } ;; exception Error of (Lexing.position * Lexing.position) * string let loc lexbuf = (lexeme_start_p lexbuf, lexeme_end_p lexbuf) let raise_located loc e = raise (Error (loc, e)) } let num = ['0'-'9'] let alpha = ['a'-'z' 'A'-'Z'] let ident = alpha (num | alpha | '_')* let string = ([^ '"' '\\']|'\\'_)* rule token = parse [' ' '\t' ] { token lexbuf } (* skip blanks *) | '\n' { new_line lexbuf; token lexbuf } | ['0'-'9']+ as lxm { INT(lxm) } | "CALL" { CALL_OF } | "RETURN" { RETURN_OF } | "COR" { CALLORRETURN_OF } | "other" { OTHERWISE } | "true" { TRUE } | "false" { FALSE } | "\\result" as lxm { IDENTIFIER(lxm) } | ident as lxm { IDENTIFIER(lxm) } | ',' { COMMA } | '+' { PLUS } | '-' { MINUS } | '*' { STAR } | '/' { SLASH } | '%' { PERCENT } | '(' { LPAREN } | ')' { RPAREN } | '[' { LSQUARE } | ']' { RSQUARE } | '{' { LCURLY } | '}' { RCURLY } | "{{" { LBRACELBRACE } | "}}" { RBRACERBRACE } | '.' { DOT } | "->" { RARROW } | '&' { AMP } | '|' { PIPE } | "&&" { AND } | "||" { OR } | '!' { NOT } | "<" { LT } | ">" { GT } | "<=" { LE } | ">=" { GE } | "==" { EQ } | "!=" { NEQ } | ';' { SEMI_COLON } | ':' { COLON } | "::" { COLUMNCOLUMN } | '^' { CARET } | '?' { QUESTION } | eof { EOF } | _ { raise_located (loc lexbuf) "Unknown token" } { let parse c = let lb = from_channel c in try Yaparser.main token lb with Parsing.Parse_error | Invalid_argument _ -> (* [VP]: Does not contain more information than what is in the exn. *) (*let (a,b)=(loc lb) in Format.print_string "Syntax error (" ; Format.print_string "l" ; Format.print_int a.pos_lnum ; Format.print_string "c" ; Format.print_int (a.pos_cnum-a.pos_bol) ; Format.print_string " -> l" ; Format.print_int b.pos_lnum ; Format.print_string "c" ; Format.print_int (b.pos_cnum-b.pos_bol) ; Format.print_string ")\n" ; *) raise_located (loc lb) "Syntax error" } frama-c-Fluorine-20130601/src/aorai/Makefile.in0000644000175000017500000001310612155630222017723 0ustar mehdimehdi########################################################################## # # # This file is part of Aorai plug-in of Frama-C. # # # # Copyright (C) 2007-2013 # # CEA (Commissariat a l'nergie atomique et aux nergies # # alternatives) # # INRIA (Institut National de Recherche en Informatique et en # # Automatique) # # INSA (Institut National des Sciences Appliquees) # # # # 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). # # # ########################################################################## # Makefile for compiling Aorai independently of Frama-C. # # To be used independently of Frama-C, a version of Frama-C compatible with # Aorai has to be properly installed as long as the Aorai-specific stuff. # 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 ?=. PLUGIN_ENABLE:=@ENABLE_AORAI@ PLUGIN_DYNAMIC:=@DYNAMIC_AORAI@ PLUGIN_NAME:=Aorai PLUGIN_GENERATED:= $(addprefix ${PLUGIN_DIR}/, \ promelalexer_withexps.ml promelaparser_withexps.ml \ promelaparser_withexps.mli \ promelalexer.ml promelaparser.ml promelaparser.mli \ ltllexer.ml ltlparser.ml ltlparser.mli \ yalexer.ml yaparser.ml yaparser.mli) PLUGIN_CMO:= bool3 \ aorai_option \ path_analysis \ promelaoutput \ logic_simplification \ data_for_aorai \ aorai_utils \ ltl_output \ utils_parser \ ltlparser \ ltllexer \ yaparser \ yalexer \ promelaparser \ promelalexer \ promelaparser_withexps \ promelalexer_withexps \ aorai_dataflow \ aorai_visitors \ aorai_register PLUGIN_CMI:= ltlast promelaast PLUGIN_HAS_MLI:=yes PLUGIN_DISTRIBUTED:=$(PLUGIN_ENABLE) PLUGIN_DISTRIB_EXTERNAL:= Makefile.in configure.ac configure PLUGIN_HAS_EXT_DOC:=no # [JS 2010/07/28] was 'yes' # but prevent 'make src-distrib to work # if ltltoba is not present, do not attempt to run any test. ifneq (@HAS_LTLTOBA@,yes) PLUGIN_NO_TEST:=yes PLUGIN_NO_DEFAULT_TEST:=yes endif PLUGIN_TESTS_DIRS:=aorai include $(FRAMAC_SHARE)/Makefile.dynamic # Regenerating the Makefile on need ifeq ("$(FRAMAC_INTERNAL)","yes") CONFIG_STATUS_DIR=$(FRAMAC_SRC) else CONFIG_STATUS_DIR=. endif $(Aorai_DIR)/Makefile: $(Aorai_DIR)/Makefile.in \ $(CONFIG_STATUS_DIR)/config.status cd $(CONFIG_STATUS_DIR) && ./config.status LOCAL_SRC_DIR=aorai COMMON_FILES_TO_COPY=$(PLUGIN_DISTRIB_EXTERNAL) Makefile.in YA.README INSTALL VERSIONS.txt FRAMAC_SRC_ROOT=../.. LOCAL_WEB_ROOT=/home/nstouls/Projets/AMAZONES/ForgeINRIA/main/aorai/ LOCAL_WEB_DIFFUSION=$(LOCAL_WEB_ROOT)/site/src/site/resources TODAY=`date +"%d-%m-%Y - %T"` TAGIN=<\!--START DATE--> TAGOUT=<\!--END DATE--> INDEX=$(LOCAL_WEB_DIFFUSION)/index.html pre-release: mkdir -p $(LOCAL_SRC_DIR)/doc @echo '## Generating bin and doc' @make -C $(FRAMAC_SRC_ROOT) depend --quiet @make -C $(FRAMAC_SRC_ROOT) --quiet @make -C $(FRAMAC_SRC_ROOT) $(PLUGIN_NAME)_DOC --quiet cp -r $(FRAMAC_SRC_ROOT)/doc/code/aorai $(LOCAL_SRC_DIR)/doc/. cp $(FRAMAC_SRC_ROOT)/doc/code/frama-c.png $(LOCAL_SRC_DIR)/doc/. cp $(FRAMAC_SRC_ROOT)/doc/code/style.css $(LOCAL_SRC_DIR)/doc/. @make -C $(FRAMAC_SRC_ROOT)/doc/aorai/ --quiet @make -C $(FRAMAC_SRC_ROOT)/doc/aorai/ install --quiet cp $(FRAMAC_SRC_ROOT)/doc/manuals/aorai-manual.pdf $(LOCAL_SRC_DIR)/doc/. cp $(FRAMAC_SRC_ROOT)/doc/manuals/aorai-example.tgz $(LOCAL_SRC_DIR)/doc/. @echo '## Deployment for local release' @make clean --quiet # SRC directory generation if [ -d autom4te.cache ] ; then rm -rf autom4te.cache ; fi cp *.* $(LOCAL_SRC_DIR) # Commun files copy for f in $(COMMON_FILES_TO_COPY) ; do \ cp $$f $(LOCAL_SRC_DIR)/. ; \ done @echo "## Generating archive" tar -czf $(LOCAL_SRC_DIR).tgz $(LOCAL_SRC_DIR) @echo "## Done." @echo "## Please make 'pre-release-deploy' to move archive to $(LOCAL_WEB_DIFFUSION)" pre-release-deploy: $(LOCAL_SRC_DIR).tgz @echo "## Moving archive to $(LOCAL_WEB_DIFFUSION)" mv $(LOCAL_SRC_DIR).tgz $(LOCAL_WEB_DIFFUSION) cat $(INDEX) | sed "s/$(TAGIN).*$(TAGOUT)/$(TAGIN)$(TODAY)$(TAGOUT)/" $(INDEX) > $(INDEX)2 mv $(INDEX)2 $(INDEX) @echo "## Website updated" cd $(LOCAL_WEB_ROOT) && ./CreateHTML.sh clean-all: @make clean @echo '## Removing generated directories' @rm -rf $(LOCAL_SRC_DIR) frama-c-Fluorine-20130601/src/aorai/promelaparser.mli0000444000175000017500000000107612155634032021241 0ustar mehdimehditype token = | PROMELA_OR | PROMELA_AND | PROMELA_NOT | PROMELA_TRUE | PROMELA_FALSE | PROMELA_NEVER | PROMELA_IF | PROMELA_FI | PROMELA_GOTO | PROMELA_SKIP | PROMELA_LABEL of (string) | PROMELA_COLON | PROMELA_SEMICOLON | PROMELA_DOUBLE_COLON | PROMELA_LBRACE | PROMELA_RBRACE | PROMELA_LPAREN | PROMELA_RPAREN | PROMELA_RIGHT_ARROW | PROMELA_CALLOF of (string) | PROMELA_RETURNOF of (string) | PROMELA_CALLORRETURNOF of (string) | EOF val promela : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Promelaast.parsed_automaton frama-c-Fluorine-20130601/src/aorai/promelaparser_withexps.mli0000444000175000017500000000153612155634032023175 0ustar mehdimehditype token = | PROMELA_OR | PROMELA_AND | PROMELA_NOT | PROMELA_TRUE | PROMELA_FALSE | PROMELA_NEVER | PROMELA_IF | PROMELA_FI | PROMELA_GOTO | PROMELA_SKIP | PROMELA_LABEL of (string) | PROMELA_INT of (string) | PROMELA_COLON | PROMELA_SEMICOLON | PROMELA_DOUBLE_COLON | PROMELA_LBRACE | PROMELA_RBRACE | PROMELA_LPAREN | PROMELA_RPAREN | PROMELA_RIGHT_ARROW | PROMELA_EQ | PROMELA_LT | PROMELA_GT | PROMELA_LE | PROMELA_GE | PROMELA_NEQ | PROMELA_PLUS | PROMELA_MINUS | PROMELA_DIV | PROMELA_STAR | PROMELA_MODULO | PROMELA_DOT | PROMELA_LEFT_SQUARE | PROMELA_RIGHT_SQUARE | PROMELA_CALLOF of (string) | PROMELA_RETURNOF of (string) | PROMELA_CALLORRETURNOF of (string) | EOF | PROMELA_FUNC val promela : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Promelaast.parsed_automaton frama-c-Fluorine-20130601/src/aorai/Aorai.mli0000644000175000017500000000375612155630222017426 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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: Ltl_to_acsl.mli,v 1.3 2008-10-10 16:03:25 uid588 Exp $ *) (** Aorai plugin (AKA Ltl_to_acsl). No function is directly exported: they are registered in {!Db.Aorai}. *) frama-c-Fluorine-20130601/src/aorai/promelalexer_withexps.ml0000444000175000017500000026122112155634032022646 0ustar mehdimehdi# 30 "src/aorai/promelalexer_withexps.mll" open Promelaparser_withexps open Lexing exception Error of (Lexing.position * Lexing.position) * string let loc lexbuf = (lexeme_start_p lexbuf, lexeme_end_p lexbuf) let raise_located loc e = raise (Error (loc, e)) let buf = Buffer.create 1024 let newline lexbuf = let pos = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum } # 21 "src/aorai/promelalexer_withexps.ml" let __ocaml_lex_tables = { Lexing.lex_base = "\000\000\208\255\210\255\078\000\212\255\213\255\214\255\215\255\ \216\255\219\255\002\000\003\000\031\000\153\000\163\000\238\000\ \094\000\235\255\002\000\033\000\001\000\013\000\057\001\242\255\ \243\255\244\255\003\000\247\255\038\000\072\001\147\001\222\001\ \041\002\116\002\191\002\010\003\085\003\160\003\235\003\054\004\ \129\004\204\004\023\005\098\005\173\005\248\005\067\006\142\006\ \217\006\036\007\111\007\186\007\005\008\080\008\249\255\246\255\ \155\008\241\255\239\255\238\255\220\255\130\000\234\255\233\255\ \165\008\240\008\059\009\134\009\209\009\028\010\103\010\178\010\ \253\010\072\011\147\011\222\011\041\012\116\012\191\012\010\013\ \085\013\160\013\235\013\054\014\129\014\204\014\023\015\098\015\ \173\015\248\015\067\016\225\255\222\255\221\255\132\000\252\255\ \253\255\254\255\091\000\255\255"; Lexing.lex_backtrk = "\255\255\255\255\255\255\044\000\255\255\255\255\255\255\255\255\ \255\255\255\255\032\000\031\000\047\000\029\000\044\000\044\000\ \038\000\255\255\019\000\018\000\047\000\047\000\037\000\255\255\ \255\255\255\255\010\000\255\255\007\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\000\000\044\000\044\000\ \044\000\001\000\002\000\044\000\003\000\044\000\044\000\015\000\ \044\000\044\000\004\000\044\000\044\000\005\000\255\255\255\255\ \029\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \044\000\044\000\044\000\044\000\044\000\044\000\023\000\023\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \025\000\025\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\024\000\024\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\003\000\255\255"; Lexing.lex_default = "\001\000\000\000\000\000\255\255\000\000\000\000\000\000\000\000\ \000\000\000\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\000\000\255\255\255\255\255\255\255\255\255\255\000\000\ \000\000\000\000\255\255\000\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\000\000\000\000\ \255\255\000\000\000\000\000\000\000\000\061\000\000\000\000\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\000\000\000\000\000\000\095\000\000\000\ \000\000\000\000\255\255\000\000"; Lexing.lex_trans = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\018\000\017\000\018\000\018\000\018\000\018\000\018\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \018\000\019\000\018\000\000\000\000\000\007\000\020\000\059\000\ \026\000\025\000\008\000\009\000\055\000\022\000\006\000\016\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\028\000\027\000\011\000\012\000\010\000\093\000\ \092\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\005\000\091\000\004\000\060\000\003\000\ \054\000\003\000\003\000\015\000\003\000\003\000\031\000\030\000\ \003\000\032\000\003\000\003\000\003\000\003\000\033\000\003\000\ \003\000\003\000\014\000\029\000\034\000\003\000\003\000\003\000\ \003\000\003\000\003\000\024\000\021\000\023\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \062\000\058\000\099\000\000\000\063\000\061\000\096\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\003\000\098\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \002\000\000\000\003\000\000\000\003\000\003\000\003\000\003\000\ \082\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\003\000\000\000\064\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \056\000\056\000\056\000\000\000\000\000\000\000\000\000\057\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\255\255\000\000\097\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\003\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\051\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\003\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\048\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\003\000\000\000\043\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\044\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \003\000\000\000\003\000\003\000\003\000\003\000\003\000\042\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\003\000\000\000\003\000\003\000\003\000\ \003\000\038\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\003\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\035\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\003\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\036\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\003\000\000\000\003\000\003\000\ \003\000\003\000\037\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\003\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\003\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\039\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\003\000\000\000\003\000\ \003\000\003\000\003\000\040\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \003\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\041\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\003\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\003\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\003\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\045\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\003\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\003\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\046\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\003\000\000\000\003\000\003\000\003\000\003\000\ \047\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\003\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \003\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\049\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\003\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\050\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\003\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\003\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\052\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\003\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\053\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\003\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\056\000\056\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\003\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\065\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\003\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\066\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\003\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\067\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\003\000\000\000\003\000\ \003\000\003\000\003\000\003\000\069\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \068\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \003\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\072\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\070\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\000\000\000\000\000\000\000\000\070\000\000\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\000\000\000\000\000\000\ \000\000\071\000\000\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\003\000\000\000\003\000\003\000\ \003\000\003\000\073\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\003\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\074\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\003\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \075\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\003\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \076\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \003\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\077\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\003\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\078\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\003\000\000\000\ \003\000\003\000\003\000\003\000\003\000\079\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\080\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\081\000\081\000\081\000\ \081\000\081\000\081\000\081\000\081\000\081\000\081\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\080\000\080\000\ \080\000\080\000\080\000\080\000\080\000\080\000\080\000\080\000\ \080\000\080\000\080\000\080\000\080\000\080\000\080\000\080\000\ \080\000\080\000\080\000\080\000\080\000\080\000\080\000\080\000\ \000\000\000\000\000\000\000\000\080\000\000\000\080\000\080\000\ \080\000\080\000\080\000\080\000\080\000\080\000\080\000\080\000\ \080\000\080\000\080\000\080\000\080\000\080\000\080\000\080\000\ \080\000\080\000\080\000\080\000\080\000\080\000\080\000\080\000\ \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\081\000\000\000\000\000\000\000\000\000\081\000\ \000\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\081\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\003\000\000\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\083\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\003\000\000\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\084\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \003\000\000\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\085\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\003\000\000\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\086\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\003\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\087\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\000\000\000\000\000\000\ \000\000\003\000\000\000\003\000\003\000\003\000\003\000\003\000\ \088\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \000\000\000\000\000\000\000\000\089\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \090\000\090\000\090\000\090\000\090\000\090\000\090\000\090\000\ \090\000\090\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ \089\000\089\000\089\000\000\000\000\000\000\000\000\000\089\000\ \000\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ \089\000\089\000\089\000\090\000\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\090\000\000\000\000\000\ \000\000\000\000\090\000\000\000\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\090\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \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\018\000\000\000\000\000\018\000\018\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\ \000\000\000\000\018\000\255\255\255\255\000\000\000\000\020\000\ \000\000\000\000\000\000\000\000\026\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\010\000\ \011\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\012\000\000\000\019\000\000\000\ \028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \016\000\021\000\098\000\255\255\061\000\016\000\094\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\255\255\255\255\255\255\255\255\003\000\094\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\255\255\255\255\ \000\000\255\255\014\000\255\255\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ \014\000\014\000\014\000\014\000\014\000\014\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\255\255\255\255\255\255\255\255\015\000\255\255\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\255\255\255\255\255\255\255\255\022\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\061\000\255\255\094\000\255\255\255\255\255\255\ \255\255\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\255\255\255\255\255\255\255\255\029\000\ \255\255\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\255\255\255\255\ \255\255\255\255\030\000\255\255\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\255\255\255\255\255\255\255\255\031\000\255\255\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\255\255\255\255\255\255\255\255\ \032\000\255\255\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\255\255\ \255\255\255\255\255\255\033\000\255\255\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\255\255\255\255\255\255\255\255\034\000\255\255\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\035\000\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\255\255\255\255\255\255\ \255\255\035\000\255\255\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \255\255\255\255\255\255\255\255\036\000\255\255\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\255\255\255\255\255\255\255\255\037\000\ \255\255\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\255\255\255\255\ \255\255\255\255\038\000\255\255\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\255\255\255\255\255\255\255\255\039\000\255\255\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\255\255\255\255\255\255\255\255\ \040\000\255\255\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\255\255\ \255\255\255\255\255\255\041\000\255\255\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\255\255\255\255\255\255\255\255\042\000\255\255\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\255\255\255\255\255\255\ \255\255\043\000\255\255\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \255\255\255\255\255\255\255\255\044\000\255\255\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\255\255\255\255\255\255\255\255\045\000\ \255\255\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\255\255\255\255\ \255\255\255\255\046\000\255\255\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\255\255\255\255\255\255\255\255\047\000\255\255\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\255\255\255\255\255\255\255\255\ \048\000\255\255\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\255\255\ \255\255\255\255\255\255\049\000\255\255\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\255\255\255\255\255\255\255\255\050\000\255\255\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\255\255\255\255\255\255\ \255\255\051\000\255\255\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \255\255\255\255\255\255\255\255\052\000\255\255\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\255\255\255\255\255\255\255\255\053\000\ \255\255\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\056\000\056\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \255\255\255\255\255\255\255\255\064\000\255\255\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\255\255\255\255\255\255\255\255\065\000\ \255\255\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\255\255\255\255\ \255\255\255\255\066\000\255\255\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\255\255\255\255\255\255\255\255\067\000\255\255\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\255\255\255\255\255\255\255\255\ \068\000\255\255\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\255\255\ \255\255\255\255\255\255\069\000\255\255\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\255\255\255\255\255\255\255\255\070\000\255\255\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\255\255\255\255\255\255\ \255\255\071\000\255\255\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \255\255\255\255\255\255\255\255\072\000\255\255\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\255\255\255\255\255\255\255\255\073\000\ \255\255\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\255\255\255\255\ \255\255\255\255\074\000\255\255\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\255\255\255\255\255\255\255\255\075\000\255\255\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\076\000\255\255\255\255\255\255\255\255\ \076\000\255\255\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\076\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\255\255\ \255\255\255\255\255\255\077\000\255\255\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\255\255\255\255\255\255\255\255\078\000\255\255\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\255\255\255\255\255\255\ \255\255\079\000\255\255\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\080\000\080\000\080\000\ \080\000\080\000\080\000\080\000\080\000\080\000\080\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\080\000\080\000\ \080\000\080\000\080\000\080\000\080\000\080\000\080\000\080\000\ \080\000\080\000\080\000\080\000\080\000\080\000\080\000\080\000\ \080\000\080\000\080\000\080\000\080\000\080\000\080\000\080\000\ \255\255\255\255\255\255\255\255\080\000\255\255\080\000\080\000\ \080\000\080\000\080\000\080\000\080\000\080\000\080\000\080\000\ \080\000\080\000\080\000\080\000\080\000\080\000\080\000\080\000\ \080\000\080\000\080\000\080\000\080\000\080\000\080\000\080\000\ \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\081\000\255\255\255\255\255\255\255\255\081\000\ \255\255\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ \081\000\081\000\081\000\082\000\082\000\082\000\082\000\082\000\ \082\000\082\000\082\000\082\000\082\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\082\000\082\000\082\000\082\000\ \082\000\082\000\082\000\082\000\082\000\082\000\082\000\082\000\ \082\000\082\000\082\000\082\000\082\000\082\000\082\000\082\000\ \082\000\082\000\082\000\082\000\082\000\082\000\255\255\255\255\ \255\255\255\255\082\000\255\255\082\000\082\000\082\000\082\000\ \082\000\082\000\082\000\082\000\082\000\082\000\082\000\082\000\ \082\000\082\000\082\000\082\000\082\000\082\000\082\000\082\000\ \082\000\082\000\082\000\082\000\082\000\082\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\255\255\255\255\255\255\255\255\083\000\255\255\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\084\000\084\000\084\000\084\000\084\000\084\000\084\000\ \084\000\084\000\084\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\084\000\084\000\084\000\084\000\084\000\084\000\ \084\000\084\000\084\000\084\000\084\000\084\000\084\000\084\000\ \084\000\084\000\084\000\084\000\084\000\084\000\084\000\084\000\ \084\000\084\000\084\000\084\000\255\255\255\255\255\255\255\255\ \084\000\255\255\084\000\084\000\084\000\084\000\084\000\084\000\ \084\000\084\000\084\000\084\000\084\000\084\000\084\000\084\000\ \084\000\084\000\084\000\084\000\084\000\084\000\084\000\084\000\ \084\000\084\000\084\000\084\000\085\000\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\085\000\085\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\085\000\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\085\000\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\085\000\085\000\085\000\255\255\ \255\255\255\255\255\255\085\000\255\255\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\085\000\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\085\000\085\000\085\000\085\000\ \085\000\085\000\085\000\085\000\085\000\085\000\085\000\086\000\ \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ \086\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ \086\000\086\000\255\255\255\255\255\255\255\255\086\000\255\255\ \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ \086\000\086\000\087\000\087\000\087\000\087\000\087\000\087\000\ \087\000\087\000\087\000\087\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\087\000\087\000\087\000\087\000\087\000\ \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ \087\000\087\000\087\000\087\000\087\000\255\255\255\255\255\255\ \255\255\087\000\255\255\087\000\087\000\087\000\087\000\087\000\ \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ \087\000\087\000\087\000\087\000\087\000\088\000\088\000\088\000\ \088\000\088\000\088\000\088\000\088\000\088\000\088\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\088\000\088\000\ \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ \255\255\255\255\255\255\255\255\088\000\255\255\088\000\088\000\ \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ \089\000\089\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ \089\000\089\000\089\000\255\255\255\255\255\255\255\255\089\000\ \255\255\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ \089\000\089\000\089\000\090\000\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\090\000\255\255\255\255\ \255\255\255\255\090\000\255\255\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\090\000\090\000\090\000\ \090\000\090\000\090\000\090\000\090\000\090\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\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 -> # 57 "src/aorai/promelalexer_withexps.mll" ( PROMELA_TRUE ) # 1194 "src/aorai/promelalexer_withexps.ml" | 1 -> # 58 "src/aorai/promelalexer_withexps.mll" ( PROMELA_NEVER ) # 1199 "src/aorai/promelalexer_withexps.ml" | 2 -> # 59 "src/aorai/promelalexer_withexps.mll" ( PROMELA_IF ) # 1204 "src/aorai/promelalexer_withexps.ml" | 3 -> # 60 "src/aorai/promelalexer_withexps.mll" ( PROMELA_FI ) # 1209 "src/aorai/promelalexer_withexps.ml" | 4 -> # 61 "src/aorai/promelalexer_withexps.mll" ( PROMELA_GOTO ) # 1214 "src/aorai/promelalexer_withexps.ml" | 5 -> # 62 "src/aorai/promelalexer_withexps.mll" ( PROMELA_SKIP ) # 1219 "src/aorai/promelalexer_withexps.ml" | 6 -> # 63 "src/aorai/promelalexer_withexps.mll" ( PROMELA_DOUBLE_COLON ) # 1224 "src/aorai/promelalexer_withexps.ml" | 7 -> # 64 "src/aorai/promelalexer_withexps.mll" ( PROMELA_COLON ) # 1229 "src/aorai/promelalexer_withexps.ml" | 8 -> # 65 "src/aorai/promelalexer_withexps.mll" ( PROMELA_SEMICOLON ) # 1234 "src/aorai/promelalexer_withexps.ml" | 9 -> # 66 "src/aorai/promelalexer_withexps.mll" ( PROMELA_FUNC ) # 1239 "src/aorai/promelalexer_withexps.ml" | 10 -> # 67 "src/aorai/promelalexer_withexps.mll" ( PROMELA_LPAREN ) # 1244 "src/aorai/promelalexer_withexps.ml" | 11 -> # 68 "src/aorai/promelalexer_withexps.mll" ( PROMELA_RPAREN ) # 1249 "src/aorai/promelalexer_withexps.ml" | 12 -> # 69 "src/aorai/promelalexer_withexps.mll" ( PROMELA_LBRACE ) # 1254 "src/aorai/promelalexer_withexps.ml" | 13 -> # 70 "src/aorai/promelalexer_withexps.mll" ( PROMELA_RBRACE ) # 1259 "src/aorai/promelalexer_withexps.ml" | 14 -> # 71 "src/aorai/promelalexer_withexps.mll" ( PROMELA_RIGHT_ARROW ) # 1264 "src/aorai/promelalexer_withexps.ml" | 15 -> # 72 "src/aorai/promelalexer_withexps.mll" ( PROMELA_FALSE ) # 1269 "src/aorai/promelalexer_withexps.ml" | 16 -> # 73 "src/aorai/promelalexer_withexps.mll" ( PROMELA_OR ) # 1274 "src/aorai/promelalexer_withexps.ml" | 17 -> # 74 "src/aorai/promelalexer_withexps.mll" ( PROMELA_AND ) # 1279 "src/aorai/promelalexer_withexps.ml" | 18 -> # 75 "src/aorai/promelalexer_withexps.mll" ( PROMELA_NOT ) # 1284 "src/aorai/promelalexer_withexps.ml" | 19 -> # 76 "src/aorai/promelalexer_withexps.mll" ( token lexbuf ) # 1289 "src/aorai/promelalexer_withexps.ml" | 20 -> # 77 "src/aorai/promelalexer_withexps.mll" ( newline lexbuf; token lexbuf ) # 1294 "src/aorai/promelalexer_withexps.ml" | 21 -> # 78 "src/aorai/promelalexer_withexps.mll" ( comment lexbuf; token lexbuf ) # 1299 "src/aorai/promelalexer_withexps.ml" | 22 -> # 79 "src/aorai/promelalexer_withexps.mll" ( newline lexbuf; token lexbuf ) # 1304 "src/aorai/promelalexer_withexps.ml" | 23 -> # 82 "src/aorai/promelalexer_withexps.mll" ( let s=(lexeme lexbuf) in let s=String.sub s 7 ((String.length s)-7) in PROMELA_CALLOF s ) # 1311 "src/aorai/promelalexer_withexps.ml" | 24 -> # 86 "src/aorai/promelalexer_withexps.mll" ( let s=(lexeme lexbuf) in let s=String.sub s 9 ((String.length s)-9) in PROMELA_RETURNOF s ) # 1318 "src/aorai/promelalexer_withexps.ml" | 25 -> # 90 "src/aorai/promelalexer_withexps.mll" ( let s=(lexeme lexbuf) in let s=String.sub s 15 ((String.length s)-15) in PROMELA_CALLORRETURNOF s ) # 1325 "src/aorai/promelalexer_withexps.ml" | 26 -> # 95 "src/aorai/promelalexer_withexps.mll" ( raise_located (loc lexbuf) "Illegal fonction name in Promela file." ) # 1330 "src/aorai/promelalexer_withexps.ml" | 27 -> # 96 "src/aorai/promelalexer_withexps.mll" ( raise_located (loc lexbuf) "Illegal fonction name in Promela file." ) # 1335 "src/aorai/promelalexer_withexps.ml" | 28 -> # 97 "src/aorai/promelalexer_withexps.mll" ( raise_located (loc lexbuf) "Illegal fonction name in Promela file." ) # 1340 "src/aorai/promelalexer_withexps.ml" | 29 -> # 100 "src/aorai/promelalexer_withexps.mll" ( PROMELA_INT (lexeme lexbuf) ) # 1345 "src/aorai/promelalexer_withexps.ml" | 30 -> # 104 "src/aorai/promelalexer_withexps.mll" ( PROMELA_EQ ) # 1350 "src/aorai/promelalexer_withexps.ml" | 31 -> # 105 "src/aorai/promelalexer_withexps.mll" ( PROMELA_LT ) # 1355 "src/aorai/promelalexer_withexps.ml" | 32 -> # 106 "src/aorai/promelalexer_withexps.mll" ( PROMELA_GT ) # 1360 "src/aorai/promelalexer_withexps.ml" | 33 -> # 107 "src/aorai/promelalexer_withexps.mll" ( PROMELA_LE ) # 1365 "src/aorai/promelalexer_withexps.ml" | 34 -> # 108 "src/aorai/promelalexer_withexps.mll" ( PROMELA_GE ) # 1370 "src/aorai/promelalexer_withexps.ml" | 35 -> # 109 "src/aorai/promelalexer_withexps.mll" ( PROMELA_NEQ ) # 1375 "src/aorai/promelalexer_withexps.ml" | 36 -> # 112 "src/aorai/promelalexer_withexps.mll" ( PROMELA_PLUS ) # 1380 "src/aorai/promelalexer_withexps.ml" | 37 -> # 113 "src/aorai/promelalexer_withexps.mll" ( PROMELA_MINUS ) # 1385 "src/aorai/promelalexer_withexps.ml" | 38 -> # 114 "src/aorai/promelalexer_withexps.mll" ( PROMELA_DIV ) # 1390 "src/aorai/promelalexer_withexps.ml" | 39 -> # 115 "src/aorai/promelalexer_withexps.mll" ( PROMELA_STAR ) # 1395 "src/aorai/promelalexer_withexps.ml" | 40 -> # 116 "src/aorai/promelalexer_withexps.mll" ( PROMELA_MODULO) # 1400 "src/aorai/promelalexer_withexps.ml" | 41 -> # 120 "src/aorai/promelalexer_withexps.mll" ( PROMELA_DOT ) # 1405 "src/aorai/promelalexer_withexps.ml" | 42 -> # 121 "src/aorai/promelalexer_withexps.mll" ( PROMELA_LEFT_SQUARE) # 1410 "src/aorai/promelalexer_withexps.ml" | 43 -> # 122 "src/aorai/promelalexer_withexps.mll" ( PROMELA_RIGHT_SQUARE) # 1415 "src/aorai/promelalexer_withexps.ml" | 44 -> # 128 "src/aorai/promelalexer_withexps.mll" ( let s = lexeme lexbuf in PROMELA_LABEL s ) # 1421 "src/aorai/promelalexer_withexps.ml" | 45 -> # 130 "src/aorai/promelalexer_withexps.mll" ( EOF ) # 1426 "src/aorai/promelalexer_withexps.ml" | 46 -> # 132 "src/aorai/promelalexer_withexps.mll" ( PROMELA_TRUE ) # 1431 "src/aorai/promelalexer_withexps.ml" | 47 -> # 133 "src/aorai/promelalexer_withexps.mll" ( Aorai_option.error "Illegal_character : '%s'\n" (lexeme lexbuf); raise Parsing.Parse_error) # 1437 "src/aorai/promelalexer_withexps.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_token_rec lexbuf __ocaml_lex_state and comment lexbuf = __ocaml_lex_comment_rec lexbuf 94 and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 140 "src/aorai/promelalexer_withexps.mll" ( () ) # 1448 "src/aorai/promelalexer_withexps.ml" | 1 -> # 141 "src/aorai/promelalexer_withexps.mll" ( Aorai_option.warning "Unterminated_comment\n" (*lex_error lexbuf "Unterminated_comment"*) ) # 1453 "src/aorai/promelalexer_withexps.ml" | 2 -> # 142 "src/aorai/promelalexer_withexps.mll" ( newline lexbuf; comment lexbuf ) # 1458 "src/aorai/promelalexer_withexps.ml" | 3 -> # 143 "src/aorai/promelalexer_withexps.mll" ( comment lexbuf ) # 1463 "src/aorai/promelalexer_withexps.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_comment_rec lexbuf __ocaml_lex_state ;; # 146 "src/aorai/promelalexer_withexps.mll" let parse c = let lb = from_channel c in try Promelaparser_withexps.promela token lb with Parsing.Parse_error | Invalid_argument _ -> let (a,b)=(loc lb) in Aorai_option.error "Syntax error (l%d c%d -> l%dc%d)" a.pos_lnum (a.pos_cnum-a.pos_bol) b.pos_lnum (b.pos_cnum-b.pos_bol); (* Format.print_string "Syntax error (" ; *) (* Format.print_string "l" ; *) (* Format.print_int a.pos_lnum ; *) (* Format.print_string "c" ; *) (* Format.print_int (a.pos_cnum-a.pos_bol) ;*) (* Format.print_string " -> l" ; *) (* Format.print_int b.pos_lnum ; *) (* Format.print_string "c" ; *) (* Format.print_int (b.pos_cnum-b.pos_bol) ;*) (* Format.print_string ")\n" ; *) raise_located (loc lb) "Syntax error" # 1495 "src/aorai/promelalexer_withexps.ml" frama-c-Fluorine-20130601/src/aorai/promelaoutput.mli0000644000175000017500000000563012155630222021304 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 print_raw_automata : Format.formatter -> Promelaast.typed_automaton -> unit val print_parsed_expression: Format.formatter -> Promelaast.expression -> unit val print_parsed_condition: Format.formatter -> Promelaast.condition -> unit val print_seq_elt: Format.formatter -> Promelaast.seq_elt -> unit val print_sequence: Format.formatter -> Promelaast.sequence -> unit val print_parsed: Format.formatter -> Promelaast.parsed_condition -> unit val print_condition: Format.formatter -> Promelaast.typed_condition -> unit val print_action: Format.formatter -> Promelaast.action -> unit val print_transition: Format.formatter -> (Promelaast.typed_condition * Promelaast.action) Promelaast.trans -> unit val print_transitionl: Format.formatter -> (Promelaast.typed_condition * Promelaast.action) Promelaast.trans list -> unit val print_state : Format.formatter -> Promelaast.state -> unit val print_statel : Format.formatter -> Promelaast.state list -> unit val output_dot_automata : Promelaast.typed_automaton -> string -> unit (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/data_for_aorai.ml0000644000175000017500000023714312155630222021153 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 Logic_ptree open Cil open Cil_types open Promelaast open Logic_simplification module Aorai_state = Datatype.Make_with_collections( struct type t = Promelaast.state let structural_descr = Structural_descr.Abstract let reprs = [ { nums = -1; name = ""; multi_state = None; acceptation = Bool3.False; init = Bool3.False } ] let name = "Aorai_state" let equal x y = Datatype.Int.equal x.nums y.nums let hash x = x.nums let rehash x = x let compare x y = Datatype.Int.compare x.nums y.nums let copy x = x let internal_pretty_code = Datatype.undefined let pretty fmt x = Format.fprintf fmt "state_%d" x.nums let varname _ = assert false (* unused while internal_pretty_code is undefined *) let mem_project = Datatype.never_any_project end ) module Aorai_typed_trans = Datatype.Make_with_collections( struct let name = "Aorai_typed_trans" type t = (Promelaast.typed_condition * Promelaast.action) Promelaast.trans let structural_descr = Structural_descr.Abstract let reprs = [ { numt = -1; start = List.hd (Aorai_state.reprs); stop = List.hd (Aorai_state.reprs); cross = (TTrue,[]); } ] let equal x y = Datatype.Int.equal x.numt y.numt let hash x = x.numt let rehash = Extlib.id let compare x y = Datatype.Int.compare x.numt y.numt let copy = Extlib.id let internal_pretty_code = Datatype.undefined let pretty = Promelaoutput.print_transition let varname _ = assert false let mem_project = Datatype.never_any_project end) module State_var = State_builder.Hashtbl (Aorai_state.Hashtbl) (Cil_datatype.Varinfo) (struct let name = "Data_for_aorai.State_var" let dependencies = [ Ast.self; Aorai_option.Ya.self ] let size = 7 end) let get_state_var = let add_var state = Cil.makeVarinfo true false state.name Cil.intType in State_var.memo add_var let get_state_logic_var state = Cil.cvar_to_lvar (get_state_var state) module Max_value_counter = State_builder.Hashtbl (Cil_datatype.Term.Hashtbl) (Cil_datatype.Term) (struct let name = "Data_for_aorai.Max_value_counter" let dependencies = [ Ast.self; Aorai_option.Ya.self ] let size = 7 end) let find_max_value t = try Some (Max_value_counter.find t) with Not_found -> None let raise_error msg = Aorai_option.fatal "Aorai plugin internal error. \nStatus : %s.\n" msg;; (* Format.printf "Aorai plugin internal error. \nStatus : %s.\n" msg; *) (* assert false *) let por t1 t2 = match t1,t2 with PTrue,_ | _,PTrue -> PTrue | PFalse,t | t,PFalse -> t | _,_ -> POr(t1,t2) let pand t1 t2 = match t1,t2 with PTrue,t | t,PTrue -> t | PFalse,_ | _,PFalse -> PFalse | _,_ -> PAnd(t1,t2) let pnot t = match t with PTrue -> PFalse | PFalse -> PTrue | PNot t -> t | _ -> PNot t let rec is_same_expression e1 e2 = match e1,e2 with | PVar x, PVar y -> x = y | PVar _,_ | _,PVar _ -> false | PCst cst1, PCst cst2 -> Logic_utils.is_same_pconstant cst1 cst2 | PCst _,_ | _,PCst _ -> false | PPrm (f1,x1), PPrm(f2,x2) -> f1 = x1 && f2 = x2 | PPrm _,_ | _,PPrm _ -> false | PBinop(b1,l1,r1), PBinop(b2,l2,r2) -> b1 = b2 && is_same_expression l1 l2 && is_same_expression r1 r2 | PBinop _, _ | _, PBinop _ -> false | PUnop(u1,e1), PUnop(u2,e2) -> u1 = u2 && is_same_expression e1 e2 | PUnop _,_ | _,PUnop _ -> false | PArrget(a1,i1), PArrget(a2,i2) -> is_same_expression a1 a2 && is_same_expression i1 i2 | PArrget _,_ | _,PArrget _ -> false | PField(e1,f1), PField(e2,f2) -> f1 = f2 && is_same_expression e1 e2 | PField _,_ | _,PField _ -> false | PArrow(e1,f1), PArrow(e2,f2) -> f1 = f2 && is_same_expression e1 e2 let declared_logics = Hashtbl.create 97 let add_logic name log_info = Hashtbl.replace declared_logics name log_info let get_logic name = try Hashtbl.find declared_logics name with _ -> raise_error ("Logic function '"^name^"' not declared in hashtbl") let declared_predicates = Hashtbl.create 97 let add_predicate name pred_info = Hashtbl.replace declared_predicates name pred_info let get_predicate name = try Hashtbl.find declared_predicates name with _ -> raise_error ("Predicate '"^name^"' not declared in hashtbl") (* ************************************************************************* *) (* Some constant names used for generation *) (* Logic variables *) let transStart = "aorai_Trans_Start" (* OK *) let transStop = "aorai_Trans_Stop" (* OK *) let transCond = "aorai_Trans_Cond" (* OK *) let transCondP = "aorai_Trans_Cond_param" (* OK *) let loopInit = "aorai_Loop_Init" (* OK *) (* C variables *) let curState = "aorai_CurStates" (* OK *) let curStateOld = "aorai_CurStates_old" (* OK *) let curTrans = "aorai_CurTrans" (* OK *) (*let curTransTmp = "aorai_CurTrans_tmp" (* OK *)*) let curOp = "aorai_CurOperation" (* OK *) let curOpStatus = "aorai_CurOpStatus" (* OK *) let acceptSt = "aorai_AcceptStates" (* TODO *) (* C constants #define *) let nbOp = "aorai_NbOper" (* Deprecated ? *) let nbStates = "aorai_NbStates" (* Deprecated ? *) let nbAcceptSt = "aorai_NbAcceptStates" (* Deprecated ? *) let nbTrans = "aorai_NbTrans" (* Deprecated ? *) (* C Macros *) let macro_ligth = "aorai_Macro_Prop_St_Tr_Without_Conds" (* Deprecated ? *) let macro_full = "aorai_Macro_Prop_St_Tr" (* Deprecated ? *) let macro_pure = "aorai_Macro_Op_without_sub_call" (* Deprecated ? *) (* C enumeration *) let listOp = "aorai_ListOper" (* OK *) let listStatus = "aorai_OpStatusList" (* OK *) let callStatus = "aorai_Called" (* OK *) let termStatus = "aorai_Terminated" (* OK *) let states = "aorai_States" (* OK *) (* C function *) let buch_sync = "Aorai_Sync" (* Deprecated ? *) (* ************************************************************************* *) (* Buchi automata as stored after parsing *) let automata = ref ([],[]) (* Each transition with a parametrized cross condition (call param access or return value access) has its parametrized part stored in this array. *) let cond_of_parametrizedTransitions = ref (Array.make (1) [[]]) (* List of variables name observed in the C file *) let variables_from_c = ref [] (* List of functions name observed in the C file *) let functions_from_c = ref [] (* List of functions call observed in the C file without declaration *) let ignored_functions = ref [] (** Return the buchi automata as stored after parsing *) let getAutomata () = !automata (** Return the number of transitions of the automata *) let getNumberOfTransitions () = List.length (snd !automata) (** Return the number of states of the automata *) let getNumberOfStates () = List.length (fst !automata) let is_c_global name = try ignore (Globals.Vars.find_from_astinfo name VGlobal); true with Not_found -> try ignore (Globals.Functions.find_by_name name); true with Not_found -> false let get_fresh = let used_names = Hashtbl.create 5 in fun name -> if Clexer.is_c_keyword name || Logic_lexer.is_acsl_keyword name || is_c_global name || Hashtbl.mem used_names name then begin let i = ref (try Hashtbl.find used_names name with Not_found -> 0) in let proposed_name () = name ^ "_" ^ string_of_int !i in while is_c_global (proposed_name()) do incr i done; Hashtbl.replace used_names name (!i+1); proposed_name () end else begin Hashtbl.add used_names name 0; name end module AuxVariables = State_builder.List_ref (Cil_datatype.Varinfo) (struct let name = "Data_for_aorai.AuxVariables" let dependencies = [ Aorai_option.Ltl_File.self; Aorai_option.Buchi.self; Aorai_option.Ya.self; Ast.self ] end) module AbstractLogicInfo = State_builder.List_ref (Cil_datatype.Logic_info) (struct let name = "Data_for_aorai.AbstractLogicInfo" let dependencies = [ Aorai_option.Ltl_File.self; Aorai_option.Buchi.self; Aorai_option.Ya.self; Ast.self ] end) class change_var vi1 vi2 = object inherit Visitor.frama_c_copy (Project.current ()) method vlogic_var_use vi = if Cil_datatype.Logic_var.equal vi1 vi then ChangeTo vi2 else SkipChildren end let change_var_term vi1 vi2 t = Visitor.visitFramacTerm (new change_var vi1 vi2) t let update_condition vi1 vi2 cond = let rec aux e = match e with | TOr (e1,e2) -> TOr(aux e1, aux e2) | TAnd (e1,e2) -> TAnd(aux e1, aux e2) | TNot e -> TNot (aux e) | TCall _ | TReturn _ | TTrue | TFalse -> e | TRel(rel,t1,t2) -> TRel(rel,change_var_term vi1 vi2 t1,change_var_term vi1 vi2 t2) in aux cond let pebble_set_at li lab = assert (li.l_profile = []); let labels = List.map (fun x -> (x,lab)) li.l_labels in Logic_const.term (Tapp (li,labels,[])) (Extlib.the li.l_type) let memo_multi_state st = match st.multi_state with | None -> let aux = Cil.makeGlobalVar (get_fresh "aorai_aux") Cil.intType in let laux = Cil.cvar_to_lvar aux in let set = Cil_const.make_logic_info (get_fresh (st.name ^ "_pebble")) in let typ = Logic_const.make_set_type (Ctype Cil.intType) in set.l_var_info.lv_type <- typ; set.l_labels <- [ LogicLabel(None,"L")]; set.l_type <- Some typ; set.l_body <- LBreads [ Logic_const.new_identified_term (Logic_const.tvar laux) ]; let multi_state = set,laux in st.multi_state <- Some multi_state; multi_state | Some multi_state -> multi_state let change_bound_var st1 st2 cond = if Extlib.has_some st1.multi_state then begin let (_,idx1) = Extlib.the st1.multi_state in let (_,idx2) = memo_multi_state st2 in update_condition idx1 idx2 cond end else cond let add_aux_variable vi = AuxVariables.add vi let aux_variables = AuxVariables.get let abstract_logic_info = AbstractLogicInfo.get module StateIndex = State_builder.Counter(struct let name = "Data_for_aorai.StateIndex" end) module TransIndex = State_builder.Counter(struct let name = "Data_for_aorai.TransIndex" end) let new_state name = { name = get_fresh name; acceptation = Bool3.False; init = Bool3.False; nums = StateIndex.next(); multi_state = None } let new_intermediate_state () = new_state "aorai_intermediate_state" let new_trans start stop cond = { start = start; stop = stop; cross = cond; numt = TransIndex.next () } let check_states s = let states,trans = getAutomata() in let max = getNumberOfStates () in List.iter (fun x -> if x.nums >= max then Aorai_option.fatal "%s: State %d found while max id is supposed to be %d" s x.nums max) states; List.iter (fun x -> try let y = List.find (fun y -> x.nums = y.nums && not (x==y)) states in Aorai_option.fatal "%s: State %s and %s share same id %d" s x.name y.name x.nums with Not_found -> () ) states; List.iter (fun x -> if not (List.memq x.start states) then Aorai_option.fatal "%s: Start state %d of transition %d is not among known states" s x.start.nums x.numt; if not (List.memq x.stop states) then Aorai_option.fatal "%s: End state %d of transition %d is not among known states" s x.start.nums x.numt;) trans let cst_one = PCst (Logic_ptree.IntConstant "1") let cst_zero = PCst (Logic_ptree.IntConstant "0") let is_cst_zero e = match e with | PCst(IntConstant "0") -> true | _ -> false let is_cst_one e = match e with PCst (IntConstant "1") -> true | _ -> false let is_single elt = match elt.min_rep, elt.max_rep with | Some min, Some max -> is_cst_one min && is_cst_one max | _ -> false (* Epsilon transitions will account for the possibility of not entering a repeated sequence at all. They will be normalized after the entire automaton is processed by adding direct transitions from the starting state to the children of the end state. *) type eps_trans = Normal of typed_condition * action | Epsilon of typed_condition * action let print_epsilon_trans fmt = function | Normal (c,a) -> Format.fprintf fmt "%a%a" Promelaoutput.print_condition c Promelaoutput.print_action a | Epsilon (c,a) -> Format.fprintf fmt "epsilon-trans:@\n%a%a" Promelaoutput.print_condition c Promelaoutput.print_action a type current_event = | ECall of kernel_function * Cil_types.logic_var Cil_datatype.Varinfo.Hashtbl.t * eps_trans Promelaast.trans | EReturn of kernel_function | ECOR of kernel_function | ENone (* None found yet *) | EMulti (* multiple event possible. repr of the stack does not take into account this particular event. *) let add_current_event event env cond = let is_empty tbl = Cil_datatype.Varinfo.Hashtbl.length tbl = 0 in match env with [] -> assert false | old_event :: tl -> match event, old_event with | ENone, _ -> env, cond | _, ENone -> event::tl, cond | ECall (kf1,_,_), ECall (kf2,_,_) when Kernel_function.equal kf1 kf2 -> env, cond | ECall (kf1,tbl1,_), ECall (kf2,tbl2,_)-> (* ltl2buchi generates such inconsistent guards, but luckily does not speak about formals. In this case, we just return False with an empty event. If this situation occurs in an handwritten automaton that uses formals we simply reject it. *) if is_empty tbl1 && is_empty tbl2 then ENone::tl, TFalse else Aorai_option.abort "specification is inconsistent: two call events for distinct \ functions %a and %a at the same time." Kernel_function.pretty kf1 Kernel_function.pretty kf2 | ECall (_,_,_), EMulti -> event::tl, cond | ECall (kf1,tbl1,_), EReturn kf2 -> if is_empty tbl1 then ENone::tl, TFalse else Aorai_option.abort "specification is inconsistent: trying to call %a and \ return from %a at the same time." Kernel_function.pretty kf1 Kernel_function.pretty kf2 | ECall(kf1,_,_), ECOR kf2 when Kernel_function.equal kf1 kf2 -> event::tl, cond | ECall (kf1,tbl1,_), ECOR kf2 -> if is_empty tbl1 then ENone::tl, TFalse else Aorai_option.abort "specification is inconsistent: trying to call %a and \ call or return from %a at the same time." Kernel_function.pretty kf1 Kernel_function.pretty kf2 | EReturn kf1, ECall(kf2,tbl2,_) -> if is_empty tbl2 then ENone::tl, TFalse else Aorai_option.abort "specification is inconsistent: trying to call %a and \ return from %a at the same time." Kernel_function.pretty kf2 Kernel_function.pretty kf1 | EReturn kf1, (ECOR kf2 | EReturn kf2) when Kernel_function.equal kf1 kf2 -> event::tl, cond | EReturn _, EReturn _ -> ENone::tl, TFalse | EReturn _, ECOR _ -> ENone::tl, TFalse | EReturn _, EMulti -> ENone::tl, TFalse | (EMulti | ECOR _), _ -> assert false (* These are compound event. They cannot be found as individual ones*) let merge_current_event env1 env2 cond1 cond2 = assert (List.tl env1 == List.tl env2); let old_env = List.tl env2 in match (List.hd env1, List.hd env2) with | ENone, _ -> env2, tor cond1 cond2 | _, ENone -> env1, tor cond1 cond2 | ECall(kf1,_,_), ECall(kf2,_,_) when Kernel_function.equal kf1 kf2 -> env2, tor cond1 cond2 | ECall _, ECall _ -> EMulti::old_env, tor cond1 cond2 | ECall _, EMulti -> env2, tor cond1 cond2 | ECall (kf1,_,_), ECOR kf2 when Kernel_function.equal kf1 kf2 -> env2, tor cond1 cond2 | ECall (kf1,_,_), EReturn kf2 when Kernel_function.equal kf1 kf2 -> ECOR kf1 :: old_env, tor cond1 cond2 | ECall _, (ECOR _ | EReturn _) -> EMulti :: old_env, tor cond1 cond2 | EReturn kf1, ECall (kf2,_,_) when Kernel_function.equal kf1 kf2 -> ECOR kf1 :: old_env, tor cond1 cond2 | EReturn _, ECall _ -> EMulti :: old_env, tor cond1 cond2 | EReturn kf1, EReturn kf2 when Kernel_function.equal kf1 kf2 -> env2, tor cond1 cond2 | EReturn _, EReturn _ -> EMulti :: old_env, tor cond1 cond2 | EReturn _, EMulti -> env2, tor cond1 cond2 | EReturn kf1, ECOR kf2 when Kernel_function.equal kf1 kf2 -> env2, tor cond1 cond2 | EReturn _, ECOR _ -> EMulti :: old_env, tor cond1 cond2 | ECOR kf1, (ECall(kf2,_,_) | EReturn kf2 | ECOR kf2) when Kernel_function.equal kf1 kf2 -> env1, tor cond1 cond2 | ECOR _, (ECall _ | EReturn _ | ECOR _) -> EMulti :: old_env, tor cond1 cond2 | ECOR _, EMulti -> env2, tor cond1 cond2 | EMulti, (ECall _ | EReturn _ | ECOR _) -> env1, tor cond1 cond2 | EMulti, EMulti -> EMulti::old_env, tor cond1 cond2 let get_bindings st my_var = let my_lval = TVar my_var, TNoOffset in match st with None -> my_lval | Some st -> let (_,idx) = memo_multi_state st in Logic_const.addTermOffsetLval (TIndex (Logic_const.tvar idx,TNoOffset)) my_lval let get_bindings_term st my_var typ = Logic_const.term (TLval (get_bindings st my_var)) typ let memo_aux_variable tr counter used_prms vi = try let my_var = Cil_datatype.Varinfo.Hashtbl.find used_prms vi in get_bindings_term counter my_var (Ctype vi.vtype) with Not_found -> let my_type = match counter with | None -> vi.vtype | Some _ -> TArray(vi.vtype,None,{scache=Not_Computed},[]) in let my_var = Cil.makeGlobalVar (get_fresh ("aorai_" ^ vi.vname)) my_type in add_aux_variable my_var; let my_lvar = Cil.cvar_to_lvar my_var in Cil_datatype.Varinfo.Hashtbl.add used_prms vi my_lvar; (match tr.cross with | Normal (cond,action) -> let st = Extlib.opt_map (fun _ -> tr.stop) counter in let loc = get_bindings st my_lvar in let copy = Copy_value (loc,Logic_const.tvar (Cil.cvar_to_lvar vi)) in tr.cross <- Normal(cond,copy::action) | Epsilon _ -> Aorai_option.fatal "Epsilon transition used as Call event" ); get_bindings_term counter my_lvar (Ctype vi.vtype) let check_one top info counter s = match info with | ECall (kf,used_prms,tr) -> (try let vi = Globals.Vars.find_from_astinfo s (VFormal kf) in if top then Some (Logic_const.tvar (Cil.cvar_to_lvar vi)) else Some (memo_aux_variable tr counter used_prms vi) with Not_found -> None) | EReturn kf when top && ( Datatype.String.equal s "return" || Datatype.String.equal s "\\result") -> let rt = Kernel_function.get_return_type kf in if Cil.isVoidType rt then Aorai_option.abort "%a returns void. \\result is meaningless in this context" Kernel_function.pretty kf; Some (Logic_const.term (TLval (TResult rt,TNoOffset)) (Ctype rt)) | ECOR _ | EReturn _ | EMulti | ENone -> None let find_in_env env counter s = let current, stack = match env with | current::stack -> current, stack | [] -> Aorai_option.fatal "Empty type-checking environment" in match check_one true current counter s with Some lv -> lv | None -> let module M = struct exception Found of term end in (try List.iter (fun x -> match check_one false x counter s with None -> () | Some lv -> raise (M.Found lv)) stack; let vi = Globals.Vars.find_from_astinfo s VGlobal in Logic_const.tvar (Cil.cvar_to_lvar vi) with M.Found lv -> lv | Not_found -> Aorai_option.abort "Unknown variable %s" s) let find_prm_in_env env ?tr counter f x = let kf = try Globals.Functions.find_by_name f with Not_found -> Aorai_option.abort "Unknown function %s" f in if Datatype.String.equal x "return" || Datatype.String.equal x "\\result" then begin (* Return event *) let rt = Kernel_function.get_return_type kf in if Cil.isVoidType rt then Aorai_option.abort "%a returns void. %s().%s is meaningless in this context" Kernel_function.pretty kf f x; let env,cond = add_current_event (EReturn kf) env (TReturn kf) in env, Logic_const.term (TLval (TResult rt,TNoOffset)) (Ctype rt), cond end else begin (* Complete Call followed by Return event *) let rec treat_env top = function | ECall(kf',_,_) as event :: _ when Kernel_function.equal kf kf'-> (match check_one top event counter x with Some lv -> env, lv, TTrue | None -> Aorai_option.abort "Function %s has no parameter %s" f x) | (ENone | EReturn _ | EMulti | ECOR _ | ECall _ ) :: tl -> treat_env false tl | [] -> let env, cond = match tr with None -> Aorai_option.abort "Function %s is not in the call stack. \ Cannot use its parameter %s here" f x | Some tr -> add_current_event (ECall (kf, Cil_datatype.Varinfo.Hashtbl.create 3, tr)) env (TCall (kf,None)) in let vi = try Globals.Vars.find_from_astinfo x (VFormal kf) with Not_found -> Aorai_option.abort "Function %s has no parameter %s" f x in (* By definition, we are at the call event: no need to store it in an aux variable or array here. *) env, Logic_const.tvar (Cil.cvar_to_lvar vi), cond in treat_env true env end module C_logic_env = struct let anonCompFieldName = Cabs2cil.anonCompFieldName let conditionalConversion = Cabs2cil.logicConditionalConversion let is_loop () = false let find_macro _ = raise Not_found let find_var _ = raise Not_found let find_enum_tag _ = raise Not_found let find_comp_type ~kind:_ _ = raise Not_found let find_comp_field info s = let field = Cil.getCompField info s in Field(field,NoOffset) let find_type _ = raise Not_found let find_label _ = raise Not_found include Logic_env let add_logic_function = add_logic_function_gen Logic_utils.is_same_logic_profile let integral_cast ty t = Aorai_option.abort "term %a has type %a, but %a is expected." Printer.pp_term t Printer.pp_logic_type Linteger Printer.pp_typ ty end module LTyping = Logic_typing.Make(C_logic_env) let type_expr env ?tr ?current e = let loc = Cil_datatype.Location.unknown in let rec aux env cond e = match e with PVar s -> let var = find_in_env env current s in env, var, cond | PPrm(f,x) -> find_prm_in_env env ?tr current f x | PCst (Logic_ptree.IntConstant s) -> let e = Cil.parseIntLogic ~loc s in env, e, cond | PCst (Logic_ptree.FloatConstant str) -> let c = Logic_utils.string_to_float_lconstant str in env, Logic_const.term (TConst c) Lreal, cond | PCst (Logic_ptree.StringConstant s) -> let t = Logic_const.term (TConst(LStr (Logic_typing.unescape s))) (Ctype Cil.charPtrType) in env,t,cond | PCst (Logic_ptree.WStringConstant s) -> let t = Logic_const.term (TConst (LWStr (Logic_typing.wcharlist_of_string s))) (Ctype (TPtr(Cil.theMachine.wcharType,[]))) in env,t,cond | PBinop(bop,e1,e2) -> let op = Logic_typing.type_binop bop in let env,e1,cond = aux env cond e1 in let env,e2,cond = aux env cond e2 in let t1 = e1.term_type in let t2 = e2.term_type in let t = if Logic_typing.is_arithmetic_type t1 && Logic_typing.is_arithmetic_type t2 then let t = Logic_typing.arithmetic_conversion t1 t2 in Logic_const.term (TBinOp (op,LTyping.mk_cast e1 t,LTyping.mk_cast e2 t)) t else (match bop with | Logic_ptree.Badd when Logic_typing.is_integral_type t2 && Logic_utils.isLogicPointerType t1 -> Logic_const.term (TBinOp (PlusPI,e1,e2)) t1 | Logic_ptree.Bsub when Logic_typing.is_integral_type t2 && Logic_utils.isLogicPointerType t1 -> Logic_const.term (TBinOp (MinusPI,e1,e2)) t1 | Logic_ptree.Badd when Logic_typing.is_integral_type t1 && Logic_utils.isLogicPointerType t2 -> Logic_const.term (TBinOp (PlusPI,e2,e1)) t2 | Logic_ptree.Bsub when Logic_typing.is_integral_type t1 && Logic_utils.isLogicPointerType t2 -> Logic_const.term (TBinOp (MinusPI,e2,e1)) t2 | Logic_ptree.Bsub when Logic_utils.isLogicPointerType t1 && Logic_utils.isLogicPointerType t2 -> Logic_const.term (TBinOp (MinusPP,e1,LTyping.mk_cast e2 t1)) Linteger | _ -> Aorai_option.abort "Invalid operands for binary operator %a: \ unexpected %a and %a" Printer.pp_binop op Printer.pp_term e1 Printer.pp_term e2) in env, t, cond | PUnop(Logic_ptree.Uminus,e) -> let env,t,cond = aux env cond e in if Logic_typing.is_arithmetic_type t.term_type then env,Logic_const.term (TUnOp (Neg,t)) Linteger,cond else Aorai_option.abort "Invalid operand for unary -: unexpected %a" Printer.pp_term t | PUnop(Logic_ptree.Ubw_not,e) -> let env,t,cond = aux env cond e in if Logic_typing.is_arithmetic_type t.term_type then env,Logic_const.term (TUnOp (BNot,t)) Linteger,cond else Aorai_option.abort "Invalid operand for bitwise not: unexpected %a" Printer.pp_term t | PUnop(Logic_ptree.Uamp,e) -> let env, t, cond = aux env cond e in let ptr = try Ctype (TPtr (Logic_utils.logicCType t.term_type,[])) with Failure _ -> Aorai_option.abort "Cannot take address: not a C type(%a): %a" Printer.pp_logic_type t.term_type Printer.pp_term t in (match t.term_node with | TLval v | TStartOf v -> env, Logic_const.taddrof v ptr, cond | _ -> Aorai_option.abort "Cannot take address: not an lvalue %a" Printer.pp_term t ) | PUnop (Logic_ptree.Ustar,e) -> let env, t, cond = aux env cond e in if Logic_utils.isLogicPointerType t.term_type then env, Logic_const.term (TLval (TMem t, TNoOffset)) (Logic_typing.type_of_pointed t.term_type), cond else Aorai_option.abort "Cannot dereference term %a" Printer.pp_term t | PArrget(e1,e2) -> let env, t1, cond = aux env cond e1 in let env, t2, cond = aux env cond e2 in let t = if Logic_utils.isLogicPointerType t1.term_type && Logic_typing.is_integral_type t2.term_type then Logic_const.term (TBinOp (IndexPI,t1,t2)) (Logic_typing.type_of_pointed t1.term_type) else if Logic_utils.isLogicPointerType t2.term_type && Logic_typing.is_integral_type t1.term_type then Logic_const.term (TBinOp (IndexPI,t2,t1)) (Logic_typing.type_of_pointed t2.term_type) else if Logic_utils.isLogicArrayType t1.term_type && Logic_typing.is_integral_type t2.term_type then (match t1.term_node with | TStartOf lv | TLval lv -> Logic_const.term (TLval (Logic_typing.add_offset_lval (TIndex (t2, TNoOffset)) lv)) (Logic_typing.type_of_array_elem t1.term_type) | _ -> Aorai_option.fatal "Unsupported operation: %a[%a]" Printer.pp_term t1 Printer.pp_term t2) else if Logic_utils.isLogicArrayType t2.term_type && Logic_typing.is_integral_type t1.term_type then (match t2.term_node with | TStartOf lv | TLval lv -> Logic_const.term (TLval (Logic_typing.add_offset_lval (TIndex (t1, TNoOffset)) lv)) (Logic_typing.type_of_array_elem t2.term_type) | _ -> Aorai_option.fatal "Unsupported operation: %a[%a]" Printer.pp_term t1 Printer.pp_term t2) else Aorai_option.abort "Subscripted value is neither array nor pointer: %a[%a]" Printer.pp_term t1 Printer.pp_term t2 in env, t, cond | PField(e,s) -> let env, t, cond = aux env cond e in (match t.term_node with | TLval lv -> let off, ty = LTyping.type_of_field loc s t.term_type in let lv = Logic_typing.add_offset_lval off lv in env, Logic_const.term (TLval lv) ty, cond | _ -> Aorai_option.fatal "Unsupported operation: %a.%s" Printer.pp_term t s) | PArrow(e,s) -> let env, t, cond = aux env cond e in if Logic_utils.isLogicPointerType t.term_type then begin let off, ty = LTyping.type_of_field loc s (Logic_typing.type_of_pointed t.term_type) in let lv = Logic_typing.add_offset_lval off (TMem t,TNoOffset) in env, Logic_const.term (TLval lv) ty, cond end else Aorai_option.abort "base term is not a pointer in %a -> %s" Printer.pp_term t s in aux env TTrue e let type_cond needs_pebble env tr cond = let current = if needs_pebble then Some tr.stop else None in let rec aux pos env = function | PRel(rel,e1,e2) -> let env, e1, c1 = type_expr env ~tr ?current e1 in let env, e2, c2 = type_expr env ~tr ?current e2 in let call_cond = if pos then tand c1 c2 else tor (tnot c1) (tnot c2) in let rel = TRel(Logic_typing.type_rel rel,e1,e2) in let cond = if pos then tand rel call_cond else tor rel call_cond in env, cond | PTrue -> env, TTrue | PFalse -> env, TFalse | POr(c1,c2) -> let env1, c1 = aux pos env c1 in let env2, c2 = aux pos env c2 in merge_current_event env1 env2 c1 c2 | PAnd(c1,c2) -> let env, c1 = aux pos env c1 in let env, c2 = aux pos env c2 in env, TAnd(c1,c2) | PNot c -> let env, c = aux (not pos) env c in env, TNot c | PCall (s,b) -> let kf = try Globals.Functions.find_by_name s with Not_found -> Aorai_option.abort "No such function: %s" s in let b = Extlib.opt_map (fun b -> let bhvs = Annotations.behaviors ~populate:false kf in try List.find (fun x -> x.b_name = b) bhvs with Not_found -> Aorai_option.abort "Function %a has no behavior named %s" Kernel_function.pretty kf b) b in if pos then add_current_event (ECall (kf, Cil_datatype.Varinfo.Hashtbl.create 3, tr)) env (TCall (kf,b)) else env, TCall (kf,b) | PReturn s -> let kf = try Globals.Functions.find_by_name s with Not_found -> Aorai_option.abort "No such function %s" s in if pos then add_current_event (EReturn kf) env (TReturn kf) else env, TReturn kf in aux true (ENone::env) cond module Reject_state = State_builder.Option_ref(Aorai_state) (struct let name = "Data_for_aorai.Reject_state" let dependencies = [ Ast.self; Aorai_option.Ltl_File.self; Aorai_option.Buchi.self; Aorai_option.Ya.self] end) let get_reject_state () = let create () = new_state "aorai_reject" in Reject_state.memo create let add_if_needed states st = if List.for_all (fun x -> not (Aorai_state.equal x st)) states then st::states else states let rec type_seq default_state tr env needs_pebble curr_start curr_end seq = let loc = Cil_datatype.Location.unknown in match seq with | [] -> (* We identify start and end. *) (env, [], [], curr_end, curr_end) | elt :: seq -> let is_single_trans = match elt.min_rep, elt.max_rep with | Some min, Some max -> is_cst_one min && is_cst_one max | None, _ | _, None -> false in let is_opt = match elt.min_rep with | Some min -> is_cst_zero min | None-> true in let might_be_zero = is_opt || (match Extlib.the elt.min_rep with PCst _ -> false | _ -> true) in let at_most_one = is_opt && match elt.max_rep with | None -> false | Some max -> is_cst_one max in let has_loop = not at_most_one && not is_single_trans in let needs_counter = match elt.min_rep, elt.max_rep with | None, None -> false | Some min, None -> not (is_cst_zero min || is_cst_one min) | None, Some max -> not (is_cst_one max) | Some min, Some max -> not (is_cst_zero min || is_cst_one min) || not (is_cst_one max) in let fixed_number_of_loop = match elt.min_rep, elt.max_rep with | _, None -> false | None, Some max -> not (is_cst_zero max) | Some min, Some max -> is_same_expression min max in let my_end = match seq with [] when not (curr_end.nums = tr.stop.nums) || is_single_trans || at_most_one -> curr_end | _ -> new_intermediate_state () in Aorai_option.debug "Examining single elt:@\n%s -> %s:@[%a@]" curr_start.name my_end.name Promelaoutput.print_seq_elt elt; let guard_exit_loop env current counter = if is_opt then TTrue else let e = Extlib.the elt.min_rep in let _,e,_ = type_expr env ?current e in (* If we have done at least the lower bound of cycles, we can exit the loop. *) TRel(Cil_types.Rle,e,counter) in let guard_loop env current counter = match elt.max_rep with | None -> (* We're using an int: adds an (somewhat artificial) requirements that the counter itself does not overflow... *) let i = Cil.max_signed_number (Cil.bitsSizeOf Cil.intType) in let e = Logic_const.tint ~loc i in TRel(Cil_types.Rlt, counter, e) | Some e -> let _,e,_ = type_expr env ?current e in Max_value_counter.replace counter e; (* The counter is incremented after the test: it must be strictly less than the upper bound to enter a new cycle. *) TRel(Cil_types.Rlt, counter, e) in let env,inner_states, inner_trans, inner_start, inner_end = match elt.condition with | None -> assert (elt.nested <> []); (* we don't have a completely empty condition. *) type_seq default_state tr env needs_pebble curr_start my_end elt.nested | Some cond -> let seq_start = match elt.nested with [] -> my_end | _ -> new_intermediate_state () in let trans_start = new_trans curr_start seq_start (Normal (TTrue,[])) in let inner_env, cond = type_cond needs_pebble env trans_start cond in let (env,states, seq_transitions, seq_end) = match elt.nested with | [] -> inner_env, [], [], my_end | _ -> let intermediate = new_intermediate_state () in let (env, states, transitions, _, seq_end) = type_seq default_state tr inner_env needs_pebble seq_start intermediate elt.nested in env, states, transitions, seq_end in let states = add_if_needed states curr_start in let transitions = trans_start :: seq_transitions in (match trans_start.cross with | Normal (conds,action) -> trans_start.cross <- Normal(tand cond conds,action) | Epsilon _ -> Aorai_option.fatal "Transition guard translated as epsilon transition"); let states = add_if_needed states seq_start in (match env with | [] | (ENone | ECall _) :: _ -> (env, states, transitions, curr_start, seq_end) | EReturn kf1 :: ECall (kf2,_,_) :: tl when Kernel_function.equal kf1 kf2 -> (tl, states, transitions, curr_start, seq_end) | (EReturn _ | ECOR _ ) :: _ -> (* If there is as mismatch (e.g. Call f; Return g), it will be caught later. There are legitimate situations for this pattern however (if the sequence itself occurs in a non-empty context in particular) *) (env, states, transitions, curr_start, seq_end) | EMulti :: env -> (env, states, transitions, curr_start, seq_end)) in let loop_end = if has_loop then new_intermediate_state () else inner_end in let (_,oth_states,oth_trans,oth_start,_) = type_seq default_state tr env needs_pebble loop_end curr_end seq in let trans = inner_trans @ oth_trans in let states = List.fold_left add_if_needed oth_states inner_states in let auto = (inner_states,inner_trans) in if at_most_one then begin (* Just adds an epsilon transition from start to end *) let opt = new_trans curr_start oth_start (Epsilon (TTrue,[])) in env, states, opt::trans, curr_start, curr_end end else if has_loop then begin (* TODO: makes it an integer *) let counter = let ty = if needs_pebble then Cil_types.TArray (Cil.intType,None,{scache=Not_Computed},[]) else Cil.intType in (* We won't always need a counter *) lazy ( let vi = Cil.makeGlobalVar (get_fresh "aorai_counter") ty in add_aux_variable vi; vi ) in let make_counter st = let vi = Lazy.force counter in let base = TVar (Cil.cvar_to_lvar vi), TNoOffset in if needs_pebble then let (_,idx) = memo_multi_state st in Logic_const.addTermOffsetLval (TIndex (Logic_const.tvar idx,TNoOffset)) base else base in let make_counter_term st = Logic_const.term (TLval (make_counter st)) (Ctype Cil.intType) in Aorai_option.debug "Inner start is %s; Inner end is %s" inner_start.name inner_end.name; let treat_state (states, oth_trans) st = let trans = Path_analysis.get_transitions_of_state st auto in if st.nums = inner_start.nums then begin let loop_trans = if needs_counter then begin List.fold_left (fun acc tr -> let init_action = Counter_init (make_counter tr.stop) in let init_cross = match tr.cross with | Normal (cond, actions) -> Normal(cond, init_action :: actions) | Epsilon(cond, actions) -> Epsilon(cond, init_action :: actions) in Aorai_option.debug "New init trans %s -> %s: %a" st.name tr.stop.name print_epsilon_trans init_cross; let init_trans = new_trans st tr.stop init_cross in if at_most_one then init_trans :: acc else begin let st = if needs_pebble then Some curr_start else None in let loop_cond = if needs_counter then guard_loop env st (make_counter_term curr_start) else TTrue in let loop_action = if needs_counter then begin let counter = make_counter curr_start in [ Counter_incr counter ] end else [] in let loop_cross = match tr.cross with | Normal(cond, actions) -> Normal(tand loop_cond cond, loop_action @ actions) | Epsilon(cond, actions) -> Epsilon(tand loop_cond cond, loop_action @ actions) in Aorai_option.debug "New loop trans %s -> %s: %a" inner_end.name tr.stop.name print_epsilon_trans loop_cross; let loop_trans = new_trans inner_end tr.stop loop_cross in init_trans :: loop_trans :: acc end) oth_trans trans end else oth_trans in let trans = if might_be_zero then begin (* We can bypass the inner transition altogether *) let zero_cond = if is_opt then TTrue else let current = if needs_pebble then Some curr_start else None in let _,t,_ = type_expr env ?current (Extlib.the elt.min_rep) in TRel (Cil_types.Req, t, Logic_const.tinteger ~loc 0) in let no_seq = new_trans st oth_start (Epsilon (zero_cond,[])) in no_seq :: loop_trans end else loop_trans in states, trans end else if st.nums = inner_end.nums then begin (* adds conditions on counter if needed *) let st = if needs_pebble then Some curr_end else None in let min_cond = if needs_counter then guard_exit_loop env st (make_counter_term curr_end) else TTrue in let min_cond = Epsilon (min_cond,[]) in Aorai_option.debug "New exit trans %s -> %s: %a" inner_end.name oth_start.name print_epsilon_trans min_cond; let exit_trans = new_trans inner_end oth_start min_cond in let trans = exit_trans :: trans @ oth_trans in states, trans end else begin (* inner state: add a rejection state for consistency purposes iff we don't have a constant number of repetition (i.e. cut out branches where automaton wrongly start a new step) and don't have an otherwise branch in the original automaton. *) if fixed_number_of_loop || default_state then states, trans @ oth_trans else begin let cond = List.fold_left (fun acc tr -> match tr.cross with | Normal (cond,_) | Epsilon (cond,_) -> let cond = change_bound_var tr.stop st cond in tor acc cond) TFalse trans in let (cond,_) = Logic_simplification.simplifyCond cond in let cond = tnot cond in (match cond with TFalse -> states, trans @ oth_trans | _ -> let reject = get_reject_state () in let states = add_if_needed states reject in let trans = new_trans st reject (Normal(cond,[])) :: trans in states, trans @ oth_trans ) end end in let states, trans = List.fold_left treat_state (* inner transition gets added in treat_state *) (states, oth_trans) inner_states in env, states, trans, curr_start, curr_end end else env, states, trans, curr_start, curr_end let single_path (states,transitions as auto) tr = Aorai_option.Deterministic.get () || (let init = Path_analysis.get_init_states auto in match init with | [ st ] -> let auto = (states, List.filter (fun x -> x.numt <> tr.numt) transitions) in Path_analysis.at_most_one_path auto st tr.start | _ -> false) let find_otherwise_trans auto st = let trans = Path_analysis.get_transitions_of_state st auto in try let tr = List.find (fun x -> x.cross = Otherwise) trans in Some tr.stop with Not_found -> None let type_trans auto env tr = let needs_pebble = not (single_path auto tr) in let has_siblings = match Path_analysis.get_transitions_of_state tr.start auto with | [] -> Aorai_option.fatal "Ill-formed automaton" (* at least tr should be there *) | [ _ ] -> false (* We only have one sequence to exit from there anyway *) | _::_::_ -> true in Aorai_option.debug "Analyzing transition %s -> %s: %a (needs pebble: %B)" tr.start.name tr.stop.name Promelaoutput.print_parsed tr.cross needs_pebble; match tr.cross with | Seq seq -> let default_state = find_otherwise_trans auto tr.start in let has_default_state = Extlib.has_some default_state in let _,states, transitions,_,_ = type_seq has_default_state tr env needs_pebble tr.start tr.stop seq in let (states, transitions) = if List.exists (fun st -> st.multi_state <> None) states then begin (* We have introduced some multi-state somewhere, we have to introduce pebbles and propagate them from state to state. *) let start = tr.start in let count = (* TODO: make it an integer. *) Cil.makeGlobalVar (get_fresh ("aorai_cnt_" ^ start.name)) Cil.intType in add_aux_variable count; let transitions = List.map (fun trans -> match trans.cross with | Epsilon _ -> trans | Normal(cond,actions) -> let (dest,d_aux) = memo_multi_state tr.stop in let actions = if tr.start.nums <> start.nums then begin let src,s_aux = memo_multi_state tr.start in Pebble_move(dest,d_aux,src,s_aux) :: actions end else begin let v = Cil.cvar_to_lvar count in let incr = Counter_incr (TVar v, TNoOffset) in let init = Pebble_init (dest, d_aux, v) in init::incr::actions end in { trans with cross = Normal(cond, actions) }) transitions in states, transitions end else states, transitions in (* For each intermediate state, add a transition to either the default state or a rejection state (in which we will stay until the end of the execution, while another branch might succeed in an acceptance state. )*) let needs_default = has_siblings && match transitions with | [] | [ _ ] -> false | _::_::_ -> true in Aorai_option.debug "Resulting transitions:@\n%a" (Pretty_utils.pp_list ~sep:"@\n" (fun fmt tr -> Format.fprintf fmt "%s -> %s:@[%a@]" tr.start.name tr.stop.name print_epsilon_trans tr.cross)) transitions; states, transitions, needs_default | Otherwise -> [],[], false (* treated directly by type_seq *) let add_reject_trans auto intermediate_states = let treat_one_state (states, trans) st = let my_trans = Path_analysis.get_transitions_of_state st auto in let reject_state = get_reject_state () in let states = add_if_needed states reject_state in let cond = List.fold_left (fun acc tr -> let cond,_ = tr.cross in let cond = change_bound_var tr.stop st cond in tor cond acc) TFalse my_trans in let cond = fst (Logic_simplification.simplifyCond (tnot cond)) in match cond with TFalse -> states,trans | _ -> Aorai_option.debug "Adding default transition %s -> %s: %a" st.name reject_state.name Promelaoutput.print_condition cond; states, new_trans st reject_state (cond,[]) :: trans in List.fold_left treat_one_state auto intermediate_states let propagate_epsilon_transitions (states, _ as auto) = let rec transitive_closure start (conds,actions) known_states curr = let known_states = curr :: known_states in let trans = Path_analysis.get_transitions_of_state curr auto in List.fold_left (fun acc tr -> match tr.cross with | Epsilon (cond,my_actions) -> Aorai_option.debug "Treating epsilon trans %s -> %s" curr.name tr.stop.name; if List.exists (fun st -> st.nums = tr.stop.nums) known_states then acc else transitive_closure start (tand cond conds, my_actions @ actions) known_states tr.stop @ acc | Normal (cond, action) -> Aorai_option.debug "Adding transition %s -> %s from epsilon trans" start.name tr.stop.name; new_trans start tr.stop (tand cond conds,action @ actions) ::acc) [] trans in let treat_one_state acc st = acc @ transitive_closure st (TTrue,[]) [] st in let trans = List.fold_left treat_one_state [] states in (states, trans) let add_default_trans (states, transitions as auto) otherwise = let add_one_trans acc tr = let st = tr.start in let my_trans = Path_analysis.get_transitions_of_state st auto in Aorai_option.debug "Considering new otherwise transition: %s -> %s" st.name tr.stop.name; let cond = List.fold_left (fun acc c -> let (cond,_) = c.cross in Aorai_option.debug "considering trans %s -> %s: %a" c.start.name c.stop.name Promelaoutput.print_condition cond; let neg = tnot cond in Aorai_option.debug "negation: %a" Promelaoutput.print_condition neg; Aorai_option.debug "acc: %a" Promelaoutput.print_condition acc; let res = tand acc (tnot cond) in Aorai_option.debug "partial result: %a" Promelaoutput.print_condition res; res ) TTrue my_trans in Aorai_option.debug "resulting transition: %a" Promelaoutput.print_condition cond; let cond,_ = Logic_simplification.simplifyCond cond in let new_trans = new_trans st tr.stop (cond,[]) in new_trans::acc in let transitions = List.fold_left add_one_trans transitions otherwise in states, transitions let type_cond_auto (st,tr as auto) = let otherwise = List.filter (fun t -> t.cross = Otherwise) tr in let add_if_needed acc st = if List.memq st acc then acc else st::acc in let type_trans (states,transitions,add_reject) tr = let (intermediate_states, trans, needs_reject) = type_trans auto [] tr in Aorai_option.debug "Considering parsed transition %s -> %s" tr.start.name tr.stop.name; Aorai_option.debug "Resulting transitions:@\n%a@\nEnd of transitions" (Pretty_utils.pp_list ~sep:"@\n" (fun fmt tr -> Format.fprintf fmt "%s -> %s: %a" tr.start.name tr.stop.name print_epsilon_trans tr.cross)) trans; let add_reject = if needs_reject then (List.filter (fun x -> not (Aorai_state.equal tr.start x || Aorai_state.equal tr.stop x)) intermediate_states) @ add_reject else add_reject in (List.fold_left add_if_needed states intermediate_states, transitions @ trans, add_reject) in let (states, trans, add_reject) = List.fold_left type_trans (st,[],[]) tr in let auto = propagate_epsilon_transitions (states, trans) in let auto = add_reject_trans auto add_reject in let (states, transitions as auto) = add_default_trans auto otherwise in (* nums (and in the past numt) are used as indices in arrays. Therefore, we must ensure that we use consecutive numbers starting from 0, or we'll have needlessly long arrays. *) let (states, transitions as auto) = match Reject_state.get_option () with | Some state -> (states, (new_trans state state (TTrue,[])):: transitions) | None -> auto in if Aorai_option.debug_atleast 1 then Promelaoutput.output_dot_automata auto "aorai_debug_typed.dot"; let (_,trans) = List.fold_left (fun (i,l as acc) t -> let cond, action = t.cross in let cond = fst (Logic_simplification.simplifyCond cond) in match cond with TFalse -> acc | _ -> (i+1,{ t with cross = (cond,action); numt = i } :: l)) (0,[]) transitions in let _, states = List.fold_left (fun (i,l as acc) s -> if List.exists (fun t -> t.start.nums = s.nums || t.stop.nums = s.nums) trans then begin s.nums <- i; (i+1, s :: l) end else acc) (0,[]) states in (List.rev states, List.rev trans) (** Stores the buchi automaton and its variables and functions as it is returned by the parsing *) let setAutomata auto = let auto = type_cond_auto auto in automata:=auto; check_states "typed automata"; if Aorai_option.debug_atleast 1 then Promelaoutput.output_dot_automata auto "aorai_debug_reduced.dot"; if (Array.length !cond_of_parametrizedTransitions) < (getNumberOfTransitions ()) then (* all transitions have a true parameterized guard, i.e. [[]] *) cond_of_parametrizedTransitions := Array.make (getNumberOfTransitions ()) [[]] let getState num = List.find (fun st -> st.nums = num) (fst !automata) let getStateName num = (getState num).name let getTransition num = List.find (fun trans -> trans.numt = num) (snd !automata) (** Initializes some tables according to data from Cil AST. *) let setCData () = let (f_decl,f_def) = Globals.Functions.fold (fun f (lf_decl,lf_def) -> let name = (Kernel_function.get_name f) in match f.fundec with | Definition _ -> (lf_decl,name::lf_def) | Declaration _ -> (name::lf_decl,lf_def)) ([],[]) in functions_from_c:=f_def; ignored_functions:=f_decl; variables_from_c:= Globals.Vars.fold (fun v _ lv -> Pretty_utils.sfprintf "%a" Cil_datatype.Varinfo.pretty_vname v :: lv) [] (** Return the list of all function name observed in the C file, except ignored functions. *) let getFunctions_from_c () = (!functions_from_c) (** Return the list of all variables name observed in the C file. *) let getVariables_from_c () = (!variables_from_c) (** Return the list of names of all ignored functions. A function is ignored if it is used in C file and if its declaration is unavailable. *) let getIgnoredFunctions () = (!ignored_functions) (** Return the list of names of all ignored functions. A function is ignored if it is used in C file and if its declaration is unavailable. *) let addIgnoredFunction fname = ignored_functions:=fname::(!ignored_functions) (** Return true if and only if the given string fname denotes an ignored function. *) let isIgnoredFunction fname = List.exists (fun s -> (String.compare fname s)=0) (!ignored_functions) let is_reject_state state = match Reject_state.get_option () with None -> false | Some state' -> Aorai_state.equal state state' (* ************************************************************************* *) (* Table giving the varinfo structure associated to a given variable name *) (* In practice it contains all variables (from promela and globals from C file) and only variables *) let varinfos = Hashtbl.create 97 let paraminfos = Hashtbl.create 97 (* Add a new variable into the association table name -> varinfo *) let set_varinfo name vi = Hashtbl.add varinfos name vi (* Given a variable name, it returns its associated varinfo. If the variable is not found then an error message is print and an assert false is raised. *) let get_varinfo name = try Hashtbl.find varinfos name with _ -> raise_error ("Variable not declared ("^name^")") let get_logic_var name = let vi = get_varinfo name in Cil.cvar_to_lvar vi (* Same as get_varinfo, but the result is an option. Hence, if the variable is not found then None is return. *) let get_varinfo_option name = try Some(Hashtbl.find varinfos name) with | _ -> None (* Add a new param into the association table (funcname,paramname) -> varinfo *) let set_paraminfo funcname paramname vi = (* Aorai_option.log "Adding %s(...,%s,...) " funcname paramname; *) Hashtbl.add paraminfos (funcname,paramname) vi (* Given a function name and a param name, it returns the varinfo associated to the given param. If the variable is not found then an error message is print and an assert false is raised. *) let get_paraminfo funcname paramname = try Hashtbl.find paraminfos (funcname,paramname) with _ -> raise_error ("Parameter '"^paramname^"' not declared for function '"^funcname^"'.") (* Add a new param into the association table funcname -> varinfo *) let set_returninfo funcname vi = (* Aorai_option.log "Adding return %s(...) " funcname ; *) Hashtbl.add paraminfos (funcname,"\\return") vi (* Given a function name, it returns the varinfo associated to the given param. If the variable is not found then an error message is print and an assert false is raised. *) let get_returninfo funcname = try Hashtbl.find paraminfos (funcname,"\\return") with _ -> raise_error ("Return varinfo not declared for function '"^funcname^"'.") type range = | Fixed of int (** constant value *) | Interval of int * int (** range of values *) | Bounded of int * term (** range bounded by a logic term (depending on program parameter). *) | Unbounded of int (** only the lower bound is known, there is no upper bound *) module Range = Datatype.Make_with_collections (struct type t = range let name = "Data_for_aorai.Range" let rehash = Datatype.identity let structural_descr = Structural_descr.Abstract let reprs = Fixed 0 :: Interval (0,1) :: Unbounded 0 :: List.map (fun x -> Bounded (0,x)) Cil_datatype.Term.reprs let equal = Datatype.from_compare let compare x y = match x,y with | Fixed c1, Fixed c2 -> Datatype.Int.compare c1 c2 | Fixed _, _ -> 1 | _, Fixed _ -> -1 | Interval (min1,max1), Interval(min2, max2) -> let c1 = Datatype.Int.compare min1 min2 in if c1 = 0 then Datatype.Int.compare max1 max2 else c1 | Interval _, _ -> 1 | _,Interval _ -> -1 | Bounded (min1,max1), Bounded(min2,max2) -> let c1 = Datatype.Int.compare min1 min2 in if c1 = 0 then Cil_datatype.Term.compare max1 max2 else c1 | Bounded _, _ -> 1 | _, Bounded _ -> -1 | Unbounded c1, Unbounded c2 -> Datatype.Int.compare c1 c2 let hash = function | Fixed c1 -> 2 * c1 | Interval(c1,c2) -> 3 * (c1 + c2) | Bounded (c1,c2) -> 5 * (c1 + Cil_datatype.Term.hash c2) | Unbounded c1 -> 7 * c1 let copy = function | Fixed c1 -> Fixed (Datatype.Int.copy c1) | Interval(c1,c2) -> Interval(Datatype.Int.copy c1, Datatype.Int.copy c2) | Bounded(c1,c2) -> Bounded(Datatype.Int.copy c1, Cil_datatype.Term.copy c2) | Unbounded c1 -> Unbounded (Datatype.Int.copy c1) let internal_pretty_code _ = Datatype.from_pretty_code let pretty fmt = function | Fixed c1 -> Format.fprintf fmt "%d" c1 | Interval (c1,c2) -> Format.fprintf fmt "@[<2>[%d..@;%d]@]" c1 c2 | Bounded(c1,c2) -> Format.fprintf fmt "@[<2>[%d..@;%a]@]" c1 Cil_datatype.Term.pretty c2 | Unbounded c1 -> Format.fprintf fmt "[%d..]" c1 let varname _ = "r" let mem_project = Datatype.never_any_project end) module Intervals = Cil_datatype.Term.Map.Make(Range) module Vals = Cil_datatype.Term.Map.Make(Intervals) (* If we have a bound for the number of iteration, the counter cannot grow more than bound (we go to a rejection state otherwise). *) let absolute_range loc min = let max = find_max_value loc in match max with | Some { term_node = TConst(Integer (t,_)) } -> Interval(min,Integer.to_int t) | Some x -> Bounded (min, Logic_const.term x.term_node x.term_type) | None -> Unbounded min let merge_range loc base r1 r2 = match r1,r2 with | Fixed c1, Fixed c2 when Datatype.Int.compare c1 c2 = 0 -> r1 | Fixed c1, Fixed c2 -> let min, max = if Datatype.Int.compare c1 c2 <= 0 then c1,c2 else c2,c1 in Interval (min,max) | Fixed c1, Interval(min,max) -> let min = if Datatype.Int.compare c1 min <= 0 then c1 else min in let max = if Datatype.Int.compare max c1 <= 0 then c1 else max in Interval (min,max) | Fixed c1, Bounded(min,_) -> let min = if Datatype.Int.compare c1 min <= 0 then c1 else min in Unbounded min | Fixed c1, Unbounded min -> let min = if Datatype.Int.compare c1 min <= 0 then c1 else min in Unbounded min | Interval(min,max), Fixed c -> if Datatype.Int.compare c min < 0 || Datatype.Int.compare c max > 0 then begin let min = if Datatype.Int.compare c min < 0 then c else min in if Cil.isLogicZero base then absolute_range loc min else Unbounded min end else r1 | Interval(min1,max1), Interval(min2,max2) -> if Datatype.Int.compare min2 min1 < 0 || Datatype.Int.compare max2 max1 > 0 then begin let min = if Datatype.Int.compare min2 min1 < 0 then min2 else min1 in if Cil.isLogicZero base then absolute_range loc min else Unbounded min end else r1 | Interval(min1,_), (Bounded(min2,_) | Unbounded min2)-> let min = if Datatype.Int.compare min1 min2 <= 0 then min1 else min2 in Unbounded min | Bounded(min1,max1), Bounded(min2,max2) when Cil_datatype.Term.equal max1 max2 -> let min = if Datatype.Int.compare min2 min1 < 0 then min2 else min1 in Bounded(min,max1) | Bounded(min1,_), (Fixed min2 | Interval(min2,_) | Bounded (min2,_) | Unbounded min2) -> let min = if Datatype.Int.compare min2 min1 < 0 then min2 else min1 in Unbounded min | Unbounded min1, (Fixed min2 | Interval(min2,_) | Bounded (min2,_) | Unbounded min2) -> let min = if Datatype.Int.compare min2 min1 < 0 then min2 else min1 in Unbounded min let tlval lv = Logic_const.term (TLval lv) (Cil.typeOfTermLval lv) let included_range range1 range2 = match range1, range2 with | Fixed c1, Fixed c2 -> Datatype.Int.equal c1 c2 | Fixed c, Interval(l,h) -> Datatype.Int.compare l c <= 0 && Datatype.Int.compare c h <= 0 | Fixed _, Bounded _ -> false | Fixed c1, Unbounded c2 -> Datatype.Int.compare c1 c2 >= 0 | Interval (l1,h1), Interval(l2,h2) -> Datatype.Int.compare l1 l2 >= 0 && Datatype.Int.compare h1 h2 <= 0 | Interval (l1,_), Unbounded l2 -> Datatype.Int.compare l1 l2 >= 0 | Interval _, (Fixed _ | Bounded _ ) -> false | Bounded _, (Fixed _ | Interval _) -> false | Bounded(l1,h1), Bounded(l2,h2) -> Datatype.Int.compare l1 l2 >= 0 && Cil_datatype.Term.equal h1 h2 | Bounded(l1,_), Unbounded l2 -> Datatype.Int.compare l1 l2 <= 0 | Unbounded l1, Unbounded l2 -> Datatype.Int.compare l1 l2 <= 0 | Unbounded _, (Fixed _ | Interval _ | Bounded _) -> false let unchanged loc = Cil_datatype.Term.Map.add loc (Fixed 0) Cil_datatype.Term.Map.empty let merge_bindings tbl1 tbl2 = let merge_range loc = Extlib.merge_opt (merge_range loc) in let merge_vals loc tbl1 tbl2 = match tbl1, tbl2 with | None, None -> None | Some tbl, None | None, Some tbl -> Some (Cil_datatype.Term.Map.merge (merge_range loc) tbl (unchanged loc)) | Some tbl1, Some tbl2 -> Some (Cil_datatype.Term.Map.merge (merge_range loc) tbl1 tbl2) in Cil_datatype.Term.Map.merge merge_vals tbl1 tbl2 module End_state = Aorai_state.Map.Make(Datatype.Triple(Aorai_state.Set)(Aorai_state.Set)(Vals)) type end_state = End_state.t (** The data associated to each statement: We have a mapping from each possible state at the entrance to the function (before actual transition) to the current state possibles, associated to any action that has occured on that path. *) module Case_state = Aorai_state.Map.Make(End_state) type state = Case_state.t let pretty_state fmt cases = Aorai_state.Map.iter (fun start tbl -> Aorai_state.Map.iter (fun stop (fst,last, actions) -> Format.fprintf fmt "Possible path from %s to %s@\n Initial trans:@\n" start.Promelaast.name stop.Promelaast.name; Aorai_state.Set.iter (fun state -> Format.fprintf fmt " %s -> %s@\n" start.Promelaast.name state.Promelaast.name) fst; Format.fprintf fmt " Final trans:@\n"; Aorai_state.Set.iter (fun state -> Format.fprintf fmt " %s -> %s@\n" state.Promelaast.name stop.Promelaast.name) last; Format.fprintf fmt " Related actions:@\n"; Cil_datatype.Term.Map.iter (fun loc tbl -> Cil_datatype.Term.Map.iter (fun base itv -> Format.fprintf fmt " %a <- %a + %a@\n" Cil_datatype.Term.pretty loc Cil_datatype.Term.pretty base Range.pretty itv) tbl) actions) tbl) cases let included_state tbl1 tbl2 = try Aorai_state.Map.iter (fun s1 tbl1 -> let tbl2 = Aorai_state.Map.find s1 tbl2 in Aorai_state.Map.iter (fun s2 (fst1, last1, tbl1) -> let (fst2, last2, tbl2) = Aorai_state.Map.find s2 tbl2 in if not (Aorai_state.Set.subset fst1 fst2) || not (Aorai_state.Set.subset last1 last2) then raise Not_found; Cil_datatype.Term.Map.iter (fun base bindings1 -> let bindings2 = Cil_datatype.Term.Map.find base tbl2 in Cil_datatype.Term.Map.iter (fun loc range1 -> let range2 = Cil_datatype.Term.Map.find loc bindings2 in if not (included_range range1 range2) then raise Not_found) bindings1) tbl1) tbl1) tbl1; true with Not_found -> false let merge_end_state tbl1 tbl2 = let merge_stop_state _ (fst1, last1, tbl1) (fst2, last2, tbl2) = let fst = Aorai_state.Set.union fst1 fst2 in let last = Aorai_state.Set.union last1 last2 in let tbl = merge_bindings tbl1 tbl2 in (fst, last, tbl) in Aorai_state.Map.merge (Extlib.merge_opt merge_stop_state) tbl1 tbl2 let merge_state tbl1 tbl2 = let merge_state _ = merge_end_state in Aorai_state.Map.merge (Extlib.merge_opt merge_state) tbl1 tbl2 module Pre_state = Kernel_function.Make_Table (Case_state) (struct let name = "Data_for_aorai.Pre_state" let dependencies = [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self; Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ] let size = 17 end) let set_kf_init_state kf state = let change old_state = merge_state old_state state in let set _ = state in ignore (Pre_state.memo ~change set kf) let dkey = Aorai_option.register_category "dataflow" let replace_kf_init_state kf state = Aorai_option.debug ~dkey "Replacing pre-state of %a:@\n @[%a@]" Kernel_function.pretty kf pretty_state state; Pre_state.replace kf state let get_kf_init_state kf = try Pre_state.find kf with Not_found -> Aorai_state.Map.empty module Post_state = Kernel_function.Make_Table (Case_state) (struct let name = "Data_for_aorai.Post_state" let dependencies = [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self; Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ] let size = 17 end) let set_kf_return_state kf state = let change old_state = merge_state old_state state in let set _ = state in ignore (Post_state.memo ~change set kf) let replace_kf_return_state = Post_state.replace let get_kf_return_state kf = try Post_state.find kf with Not_found -> Aorai_state.Map.empty module Loop_init_state = State_builder.Hashtbl (Cil_datatype.Stmt.Hashtbl) (Case_state) (struct let name = "Data_for_aorai.Loop_init_state" let dependencies = [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self; Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ] let size = 17 end) let set_loop_init_state stmt state = let change old_state = merge_state old_state state in let set _ = state in ignore (Loop_init_state.memo ~change set stmt) let replace_loop_init_state = Loop_init_state.replace let get_loop_init_state stmt = try Loop_init_state.find stmt with Not_found -> Aorai_state.Map.empty module Loop_invariant_state = State_builder.Hashtbl (Cil_datatype.Stmt.Hashtbl) (Case_state) (struct let name = "Data_for_aorai.Loop_invariant_state" let dependencies = [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self; Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ] let size = 17 end) let set_loop_invariant_state stmt state = let change old_state = merge_state old_state state in let set _ = state in ignore (Loop_invariant_state.memo ~change set stmt) let replace_loop_invariant_state = Loop_invariant_state.replace let get_loop_invariant_state stmt = try Loop_invariant_state.find stmt with Not_found -> Aorai_state.Map.empty let pretty_pre_state fmt = Pre_state.iter (fun kf state -> Format.fprintf fmt "Function %a:@\n @[%a@]@\n" Kernel_function.pretty kf pretty_state state) let pretty_post_state fmt = Post_state.iter (fun kf state -> Format.fprintf fmt "Function %a:@\n @[%a@]@\n" Kernel_function.pretty kf pretty_state state) let pretty_loop_init fmt = Loop_init_state.iter (fun stmt state -> let kf = Kernel_function.find_englobing_kf stmt in Format.fprintf fmt "Function %a, sid %d:@\n @[%a@]@\n" Kernel_function.pretty kf stmt.sid pretty_state state) let pretty_loop_invariant fmt = Loop_invariant_state.iter (fun stmt state -> let kf = Kernel_function.find_englobing_kf stmt in Format.fprintf fmt "Function %a, sid %d:@\n @[%a@]@\n" Kernel_function.pretty kf stmt.sid pretty_state state) let debug_computed_state () = Aorai_option.debug ~dkey "Computed state:@\nPre-states:@\n @[%t@]@\nPost-states:@\n @[%t@]@\n\ Loop init:@\n @[%t@]@\nLoop invariants:@\n @[%t@]" pretty_pre_state pretty_post_state pretty_loop_init pretty_loop_invariant (* ************************************************************************* *) let removeUnusedTransitionsAndStates () = (* Step 1 : computation of reached states and crossed transitions *) let treat_one_state state map set = Aorai_state.Map.fold (fun state (fst, last, _) set -> Aorai_state.Set.add state (Aorai_state.Set.union last (Aorai_state.Set.union fst set))) map (Aorai_state.Set.add state set) in let reached _ state set = Aorai_state.Map.fold treat_one_state state set in let reached_states = Pre_state.fold reached Aorai_state.Set.empty in let reached_states = Post_state.fold reached reached_states in let reached_states = Loop_init_state.fold reached reached_states in let reached_states = Loop_invariant_state.fold reached reached_states in (* Step 2 : computation of translation tables *) let state_list = List.sort (fun x y -> Datatype.String.compare x.Promelaast.name y.Promelaast.name) (Aorai_state.Set.elements reached_states) in let (_, translate_table) = List.fold_left (fun (i,map) x -> let map = Aorai_state.Map.add x { x with nums = i } map in (i+1,map)) (0,Aorai_state.Map.empty) state_list in let new_state s = Aorai_state.Map.find s translate_table in let (_, trans_list) = List.fold_left (fun (i,list as acc) trans -> try let new_start = new_state trans.start in let new_stop = new_state trans.stop in (i+1, { trans with start = new_start; stop = new_stop; numt = i } :: list) with Not_found -> acc) (0,[]) (snd (getAutomata())) in let state_list = List.map new_state state_list in Reject_state.may (fun reject_state -> try let new_reject = Aorai_state.Map.find reject_state translate_table in Reject_state.set new_reject with Not_found -> Reject_state.clear ()); (* Step 3 : rewriting stored information *) automata:= (state_list,trans_list); check_states "reduced automata"; let rewrite_state state = let rewrite_set set = Aorai_state.Set.fold (fun s set -> Aorai_state.Set.add (new_state s) set) set Aorai_state.Set.empty in let rewrite_bindings (fst_states, last_states, bindings) = (rewrite_set fst_states, rewrite_set last_states, bindings) in let rewrite_curr_state s bindings acc = let new_s = new_state s in let bindings = rewrite_bindings bindings in Aorai_state.Map.add new_s bindings acc in let rewrite_one_state s map acc = let new_s = new_state s in let new_map = Aorai_state.Map.fold rewrite_curr_state map Aorai_state.Map.empty in Aorai_state.Map.add new_s new_map acc in Aorai_state.Map.fold rewrite_one_state state Aorai_state.Map.empty in Pre_state.iter (fun kf state -> Pre_state.replace kf (rewrite_state state)); Post_state.iter (fun kf state -> Post_state.replace kf (rewrite_state state)); Loop_init_state.iter (fun s state -> Loop_init_state.replace s (rewrite_state state)); Loop_invariant_state.iter (fun s state -> Loop_invariant_state.replace s (rewrite_state state)) (* ************************************************************************* *) (* Given the name of a function, it return the name of the associated element in the operation list. *) let func_to_op_func f = "op_"^f let used_enuminfo = Hashtbl.create 2 let set_usedinfo name einfo = Hashtbl.add used_enuminfo name einfo let get_usedinfo name = try Hashtbl.find used_enuminfo name with _ -> raise_error ("Incomplete enum information.") let get_cenum_option name = let opnamed = func_to_op_func name in Hashtbl.fold (fun _ ei value -> match value with | Some(_) as r -> r (* Already found *) | None -> let rec search = function | {einame = n} as ei ::_ when n=name -> Some(CEnum ei) | {einame = n} as ei ::_ when n=opnamed -> Some(CEnum ei) | _::l -> search l | [] -> None in search ei.eitems ) used_enuminfo None let func_enum_type () = TEnum(Hashtbl.find used_enuminfo listOp,[]) let status_enum_type () = TEnum(Hashtbl.find used_enuminfo listStatus,[]) let func_to_cenum func = try let ei = Hashtbl.find used_enuminfo listOp in let name = func_to_op_func func in let rec search = function | {einame = n} as ei ::_ when n=name -> CEnum ei | _::l -> search l | [] -> raise_error ("Operation '"^name^"' not found in operations enumeration") in search ei.eitems (* CEnum(ex,s,ei)*) with _ -> raise_error ("Operation not found") let op_status_to_cenum status = try let ei = Hashtbl.find used_enuminfo listStatus in let name = if status = Promelaast.Call then callStatus else termStatus in let rec search = function | {einame=n} as ei ::_ when n=name -> CEnum ei | _::l -> search l | [] -> raise_error ("Status not found") in search ei.eitems with _ -> raise_error ("Status not found") (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/promelaoutput.ml0000644000175000017500000002426512155630222021140 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 Logic_ptree open Aorai_option open Promelaast open Bool3 open Format let string_of_unop = function | Uminus -> "-" | Ustar -> "*" | Uamp -> "&" | Ubw_not -> "~" let rec print_parsed_expression fmt = function | PVar s -> Format.fprintf fmt "%s" s | PPrm (f,s) -> Format.fprintf fmt "%s().%s" f s | PCst (IntConstant s) -> Format.fprintf fmt "%s" s | PCst (FloatConstant s) -> Format.fprintf fmt "%s" s | PCst (StringConstant s) -> Format.fprintf fmt "%S" s | PCst (WStringConstant s) -> Format.fprintf fmt "%S" s | PBinop(bop,e1,e2) -> Format.fprintf fmt "(@[%a@])@ %a@ (@[%a@])" print_parsed_expression e1 Printer.pp_binop (Logic_typing.type_binop bop) print_parsed_expression e2 | PUnop(uop,e) -> Format.fprintf fmt "%s@;(@[%a@])" (string_of_unop uop) print_parsed_expression e | PArrget(e1,e2) -> Format.fprintf fmt "%a@;[@(%a@]]" print_parsed_expression e1 print_parsed_expression e2 | PField(e,s) -> Format.fprintf fmt "%a.%s" print_parsed_expression e s | PArrow(e,s) -> Format.fprintf fmt "%a->%s" print_parsed_expression e s let rec print_parsed_condition fmt = function | PRel(rel,e1,e2) -> Format.fprintf fmt "%a %a@ %a" print_parsed_expression e1 Printer.pp_relation (Logic_typing.type_rel rel) print_parsed_expression e2 | PTrue -> Format.pp_print_string fmt "true" | PFalse -> Format.pp_print_string fmt "false" | POr(e1,e2) -> Format.fprintf fmt "(@[%a@])@ or@ (@[%a@])" print_parsed_condition e1 print_parsed_condition e2 | PAnd(e1,e2) -> Format.fprintf fmt "(@[%a@])@ and@ (@[%a@])" print_parsed_condition e1 print_parsed_condition e2 | PNot c -> Format.fprintf fmt "not(@[%a@])" print_parsed_condition c | PCall (s,None) -> Format.fprintf fmt "CALL(%s)" s | PCall (s, Some b) -> Format.fprintf fmt "CALL(%s::%s)" s b | PReturn s -> Format.fprintf fmt "RETURN(%s)" s let rec print_seq_elt fmt elt = Format.fprintf fmt "(%a%a){@[%a,%a@]}" (Pretty_utils.pp_opt print_parsed_condition) elt.condition print_sequence elt.nested (Pretty_utils.pp_opt print_parsed_expression) elt.min_rep (Pretty_utils.pp_opt print_parsed_expression) elt.max_rep and print_sequence fmt l = Pretty_utils.pp_list ~pre:"[@[" ~sep:";@ " ~suf:"@]]" print_seq_elt fmt l let print_parsed fmt = function | Seq l -> print_sequence fmt l | Otherwise -> Format.pp_print_string fmt "Otherwise" let rec print_condition fmt = function | TCall (kf,None) -> Format.fprintf fmt "Call(%a)" Kernel_function.pretty kf | TCall (kf, Some b) -> Format.fprintf fmt "Call(%a::%s)" Kernel_function.pretty kf b.b_name | TReturn kf -> Format.fprintf fmt "Return(%a)" Kernel_function.pretty kf | TOr (c1,c2) -> Format.fprintf fmt "@[(@[<2>%a@])@]@ or@ @[(@[<2>%a@])@]" print_condition c1 print_condition c2 | TAnd (c1,c2) -> Format.fprintf fmt "@[(@[<2>%a@])@]@ and@ @[(@[<2>%a@])@]" print_condition c1 print_condition c2 | TNot c -> Format.fprintf fmt "@[@[not(%a@])@]" print_condition c | TTrue -> Format.pp_print_string fmt "True" | TFalse -> Format.pp_print_string fmt "False" | TRel(rel,exp1,exp2) -> (* \result will be printed as such, not as f().return *) Format.fprintf fmt "@[(%a)@]@ %a@ @[(%a)@]" Printer.pp_term exp1 Printer.pp_relation rel Printer.pp_term exp2 let print_one_action fmt = function | Counter_init lv -> Format.fprintf fmt "@[%a <- 1@]" Printer.pp_term_lval lv | Counter_incr lv -> Format.fprintf fmt "@[%a <- @[%a@ +@ 1@]@]" Printer.pp_term_lval lv Printer.pp_term_lval lv | Pebble_init (set,_,v) -> Format.fprintf fmt "@[%a <- {@[ %a @]}@]" Printer.pp_logic_var set.l_var_info Printer.pp_logic_var v | Pebble_move(s1,_,s2,_) -> Format.fprintf fmt "@[%a <- %a@]" Printer.pp_logic_var s1.l_var_info Printer.pp_logic_var s2.l_var_info | Copy_value(lv,v) -> Format.fprintf fmt "@[%a <- %a@]" Printer.pp_term_lval lv Printer.pp_term v let print_action fmt l = Pretty_utils.pp_list ~sep:"@\n" print_one_action fmt l let normal_funcs = ref None (* Use well-parenthesized combination of escape_newline/normal_newline*) let escape_newline fmt = let (out,flush,newline,spaces as funcs) = Format.pp_get_all_formatter_output_functions fmt () in (match !normal_funcs with None -> normal_funcs:= Some funcs | Some _ -> Aorai_option.fatal "Already in escape newline mode"); let has_printed = ref false in let newline () = if !has_printed then out " \\\n" 0 3 else newline () in let out s b l = if String.contains (String.sub s b l) '"' then has_printed:=not !has_printed; out s b l in Format.pp_set_all_formatter_output_functions fmt ~out ~flush ~newline ~spaces let normal_newline fmt = let (out, flush, newline, spaces) = Extlib.the !normal_funcs in normal_funcs := None; Format.pp_set_all_formatter_output_functions fmt ~out ~flush ~newline ~spaces let print_full_transition fmt (cond,action) = Format.fprintf fmt "%a@\n%a" print_condition cond print_action action let trans_label num = "tr"^string_of_int(num) let print_trans fmt trans = Format.fprintf fmt "@[<2>%s:@ %a@]" (trans_label trans.numt) print_full_transition trans.cross let state_label num = "st"^string_of_int(num) let print_state_label fmt st = Format.fprintf fmt "@[<2>%s:@ %s@]" (state_label st.nums) st.name let print_bool3 fmt b = Format.pp_print_string fmt (match b with | True -> "True" | False -> "False" | Undefined -> "Undef") let print_transition fmt tr = Format.fprintf fmt "@[<2>{@ %d:@ %s@ {%a}@ %s@]}" tr.numt tr.start.name print_full_transition tr.cross tr.stop.name let print_transitionl fmt trl = Format.fprintf fmt "@[<2>Transitions:@\n%a@]" (Pretty_utils.pp_list ~sep:"@\n" ~suf:"@\n" print_transition) trl let print_state fmt st = Format.fprintf fmt "@[<2>%s@ (acc=%a;@ init=%a;@ num=%d)@]" st.name print_bool3 st.acceptation print_bool3 st.init st.nums let print_statel fmt stl = Format.fprintf fmt "@[<2>States:@\n%a@]" (Pretty_utils.pp_list ~sep:"@\n" ~suf:"@\n" print_state) stl let print_raw_automata fmt (stl,trl) = Format.fprintf fmt "@[<2>Automaton:@\n%a%a@]" print_statel stl print_transitionl trl let dot_state out st = let shape = if st.init = Bool3.True && st.acceptation=Bool3.True then "doubleoctagon" else if st.acceptation=Bool3.True then "octagon" else if st.init=Bool3.True then "doublecircle" else "circle" in Format.fprintf out "\"%a\" [shape = %s];@\n" print_state_label st shape let dot_trans out tr = let print_label fmt tr = if DotSeparatedLabels.get () then Format.pp_print_int fmt tr.numt else print_trans fmt tr in Format.fprintf out "\"%a\"@ ->@ \"%a\"@ [label = @[\"%a\"@]];@\n" print_state_label tr.start print_state_label tr.stop print_label tr let output_dot_automata (states_l,trans_l) fichier = let cout = open_out fichier in let fmt = formatter_of_out_channel cout in escape_newline fmt; let one_line_comment s = let l = String.length s in let fill = if l >= 75 then 0 else 75 - l in let spaces = String.make fill ' ' in Format.fprintf fmt "@[/* %s%s*/@\n@]" s spaces in one_line_comment "File generated by Aorai LTL2ACSL Plug-in"; one_line_comment ""; one_line_comment "Usage of dot files '.dot' :"; one_line_comment " dot -T > "; one_line_comment ""; one_line_comment " Allowed types : canon,dot,xdot,fig,gd,gd2,"; one_line_comment " gif,hpgl,imap,cmap,ismap,jpg,jpeg,mif,mp,pcl,pic,plain,"; one_line_comment " plain-ext,png,ps,ps2,svg,svgz,vrml,vtx,wbmp"; one_line_comment ""; one_line_comment " Example with postscript file :"; one_line_comment " dot property.dot -Tps > property.ps"; Format.fprintf fmt "@[<2>@\ndigraph %s {@\n@\n%a@\n%a@\n%t}@\n@]" (Filename.chop_extension (Filename.basename fichier)) (Pretty_utils.pp_list dot_state) states_l (Pretty_utils.pp_list dot_trans) trans_l (fun fmt -> if DotSeparatedLabels.get () then (Format.fprintf fmt "/* guards of transitions */@\ncomment=%t\"%a\"%t;@\n" escape_newline (Pretty_utils.pp_list ~sep:"@\n" print_trans) trans_l normal_newline )); normal_newline fmt; close_out cout (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/logic_simplification.mli0000644000175000017500000000605412155630222022554 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 simplification over {!Promelaast.typed_condition} *) open Promelaast (** {2 smart constructors for typed conditions} *) val tand: typed_condition -> typed_condition -> typed_condition val tor: typed_condition -> typed_condition -> typed_condition val tnot: typed_condition -> typed_condition (** {2 simplifications} *) (** Given a condition, this function does some logical simplifications and returns an equivalent DNF form together with the simplified version *) val simplifyCond: Promelaast.typed_condition -> Promelaast.typed_condition *(Promelaast.typed_condition list list) (** Given a transition list, this function returns the same transition list with simplifyCond done on each cross condition. Uncrossable transition are removed. *) val simplifyTrans: Promelaast.typed_condition Promelaast.trans list -> (Promelaast.typed_condition Promelaast.trans list)* (Promelaast.typed_condition list list list) val dnfToCond : (Promelaast.typed_condition list list) -> Promelaast.typed_condition val simplifyDNFwrtCtx : Promelaast.typed_condition list list -> Cil_types.kernel_function -> Promelaast.funcStatus -> Promelaast.typed_condition (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/promelalexer.ml0000444000175000017500000025151712155634032020722 0ustar mehdimehdi# 30 "src/aorai/promelalexer.mll" open Promelaparser open Lexing exception Error of (Lexing.position * Lexing.position) * string let loc lexbuf = (lexeme_start_p lexbuf, lexeme_end_p lexbuf) let raise_located loc e = raise (Error (loc, e)) let buf = Buffer.create 1024 let newline lexbuf = let pos = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum } # 20 "src/aorai/promelalexer.ml" let __ocaml_lex_tables = { Lexing.lex_base = "\000\000\224\255\225\255\226\255\078\000\160\000\235\000\001\000\ \236\255\002\000\238\255\001\000\012\000\000\000\243\255\244\255\ \245\255\246\255\247\255\002\000\054\001\129\001\204\001\023\002\ \098\002\173\002\248\002\067\003\142\003\217\003\036\004\111\004\ \186\004\005\005\080\005\155\005\230\005\049\006\124\006\199\006\ \018\007\093\007\168\007\243\007\062\008\249\255\242\255\240\255\ \239\255\040\000\235\255\234\255\137\008\212\008\031\009\106\009\ \181\009\000\010\075\010\150\010\225\010\044\011\119\011\194\011\ \013\012\088\012\163\012\238\012\057\013\132\013\207\013\026\014\ \101\014\176\014\251\014\070\015\145\015\220\015\039\016\194\015\ \252\255\253\255\254\255\004\000\255\255"; Lexing.lex_backtrk = "\255\255\255\255\255\255\255\255\028\000\028\000\028\000\031\000\ \255\255\018\000\255\255\031\000\031\000\031\000\255\255\255\255\ \255\255\255\255\255\255\007\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\000\000\028\000\028\000\028\000\ \001\000\002\000\028\000\003\000\028\000\028\000\014\000\028\000\ \028\000\004\000\028\000\028\000\005\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\028\000\028\000\028\000\028\000\ \028\000\028\000\022\000\022\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\024\000\024\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\023\000\023\000\255\255\ \255\255\255\255\255\255\003\000\255\255"; Lexing.lex_default = "\001\000\000\000\000\000\000\000\255\255\255\255\255\255\255\255\ \000\000\255\255\000\000\255\255\255\255\255\255\000\000\000\000\ \000\000\000\000\000\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\000\000\000\000\000\000\ \000\000\049\000\000\000\000\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\080\000\ \000\000\000\000\000\000\255\255\000\000"; Lexing.lex_trans = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\009\000\008\000\009\000\009\000\009\000\009\000\009\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \009\000\010\000\009\000\000\000\000\000\000\000\011\000\048\000\ \017\000\016\000\000\000\050\000\000\000\013\000\000\000\007\000\ \049\000\002\000\051\000\084\000\000\000\000\000\000\000\000\000\ \000\000\000\000\019\000\018\000\045\000\000\000\046\000\000\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\000\000\000\000\000\000\004\000\ \000\000\004\000\004\000\006\000\004\000\004\000\022\000\021\000\ \004\000\023\000\004\000\004\000\004\000\004\000\024\000\004\000\ \004\000\004\000\005\000\020\000\025\000\004\000\004\000\004\000\ \004\000\004\000\004\000\015\000\012\000\014\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \047\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\004\000\000\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\000\000\000\000\000\000\004\000\ \003\000\004\000\004\000\004\000\004\000\070\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\000\000\000\000\000\000\ \255\255\000\000\000\000\000\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\000\000\000\000\ \000\000\000\000\004\000\000\000\052\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\004\000\000\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\042\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\000\000\000\000\000\000\000\000\ \004\000\000\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \039\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\000\000\ \000\000\000\000\000\000\004\000\000\000\034\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\035\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\000\000\000\000\000\000\004\000\000\000\ \004\000\004\000\004\000\004\000\004\000\033\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\000\000\000\000\000\000\ \000\000\004\000\000\000\004\000\004\000\004\000\004\000\029\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \000\000\000\000\000\000\000\000\004\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\026\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\000\000\000\000\000\000\004\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\027\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\000\000\000\000\ \000\000\000\000\004\000\000\000\004\000\004\000\004\000\004\000\ \028\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\004\000\000\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\000\000\000\000\000\000\000\000\ \004\000\000\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\030\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\000\000\ \000\000\000\000\000\000\004\000\000\000\004\000\004\000\004\000\ \004\000\031\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\000\000\000\000\000\000\004\000\000\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\032\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\000\000\000\000\000\000\ \000\000\004\000\000\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \000\000\000\000\000\000\000\000\004\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\000\000\000\000\000\000\004\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\036\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\000\000\000\000\ \000\000\000\000\004\000\000\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\004\000\000\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\037\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\000\000\000\000\000\000\000\000\ \004\000\000\000\004\000\004\000\004\000\004\000\038\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\000\000\ \000\000\000\000\000\000\004\000\000\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\000\000\000\000\000\000\004\000\000\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\040\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\000\000\000\000\000\000\ \000\000\004\000\000\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\041\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \000\000\000\000\000\000\000\000\004\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\000\000\000\000\000\000\004\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\043\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\000\000\000\000\ \000\000\000\000\004\000\000\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\044\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\004\000\000\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\000\000\000\000\000\000\000\000\ \004\000\000\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\053\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\000\000\ \000\000\000\000\000\000\004\000\000\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \054\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\000\000\000\000\000\000\004\000\000\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\055\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\000\000\000\000\000\000\ \000\000\004\000\000\000\004\000\004\000\004\000\004\000\004\000\ \057\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\056\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \000\000\000\000\000\000\000\000\004\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\060\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\000\000\000\000\000\000\058\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\000\000\000\000\ \000\000\000\000\058\000\000\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\000\000\000\000\000\000\000\000\059\000\000\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\000\000\000\000\000\000\000\000\ \004\000\000\000\004\000\004\000\004\000\004\000\061\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\000\000\ \000\000\000\000\000\000\004\000\000\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \062\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\000\000\000\000\000\000\004\000\000\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\063\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\000\000\000\000\000\000\ \000\000\004\000\000\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\064\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \000\000\000\000\000\000\000\000\004\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\065\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\000\000\000\000\000\000\004\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\066\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\000\000\000\000\ \000\000\000\000\004\000\000\000\004\000\004\000\004\000\004\000\ \004\000\067\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\068\000\000\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\000\000\000\000\000\000\000\000\ \068\000\000\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\000\000\ \000\000\000\000\000\000\069\000\000\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\000\000\000\000\000\000\004\000\000\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\071\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\000\000\000\000\000\000\ \000\000\004\000\000\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\072\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \000\000\000\000\000\000\000\000\004\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\073\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\000\000\000\000\000\000\004\000\ \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\074\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\000\000\000\000\ \000\000\000\000\004\000\000\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\075\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\000\000\000\000\000\000\000\000\004\000\000\000\004\000\ \004\000\004\000\004\000\004\000\076\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\000\000\081\000\000\000\000\000\000\000\ \000\000\000\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\083\000\000\000\000\000\000\000\ \077\000\000\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\000\000\ \000\000\000\000\000\000\077\000\000\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\000\000\000\000\000\000\000\000\078\000\000\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\082\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\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\009\000\000\000\000\000\009\000\009\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\ \000\000\000\000\009\000\255\255\255\255\255\255\000\000\011\000\ \000\000\000\000\255\255\007\000\255\255\000\000\255\255\000\000\ \007\000\000\000\049\000\083\000\255\255\255\255\255\255\255\255\ \255\255\255\255\000\000\000\000\019\000\255\255\013\000\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\000\000\000\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \012\000\255\255\255\255\255\255\255\255\255\255\255\255\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\255\255\255\255\255\255\255\255\004\000\255\255\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \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\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\ \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\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\ \049\000\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\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\020\000\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\255\255\255\255\255\255\255\255\020\000\255\255\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ \020\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ \021\000\021\000\021\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\021\000\021\000\021\000\021\000\021\000\021\000\ \021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ \021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ \021\000\021\000\021\000\021\000\255\255\255\255\255\255\255\255\ \021\000\255\255\021\000\021\000\021\000\021\000\021\000\021\000\ \021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ \021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ \021\000\021\000\021\000\021\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\255\255\ \255\255\255\255\255\255\022\000\255\255\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\023\000\ \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ \023\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ \023\000\023\000\255\255\255\255\255\255\255\255\023\000\255\255\ \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ \023\000\023\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\255\255\255\255\255\255\ \255\255\024\000\255\255\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \255\255\255\255\255\255\255\255\025\000\255\255\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\255\255\255\255\255\255\255\255\026\000\ \255\255\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\255\255\255\255\ \255\255\255\255\027\000\255\255\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\255\255\255\255\255\255\255\255\028\000\255\255\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\255\255\255\255\255\255\255\255\ \029\000\255\255\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\255\255\ \255\255\255\255\255\255\030\000\255\255\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\255\255\255\255\255\255\255\255\031\000\255\255\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\255\255\255\255\255\255\ \255\255\032\000\255\255\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \255\255\255\255\255\255\255\255\033\000\255\255\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\255\255\255\255\255\255\255\255\034\000\ \255\255\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\ \034\000\034\000\034\000\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\255\255\255\255\ \255\255\255\255\035\000\255\255\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\255\255\255\255\255\255\255\255\036\000\255\255\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\255\255\255\255\255\255\255\255\ \037\000\255\255\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\255\255\ \255\255\255\255\255\255\038\000\255\255\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\255\255\255\255\255\255\255\255\039\000\255\255\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\255\255\255\255\255\255\ \255\255\040\000\255\255\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \255\255\255\255\255\255\255\255\041\000\255\255\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\255\255\255\255\255\255\255\255\042\000\ \255\255\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\255\255\255\255\ \255\255\255\255\043\000\255\255\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\255\255\255\255\255\255\255\255\044\000\255\255\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\255\255\255\255\255\255\255\255\ \052\000\255\255\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\255\255\ \255\255\255\255\255\255\053\000\255\255\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\054\000\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\054\000\255\255\255\255\255\255\255\255\054\000\255\255\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\054\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\255\255\255\255\255\255\ \255\255\055\000\255\255\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \255\255\255\255\255\255\255\255\056\000\255\255\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \057\000\057\000\057\000\057\000\057\000\057\000\057\000\057\000\ \057\000\057\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\057\000\057\000\057\000\057\000\057\000\057\000\057\000\ \057\000\057\000\057\000\057\000\057\000\057\000\057\000\057\000\ \057\000\057\000\057\000\057\000\057\000\057\000\057\000\057\000\ \057\000\057\000\057\000\255\255\255\255\255\255\255\255\057\000\ \255\255\057\000\057\000\057\000\057\000\057\000\057\000\057\000\ \057\000\057\000\057\000\057\000\057\000\057\000\057\000\057\000\ \057\000\057\000\057\000\057\000\057\000\057\000\057\000\057\000\ \057\000\057\000\057\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\255\255\255\255\ \255\255\255\255\058\000\255\255\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\255\255\255\255\255\255\255\255\059\000\255\255\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\255\255\255\255\255\255\255\255\ \060\000\255\255\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\061\000\061\000\061\000\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\061\000\061\000\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\061\000\255\255\ \255\255\255\255\255\255\061\000\255\255\061\000\061\000\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ \061\000\061\000\061\000\061\000\061\000\061\000\061\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\255\255\255\255\255\255\255\255\062\000\255\255\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\062\000\062\000\062\000\062\000\062\000\062\000\ \062\000\062\000\063\000\063\000\063\000\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\063\000\063\000\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\063\000\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\063\000\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\063\000\255\255\255\255\255\255\ \255\255\063\000\255\255\063\000\063\000\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\063\000\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\063\000\063\000\063\000\063\000\ \063\000\063\000\063\000\063\000\063\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \255\255\255\255\255\255\255\255\064\000\255\255\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \064\000\064\000\064\000\064\000\064\000\064\000\064\000\064\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\255\255\255\255\255\255\255\255\065\000\ \255\255\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\065\000\065\000\065\000\065\000\065\000\ \065\000\065\000\065\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\255\255\255\255\ \255\255\255\255\066\000\255\255\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ \066\000\066\000\066\000\066\000\066\000\066\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\255\255\255\255\255\255\255\255\067\000\255\255\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\255\255\255\255\255\255\255\255\ \068\000\255\255\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\068\000\068\000\068\000\068\000\ \068\000\068\000\068\000\068\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\255\255\ \255\255\255\255\255\255\069\000\255\255\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\255\255\255\255\255\255\255\255\070\000\255\255\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\255\255\255\255\255\255\ \255\255\071\000\255\255\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \255\255\255\255\255\255\255\255\072\000\255\255\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \072\000\072\000\072\000\072\000\072\000\072\000\072\000\072\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\255\255\255\255\255\255\255\255\073\000\ \255\255\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ \073\000\073\000\073\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\255\255\255\255\ \255\255\255\255\074\000\255\255\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\255\255\255\255\255\255\255\255\075\000\255\255\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ \075\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\255\255\079\000\255\255\255\255\255\255\ \255\255\255\255\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\076\000\079\000\255\255\255\255\255\255\ \076\000\255\255\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ \076\000\076\000\076\000\076\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\255\255\ \255\255\255\255\255\255\077\000\255\255\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ \077\000\077\000\077\000\077\000\077\000\077\000\077\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\255\255\255\255\255\255\255\255\078\000\255\255\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\000\078\000\078\000\078\000\078\000\078\000\078\000\ \078\000\078\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\079\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\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 -> # 53 "src/aorai/promelalexer.mll" ( PROMELA_TRUE ) # 1181 "src/aorai/promelalexer.ml" | 1 -> # 54 "src/aorai/promelalexer.mll" ( PROMELA_NEVER ) # 1186 "src/aorai/promelalexer.ml" | 2 -> # 55 "src/aorai/promelalexer.mll" ( PROMELA_IF ) # 1191 "src/aorai/promelalexer.ml" | 3 -> # 56 "src/aorai/promelalexer.mll" ( PROMELA_FI ) # 1196 "src/aorai/promelalexer.ml" | 4 -> # 57 "src/aorai/promelalexer.mll" ( PROMELA_GOTO ) # 1201 "src/aorai/promelalexer.ml" | 5 -> # 58 "src/aorai/promelalexer.mll" ( PROMELA_SKIP ) # 1206 "src/aorai/promelalexer.ml" | 6 -> # 59 "src/aorai/promelalexer.mll" ( PROMELA_DOUBLE_COLON ) # 1211 "src/aorai/promelalexer.ml" | 7 -> # 60 "src/aorai/promelalexer.mll" ( PROMELA_COLON ) # 1216 "src/aorai/promelalexer.ml" | 8 -> # 61 "src/aorai/promelalexer.mll" ( PROMELA_SEMICOLON ) # 1221 "src/aorai/promelalexer.ml" | 9 -> # 62 "src/aorai/promelalexer.mll" ( PROMELA_LPAREN ) # 1226 "src/aorai/promelalexer.ml" | 10 -> # 63 "src/aorai/promelalexer.mll" ( PROMELA_RPAREN ) # 1231 "src/aorai/promelalexer.ml" | 11 -> # 64 "src/aorai/promelalexer.mll" ( PROMELA_LBRACE ) # 1236 "src/aorai/promelalexer.ml" | 12 -> # 65 "src/aorai/promelalexer.mll" ( PROMELA_RBRACE ) # 1241 "src/aorai/promelalexer.ml" | 13 -> # 66 "src/aorai/promelalexer.mll" ( PROMELA_RIGHT_ARROW ) # 1246 "src/aorai/promelalexer.ml" | 14 -> # 67 "src/aorai/promelalexer.mll" ( PROMELA_FALSE ) # 1251 "src/aorai/promelalexer.ml" | 15 -> # 68 "src/aorai/promelalexer.mll" ( PROMELA_OR ) # 1256 "src/aorai/promelalexer.ml" | 16 -> # 69 "src/aorai/promelalexer.mll" ( PROMELA_AND ) # 1261 "src/aorai/promelalexer.ml" | 17 -> # 70 "src/aorai/promelalexer.mll" ( PROMELA_NOT ) # 1266 "src/aorai/promelalexer.ml" | 18 -> # 71 "src/aorai/promelalexer.mll" ( token lexbuf ) # 1271 "src/aorai/promelalexer.ml" | 19 -> # 72 "src/aorai/promelalexer.mll" ( newline lexbuf; token lexbuf ) # 1276 "src/aorai/promelalexer.ml" | 20 -> # 73 "src/aorai/promelalexer.mll" ( comment lexbuf; token lexbuf ) # 1281 "src/aorai/promelalexer.ml" | 21 -> # 74 "src/aorai/promelalexer.mll" ( newline lexbuf; token lexbuf ) # 1286 "src/aorai/promelalexer.ml" | 22 -> # 77 "src/aorai/promelalexer.mll" ( let s=(lexeme lexbuf) in let s=String.sub s 7 ((String.length s)-7) in PROMELA_CALLOF s ) # 1293 "src/aorai/promelalexer.ml" | 23 -> # 81 "src/aorai/promelalexer.mll" ( let s=(lexeme lexbuf) in let s=String.sub s 9 ((String.length s)-9) in PROMELA_RETURNOF s ) # 1300 "src/aorai/promelalexer.ml" | 24 -> # 85 "src/aorai/promelalexer.mll" ( let s=(lexeme lexbuf) in let s=String.sub s 15 ((String.length s)-15) in PROMELA_CALLORRETURNOF s ) # 1307 "src/aorai/promelalexer.ml" | 25 -> # 90 "src/aorai/promelalexer.mll" ( raise_located (loc lexbuf) "Illegal fonction name in Promela file." ) # 1312 "src/aorai/promelalexer.ml" | 26 -> # 91 "src/aorai/promelalexer.mll" ( raise_located (loc lexbuf) "Illegal fonction name in Promela file." ) # 1317 "src/aorai/promelalexer.ml" | 27 -> # 92 "src/aorai/promelalexer.mll" ( raise_located (loc lexbuf) "Illegal fonction name in Promela file." ) # 1322 "src/aorai/promelalexer.ml" | 28 -> # 96 "src/aorai/promelalexer.mll" ( let s = lexeme lexbuf in PROMELA_LABEL s ) # 1328 "src/aorai/promelalexer.ml" | 29 -> # 98 "src/aorai/promelalexer.mll" ( EOF ) # 1333 "src/aorai/promelalexer.ml" | 30 -> # 100 "src/aorai/promelalexer.mll" ( PROMELA_TRUE ) # 1338 "src/aorai/promelalexer.ml" | 31 -> # 101 "src/aorai/promelalexer.mll" ( Aorai_option.error "Illegal_character : '%s'\n" (lexeme lexbuf); raise Parsing.Parse_error) # 1344 "src/aorai/promelalexer.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_token_rec lexbuf __ocaml_lex_state and comment lexbuf = __ocaml_lex_comment_rec lexbuf 79 and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 108 "src/aorai/promelalexer.mll" ( () ) # 1355 "src/aorai/promelalexer.ml" | 1 -> # 109 "src/aorai/promelalexer.mll" ( Aorai_option.error "Unterminated_comment\n" (*lex_error lexbuf "Unterminated_comment"*) ) # 1360 "src/aorai/promelalexer.ml" | 2 -> # 110 "src/aorai/promelalexer.mll" ( newline lexbuf; comment lexbuf ) # 1365 "src/aorai/promelalexer.ml" | 3 -> # 111 "src/aorai/promelalexer.mll" ( comment lexbuf ) # 1370 "src/aorai/promelalexer.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_comment_rec lexbuf __ocaml_lex_state ;; # 114 "src/aorai/promelalexer.mll" let parse c = let lb = from_channel c in try Promelaparser.promela token lb with Parsing.Parse_error | Invalid_argument _ -> let (a,b)=(loc lb) in Aorai_option.error "Syntax error (l%d c%d -> l%dc%d)" a.pos_lnum (a.pos_cnum-a.pos_bol) b.pos_lnum (b.pos_cnum-b.pos_bol); (* Format.print_string "Syntax error (" ; *) (* Format.print_string "l" ; *) (* Format.print_int a.pos_lnum ; *) (* Format.print_string "c" ; *) (* Format.print_int (a.pos_cnum-a.pos_bol) ;*) (* Format.print_string " -> l" ; *) (* Format.print_int b.pos_lnum ; *) (* Format.print_string "c" ; *) (* Format.print_int (b.pos_cnum-b.pos_bol) ;*) (* Format.print_string ")\n" ; *) raise_located (loc lb) "Syntax error" # 1402 "src/aorai/promelalexer.ml" frama-c-Fluorine-20130601/src/aorai/promelaast.mli0000644000175000017500000001523012155630222020530 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 abstract tree of promela representation. Such tree is used by promela parser/lexer before its translation into Data_for_aorai module. *) type expression = | PVar of string | PPrm of string * string (* f().N *) | PCst of Logic_ptree.constant | PBinop of Logic_ptree.binop * expression * expression | PUnop of Logic_ptree.unop * expression | PArrget of expression * expression | PField of expression * string | PArrow of expression * string type condition = | PRel of Logic_ptree.relation * expression * expression | PTrue | PFalse | POr of condition * condition | PAnd of condition * condition | PNot of condition | PCall of string * string option (** Call might be done in a given behavior *) | PReturn of string and seq_elt = { condition: condition option; nested: sequence; min_rep: expression option; max_rep: expression option; } and sequence = seq_elt list (** Promela parsed abstract syntax trees. Either a sequence of event or the otherwise keyword. A single condition is expressed with a singleton having an empty nested sequence and min_rep and max_rep being equal to one. *) type parsed_condition = Seq of sequence | Otherwise type typed_condition = | TOr of typed_condition * typed_condition (** Logical OR *) | TAnd of typed_condition * typed_condition (** Logical AND *) | TNot of typed_condition (** Logical NOT *) | TCall of Cil_types.kernel_function * Cil_types.funbehavior option (** Predicate modelling the call of an operation *) | TReturn of Cil_types.kernel_function (** Predicate modelling the return of an operation *) | TTrue (** Logical constant TRUE *) | TFalse (** Logical constant FALSE *) | TRel of Cil_types.relation * Cil_types.term * Cil_types.term (** Condition. If one of the terms contains TResult, TRel is in conjunction with exactly one TReturn event, and the TResult is tied to the corresponding value. *) type single_action = | Counter_init of Cil_types.term_lval | Counter_incr of Cil_types.term_lval | Pebble_init of Cil_types.logic_info * Cil_types.logic_var * Cil_types.logic_var (** adds a new pebble. [Pebble_init(set,aux,count)] indicates that pebble [count] is put in [set] whose content is governed by C variable [aux]. *) | Pebble_move of Cil_types.logic_info * Cil_types.logic_var * Cil_types.logic_info * Cil_types.logic_var (** [Pebble_move(new_set,new_aux,old_set,old_aux)] moves pebbles from [old_set] to [new_set], governed by the corresponding aux variables. *) | Copy_value of Cil_types.term_lval * Cil_types.term (** copy the current value of the given term into the given location so that it can be accessed by a later state. *) (** Additional actions to perform when crossing a transition. There is at most one Pebble_* action for each transition, and each transition leading to a state with multi-state has such an action. *) type action = single_action list (** Internal representation of a State from the Buchi automata. *) type state = { name : string (** State name *); mutable acceptation : Bool3.t (** True iff state is an acceptation state *); mutable init : Bool3.t (** True iff state is an initial state *); mutable nums : int; (** Numerical ID of the state *) mutable multi_state: (Cil_types.logic_info * Cil_types.logic_var) option (** Translation of some sequences might lead to some kind of pebble automaton, where we need to distinguish various branches. This is done by having a set of pebbles instead of just a zero/one switch to know if we are in the given state. The guards apply to each active pebble and are thus of the form \forall integer x; in(x,multi_state) ==> guard. multi_state is the first lvar of the pair, x is the second *) } (** Internal representation of a transition from the Buchi automata. *) type 'condition trans = { start : state ; (** Starting state of the transition *) stop : state ; (** Ending state of the transition *) mutable cross : 'condition ; (** Cross condition of the transition *) mutable numt : int (** Numerical ID of the transition *) } (** Internal representation of a Buchi automata : a list of states and a list of transitions.*) type 'condition automaton = (state list) * ('condition trans list) type parsed_automaton = parsed_condition automaton type typed_automaton = (typed_condition * action) automaton (** An operation can have two status: currently calling or returning. *) type funcStatus = | Call | Return (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/utils_parser.ml0000644000175000017500000000773312155630222020735 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 rec get_last_field my_field my_offset = match my_offset with | Cil_types.NoOffset -> my_field | Cil_types.Field(fieldinfo,the_offset) -> get_last_field fieldinfo the_offset | _ -> Aorai_option.fatal "NOT YET IMPLEMENTED : struct with array access." let rec add_offset father_offset new_offset = match father_offset with | Cil_types.NoOffset -> new_offset | Cil_types.Field(_,the_offset) -> (Cil.addOffset father_offset (add_offset the_offset new_offset)) | _ -> Aorai_option.fatal "NOT YET IMPLEMENTED : struct with array access." let rec get_field_info_from_name my_list name = if(List.length my_list <> 0) then begin let my_field = List.hd my_list in if(my_field.Cil_types.fname = name) then my_field else get_field_info_from_name (List.tl my_list) name end else Aorai_option.fatal "no field found with name :%s" name let get_new_offset my_host my_offset name= match my_host with | Cil_types.Var(var) -> let var_info = var in (* if my_offset is null no need to search the last field *) (* else we need to have the last *) let my_comp = if (my_offset = Cil_types.NoOffset) then match var_info.Cil_types.vtype with | Cil_types.TComp(mc,_,_) -> mc | _ -> assert false (*Cil_types.TComp(my_comp,_,_) = var_info.Cil_types.vtype in*) else begin let get_field_from_offset my_offset = begin match my_offset with | Cil_types.Field(fieldinfo,_) -> fieldinfo | _ -> Aorai_option.fatal "support only struct no array wtih struct" end in let field_info = get_field_from_offset my_offset in let last_field_offset = get_last_field field_info my_offset in (* last field in offset but not the field we want, for that we search in*) let mc = last_field_offset.Cil_types.fcomp in mc end in let field_info = get_field_info_from_name my_comp.Cil_types.cfields name in Cil_types.Field(field_info,Cil_types.NoOffset) | _ -> Aorai_option.fatal "NOT YET IMPLEMENTED : mem is not supported" frama-c-Fluorine-20130601/src/aorai/promelaparser.ml0000444000175000017500000003665512155634032021103 0ustar mehdimehditype token = | PROMELA_OR | PROMELA_AND | PROMELA_NOT | PROMELA_TRUE | PROMELA_FALSE | PROMELA_NEVER | PROMELA_IF | PROMELA_FI | PROMELA_GOTO | PROMELA_SKIP | PROMELA_LABEL of (string) | PROMELA_COLON | PROMELA_SEMICOLON | PROMELA_DOUBLE_COLON | PROMELA_LBRACE | PROMELA_RBRACE | PROMELA_LPAREN | PROMELA_RPAREN | PROMELA_RIGHT_ARROW | PROMELA_CALLOF of (string) | PROMELA_RETURNOF of (string) | PROMELA_CALLORRETURNOF of (string) | EOF open Parsing;; let _ = parse_error;; # 30 "src/aorai/promelaparser.mly" open Promelaast open Bool3 let observed_states=Hashtbl.create 1 let to_seq c = [{ condition = Some c; nested = []; min_rep = Some (PCst (Logic_ptree.IntConstant "1")); max_rep = Some (PCst (Logic_ptree.IntConstant "1")); }] # 41 "src/aorai/promelaparser.ml" let yytransl_const = [| 257 (* PROMELA_OR *); 258 (* PROMELA_AND *); 259 (* PROMELA_NOT *); 260 (* PROMELA_TRUE *); 261 (* PROMELA_FALSE *); 262 (* PROMELA_NEVER *); 263 (* PROMELA_IF *); 264 (* PROMELA_FI *); 265 (* PROMELA_GOTO *); 266 (* PROMELA_SKIP *); 268 (* PROMELA_COLON *); 269 (* PROMELA_SEMICOLON *); 270 (* PROMELA_DOUBLE_COLON *); 271 (* PROMELA_LBRACE *); 272 (* PROMELA_RBRACE *); 273 (* PROMELA_LPAREN *); 274 (* PROMELA_RPAREN *); 275 (* PROMELA_RIGHT_ARROW *); 0 (* EOF *); 0|] let yytransl_block = [| 267 (* PROMELA_LABEL *); 276 (* PROMELA_CALLOF *); 277 (* PROMELA_RETURNOF *); 278 (* PROMELA_CALLORRETURNOF *); 0|] let yylhs = "\255\255\ \001\000\001\000\002\000\002\000\003\000\004\000\004\000\006\000\ \005\000\005\000\005\000\005\000\007\000\007\000\008\000\009\000\ \009\000\009\000\009\000\009\000\009\000\009\000\009\000\009\000\ \009\000\000\000" let yylen = "\002\000\ \005\000\006\000\003\000\001\000\002\000\002\000\001\000\002\000\ \003\000\001\000\001\000\004\000\002\000\001\000\005\000\001\000\ \001\000\001\000\001\000\001\000\002\000\003\000\003\000\003\000\ \001\000\002\000" let yydefred = "\000\000\ \000\000\000\000\000\000\026\000\000\000\000\000\000\000\004\000\ \000\000\000\000\008\000\000\000\000\000\011\000\000\000\010\000\ \005\000\006\000\000\000\003\000\001\000\000\000\000\000\014\000\ \002\000\000\000\019\000\000\000\025\000\000\000\017\000\018\000\ \016\000\000\000\009\000\000\000\013\000\020\000\021\000\012\000\ \000\000\000\000\000\000\000\000\024\000\000\000\000\000\000\000\ \015\000" let yydgoto = "\002\000\ \004\000\007\000\008\000\009\000\017\000\010\000\023\000\024\000\ \034\000" let yysindex = "\012\000\ \029\255\000\000\026\255\000\000\038\255\039\255\027\255\000\000\ \037\255\038\255\000\000\015\255\052\000\000\000\040\255\000\000\ \000\000\000\000\055\000\000\000\000\000\253\254\022\255\000\000\ \000\000\017\255\000\000\048\255\000\000\017\255\000\000\000\000\ \000\000\004\255\000\000\017\255\000\000\000\000\000\000\000\000\ \014\255\017\255\017\255\049\255\000\000\002\255\055\255\050\255\ \000\000" let yyrindex = "\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\043\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\008\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\249\254\006\255\000\000\ \000\000" let yygindex = "\000\000\ \000\000\000\000\047\000\050\000\000\000\000\000\000\000\039\000\ \003\000" let yytablesize = 62 let yytable = "\026\000\ \027\000\028\000\042\000\043\000\042\000\043\000\022\000\029\000\ \020\000\020\000\023\000\023\000\001\000\030\000\042\000\043\000\ \031\000\032\000\033\000\026\000\027\000\038\000\044\000\022\000\ \022\000\006\000\020\000\029\000\039\000\035\000\019\000\045\000\ \041\000\030\000\003\000\036\000\031\000\032\000\033\000\012\000\ \005\000\014\000\013\000\015\000\046\000\047\000\016\000\007\000\ \006\000\007\000\011\000\021\000\007\000\022\000\025\000\040\000\ \043\000\048\000\020\000\018\000\049\000\037\000" let yycheck = "\003\001\ \004\001\005\001\001\001\002\001\001\001\002\001\001\001\011\001\ \001\001\002\001\018\001\019\001\001\000\017\001\001\001\002\001\ \020\001\021\001\022\001\003\001\004\001\005\001\019\001\018\001\ \019\001\011\001\019\001\011\001\026\000\008\001\016\001\018\001\ \030\000\017\001\006\001\014\001\020\001\021\001\022\001\013\001\ \015\001\005\001\016\001\007\001\042\000\043\000\010\001\005\001\ \011\001\007\001\012\001\000\000\010\001\014\001\000\000\008\001\ \002\001\009\001\012\000\010\000\011\001\023\000" let yynames_const = "\ PROMELA_OR\000\ PROMELA_AND\000\ PROMELA_NOT\000\ PROMELA_TRUE\000\ PROMELA_FALSE\000\ PROMELA_NEVER\000\ PROMELA_IF\000\ PROMELA_FI\000\ PROMELA_GOTO\000\ PROMELA_SKIP\000\ PROMELA_COLON\000\ PROMELA_SEMICOLON\000\ PROMELA_DOUBLE_COLON\000\ PROMELA_LBRACE\000\ PROMELA_RBRACE\000\ PROMELA_LPAREN\000\ PROMELA_RPAREN\000\ PROMELA_RIGHT_ARROW\000\ EOF\000\ " let yynames_block = "\ PROMELA_LABEL\000\ PROMELA_CALLOF\000\ PROMELA_RETURNOF\000\ PROMELA_CALLORRETURNOF\000\ " let yyact = [| (fun _ -> failwith "parser") ; (fun __caml_parser_env -> let _3 = (Parsing.peek_val __caml_parser_env 2 : 'states) in Obj.repr( # 69 "src/aorai/promelaparser.mly" ( let states= Hashtbl.fold (fun _ st l -> if st.acceptation=Undefined or st.init=Undefined then begin Aorai_option.abort "Error: the state %s is used but never defined" st.name; end; st::l ) observed_states [] in (states , _3) ) # 187 "src/aorai/promelaparser.ml" : Promelaast.parsed_automaton)) ; (fun __caml_parser_env -> let _3 = (Parsing.peek_val __caml_parser_env 3 : 'states) in Obj.repr( # 83 "src/aorai/promelaparser.mly" ( let states= Hashtbl.fold (fun _ st l -> if st.acceptation=Undefined or st.init=Undefined then begin Aorai_option.abort "Error: the state %s is used but never defined" st.name; end; st::l ) observed_states [] in (states , _3) ) # 205 "src/aorai/promelaparser.ml" : Promelaast.parsed_automaton)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'states) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'state) in Obj.repr( # 98 "src/aorai/promelaparser.mly" ( _1@_3 ) # 215 "src/aorai/promelaparser.ml" : 'states)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'state) in Obj.repr( # 101 "src/aorai/promelaparser.mly" ( _1 ) # 222 "src/aorai/promelaparser.ml" : 'states)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'state_labels) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'state_body) in Obj.repr( # 105 "src/aorai/promelaparser.mly" ( let (stl,trans)=_1 in let (trl,force_final)=_2 in if force_final then begin List.iter (fun s -> try (Hashtbl.find observed_states s.name).acceptation <- True with | Not_found -> assert false (* This state has to be in the hashtable -- by construction *) ) stl end; if trl=[] then trans else let tr_list= List.fold_left (fun l1 (cr,stop_st) -> List.fold_left (fun l2 st -> {start=st;stop=stop_st;cross=Seq (to_seq cr);numt=(-1)}::l2 ) l1 stl ) [] trl in (List.rev tr_list)@trans ) # 254 "src/aorai/promelaparser.ml" : 'state)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'label) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'state_labels) in Obj.repr( # 133 "src/aorai/promelaparser.mly" ( let (stl1,trl1)=_1 in let (stl2,trl2)=_2 in (stl1@stl2,trl1@trl2) ) # 266 "src/aorai/promelaparser.ml" : 'state_labels)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'label) in Obj.repr( # 138 "src/aorai/promelaparser.mly" ( _1 ) # 273 "src/aorai/promelaparser.ml" : 'state_labels)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in Obj.repr( # 142 "src/aorai/promelaparser.mly" ( begin (* Step 0 : trans is the set of new transitions and old is the description of the current state *) let trans = ref [] in (* Promela Label is a state. According to its name, we will try to give him its properties (init / accept) *) (* Firstly, if this state is still referenced, then we get it back. Else, we make a new "empty" state *) let old= try Hashtbl.find observed_states _1 with | Not_found -> let s = Data_for_aorai.new_state _1 in Hashtbl.add observed_states _1 s; s in (* Step 1 : setting up the acceptance status *) (* Default status : Non acceptation state *) old.acceptation <- False; (* Accept_all state means acceptance state with a reflexive transition without cross condition *) (* This case is not exclusive with the following. Acceptation status is set in this last. *) if (String.length _1>=10) && (String.compare (String.sub _1 0 10) "accept_all")=0 then trans:= {start=old;stop=old;cross=Seq (to_seq PTrue);numt=(-1)} :: !trans; (* If the name includes accept then this state is an acceptation one. *) if (String.length _1>=7) && (String.compare (String.sub _1 0 7) "accept_")=0 then old.acceptation <- True; (* Step 2 : setting up the init status *) (* If the state name ended with "_init" then it is an initial state. Else, it is not. *) if (String.length _1>=5) && (String.compare (String.sub _1 ((String.length _1)-5) 5) "_init" ) = 0 then old.init <- True else old.init <- False; ([old],!trans) end ) # 328 "src/aorai/promelaparser.ml" : 'label)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'transitions) in Obj.repr( # 195 "src/aorai/promelaparser.mly" ( (_2,false) ) # 335 "src/aorai/promelaparser.ml" : 'state_body)) ; (fun __caml_parser_env -> Obj.repr( # 196 "src/aorai/promelaparser.mly" ( ([],false) ) # 341 "src/aorai/promelaparser.ml" : 'state_body)) ; (fun __caml_parser_env -> Obj.repr( # 197 "src/aorai/promelaparser.mly" ( ([],true) ) # 347 "src/aorai/promelaparser.ml" : 'state_body)) ; (fun __caml_parser_env -> Obj.repr( # 198 "src/aorai/promelaparser.mly" ( ([],true) ) # 353 "src/aorai/promelaparser.ml" : 'state_body)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'transitions) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'transition) in Obj.repr( # 203 "src/aorai/promelaparser.mly" ( _1@[_2] ) # 361 "src/aorai/promelaparser.ml" : 'transitions)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'transition) in Obj.repr( # 204 "src/aorai/promelaparser.mly" ( [_1] ) # 368 "src/aorai/promelaparser.ml" : 'transitions)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 3 : 'guard) in let _5 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 208 "src/aorai/promelaparser.mly" ( let s= try Hashtbl.find observed_states _5 with Not_found -> let r = Data_for_aorai.new_state _5 in Hashtbl.add observed_states _5 r; r in (_2,s) ) # 387 "src/aorai/promelaparser.ml" : 'transition)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 223 "src/aorai/promelaparser.mly" ( POr(PCall (_1,None), PReturn _1) ) # 394 "src/aorai/promelaparser.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 224 "src/aorai/promelaparser.mly" ( PCall (_1,None) ) # 401 "src/aorai/promelaparser.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 225 "src/aorai/promelaparser.mly" ( PReturn _1 ) # 408 "src/aorai/promelaparser.ml" : 'guard)) ; (fun __caml_parser_env -> Obj.repr( # 226 "src/aorai/promelaparser.mly" ( PTrue ) # 414 "src/aorai/promelaparser.ml" : 'guard)) ; (fun __caml_parser_env -> Obj.repr( # 227 "src/aorai/promelaparser.mly" ( PFalse ) # 420 "src/aorai/promelaparser.ml" : 'guard)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'guard) in Obj.repr( # 228 "src/aorai/promelaparser.mly" ( PNot _2 ) # 427 "src/aorai/promelaparser.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'guard) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'guard) in Obj.repr( # 229 "src/aorai/promelaparser.mly" ( PAnd (_1,_3) ) # 435 "src/aorai/promelaparser.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'guard) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'guard) in Obj.repr( # 230 "src/aorai/promelaparser.mly" ( POr (_1,_3) ) # 443 "src/aorai/promelaparser.ml" : 'guard)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'guard) in Obj.repr( # 231 "src/aorai/promelaparser.mly" ( _2 ) # 450 "src/aorai/promelaparser.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 233 "src/aorai/promelaparser.mly" ( PRel (Logic_ptree.Neq,PVar _1,PCst(Logic_ptree.IntConstant "0")) ) # 457 "src/aorai/promelaparser.ml" : 'guard)) (* Entry promela *) ; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) |] let yytables = { Parsing.actions=yyact; Parsing.transl_const=yytransl_const; Parsing.transl_block=yytransl_block; Parsing.lhs=yylhs; Parsing.len=yylen; Parsing.defred=yydefred; Parsing.dgoto=yydgoto; Parsing.sindex=yysindex; Parsing.rindex=yyrindex; Parsing.gindex=yygindex; Parsing.tablesize=yytablesize; Parsing.table=yytable; Parsing.check=yycheck; Parsing.error_function=parse_error; Parsing.names_const=yynames_const; Parsing.names_block=yynames_block } let promela (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = (Parsing.yyparse yytables 1 lexfun lexbuf : Promelaast.parsed_automaton) frama-c-Fluorine-20130601/src/aorai/promelaparser_withexps.mly0000644000175000017500000002276612155630222023224 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Aorai plug-in of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat a l'nergie atomique et aux nergies */ /* alternatives) */ /* INRIA (Institut National de Recherche en Informatique et en */ /* Automatique) */ /* INSA (Institut National des Sciences Appliquees) */ /* */ /* 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: promelaparser_withexps.mly,v 1.2 2008-10-02 13:33:29 uid588 Exp $ */ /* Originated from http://www.ltl2dstar.de/down/ltl2dstar-0.4.2.zip */ %{ open Logic_ptree open Promelaast open Bool3 let observed_states=Hashtbl.create 1 let to_seq c = [{ condition = Some c; nested = []; min_rep = Some (PCst (IntConstant "1")); max_rep = Some (PCst (IntConstant "1")); }] %} %token PROMELA_OR %token PROMELA_AND %token PROMELA_NOT PROMELA_TRUE PROMELA_FALSE %right PROMELA_OR %right PROMELA_AND %nonassoc PROMELA_NOT PROMELA_TRUE PROMELA_FALSE %token PROMELA_NEVER PROMELA_IF PROMELA_FI PROMELA_GOTO PROMELA_SKIP %token PROMELA_LABEL %token PROMELA_INT %token PROMELA_COLON PROMELA_SEMICOLON PROMELA_DOUBLE_COLON %token PROMELA_LBRACE PROMELA_RBRACE PROMELA_LPAREN %token PROMELA_RPAREN PROMELA_RIGHT_ARROW %token PROMELA_TRUE PROMELA_FALSE /* Logic relations */ %token PROMELA_EQ PROMELA_LT PROMELA_GT PROMELA_LE PROMELA_GE PROMELA_NEQ %right PROMELA_EQ PROMELA_LT PROMELA_GT PROMELA_LE PROMELA_GE PROMELA_NEQ /* Arithmetic relations */ %token PROMELA_PLUS PROMELA_MINUS %token PROMELA_DIV PROMELA_STAR PROMELA_MODULO %right PROMELA_PLUS PROMELA_MINUS PROMELA_DIV PROMELA_STAR PROMELA_MODULO /* Access */ %token PROMELA_DOT PROMELA_LEFT_SQUARE PROMELA_RIGHT_SQUARE %token PROMELA_CALLOF PROMELA_RETURNOF PROMELA_CALLORRETURNOF %token EOF %token PROMELA_FUNC %type promela %start promela %% promela : PROMELA_NEVER PROMELA_LBRACE states PROMELA_RBRACE EOF { let states= Hashtbl.fold (fun _ st l -> if st.acceptation=Undefined or st.init=Undefined then begin Format.print_string ("Error: the state '"^(st.name)^"' is used but never defined.\n"); exit 1 end; st::l ) observed_states [] in (states , $3) } | PROMELA_NEVER PROMELA_LBRACE states PROMELA_SEMICOLON PROMELA_RBRACE EOF { let states= Hashtbl.fold (fun _ st l -> if st.acceptation=Undefined or st.init=Undefined then begin Aorai_option.abort "Error: state %s is used bug never defined" st.name end; st::l ) observed_states [] in (states , $3) } ; states : states PROMELA_SEMICOLON state { $1@$3 } | state { $1 } ; state : state_labels state_body { let (stl,trans)=$1 in let (trl,force_final)=$2 in if force_final then begin List.iter (fun s -> try (Hashtbl.find observed_states s.name).acceptation <- True with | Not_found -> assert false (* This state has to be in the hashtable -- by construction *) ) stl end; if trl=[] then trans else let tr_list= List.fold_left (fun l1 (cr,stop_st) -> List.fold_left (fun l2 st -> {start=st;stop=stop_st;cross=Seq (to_seq cr);numt=(-1)}::l2 ) l1 stl ) [] trl in (List.rev tr_list)@trans } ; state_labels : label state_labels { let (stl1,trl1)=$1 in let (stl2,trl2)=$2 in (stl1@stl2,trl1@trl2) } | label { $1 } ; label : PROMELA_LABEL PROMELA_COLON { begin (* Step 0 : trans is the set of new transitions and old is the description of the current state *) let trans = ref [] in (* Promela Label is a state. According to its name, we will try to give him its properties (init / accept) *) (* Firstly, if this state is still referenced, then we get it back. Else, we make a new "empty" state *) let old= try Hashtbl.find observed_states $1 with | Not_found -> let s = Data_for_aorai.new_state $1 in Hashtbl.add observed_states $1 s; s in (* Step 1 : setting up the acceptance status *) (* Default status : Non acceptation state *) old.acceptation <- False; (* Accept_all state means acceptance state with a reflexive transition without cross condition *) (* This case is not exclusive with the following. Acceptation status is set in this last. *) if (String.length $1>=10) && (String.compare (String.sub $1 0 10) "accept_all")=0 then trans:= {start=old;stop=old;cross=Seq (to_seq PTrue);numt=(-1)}::!trans; (* If the name includes accept then this state is an acceptation one. *) if (String.length $1>=7) && (String.compare (String.sub $1 0 7) "accept_")=0 then old.acceptation <- True; (* Step 2 : setting up the init status *) (* If the state name ended with "_init" then it is an initial state. Else, it is not. *) if (String.length $1>=5) && (String.compare (String.sub $1 ((String.length $1)-5) 5) "_init" ) = 0 then old.init <- True else old.init <- False; ([old],!trans) end } ; state_body : PROMELA_IF transitions PROMELA_FI { ($2,false) } | PROMELA_SKIP { ([],false) } | PROMELA_FALSE { ([],true) } | PROMELA_IF PROMELA_DOUBLE_COLON PROMELA_FALSE PROMELA_FI { ([],true) } ; transitions : transitions transition { $1@[$2] } | transition { [$1] } ; transition : PROMELA_DOUBLE_COLON guard PROMELA_RIGHT_ARROW PROMELA_GOTO PROMELA_LABEL { let s= try Hashtbl.find observed_states $5 with Not_found -> let r = Data_for_aorai.new_state $5 in Hashtbl.add observed_states $5 r; r in ($2,s) } ; guard : PROMELA_CALLORRETURNOF { POr(PCall ($1,None), PReturn $1) } | PROMELA_CALLOF { PCall ($1,None) } | PROMELA_RETURNOF { PReturn $1 } | PROMELA_TRUE { PTrue } | PROMELA_FALSE { PFalse } | PROMELA_NOT guard { PNot $2 } | guard PROMELA_AND guard { PAnd ($1,$3) } | guard PROMELA_OR guard { POr ($1,$3) } | PROMELA_LPAREN guard PROMELA_RPAREN { $2 } | logic_relation { $1 } ; logic_relation : arith_relation PROMELA_EQ arith_relation { PRel(Eq, $1, $3) } | arith_relation PROMELA_LT arith_relation { PRel(Lt, $1, $3) } | arith_relation PROMELA_GT arith_relation { PRel(Gt, $1, $3) } | arith_relation PROMELA_LE arith_relation { PRel(Le, $1, $3) } | arith_relation PROMELA_GE arith_relation { PRel(Ge, $1, $3) } | arith_relation PROMELA_NEQ arith_relation { PRel(Neq,$1, $3) } | arith_relation { PRel(Neq,$1, PCst(IntConstant "0")) } ; /* returns a Cil_types.exp expression */ arith_relation : arith_relation_mul PROMELA_PLUS arith_relation { PBinop(Badd, $1 , $3)} | arith_relation_mul PROMELA_MINUS arith_relation { PBinop(Bsub,$1,$3) } | arith_relation_mul { $1 } ; arith_relation_mul : arith_relation_mul PROMELA_DIV access_or_const { PBinop(Bdiv,$1,$3) } | arith_relation_mul PROMELA_STAR access_or_const { PBinop(Bmul,$1,$3) } | arith_relation_mul PROMELA_MODULO access_or_const { PBinop(Bmod,$1,$3) } | access_or_const { $1 } ; access_or_const : PROMELA_INT { PCst(IntConstant $1) } | PROMELA_MINUS PROMELA_INT { PUnop (Uminus, PCst (IntConstant $2)) } | access { $1 } | PROMELA_LPAREN arith_relation PROMELA_RPAREN { $2 } ; access : access PROMELA_DOT PROMELA_LABEL { PField ($1,$3) } | access_array {$1} access_array : access_array PROMELA_LEFT_SQUARE access_or_const PROMELA_RIGHT_SQUARE { PArrget($1,$3) } | access_leaf {$1} access_leaf : PROMELA_STAR access { PUnop(Ustar,$2) } | PROMELA_LABEL PROMELA_FUNC PROMELA_DOT PROMELA_LABEL { PPrm($1,$4) } | PROMELA_LABEL { PVar $1 } | PROMELA_LPAREN access PROMELA_RPAREN { $2 } ; frama-c-Fluorine-20130601/src/aorai/ltllexer.mll0000644000175000017500000001254712155630222020227 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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: ltllexer.mll,v 1.2 2008-10-02 13:33:29 uid588 Exp $ *) (* from http://www.ltl2dstar.de/down/ltl2dstar-0.4.2.zip *) { open Ltlparser open Lexing let loc lexbuf = (lexeme_start_p lexbuf, lexeme_end_p lexbuf) (*let lex_error lexbuf s = ()*) (* Creport.raise_located (loc lexbuf) (AnyMessage ("lexical error: " ^ s)) *) let buf = Buffer.create 1024 let newline lexbuf = let pos = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum } (* Update the current location with file name and line number. *) (* let update_loc lexbuf file line absolute chars = let pos = lexbuf.lex_curr_p in let new_file = match file with | None -> pos.pos_fname | Some s -> s in lexbuf.lex_curr_p <- { pos with pos_fname = new_file; pos_lnum = if absolute then line else pos.pos_lnum + line; pos_bol = pos.pos_cnum - chars; } *) exception Error of (Lexing.position * Lexing.position) * string let raise_located loc e = raise (Error (loc, e)) } let rD = ['0'-'9'] let rL = ['a'-'z' 'A'-'Z' '_'] rule token = parse | "true" { LTL_TRUE } | "false" { LTL_FALSE } | '(' { LTL_LPAREN } | ')' { LTL_RPAREN } (* Logic operators *) | "=>" { LTL_IMPLIES } | "<=>" { LTL_LEFT_RIGHT_ARROW } | "||" { LTL_OR } | "&&" { LTL_AND } | '!' { LTL_NOT } | "_G_" { LTL_GLOBALLY } | "_F_" { LTL_FATALLY } | "_U_" { LTL_UNTIL } | "_R_" { LTL_RELEASE } | "_X_" { LTL_NEXT } (* Logic relations *) | "==" { LTL_EQ } | "<" { LTL_LT } | ">" { LTL_GT } | "<=" { LTL_LE } | ">=" { LTL_GE } | "!=" { LTL_NEQ } (* Arithmetic relations *) | '+' { LTL_PLUS } | '-' { LTL_MINUS } | '/' { LTL_DIV } | '*' { LTL_STAR } | '%' { LTL_MODULO} (* Access *) | "->" { LTL_RIGHT_ARROW } | '.' { LTL_DOT } | '[' { LTL_LEFT_SQUARE} | ']' { LTL_RIGHT_SQUARE} | '&' { LTL_ADRESSE } | "CALL" { LTL_CALL } | "RETURN" { LTL_RETURN } | "CALL_OR_RETURN" { LTL_CALL_OR_RETURN } (* Comments *) | "/*" { comment lexbuf; token lexbuf } | "//" [^ '\n']* '\n' { newline lexbuf; token lexbuf } (* Spaces *) | [' ' '\t' '\012' '\r']+ { token lexbuf } | '\n' { newline lexbuf; token lexbuf } (* Variables and constants *) | rD+ | '-' rD+ { LTL_INT (lexeme lexbuf) } | rL (rL | rD)* { LTL_LABEL (lexeme lexbuf) } (* Others *) | eof { EOF } | _ { raise_located (loc lexbuf) (Format.sprintf "Illegal_character %s\n" (lexeme lexbuf)) } and comment = parse | "*/" { () } | eof { raise_located (loc lexbuf) "Unterminated_comment\n" } | '\n' { newline lexbuf; comment lexbuf } | _ { comment lexbuf } { let parse c = let lb = from_channel c in try Ltlparser.ltl token lb with Parsing.Parse_error | Invalid_argument _ -> raise_located (loc lb) "Syntax error" } frama-c-Fluorine-20130601/src/aorai/aorai_dataflow.ml0000644000175000017500000010004712155630222021165 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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). *) (* *) (**************************************************************************) (** Overapproximation of the states that can be attained at each statement, together with actions that have been performed. *) open Dataflow open Data_for_aorai open Promelaast open Cil_types let dkey = Aorai_option.register_category "dataflow" let set_of_map map = Data_for_aorai.Aorai_state.Map.fold (fun state _ acc -> Data_for_aorai.Aorai_state.Set.add state acc) map Data_for_aorai.Aorai_state.Set.empty let filter_state set map = Data_for_aorai.Aorai_state.Map.filter (fun state _ -> Data_for_aorai.Aorai_state.Set.mem state set) map module Call_state = State_builder.Hashtbl (Cil_datatype.Stmt.Hashtbl) (Case_state) (struct let name = "Data_for_aorai.Call_state" let dependencies = [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self; Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ] let size = 17 end) let set_call_state stmt state = let change old_state = Data_for_aorai.merge_state old_state state in let set _ = state in ignore (Call_state.memo ~change set stmt) module Return_state = State_builder.Hashtbl (Cil_datatype.Stmt.Hashtbl) (Case_state) (struct let name = "Data_for_aorai.Return_state" let dependencies = [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self; Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ] let size = 17 end) let set_return_state stmt state = let change old_state = Data_for_aorai.merge_state old_state state in let set _ = state in ignore (Return_state.memo ~change set stmt) module type Init = sig val kf: Kernel_function.t val stack: (Kernel_function.t * bool ref) list (* call stack. flag is set to true for the topmost function of each recursion. *) val initial_state: Data_for_aorai.state * Cil_datatype.Stmt.Set.t val stmt_can_reach: stmt -> stmt -> bool end let compute_func = ref (fun _ _ _ _ -> Aorai_option.fatal "Aorai_dataflow.compute_func not properly initialized") let extract_current_states s = Data_for_aorai.Aorai_state.Map.fold (fun _ tbl acc -> Data_for_aorai.Aorai_state.Map.fold (fun s _ acc -> Data_for_aorai.Aorai_state.Set.add s acc) tbl acc) s Data_for_aorai.Aorai_state.Set.empty let add_or_merge state (fst, last, bindings as elt) tbl = try let (old_fst, old_last, old_bindings) = Data_for_aorai.Aorai_state.Map.find state tbl in let merged_fst = Data_for_aorai.Aorai_state.Set.union old_fst fst in let merged_last = Data_for_aorai.Aorai_state.Set.union old_last last in let merged_bindings = Data_for_aorai.merge_bindings old_bindings bindings in Data_for_aorai.Aorai_state.Map.add state (merged_fst, merged_last, merged_bindings) tbl with Not_found -> Data_for_aorai.Aorai_state.Map.add state elt tbl let actions_to_range l = let add_single_action t b off acc = let binding = Cil_datatype.Term.Map.add b off Cil_datatype.Term.Map.empty in Cil_datatype.Term.Map.add t binding acc in let treat_one_action acc = function | Counter_init lv -> let t = Data_for_aorai.tlval lv in add_single_action t (Cil.lzero()) (Fixed 1) acc | Counter_incr lv -> let t = Data_for_aorai.tlval lv in add_single_action t t (Fixed 1) acc | Pebble_init(_,_,c) -> (* TODO: put post-conds on pebble sets *) let t = Logic_const.tvar c in add_single_action t t (Fixed 1) acc | Pebble_move _ -> acc (* TODO: put post-conds on pebble sets *) | Copy_value (lv,t) -> let loc = Data_for_aorai.tlval lv in add_single_action loc t (Fixed 0) acc in List.fold_left treat_one_action Cil_datatype.Term.Map.empty l let make_start_transition ?(is_main=false) kf init_states = let auto = Data_for_aorai.getAutomata () in let is_crossable = if is_main then Aorai_utils.isCrossableAtInit else (fun trans kf -> Aorai_utils.isCrossable trans kf Promelaast.Call) in let treat_one_state state acc = let my_trans = Path_analysis.get_transitions_of_state state auto in let treat_one_trans acc trans = if is_crossable trans kf then begin let (_,action) = trans.cross in let bindings = actions_to_range action in let fst_set = Data_for_aorai.Aorai_state.Set.singleton trans.stop in let last_set = Data_for_aorai.Aorai_state.Set.singleton state in add_or_merge trans.stop (fst_set, last_set, bindings) acc end else acc in let possible_states = List.fold_left treat_one_trans Data_for_aorai.Aorai_state.Map.empty my_trans in if Data_for_aorai.Aorai_state.Map.is_empty possible_states then acc else Data_for_aorai.Aorai_state.Map.add state possible_states acc in let res = Data_for_aorai.Aorai_state.Set.fold treat_one_state init_states Data_for_aorai.Aorai_state.Map.empty in res let compose_range loc b r1 r2 = match r1, r2 with | Fixed c1, Fixed c2 -> Fixed (c1 + c2) | Fixed c, Interval(min,max) | Interval(min,max), Fixed c -> Interval (c+min,c+max) | Fixed c, Bounded(min,max) | Bounded(min,max), Fixed c -> let max = Logic_const.term (TBinOp(PlusA,max, Logic_const.tinteger c)) Linteger in Bounded(c+min,max) | Fixed c1, Unbounded min | Unbounded min, Fixed c1 -> Unbounded (min+c1) | Interval(min1,max1), Interval(min2,max2) -> Interval(min1+min2,max1+max2) (* NB: in the bounded case, we could check if upper bound of interval is less then lower bound of bounded to keep bounded. *) | Interval(min1,_), Bounded(min2,_) | Bounded(min2,_), Interval(min1,_) | Interval(min1,_), Unbounded min2 | Unbounded min2, Interval (min1,_) | Bounded(min1, _), Bounded (min2, _) | Unbounded min1, Unbounded min2 | Bounded(min1,_), Unbounded min2 | Unbounded min1, Bounded(min2,_) -> if Cil.isLogicZero b then Data_for_aorai.absolute_range loc (min1 + min2) else Unbounded (min1 + min2) let compose_bindings map1 loc vals map = let vals = Cil_datatype.Term.Map.fold (fun base intv vals -> let vals' = if Cil.isLogicZero base then Cil_datatype.Term.Map.add base intv Cil_datatype.Term.Map.empty else try let orig_base = Cil_datatype.Term.Map.find base map1 in Cil_datatype.Term.Map.fold (fun base intv' map -> let intv' = compose_range loc base intv' intv in Cil_datatype.Term.Map.add base intv' map ) orig_base Cil_datatype.Term.Map.empty with Not_found -> Cil_datatype.Term.Map.add base intv Cil_datatype.Term.Map.empty in Cil_datatype.Term.Map.merge (Extlib.merge_opt (Data_for_aorai.merge_range loc)) vals' vals ) vals Cil_datatype.Term.Map.empty in try let vals' = Cil_datatype.Term.Map.find loc map in let vals' = Cil_datatype.Term.Map.merge (Extlib.merge_opt (Data_for_aorai.merge_range loc)) vals' vals in Cil_datatype.Term.Map.add loc vals' map with Not_found -> Cil_datatype.Term.Map.add loc vals map let compose_actions (fst,_,map1) (_,last,map2) = let map = Cil_datatype.Term.Map.fold (compose_bindings map1) map2 Cil_datatype.Term.Map.empty in (fst,last, Cil_datatype.Term.Map.fold (fun elt bind map -> if Cil_datatype.Term.Map.mem elt map2 then map else Cil_datatype.Term.Map.add elt bind map) map1 map) let compose_states start_state end_state = let treat_one_curr_state stop bindings acc = try let new_states = Data_for_aorai.Aorai_state.Map.find stop end_state in let composed_actions = Data_for_aorai.Aorai_state.Map.map (fun elt -> compose_actions bindings elt) new_states in let merge_stop_state _ (fst1, last1, map1) (fst2, last2, map2) = (Data_for_aorai.Aorai_state.Set.union fst1 fst2, Data_for_aorai.Aorai_state.Set.union last1 last2, Data_for_aorai.merge_bindings map1 map2) in Data_for_aorai.Aorai_state.Map.merge (Extlib.merge_opt merge_stop_state) composed_actions acc with Not_found -> acc in let treat_one_start_state start curr_states acc = let trans_state = Data_for_aorai.Aorai_state.Map.fold treat_one_curr_state curr_states Data_for_aorai.Aorai_state.Map.empty in if Data_for_aorai.Aorai_state.Map.is_empty trans_state then acc else Data_for_aorai.Aorai_state.Map.add start trans_state acc in Data_for_aorai.Aorai_state.Map.fold treat_one_start_state start_state Data_for_aorai.Aorai_state.Map.empty let make_return_transition kf state = let s = Kernel_function.find_return kf in set_return_state s state; let auto = Data_for_aorai.getAutomata () in let treat_one_state state bindings acc = let my_trans = Path_analysis.get_transitions_of_state state auto in let last = Data_for_aorai.Aorai_state.Set.singleton state in let treat_one_trans acc trans = if Aorai_utils.isCrossable trans kf Promelaast.Return then begin let (_,action) = trans.cross in let my_bindings = actions_to_range action in let new_bindings = compose_actions bindings (last, last, my_bindings) in add_or_merge trans.stop new_bindings acc end else acc in List.fold_left treat_one_trans acc my_trans in let treat_one_path start_state curr_state acc = let res = Data_for_aorai.Aorai_state.Map.fold treat_one_state curr_state Data_for_aorai.Aorai_state.Map.empty in if Data_for_aorai.Aorai_state.Map.is_empty res then acc else Data_for_aorai.Aorai_state.Map.add start_state res acc in Data_for_aorai.Aorai_state.Map.fold treat_one_path state Data_for_aorai.Aorai_state.Map.empty module Computer(I: Init) = struct let name = "Aorai forward analysis" let debug = ref false (* We keep track of the loops that we have entered, since we distinguish states at loop initialization from states during loop itself: when combining predecessors, we must know where we come from. *) type data = (Data_for_aorai.state * Cil_datatype.Stmt.Set.t) type t = data let copy = Extlib.id let pretty fmt (s,_) = Data_for_aorai.pretty_state fmt s let computeFirstPredecessor stmt (s,loops) = let loops = match stmt.skind with | Loop _ -> Data_for_aorai.set_loop_init_state stmt s; Cil_datatype.Stmt.Set.add stmt loops | _ -> loops in s,loops let combinePredecessors stmt ~old (cur,loops) = let (old,_) = old in (* we don't care about loops in old state: it has already been handled *) let is_loop = match stmt.skind with | Loop _ -> true | _ -> false in Aorai_option.debug ~dkey "Combining state (loop is %B)@\n @[%a@]@\nwith state@\n @[%a@]" is_loop Data_for_aorai.pretty_state old Data_for_aorai.pretty_state cur; if Data_for_aorai.included_state cur old then begin Aorai_option.debug ~dkey "Included"; if is_loop && Cil_datatype.Stmt.Set.mem stmt loops && Data_for_aorai.Aorai_state.Map.is_empty (Data_for_aorai.get_loop_invariant_state stmt) then Data_for_aorai.set_loop_invariant_state stmt cur; None end else begin let res = if is_loop then begin (* set_loop implicitly merges states when needed. However, we still have to distinguish whether we are already in the loop or at the initial stage. *) if Cil_datatype.Stmt.Set.mem stmt loops then begin Data_for_aorai.set_loop_invariant_state stmt cur; Data_for_aorai.get_loop_invariant_state stmt end else begin Data_for_aorai.set_loop_init_state stmt cur; Data_for_aorai.get_loop_init_state stmt end end else begin Data_for_aorai.merge_state old cur end in Aorai_option.debug ~dkey "Merged state is@\n @[%a@]" Data_for_aorai.pretty_state res; let loops = if is_loop then Cil_datatype.Stmt.Set.add stmt loops else loops in Some (res,loops) end let doInstr s i (state,loops) = match i with | Call (_,{ enode = Lval(Var v,NoOffset) },_,_) -> let kf = Globals.Functions.get v in if Data_for_aorai.isIgnoredFunction (Kernel_function.get_name kf) then Dataflow.Default (* we simply skip ignored functions. *) else begin set_call_state s state; Aorai_option.debug ~dkey "Call to %a from state:@\n @[%a@]" Kernel_function.pretty kf Data_for_aorai.pretty_state state; let init_states = extract_current_states state in let kf = Globals.Functions.get v in let init_trans = make_start_transition kf init_states in let end_state = !compute_func I.stack (Kstmt s) kf init_trans in let new_state = compose_states state end_state in Aorai_option.debug ~dkey "At end of call:@\n @[%a@]" Data_for_aorai.pretty_state new_state; Done (new_state,loops) end | Call (_,e,_,_) -> Aorai_option.not_yet_implemented "Indirect call to %a is not handled yet" Printer.pp_exp e | Set _ | Asm _ | Skip _ | Code_annot _ -> Dataflow.Default let doGuard _ _ _ = (GDefault, GDefault) let doStmt _ (state,_) = if Data_for_aorai.Aorai_state.Map.is_empty state then (* Statement is not conforming to the automaton. It must be on a dead path for the whole program to match the spec. *) SDone else SDefault let filterStmt _ = true let stmt_can_reach = I.stmt_can_reach let doEdge _ _ t = t module StmtStartData = Dataflow.StartData(struct type t = data let size = 17 end) let () = let start = Kernel_function.find_first_stmt I.kf in StmtStartData.add start I.initial_state end let compute_func_aux stack call_site kf init_state = if Data_for_aorai.isIgnoredFunction (Kernel_function.get_name kf) then Aorai_option.fatal "compute_func on function %a which is ignored by Aorai" Kernel_function.pretty kf else if List.mem_assq kf stack then begin (* Recursive call: we assume all possible paths can be taken *) let flag = List.assq kf stack in flag := true; Data_for_aorai.set_kf_init_state kf init_state; let end_state = try Data_for_aorai.get_kf_return_state kf with Not_found -> Data_for_aorai.Aorai_state.Map.empty in end_state end else begin let module Init = struct let kf = kf let stack = (kf, ref false) :: stack let loops = match Kernel_function.find_first_stmt kf with | { skind = Loop _ } as stmt -> Cil_datatype.Stmt.Set.singleton stmt | _ -> Cil_datatype.Stmt.Set.empty let initial_state = (init_state, loops) let stmt_can_reach = Stmts_graph.stmt_can_reach kf end in let module Compute = Computer (Init) in let module Dataflow = Forwards(Compute) in Aorai_option.debug ~dkey "Call to %a, Initial state is:@\n @[%a@]" Kernel_function.pretty kf Data_for_aorai.pretty_state init_state; Data_for_aorai.set_kf_init_state kf init_state; if Kernel_function.is_definition kf then begin let start = Kernel_function.find_first_stmt kf in (match start.skind with (* If the first statement itself is a loop, sets the appropriate table, as this won't be done in Computer (technically, there is not firstPredecessor in this particular case) *) | Loop _ -> Data_for_aorai.set_loop_init_state start init_state | _ -> ()); Dataflow.compute [Kernel_function.find_first_stmt kf] end; let end_state = if Kernel_function.is_definition kf then begin try Compute.StmtStartData.find (Kernel_function.find_return kf) with Not_found -> Aorai_option.warning ~source:(fst (Cil_datatype.Kinstr.loc call_site)) "Call to %a does not follow automaton's specification. \ This path is assumed to be dead" Kernel_function.pretty kf; (Data_for_aorai.Aorai_state.Map.empty, Cil_datatype.Stmt.Set.empty) end else (* we assume a declared function does not make any call. *) (init_state, Cil_datatype.Stmt.Set.empty) in let trans_state = make_return_transition kf (fst end_state) in let (my_kf, flag) = List.hd Init.stack in assert (kf == my_kf); if !flag then begin let curr_end = try Data_for_aorai.get_kf_return_state kf with Not_found -> Data_for_aorai.Aorai_state.Map.empty in Data_for_aorai.set_kf_return_state kf trans_state; if Data_for_aorai.included_state trans_state curr_end then curr_end else (* See if we've reached a fixpoint *) let init_state = Data_for_aorai.get_kf_init_state kf in !compute_func stack call_site kf init_state end else begin Data_for_aorai.set_kf_return_state kf trans_state; trans_state end end let () = compute_func := compute_func_aux let compute_forward () = let kf = Globals.Functions.find_by_name (Kernel.MainFunction.get()) in if Data_for_aorai.isIgnoredFunction (Kernel_function.get_name kf) then Aorai_option.abort "Main function %a is ignored by Aorai" Kernel_function.pretty kf; let (states,_) = Data_for_aorai.getAutomata () in let start = List.fold_left (fun acc s -> match s.Promelaast.init with | Bool3.True -> Data_for_aorai.Aorai_state.Set.add s acc | _ -> acc) Data_for_aorai.Aorai_state.Set.empty states in let start_state = make_start_transition ~is_main:true kf start in ignore (compute_func_aux [] Kglobal kf start_state) module type Reachable_end_states = sig val kf: Kernel_function.t val stack: Kernel_function.t list val end_state: Data_for_aorai.state end module Pre_state = Kernel_function.Make_Table (Data_for_aorai.Case_state) (struct let name = "Aorai_dataflow.Pre_state" let dependencies = [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self; Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ] let size = 17 end) let set_kf_init_state kf state = let change old_state = Data_for_aorai.merge_state old_state state in let set _ = state in let state = (Pre_state.memo ~change set kf) in Aorai_option.debug ~dkey "Call to %a, pre-state after backward analysis:@\n @[%a@]" Kernel_function.pretty kf Data_for_aorai.pretty_state state; module Post_state = Kernel_function.Make_Table (Data_for_aorai.Case_state) (struct let name = "Aorai_dataflow.Post_state" let dependencies = [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self; Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ] let size = 17 end) let set_kf_return_state kf state = let change old_state = Data_for_aorai.merge_state old_state state in let set _ = state in ignore (Post_state.memo ~change set kf) module Init_loop_state = State_builder.Hashtbl (Cil_datatype.Stmt.Hashtbl) (Data_for_aorai.Case_state) (struct let name = "Aorai_dataflow.Init_loop_state" let dependencies = [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self; Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ] let size = 17 end) let set_init_loop_state stmt state = let change old_state = Data_for_aorai.merge_state old_state state in let set _ = state in ignore (Init_loop_state.memo ~change set stmt) module Invariant_loop_state = State_builder.Hashtbl (Cil_datatype.Stmt.Hashtbl) (Data_for_aorai.Case_state) (struct let name = "Aorai_dataflow.Invariant_loop_state" let dependencies = [ Ast.self; Aorai_option.Ya.self; Aorai_option.Ltl_File.self; Aorai_option.To_Buchi.self; Aorai_option.Deterministic.self ] let size = 17 end) let set_invariant_loop_state stmt state = let change old_state = Data_for_aorai.merge_state old_state state in let set _ = state in ignore (Invariant_loop_state.memo ~change set stmt) let backward_analysis = ref (fun _ _ _ -> Aorai_option.fatal "Aorai_dataflow.backward_analysis not properly initialized") module Backwards_computer (Reach: Reachable_end_states) = struct let name = "Aorai backward computation" let debug = ref false type t = Data_for_aorai.state let pretty = Data_for_aorai.pretty_state let funcExitData = Data_for_aorai.Aorai_state.Map.empty let combineStmtStartData _ ~old st = if Data_for_aorai.included_state st old then None else Some (Data_for_aorai.merge_state old st) let combineSuccessors = Data_for_aorai.merge_state let doStmt s = match s.skind with | Return _ -> Dataflow.Done Reach.end_state | _ -> Dataflow.Default let doInstr s instr state = match instr with | Call (_,{ enode = Lval(Var v,NoOffset) },_,_) -> let kf = Globals.Functions.get v in if Data_for_aorai.isIgnoredFunction (Kernel_function.get_name kf) then Dataflow.Default (* we simply skip ignored functions. *) else begin try let call_state = Call_state.find s in let treat_one_state state map acc = let kf = Globals.Functions.get v in let current_states = set_of_map map in let before_state = !backward_analysis Reach.stack kf current_states in let possible_states = set_of_map before_state in let call_map = Data_for_aorai.Aorai_state.Map.find state call_state in let call_map = filter_state possible_states call_map in if Data_for_aorai.Aorai_state.Map.is_empty call_map then acc else Data_for_aorai.Aorai_state.Map.add state call_map acc in let before_state = Data_for_aorai.Aorai_state.Map.fold treat_one_state state Data_for_aorai.Aorai_state.Map.empty in Done before_state with Not_found -> (* Not attained by forward analysis: this code is dead anyway. *) Done Data_for_aorai.Aorai_state.Map.empty end | Call (_,e,_,_) -> Aorai_option.not_yet_implemented "Indirect call to %a is not handled yet" Printer.pp_exp e | Set _ | Asm _ | Skip _ | Code_annot _ -> Dataflow.Default let filterStmt s1 s2 = Stmts_graph.stmt_can_reach Reach.kf s1 s2 module StmtStartData = Dataflow.StartData (struct type t = Data_for_aorai.state let size = 17 end) let () = if Kernel_function.is_definition Reach.kf then begin let (all_stmts,_) = Dataflow.find_stmts (Kernel_function.get_definition Reach.kf) in List.iter (fun s -> StmtStartData.add s Data_for_aorai.Aorai_state.Map.empty) all_stmts; end let stmt_can_reach = Stmts_graph.stmt_can_reach Reach.kf end let filter_possible_states kf states = let post_state = Data_for_aorai.get_kf_return_state kf in let treat_one_state state post_state acc = let post_state = filter_state states post_state in if Data_for_aorai.Aorai_state.Map.is_empty post_state then acc else Data_for_aorai.Aorai_state.Map.add state post_state acc in Data_for_aorai.Aorai_state.Map.fold treat_one_state post_state Data_for_aorai.Aorai_state.Map.empty let filter_return_states kf states = let end_state = Return_state.find (Kernel_function.find_return kf) in let auto = Data_for_aorai.getAutomata () in let is_possible_state start_state state _ = try let trans = Path_analysis.get_transitions_of_state state auto in let return_states = Data_for_aorai.Aorai_state.Map.find start_state states in let crossable tr = Aorai_utils.isCrossable tr kf Promelaast.Return && Data_for_aorai.Aorai_state.Map.mem tr.stop return_states in List.exists crossable trans with Not_found -> false in let filter_possible_states state map = Data_for_aorai.Aorai_state.Map.filter (is_possible_state state) map in let treat_one_state state map acc = let res = filter_possible_states state map in if Data_for_aorai.Aorai_state.Map.is_empty res then acc else Data_for_aorai.Aorai_state.Map.add state res acc in let res = Data_for_aorai.Aorai_state.Map.fold treat_one_state end_state Data_for_aorai.Aorai_state.Map.empty in if Data_for_aorai.Aorai_state.Map.is_empty res && not (Data_for_aorai.Aorai_state.Map.is_empty end_state) then (* Do not emit warning if forward computation already decided that the call was not conforming to the spec. *) Aorai_option.warning ~current:true "Call to %a not conforming to automaton (post-cond). \ Assuming it is on a dead path" Kernel_function.pretty kf; res let filter_loop_states old_map restrict_map = let treat_one_state state old_states acc = try let restrict_states = Data_for_aorai.Aorai_state.Map.find state restrict_map in let old_states = filter_state (set_of_map restrict_states) old_states in if Data_for_aorai.Aorai_state.Map.is_empty old_states then acc else Data_for_aorai.Aorai_state.Map.add state old_states acc with Not_found -> acc (* not accessible in any case *) in Data_for_aorai.Aorai_state.Map.fold treat_one_state old_map Data_for_aorai.Aorai_state.Map.empty let filter_init_state restrict initial map acc = try let restrict_map = Data_for_aorai.Aorai_state.Map.find initial restrict in let map = Data_for_aorai.Aorai_state.Map.filter (fun state _ -> Data_for_aorai.Aorai_state.Map.mem state restrict_map) map in if Data_for_aorai.Aorai_state.Map.is_empty map then acc else Data_for_aorai.Aorai_state.Map.add initial map acc with Not_found -> acc let backward_analysis_aux stack kf ret_state = if (Data_for_aorai.isIgnoredFunction (Kernel_function.get_name kf)) then Aorai_option.fatal "Call backward analysis on ignored function %a" Kernel_function.pretty kf else if List.memq kf stack then begin (* recursive function: just attempt to filter wrt attainable current states *) let kf_post_state = filter_possible_states kf ret_state in set_kf_return_state kf kf_post_state; let before_state = Data_for_aorai.get_kf_init_state kf in let before_state = Data_for_aorai.Aorai_state.Map.filter (fun s _ -> Data_for_aorai.Aorai_state.Map.mem s kf_post_state) before_state in set_kf_init_state kf before_state; before_state end else begin let kf_post_state = filter_possible_states kf ret_state in set_kf_return_state kf kf_post_state; let end_state = filter_return_states kf kf_post_state in let module Computer = Backwards_computer (struct let stack = kf :: stack let kf = kf let end_state = end_state end) in let module Compute = Dataflow.Backwards(Computer) in let (all_stmts,sink_stmts) = Dataflow.find_stmts (Kernel_function.get_definition kf) in Compute.compute sink_stmts; let restrict_state = try Computer.StmtStartData.find (Kernel_function.find_first_stmt kf) with Not_found -> Data_for_aorai.Aorai_state.Map.empty in let before_state = Data_for_aorai.get_kf_init_state kf in let new_state = Data_for_aorai.Aorai_state.Map.fold (filter_init_state restrict_state) before_state Data_for_aorai.Aorai_state.Map.empty in if Data_for_aorai.Aorai_state.Map.is_empty new_state && not (Data_for_aorai.Aorai_state.Map.is_empty before_state) then begin Aorai_option.warning ~current:true "Call to %a not conforming to automaton (pre-cond). \ Assuming it is on a dead path" Kernel_function.pretty kf; end; set_kf_init_state kf new_state; let treat_one_loop s = try let states = Computer.StmtStartData.find s in (try let init = Data_for_aorai.get_loop_init_state s in let init = filter_loop_states init states in set_init_loop_state s init; with Not_found -> ()); (try let inv = Data_for_aorai.get_loop_invariant_state s in let inv = filter_loop_states inv states in set_invariant_loop_state s inv with Not_found -> ()) with Not_found -> Aorai_option.warning ~source:(fst (Cil_datatype.Stmt.loc s)) "Statement %a@ not conforming to automaton. \ Assuming it is on a dead path" Printer.pp_stmt s in let visit = object inherit Visitor.frama_c_inplace method vstmt_aux s = match s.skind with | Loop _ -> treat_one_loop s; Cil.DoChildren | _ -> Cil.DoChildren end in let visit_stmt s = ignore (Visitor.visitFramacStmt visit s) in List.iter visit_stmt all_stmts; before_state end let () = backward_analysis := backward_analysis_aux let compute_backward () = let kf = Globals.Functions.find_by_name (Kernel.MainFunction.get()) in if Data_for_aorai.isIgnoredFunction (Kernel_function.get_name kf) then Aorai_option.abort "Main function %a is ignored by Aorai" Kernel_function.pretty kf; let final_state = Data_for_aorai.get_kf_return_state kf in let accepted_states = Data_for_aorai.Aorai_state.Map.fold (fun _ map acc -> Data_for_aorai.Aorai_state.Set.union (set_of_map map) acc) final_state Data_for_aorai.Aorai_state.Set.empty in ignore (backward_analysis_aux [] kf accepted_states); Pre_state.iter Data_for_aorai.replace_kf_init_state; Post_state.iter Data_for_aorai.replace_kf_return_state; Init_loop_state.iter Data_for_aorai.replace_loop_init_state; Invariant_loop_state.iter Data_for_aorai.replace_loop_invariant_state let compute () = compute_forward (); Aorai_option.debug ~dkey "After forward analysis"; Data_for_aorai.debug_computed_state (); compute_backward (); Aorai_option.debug ~dkey "After backward analysis"; Data_for_aorai.debug_computed_state(); (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/ltlparser.ml0000444000175000017500000006370412155634032020232 0ustar mehdimehditype token = | LTL_TRUE | LTL_FALSE | LTL_LPAREN | LTL_RPAREN | LTL_OR | LTL_IMPLIES | LTL_LEFT_RIGHT_ARROW | LTL_AND | LTL_NOT | LTL_GLOBALLY | LTL_FATALLY | LTL_UNTIL | LTL_RELEASE | LTL_NEXT | LTL_EQ | LTL_LT | LTL_GT | LTL_LE | LTL_GE | LTL_NEQ | LTL_PLUS | LTL_MINUS | LTL_DIV | LTL_STAR | LTL_MODULO | LTL_RIGHT_ARROW | LTL_DOT | LTL_LEFT_SQUARE | LTL_RIGHT_SQUARE | LTL_ADRESSE | LTL_CALL | LTL_RETURN | LTL_CALL_OR_RETURN | LTL_INT of (string) | LTL_LABEL of (string) | EOF open Parsing;; let _ = parse_error;; # 30 "src/aorai/ltlparser.mly" open Promelaast open Logic_ptree let observed_expressions=Hashtbl.create 97 let ident_count=ref 0 let get_fresh_ident () = ident_count:=!ident_count+1; ("buchfreshident"^(string_of_int !ident_count)) # 52 "src/aorai/ltlparser.ml" let yytransl_const = [| 257 (* LTL_TRUE *); 258 (* LTL_FALSE *); 259 (* LTL_LPAREN *); 260 (* LTL_RPAREN *); 261 (* LTL_OR *); 262 (* LTL_IMPLIES *); 263 (* LTL_LEFT_RIGHT_ARROW *); 264 (* LTL_AND *); 265 (* LTL_NOT *); 266 (* LTL_GLOBALLY *); 267 (* LTL_FATALLY *); 268 (* LTL_UNTIL *); 269 (* LTL_RELEASE *); 270 (* LTL_NEXT *); 271 (* LTL_EQ *); 272 (* LTL_LT *); 273 (* LTL_GT *); 274 (* LTL_LE *); 275 (* LTL_GE *); 276 (* LTL_NEQ *); 277 (* LTL_PLUS *); 278 (* LTL_MINUS *); 279 (* LTL_DIV *); 280 (* LTL_STAR *); 281 (* LTL_MODULO *); 282 (* LTL_RIGHT_ARROW *); 283 (* LTL_DOT *); 284 (* LTL_LEFT_SQUARE *); 285 (* LTL_RIGHT_SQUARE *); 286 (* LTL_ADRESSE *); 287 (* LTL_CALL *); 288 (* LTL_RETURN *); 289 (* LTL_CALL_OR_RETURN *); 0 (* EOF *); 0|] let yytransl_block = [| 290 (* LTL_INT *); 291 (* LTL_LABEL *); 0|] let yylhs = "\255\255\ \001\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\004\000\004\000\004\000\005\000\005\000\005\000\005\000\ \006\000\006\000\006\000\006\000\007\000\007\000\007\000\008\000\ \008\000\009\000\009\000\009\000\009\000\000\000" let yylen = "\002\000\ \002\000\001\000\001\000\003\000\002\000\002\000\003\000\003\000\ \002\000\003\000\003\000\002\000\003\000\003\000\004\000\004\000\ \004\000\001\000\003\000\003\000\003\000\003\000\003\000\003\000\ \001\000\003\000\003\000\001\000\003\000\003\000\003\000\001\000\ \001\000\002\000\001\000\003\000\003\000\003\000\001\000\004\000\ \001\000\002\000\002\000\001\000\003\000\002\000" let yydefred = "\000\000\ \000\000\000\000\002\000\003\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\ \044\000\046\000\000\000\018\000\000\000\000\000\032\000\000\000\ \000\000\041\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\034\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\004\000\036\000\045\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\020\000\021\000\022\000\023\000\ \024\000\026\000\027\000\029\000\030\000\031\000\037\000\038\000\ \000\000\015\000\016\000\017\000\000\000\040\000" let yydgoto = "\002\000\ \018\000\019\000\020\000\021\000\022\000\023\000\024\000\025\000\ \026\000" let yysindex = "\010\000\ \066\255\000\000\000\000\000\000\066\255\066\255\066\255\066\255\ \066\255\224\254\002\255\002\255\027\255\031\255\063\255\000\000\ \000\000\000\000\131\000\000\000\045\255\070\255\000\000\014\255\ \243\254\000\000\102\255\067\255\012\255\039\255\039\255\039\255\ \039\255\000\000\002\255\014\255\014\255\007\255\037\255\043\255\ \066\255\066\255\066\255\066\255\066\255\066\255\000\000\001\255\ \001\255\001\255\001\255\001\255\001\255\001\255\001\255\001\255\ \001\255\001\255\046\255\054\255\001\255\000\000\000\000\000\000\ \012\255\098\255\099\255\100\255\111\255\111\255\111\255\016\255\ \039\255\039\255\001\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\ \082\255\000\000\000\000\000\000\108\255\000\000" let yyrindex = "\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\122\000\105\000\000\000\079\000\ \001\000\000\000\000\000\120\255\157\255\141\000\146\000\151\000\ \156\000\000\000\000\000\027\000\053\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\006\000\007\000\008\000\171\000\ \161\000\166\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000" let yygindex = "\000\000\ \000\000\013\000\000\000\251\255\000\000\212\255\254\255\000\000\ \000\000" let yytablesize = 434 let yytable = "\028\000\ \039\000\034\000\029\000\075\000\035\000\010\000\013\000\014\000\ \036\000\037\000\001\000\084\000\085\000\086\000\061\000\064\000\ \089\000\027\000\030\000\031\000\032\000\033\000\010\000\044\000\ \011\000\011\000\043\000\045\000\046\000\038\000\012\000\012\000\ \065\000\039\000\016\000\017\000\017\000\059\000\060\000\059\000\ \060\000\066\000\076\000\077\000\078\000\079\000\080\000\081\000\ \082\000\083\000\045\000\046\000\042\000\069\000\070\000\071\000\ \072\000\073\000\074\000\048\000\049\000\050\000\051\000\052\000\ \053\000\040\000\003\000\004\000\005\000\093\000\063\000\067\000\ \029\000\000\000\006\000\007\000\008\000\068\000\035\000\009\000\ \087\000\048\000\049\000\050\000\051\000\052\000\053\000\010\000\ \088\000\011\000\054\000\055\000\056\000\057\000\058\000\012\000\ \013\000\014\000\015\000\016\000\017\000\090\000\091\000\092\000\ \028\000\062\000\041\000\042\000\043\000\044\000\094\000\063\000\ \000\000\045\000\046\000\041\000\042\000\043\000\044\000\000\000\ \000\000\025\000\045\000\046\000\025\000\025\000\025\000\025\000\ \000\000\000\000\047\000\025\000\025\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\012\000\000\000\000\000\000\000\ \000\000\005\000\000\000\000\000\000\000\000\000\006\000\000\000\ \000\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\ \007\000\035\000\035\000\035\000\035\000\008\000\000\000\000\000\ \035\000\035\000\011\000\035\000\035\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\039\000\039\000\039\000\039\000\ \039\000\010\000\013\000\014\000\039\000\039\000\000\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\000\000\039\000\043\000\043\000\ \043\000\043\000\043\000\000\000\000\000\000\000\043\000\043\000\ \000\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\000\000\000\000\043\000\043\000\ \042\000\042\000\042\000\042\000\042\000\000\000\000\000\000\000\ \042\000\042\000\000\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\000\000\000\000\ \042\000\042\000\035\000\035\000\035\000\035\000\035\000\000\000\ \000\000\000\000\035\000\035\000\000\000\035\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\035\000\035\000\ \000\000\000\000\000\000\035\000\028\000\028\000\028\000\028\000\ \028\000\000\000\000\000\000\000\028\000\028\000\000\000\028\000\ \028\000\028\000\028\000\028\000\028\000\025\000\025\000\025\000\ \025\000\025\000\000\000\000\000\000\000\025\000\025\000\041\000\ \042\000\043\000\044\000\000\000\000\000\000\000\045\000\046\000\ \012\000\012\000\012\000\012\000\012\000\005\000\005\000\005\000\ \005\000\005\000\006\000\006\000\006\000\006\000\006\000\009\000\ \009\000\009\000\009\000\009\000\007\000\007\000\007\000\007\000\ \007\000\008\000\008\000\008\000\008\000\008\000\011\000\011\000\ \011\000\011\000" let yycheck = "\005\000\ \000\000\034\001\005\000\003\001\003\001\000\000\000\000\000\000\ \011\000\012\000\001\000\056\000\057\000\058\000\028\001\004\001\ \061\000\005\000\006\000\007\000\008\000\009\000\022\001\008\001\ \024\001\024\001\000\000\012\001\013\001\003\001\030\001\030\001\ \035\000\003\001\034\001\035\001\035\001\026\001\027\001\026\001\ \027\001\035\001\048\000\049\000\050\000\051\000\052\000\053\000\ \054\000\055\000\012\001\013\001\000\000\041\000\042\000\043\000\ \044\000\045\000\046\000\015\001\016\001\017\001\018\001\019\001\ \020\001\003\001\001\001\002\001\003\001\075\000\004\001\035\001\ \075\000\255\255\009\001\010\001\011\001\035\001\000\000\014\001\ \035\001\015\001\016\001\017\001\018\001\019\001\020\001\022\001\ \035\001\024\001\021\001\022\001\023\001\024\001\025\001\030\001\ \031\001\032\001\033\001\034\001\035\001\004\001\004\001\004\001\ \000\000\004\001\005\001\006\001\007\001\008\001\029\001\004\001\ \255\255\012\001\013\001\005\001\006\001\007\001\008\001\255\255\ \255\255\000\000\012\001\013\001\005\001\006\001\007\001\008\001\ \255\255\255\255\000\000\012\001\013\001\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\000\000\255\255\255\255\255\255\ \255\255\000\000\255\255\255\255\255\255\255\255\000\000\255\255\ \255\255\255\255\255\255\000\000\255\255\255\255\255\255\255\255\ \000\000\005\001\006\001\007\001\008\001\000\000\255\255\255\255\ \012\001\013\001\000\000\015\001\016\001\017\001\018\001\019\001\ \020\001\021\001\022\001\023\001\024\001\025\001\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\004\001\005\001\006\001\007\001\ \008\001\004\001\004\001\004\001\012\001\013\001\255\255\015\001\ \016\001\017\001\018\001\019\001\020\001\021\001\022\001\023\001\ \024\001\025\001\026\001\027\001\255\255\029\001\004\001\005\001\ \006\001\007\001\008\001\255\255\255\255\255\255\012\001\013\001\ \255\255\015\001\016\001\017\001\018\001\019\001\020\001\021\001\ \022\001\023\001\024\001\025\001\255\255\255\255\028\001\029\001\ \004\001\005\001\006\001\007\001\008\001\255\255\255\255\255\255\ \012\001\013\001\255\255\015\001\016\001\017\001\018\001\019\001\ \020\001\021\001\022\001\023\001\024\001\025\001\255\255\255\255\ \028\001\029\001\004\001\005\001\006\001\007\001\008\001\255\255\ \255\255\255\255\012\001\013\001\255\255\015\001\016\001\017\001\ \018\001\019\001\020\001\021\001\022\001\023\001\024\001\025\001\ \255\255\255\255\255\255\029\001\004\001\005\001\006\001\007\001\ \008\001\255\255\255\255\255\255\012\001\013\001\255\255\015\001\ \016\001\017\001\018\001\019\001\020\001\004\001\005\001\006\001\ \007\001\008\001\255\255\255\255\255\255\012\001\013\001\005\001\ \006\001\007\001\008\001\255\255\255\255\255\255\012\001\013\001\ \004\001\005\001\006\001\007\001\008\001\004\001\005\001\006\001\ \007\001\008\001\004\001\005\001\006\001\007\001\008\001\004\001\ \005\001\006\001\007\001\008\001\004\001\005\001\006\001\007\001\ \008\001\004\001\005\001\006\001\007\001\008\001\004\001\005\001\ \006\001\007\001" let yynames_const = "\ LTL_TRUE\000\ LTL_FALSE\000\ LTL_LPAREN\000\ LTL_RPAREN\000\ LTL_OR\000\ LTL_IMPLIES\000\ LTL_LEFT_RIGHT_ARROW\000\ LTL_AND\000\ LTL_NOT\000\ LTL_GLOBALLY\000\ LTL_FATALLY\000\ LTL_UNTIL\000\ LTL_RELEASE\000\ LTL_NEXT\000\ LTL_EQ\000\ LTL_LT\000\ LTL_GT\000\ LTL_LE\000\ LTL_GE\000\ LTL_NEQ\000\ LTL_PLUS\000\ LTL_MINUS\000\ LTL_DIV\000\ LTL_STAR\000\ LTL_MODULO\000\ LTL_RIGHT_ARROW\000\ LTL_DOT\000\ LTL_LEFT_SQUARE\000\ LTL_RIGHT_SQUARE\000\ LTL_ADRESSE\000\ LTL_CALL\000\ LTL_RETURN\000\ LTL_CALL_OR_RETURN\000\ EOF\000\ " let yynames_block = "\ LTL_INT\000\ LTL_LABEL\000\ " let yyact = [| (fun _ -> failwith "parser") ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'formula) in Obj.repr( # 84 "src/aorai/ltlparser.mly" ((_1,observed_expressions)) # 325 "src/aorai/ltlparser.ml" : (Ltlast.formula * (string, (Logic_ptree.relation * Promelaast.expression * Promelaast.expression)) Hashtbl.t))) ; (fun __caml_parser_env -> Obj.repr( # 90 "src/aorai/ltlparser.mly" (Ltlast.LTrue) # 331 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> Obj.repr( # 92 "src/aorai/ltlparser.mly" (Ltlast.LFalse) # 337 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'formula) in Obj.repr( # 94 "src/aorai/ltlparser.mly" ( _2 ) # 344 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'formula) in Obj.repr( # 97 "src/aorai/ltlparser.mly" ( Ltlast.LGlobally(_2) ) # 351 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'formula) in Obj.repr( # 99 "src/aorai/ltlparser.mly" ( Ltlast.LFatally(_2) ) # 358 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'formula) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'formula) in Obj.repr( # 101 "src/aorai/ltlparser.mly" ( Ltlast.LUntil(_1,_3) ) # 366 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'formula) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'formula) in Obj.repr( # 103 "src/aorai/ltlparser.mly" ( Ltlast.LRelease(_1,_3) ) # 374 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'formula) in Obj.repr( # 105 "src/aorai/ltlparser.mly" ( Ltlast.LNext(_2) ) # 381 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'formula) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'formula) in Obj.repr( # 108 "src/aorai/ltlparser.mly" ( Ltlast.LOr(_1,_3) ) # 389 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'formula) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'formula) in Obj.repr( # 110 "src/aorai/ltlparser.mly" ( Ltlast.LAnd(_1,_3) ) # 397 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'formula) in Obj.repr( # 112 "src/aorai/ltlparser.mly" ( Ltlast.LNot(_2) ) # 404 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'formula) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'formula) in Obj.repr( # 114 "src/aorai/ltlparser.mly" ( Ltlast.LImplies(_1,_3) ) # 412 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'formula) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'formula) in Obj.repr( # 116 "src/aorai/ltlparser.mly" ( Ltlast.LIff(_1,_3) ) # 420 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _3 = (Parsing.peek_val __caml_parser_env 1 : string) in Obj.repr( # 119 "src/aorai/ltlparser.mly" ( Ltlast.LCall(_3)) # 427 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _3 = (Parsing.peek_val __caml_parser_env 1 : string) in Obj.repr( # 121 "src/aorai/ltlparser.mly" ( Ltlast.LReturn(_3)) # 434 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _3 = (Parsing.peek_val __caml_parser_env 1 : string) in Obj.repr( # 123 "src/aorai/ltlparser.mly" ( Ltlast.LCallOrReturn(_3)) # 441 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'logic_relation) in Obj.repr( # 127 "src/aorai/ltlparser.mly" ( let id = get_fresh_ident () in Hashtbl.add observed_expressions id _1; Ltlast.LIdent(id) ) # 452 "src/aorai/ltlparser.ml" : 'formula)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 135 "src/aorai/ltlparser.mly" ( Eq, _1 , _3) # 460 "src/aorai/ltlparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 136 "src/aorai/ltlparser.mly" ( Lt, _1, _3 ) # 468 "src/aorai/ltlparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 137 "src/aorai/ltlparser.mly" ( Gt, _1, _3 ) # 476 "src/aorai/ltlparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 138 "src/aorai/ltlparser.mly" ( Le, _1, _3 ) # 484 "src/aorai/ltlparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 139 "src/aorai/ltlparser.mly" ( Ge, _1, _3 ) # 492 "src/aorai/ltlparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 140 "src/aorai/ltlparser.mly" ( Neq, _1, _3 ) # 500 "src/aorai/ltlparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 141 "src/aorai/ltlparser.mly" ( Neq, _1, PCst (IntConstant "0") ) # 507 "src/aorai/ltlparser.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 145 "src/aorai/ltlparser.mly" ( PBinop(Badd,_1,_3) ) # 515 "src/aorai/ltlparser.ml" : 'arith_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 146 "src/aorai/ltlparser.mly" ( PBinop(Bsub,_1,_3) ) # 523 "src/aorai/ltlparser.ml" : 'arith_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation_mul) in Obj.repr( # 147 "src/aorai/ltlparser.mly" ( _1 ) # 530 "src/aorai/ltlparser.ml" : 'arith_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'access_or_const) in Obj.repr( # 152 "src/aorai/ltlparser.mly" ( PBinop(Bdiv,_1,_3) ) # 538 "src/aorai/ltlparser.ml" : 'arith_relation_mul)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'access_or_const) in Obj.repr( # 153 "src/aorai/ltlparser.mly" ( PBinop(Bmul,_1,_3) ) # 546 "src/aorai/ltlparser.ml" : 'arith_relation_mul)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'access_or_const) in Obj.repr( # 154 "src/aorai/ltlparser.mly" ( PBinop(Bmod,_1,_3)) # 554 "src/aorai/ltlparser.ml" : 'arith_relation_mul)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'access_or_const) in Obj.repr( # 155 "src/aorai/ltlparser.mly" ( _1 ) # 561 "src/aorai/ltlparser.ml" : 'arith_relation_mul)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 160 "src/aorai/ltlparser.mly" ( PCst (IntConstant _1) ) # 568 "src/aorai/ltlparser.ml" : 'access_or_const)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 161 "src/aorai/ltlparser.mly" ( PUnop (Uminus,PCst (IntConstant _2)) ) # 575 "src/aorai/ltlparser.ml" : 'access_or_const)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'access) in Obj.repr( # 162 "src/aorai/ltlparser.mly" ( _1 ) # 582 "src/aorai/ltlparser.ml" : 'access_or_const)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'arith_relation) in Obj.repr( # 163 "src/aorai/ltlparser.mly" ( _2 ) # 589 "src/aorai/ltlparser.ml" : 'access_or_const)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'access) in let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 169 "src/aorai/ltlparser.mly" ( PField (PUnop(Ustar,_1),_3) ) # 597 "src/aorai/ltlparser.ml" : 'access)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'access) in let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 170 "src/aorai/ltlparser.mly" ( PField(_1,_3) ) # 605 "src/aorai/ltlparser.ml" : 'access)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'access_array) in Obj.repr( # 171 "src/aorai/ltlparser.mly" (_1) # 612 "src/aorai/ltlparser.ml" : 'access)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'access_array) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'access_or_const) in Obj.repr( # 175 "src/aorai/ltlparser.mly" ( PArrget(_1,_3) ) # 620 "src/aorai/ltlparser.ml" : 'access_array)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'access_leaf) in Obj.repr( # 176 "src/aorai/ltlparser.mly" (_1) # 627 "src/aorai/ltlparser.ml" : 'access_array)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'access) in Obj.repr( # 180 "src/aorai/ltlparser.mly" ( PUnop (Uamp,_2) ) # 634 "src/aorai/ltlparser.ml" : 'access_leaf)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'access) in Obj.repr( # 181 "src/aorai/ltlparser.mly" ( PUnop (Ustar, _2 ) ) # 641 "src/aorai/ltlparser.ml" : 'access_leaf)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 182 "src/aorai/ltlparser.mly" ( PVar _1 ) # 648 "src/aorai/ltlparser.ml" : 'access_leaf)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'access) in Obj.repr( # 183 "src/aorai/ltlparser.mly" ( _2 ) # 655 "src/aorai/ltlparser.ml" : 'access_leaf)) (* Entry ltl *) ; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) |] let yytables = { Parsing.actions=yyact; Parsing.transl_const=yytransl_const; Parsing.transl_block=yytransl_block; Parsing.lhs=yylhs; Parsing.len=yylen; Parsing.defred=yydefred; Parsing.dgoto=yydgoto; Parsing.sindex=yysindex; Parsing.rindex=yyrindex; Parsing.gindex=yygindex; Parsing.tablesize=yytablesize; Parsing.table=yytable; Parsing.check=yycheck; Parsing.error_function=parse_error; Parsing.names_const=yynames_const; Parsing.names_block=yynames_block } let ltl (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = (Parsing.yyparse yytables 1 lexfun lexbuf : (Ltlast.formula * (string, (Logic_ptree.relation * Promelaast.expression * Promelaast.expression)) Hashtbl.t)) frama-c-Fluorine-20130601/src/aorai/aorai_visitors.ml0000644000175000017500000011455312155630222021255 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 Promelaast open Extlib open Logic_const open Cil_types open Cil (**************************************************************************) let dkey = Aorai_option.register_category "action" let get_acceptance_pred () = let (st,_) = Data_for_aorai.getAutomata () in List.fold_left (fun acc s -> match s.acceptation with Bool3.True -> Logic_const.por (acc, Aorai_utils.is_state_pred s) | Bool3.False | Bool3.Undefined -> acc) Logic_const.pfalse st let get_call_name exp = match exp.enode with | Const(CStr(s)) -> s | Lval(Var(vi),NoOffset) -> vi.vname | _ -> Aorai_option.not_yet_implemented "At this time, only explicit calls are allowed by the Aorai plugin." (****************************************************************************) (* The instrumentation is done in two passes: 1) creating auxiliary functions for each non-ignored C function, that update automaton's state when entering and exiting the function 2) generating specifications for all the functions. We maintain tables from aux to orig so that the second visitor knows which is which. Note that this tables are cleared after each visit, and thus need not be projectified. *) (* the various kinds of auxiliary functions. *) type func_auto_mode = Not_auto_func (* original C function. *) | Pre_func of kernel_function (* Pre_func f denotes a function updating the automaton before call to f. *) | Post_func of kernel_function (* Post_func f denotes a function updating the automaton when returning from f. *) (* table from auxiliary functions to the corresponding original one. *) let func_orig_table = Cil_datatype.Varinfo.Hashtbl.create 17 let kind_of_func vi = try Cil_datatype.Varinfo.Hashtbl.find func_orig_table vi with Not_found -> Not_auto_func (** This visitor adds an auxiliary function for each C function which takes care of setting the automaton in a correct state before calling the original one, and replaces each occurrence of the original function by the auxiliary one. It also takes care of changing the automaton at function's return. *) class visit_adding_code_for_synchronisation = object (self) inherit Visitor.frama_c_inplace val aux_post_table = Kernel_function.Hashtbl.create 17 method vglob_aux g = match g with | GFun (fundec,loc) -> let kf = Extlib.the self#current_kf in let vi = Kernel_function.get_vi kf in let vi_pre = Cil_const.copy_with_new_vid vi in vi_pre.vname <- Data_for_aorai.get_fresh (vi_pre.vname ^ "_pre_func"); vi_pre.vdefined <- false; Cil_datatype.Varinfo.Hashtbl.add func_orig_table vi_pre (Pre_func kf); (* TODO: - what about protos that have no specified args (NB: cannot be identified here because of implem of Kernel_function). - what about varargs? *) let (rettype,args,varargs,_) = Cil.splitFunctionTypeVI vi_pre in vi_pre.vtype <- TFun(Cil.voidType, args, varargs,[]); vi_pre.vattr <- []; (* in particular get rid of __no_return if set in vi*) let arg = if Cil.isVoidType rettype then [] else ["res",rettype,[]] in let vi_post = Cil.makeGlobalVar (Data_for_aorai.get_fresh (vi.vname ^ "_post_func")) (TFun(voidType,Some arg,false,[])) in Kernel_function.Hashtbl.add aux_post_table kf vi_post; Cil_datatype.Varinfo.Hashtbl.add func_orig_table vi_post (Post_func kf); let globs = [ GVarDecl(Cil.empty_funspec (), vi_pre, loc); GVarDecl(Cil.empty_funspec (), vi_post,loc) ] in fundec.sbody.bstmts <- Cil.mkStmtOneInstr (Call(None,Cil.evar ~loc vi_pre, List.map (fun x -> Cil.evar ~loc x) (Kernel_function.get_formals kf), loc)) :: fundec.sbody.bstmts; Globals.Functions.replace_by_declaration (Cil.empty_funspec ()) vi_pre loc; Globals.Functions.replace_by_declaration (Cil.empty_funspec()) vi_post loc; ChangeDoChildrenPost([g], fun x -> globs @ x) | _ -> DoChildren method vstmt_aux stmt = match stmt.skind with | Return (res,loc) -> let kf = Extlib.the self#current_kf in let vi = Kernel_function.get_vi kf in let current_function = vi.vname in if not (Data_for_aorai.isIgnoredFunction current_function) then begin let args = match res with | None -> [] | Some exp -> [Cil.copy_exp exp] in let aux_vi = Kernel_function.Hashtbl.find aux_post_table kf in let call = mkStmtOneInstr (Call (None,Cil.evar ~loc aux_vi,args,loc)) in let new_return = mkStmt ~valid_sid:true stmt.skind in let new_stmts = [call; new_return] in stmt.skind<-Block(Cil.mkBlock(new_stmts)) end; SkipChildren | _ -> DoChildren end (*********************************************************************) (* update from formals of original C function to one of the auxiliary function (f_aux or f_pre) *) class change_formals old_kf new_kf = let old_formals = Kernel_function.get_formals old_kf in let new_formals = Kernel_function.get_formals new_kf in let formals = List.combine old_formals new_formals in object inherit Visitor.frama_c_inplace method vlogic_var_use lv = match lv.lv_origin with | None -> SkipChildren | Some vi -> try let vi'= List.assq vi formals in ChangeTo (Cil.cvar_to_lvar vi') with Not_found -> SkipChildren end (* update \result to param of f_post when it exists. Must not be called if f_post has no parameter (original f returns void). *) class change_result new_kf = let v = List.hd (Kernel_function.get_formals new_kf) in object inherit Visitor.frama_c_inplace method vterm_lhost lh = match lh with TResult _ -> ChangeTo (TVar (Cil.cvar_to_lvar v)) | _ -> DoChildren end let post_treatment_loops = Hashtbl.create 97 let update_loop_assigns kf stmt vi code_annot = let loc = Cil_datatype.Stmt.loc stmt in let assigns = Aorai_utils.aorai_assigns loc in let assigns = Logic_utils.concat_assigns (Writes [Logic_const.new_identified_term (Logic_const.tvar ~loc vi), From []]) assigns in let new_assigns = match code_annot.annot_content with | AAssigns (bhvs,old_assigns) -> Logic_const.new_code_annotation (AAssigns (bhvs, Logic_utils.concat_assigns old_assigns assigns)) | _ -> Aorai_option.fatal "Expecting an assigns clause here" in Annotations.add_code_annot Aorai_option.emitter ~kf stmt new_assigns let get_action_post_cond kf ?init_trans return_states = let to_consider pre_state int_states = match init_trans with | None -> true | Some init_trans -> try let possible_states = Data_for_aorai.Aorai_state.Map.find pre_state init_trans in not (Data_for_aorai.Aorai_state.Set.is_empty (Data_for_aorai.Aorai_state.Set.inter int_states possible_states)) with Not_found -> false in let treat_one_path pre_state post_state (int_states,_,bindings) acc = if to_consider pre_state int_states then begin let post_conds = Aorai_utils.action_to_pred ~pre_state ~post_state bindings in Aorai_option.debug ~dkey "Getting action post-conditions for %a, from state %s to state %s@\n%a" Kernel_function.pretty kf pre_state.Promelaast.name post_state.Promelaast.name (Pretty_utils.pp_list ~sep:"@\n" Printer.pp_predicate_named) post_conds; post_conds @ acc end else acc in let treat_one_pre_state pre_state map acc = Data_for_aorai.Aorai_state.Map.fold (treat_one_path pre_state) map acc in let post_cond = Data_for_aorai.Aorai_state.Map.fold treat_one_pre_state return_states [] in List.map (fun post_cond -> (Normal, Logic_const.new_predicate post_cond)) post_cond let make_zero_one_choice reachable_states = let treat_one_state state _ acc = (Logic_const.por (Aorai_utils.is_state_pred state, Aorai_utils.is_out_of_state_pred state)) :: acc in Data_for_aorai.Aorai_state.Map.fold treat_one_state reachable_states [] let needs_zero_one_choice states = let needs_choice = try ignore (Data_for_aorai.Aorai_state.Map.fold (fun _ _ flag -> if flag then raise Exit else true) states false); false with Exit -> true in if needs_choice then List.map Logic_const.new_predicate (make_zero_one_choice states) else [] let pred_reachable reachable_states = let treat_one_state (nb, reachable, unreachable) state = if Data_for_aorai.Aorai_state.Map.mem state reachable_states then (nb+1, Logic_const.por (reachable, Aorai_utils.is_state_pred state), unreachable) else (nb, reachable, Logic_const.pand (unreachable, Aorai_utils.is_out_of_state_pred state)) in let (states,_) = Data_for_aorai.getAutomata () in let (nb, reachable, unreachable) = List.fold_left treat_one_state (0,pfalse,ptrue) states in (nb > 1, reachable, unreachable) let possible_start kf (start,int) = let auto = Data_for_aorai.getAutomata () in let trans = Path_analysis.get_edges start int auto in let treat_one_trans cond tr = Logic_const.por (cond, Aorai_utils.crosscond_to_pred (fst tr.cross) kf Promelaast.Call) in let cond = List.fold_left treat_one_trans Logic_const.pfalse trans in Logic_const.pand (Aorai_utils.is_state_pred start, cond) let neg_trans kf trans = let auto = Data_for_aorai.getAutomata () in let rec aux l acc = match l with | [] -> acc | (start,stop) :: l -> let same_start, rest = List.fold_left (fun (same_start, rest) (start', stop' as elt) -> if Data_for_aorai.Aorai_state.equal start start' then stop' :: same_start, rest else same_start, elt :: rest) ([stop],[]) l in let cond = List.fold_left (fun cond stop -> let trans = Path_analysis.get_edges start stop auto in List.fold_left (fun cond tr -> Logic_simplification.tand cond (Logic_simplification.tnot (fst tr.cross))) cond trans) TTrue same_start in let cond = fst (Logic_simplification.simplifyCond cond) in let cond = Aorai_utils.crosscond_to_pred cond kf Promelaast.Call in let cond = Logic_const.por (Aorai_utils.is_out_of_state_pred start, cond) in aux rest (Logic_const.pand (acc,cond)) in aux trans Logic_const.ptrue let get_unchanged_aux_var loc current_state = let partition_action state (_,_,map) (actions,possible_states) = let possible_states = Data_for_aorai.Aorai_state.Set.add state possible_states in let treat_one_action t _ acc = let states = try Cil_datatype.Term.Map.find t acc with Not_found -> Data_for_aorai.Aorai_state.Set.empty in Cil_datatype.Term.Map.add t (Data_for_aorai.Aorai_state.Set.add state states) acc in let actions = Cil_datatype.Term.Map.fold treat_one_action map actions in (actions,possible_states) in let treat_one_action pre_hyp possible_states t action_states acc = if not (Data_for_aorai.Aorai_state.Set.is_empty (Data_for_aorai.Aorai_state.Set.diff possible_states action_states)) then begin let post_hyp = Data_for_aorai.Aorai_state.Set.fold (fun st acc -> Logic_const.pand ~loc (acc,Aorai_utils.is_out_of_state_pred st)) action_states Logic_const.ptrue in let pred = Logic_const.new_predicate (Logic_const.pimplies ~loc (pre_hyp, Logic_const.pimplies ~loc (post_hyp, Logic_const.prel ~loc (Req,t,Logic_const.told ~loc t)))) in (Normal,pred) :: acc end else acc (* all possible states will update this lval, no need to make a special case here. *) in let treat_one_pre_state start map acc = let pre_hyp = Logic_const.pold ~loc (Aorai_utils.is_state_pred start) in let actions_map, possible_states = Data_for_aorai.Aorai_state.Map.fold partition_action map (Cil_datatype.Term.Map.empty, Data_for_aorai.Aorai_state.Set.empty) in Cil_datatype.Term.Map.fold (treat_one_action pre_hyp possible_states) actions_map acc in Data_for_aorai.Aorai_state.Map.fold treat_one_pre_state current_state [] (** This visitor adds a specification to each fonction and to each loop, according to specifications stored into Data_for_aorai. *) class visit_adding_pre_post_from_buch treatloops = let predicate_to_invariant kf stmt pred = Annotations.add_code_annot Aorai_option.emitter ~kf stmt (Logic_const.new_code_annotation (AInvariant([],true,pred))); in let all_possible_states state = let treat_one_state _ = Data_for_aorai.merge_end_state in Data_for_aorai.Aorai_state.Map.fold treat_one_state state Data_for_aorai.Aorai_state.Map.empty in let condition_to_invariant kf possible_states stmt = (* Checks whether we have at least two possible automaton's states in the invariant. *) let has_multiple_choice = try ignore (Data_for_aorai.Aorai_state.Map.fold (fun _ _ b -> if b then raise Exit else true) possible_states false); false with Exit -> true in let treat_one_state s = if Data_for_aorai.Aorai_state.Map.mem s possible_states then begin if has_multiple_choice then begin let pred = Logic_const.por (Aorai_utils.is_state_pred s, Aorai_utils.is_out_of_state_pred s) in predicate_to_invariant kf stmt pred end else begin (* We can only be in one state. Since we must be in at least one state, the invariant is quite simple. *) predicate_to_invariant kf stmt (Aorai_utils.is_state_pred s) end end else begin let pred = Aorai_utils.is_out_of_state_pred s in predicate_to_invariant kf stmt pred end in let (states,_) = Data_for_aorai.getAutomata () in List.iter treat_one_state states; if has_multiple_choice then begin let add_possible_state state _ acc = if Data_for_aorai.is_reject_state state then acc else Logic_const.por (acc,Aorai_utils.is_state_pred state) in let pred = Data_for_aorai.Aorai_state.Map.fold add_possible_state possible_states Logic_const.pfalse in predicate_to_invariant kf stmt pred end in let impossible_states_preds possible_states my_state = let treat_one_start_state state start_state end_states acc = if not (Data_for_aorai.Aorai_state.Map.mem state end_states) then Logic_const.pimplies (Logic_const.pat(Aorai_utils.is_state_pred start_state, Logic_const.pre_label), Aorai_utils.is_out_of_state_pred state) :: acc else acc in let treat_one_state state _ acc = Data_for_aorai.Aorai_state.Map.fold (treat_one_start_state state) my_state acc in Data_for_aorai.Aorai_state.Map.fold treat_one_state possible_states [] in let partition_pre_state map = let (states,_) = Data_for_aorai.getAutomata () in let is_equiv st1 st2 = let check_one _ o1 o2 = match o1, o2 with | None, None | Some _, Some _ -> Some () | None, Some _ | Some _, None -> raise Not_found in try ignore (Data_for_aorai.Aorai_state.Map.merge check_one st1 st2); true with Not_found -> false in let find_equivs (start,state, end_states) equivs = let rec aux = function | [] -> [[start,state],end_states] | (equiv_class,end_states2 as infos) :: l -> if is_equiv end_states end_states2 then ((start, state) :: equiv_class, end_states2) :: l else infos :: aux l in aux equivs in let filter equivs state = let check_one_state start end_states equivs = let end_states = Data_for_aorai.Aorai_state.Map.filter (fun _ (int_states,_,_) -> Data_for_aorai.Aorai_state.Set.mem state int_states) end_states in if Data_for_aorai.Aorai_state.Map.is_empty end_states then equivs else find_equivs (start, state, end_states) equivs in Data_for_aorai.Aorai_state.Map.fold check_one_state map equivs in let res = List.fold_left filter [] states in List.map fst res in (* TODO: add assigns of auxiliary variables... *) let update_assigns loc kf spec = let update_assigns bhv = let assigns = Aorai_utils.aorai_assigns loc in match kf with | None -> (* stmt contract *) bhv.b_assigns <- Logic_utils.concat_assigns bhv.b_assigns assigns | Some kf -> (* function contract *) Annotations.add_assigns ~keep_empty:true Aorai_option.emitter kf bhv.b_name assigns; in List.iter update_assigns spec.spec_behavior in let mk_auto_fct_spec kf status auto_state = let loc = Kernel_function.get_location kf in Aorai_utils.auto_func_behaviors loc kf status auto_state in let mk_pre_fct_spec kf = mk_auto_fct_spec kf Promelaast.Call (Data_for_aorai.get_kf_init_state kf) in let mk_post_fct_spec kf = mk_auto_fct_spec kf Promelaast.Return (Data_for_aorai.get_kf_return_state kf) in let needs_post kf = let loc = Kernel_function.get_location kf in let return_state = Data_for_aorai.get_kf_return_state kf in let possible_states = Data_for_aorai.Aorai_state.Map.fold (fun _ map acc -> Data_for_aorai.Aorai_state.Map.fold (fun st _ acc -> Data_for_aorai.Aorai_state.Set.add st acc) map acc) return_state Data_for_aorai.Aorai_state.Set.empty in let action_post = get_unchanged_aux_var loc return_state in if Data_for_aorai.Aorai_state.Set.exists Data_for_aorai.is_reject_state possible_states then (* We must ensure that there is at least one active state beside the rejection state *) let cond = Data_for_aorai.Aorai_state.Set.fold (fun st acc -> if Data_for_aorai.is_reject_state st then acc else Logic_const.por (Aorai_utils.is_state_pred st,acc)) possible_states Logic_const.pfalse in (Normal,Logic_const.new_predicate cond) :: action_post else action_post in let mk_post kf = let return_state = Data_for_aorai.get_kf_return_state kf in (* + Post-condition registration *) (* If several states are associated to the same post-condition, then their specification is factorised. *) let equivs = partition_pre_state return_state in let bhvs = match equivs with | [ e ] -> (* we just have one possible case, no need to generate assumes and a negative behavior *) let name = "Buchi_property_behavior" in let s = fst (List.hd e) in let reachable_states = Data_for_aorai.Aorai_state.Map.find s return_state in let (multi_choice, reachable, unreachable) = pred_reachable reachable_states in let post_cond = Normal, Logic_const.new_predicate reachable in let post_cond = if Aorai_option.Deterministic.get () then [post_cond] else [Normal, Logic_const.new_predicate unreachable; post_cond] in let post_cond = if multi_choice && not (Aorai_option.Deterministic.get ()) then begin let preds = make_zero_one_choice reachable_states in List.fold_left (fun acc p -> (Normal, Logic_const.new_predicate p) :: acc) post_cond preds end else post_cond in let infos = Aorai_utils.get_preds_post_bc_wrt_params kf in let post_cond = if Logic_utils.is_trivially_true infos then post_cond else (Normal, Logic_const.new_predicate infos) :: post_cond in let post_cond = post_cond @ get_action_post_cond kf return_state in [Cil.mk_behavior ~name ~post_cond ()] | _ -> let _,bhvs = List.fold_left (fun (i,acc) equiv -> let (case_start, case_int) = List.hd equiv in let assumes_l = List.map (possible_start kf) equiv in let name = "Buchi_behavior_in_" ^ (string_of_int i) in let assumes = [Logic_const.new_predicate (Logic_const.pors assumes_l)] in let reachable_states = Data_for_aorai.Aorai_state.Map.find case_start return_state in let reachable_states = Data_for_aorai.Aorai_state.Map.filter (fun _ (int,_,_) -> Data_for_aorai.Aorai_state.Set.mem case_int int) reachable_states in let (multi_choice, reachable, _) = pred_reachable reachable_states in let post_cond = [Normal, Logic_const.new_predicate reachable] in let post_cond = if multi_choice && not (Aorai_option.Deterministic.get()) then begin let preds = make_zero_one_choice reachable_states in List.fold_left (fun acc p -> (Normal, Logic_const.new_predicate p) :: acc) post_cond preds end else post_cond in let infos = Aorai_utils.get_preds_post_bc_wrt_params kf in let post_cond = if Logic_utils.is_trivially_true infos then post_cond else (Normal, Logic_const.new_predicate infos) :: post_cond in let init_trans = List.fold_left (fun acc (start, int) -> let set = try Data_for_aorai.Aorai_state.Map.find start acc with Not_found -> Data_for_aorai.Aorai_state.Set.empty in Data_for_aorai.Aorai_state.Map.add start (Data_for_aorai.Aorai_state.Set.add int set) acc) Data_for_aorai.Aorai_state.Map.empty equiv in let post_cond = post_cond @ (get_action_post_cond kf ~init_trans return_state) in (i+1, Cil.mk_behavior ~name ~assumes ~post_cond () :: acc)) (0,[]) equivs in if Aorai_option.Deterministic.get () then bhvs else begin (* post-conditions for state in which we are not at the end of the functions. They have to be grouped differently than positive information because of non-determinism (if two non-equivalent states are active when entering the function and activate the same state at exit) *) let aux (i,bhvs) state = let name = "Buchi_behavior_out_" ^ (string_of_int i) in let select_equivalence_class equiv = let (start, int) = List.hd equiv in try let map = Data_for_aorai.Aorai_state.Map.find start return_state in let (int_states, _,_) = Data_for_aorai.Aorai_state.Map.find state map in Data_for_aorai.Aorai_state.Set.mem int int_states with Not_found -> false in let my_trans = List.fold_left (fun acc equiv -> if select_equivalence_class equiv then acc @ equiv else acc) [] equivs in let assumes = neg_trans kf my_trans in if Logic_utils.is_trivially_false assumes then (i+1,bhvs) else let p = Aorai_utils.is_out_of_state_pred state in let post_cond = [Normal, Logic_const.new_predicate p] in let bhv = if Logic_utils.is_trivially_true assumes then Cil.mk_behavior ~name ~post_cond () else begin let assumes = [Logic_const.new_predicate assumes] in Cil.mk_behavior ~name ~assumes ~post_cond () end in (i+1,bhv :: bhvs) in let (states,_) = Data_for_aorai.getAutomata () in List.rev (snd (List.fold_left aux (0,bhvs) states)) end in (* If this is the main function, we should exit in at least one acceptance state. *) let bhvs = if Aorai_option.ConsiderAcceptance.get () && Datatype.String.equal (Kernel_function.get_name kf) (Kernel.MainFunction.get()) then let accept = Logic_const.new_predicate (get_acceptance_pred()) in let post_cond = [Normal, accept] in let name = "aorai_acceptance" in Cil.mk_behavior ~name ~post_cond () :: bhvs else bhvs in if Aorai_option.AddingOperationNameAndStatusInSpecification.get() then begin let called_post = Logic_const.new_predicate (Logic_const.prel (Req , Logic_const.tvar (Data_for_aorai.get_logic_var Data_for_aorai.curOpStatus), Logic_const.term (TConst (Logic_utils.constant_to_lconstant (Data_for_aorai.op_status_to_cenum Promelaast.Return))) (Ctype Cil.intType))) in let called_post_2 = Logic_const.new_predicate (Logic_const.prel (Req, Logic_const.tvar (Data_for_aorai.get_logic_var Data_for_aorai.curOp), Logic_const.term (TConst (Logic_utils.constant_to_lconstant (Data_for_aorai.func_to_cenum (Kernel_function.get_name kf)))) (Ctype Cil.intType))) in let name = "Buchi_property_behavior_function_states" in let post_cond = [Normal, called_post; Normal, called_post_2] in Cil.mk_behavior ~name ~post_cond () :: bhvs end else bhvs in object(self) inherit Visitor.frama_c_inplace (* We have to update assigns whenever a call occurs in the scope of a statement contract (function always update the automaton's state, so assigns there have to be changed anyway.) *) val has_call = Stack.create () method private enter_block () = Stack.push (ref false) has_call method private call () = Stack.iter (fun x -> x := true) has_call method private leave_block () = !(Stack.pop has_call) method vfunc f = let my_kf = Extlib.the self#current_kf in let vi = Kernel_function.get_vi my_kf in let spec = Annotations.funspec my_kf in let loc = Kernel_function.get_location my_kf in (match kind_of_func vi with | Pre_func _ | Post_func _ -> Aorai_option.fatal "functions managing automaton's state are \ not supposed to have a body" | Not_auto_func -> (* Normal C function *) let bhvs = mk_post my_kf in let my_state = Data_for_aorai.get_kf_init_state my_kf in let requires = needs_zero_one_choice my_state in let requires = Aorai_utils.auto_func_preconditions loc my_kf Promelaast.Call my_state @ requires in let post_cond = needs_post my_kf in match Cil.find_default_behavior spec with | Some b -> Annotations.add_requires Aorai_option.emitter my_kf b.b_name requires; Annotations.add_ensures Aorai_option.emitter my_kf b.b_name post_cond; Annotations.add_behaviors Aorai_option.emitter my_kf bhvs | None -> let bhv = Cil.mk_behavior ~requires ~post_cond () in Annotations.add_behaviors Aorai_option.emitter my_kf (bhv :: bhvs)); let after f = update_assigns f.svar.vdecl (Some my_kf) spec; f in ChangeDoChildrenPost(f,after) method vglob_aux g = match g with | GVarDecl(_,v,_) when Cil.isFunctionType v.vtype && not (Kernel_function.is_definition (Extlib.the self#current_kf)) -> let my_kf = Extlib.the self#current_kf in (* don't use get_spec, as we'd generate default assigns, while we'll fill the spec just below. *) let vi = Kernel_function.get_vi my_kf in (match kind_of_func vi with | Pre_func kf -> (* must advance the automaton according to current call. *) let bhvs = mk_pre_fct_spec kf in let bhvs = Visitor.visitFramacBehaviors (new change_formals kf my_kf) bhvs in Annotations.add_behaviors Aorai_option.emitter my_kf bhvs; SkipChildren | Post_func kf -> (* must advance the automaton according to return event. *) let (rt, _, _, _) = Cil.splitFunctionTypeVI (Kernel_function.get_vi kf) in let bhvs = mk_post_fct_spec kf in let bhvs = (* if return type is not void, convert \result in the formal arg of current kf. Otherwise, there's no conversion to do. *) if Cil.isVoidType rt then bhvs else Visitor.visitFramacBehaviors (new change_result my_kf) bhvs in Annotations.add_behaviors Aorai_option.emitter my_kf bhvs; SkipChildren | Not_auto_func -> DoChildren (* they are not considered here. *)) | _ -> DoChildren method vstmt_aux stmt = let kf = Extlib.the self#current_kf in let treat_loop body_ref stmt = let init_state = Data_for_aorai.get_loop_init_state stmt in let inv_state = Data_for_aorai.get_loop_invariant_state stmt in let glob_state = Data_for_aorai.merge_state init_state inv_state in let possible_states = all_possible_states glob_state in let loop_assigns = Annotations.code_annot ~filter:Logic_utils.is_assigns stmt in (* varinfo of the init_var associated to this loop *) let vi_init = Data_for_aorai.get_varinfo (Data_for_aorai.loopInit ^ "_" ^ string_of_int stmt.sid) in (* 1) The associated init variable is set to 0 in first position (or in second position if the first stmt is a if)*) let loc = Cil_datatype.Stmt.loc stmt in let stmt_varset = Cil.mkStmtOneInstr (Set((Var vi_init,NoOffset), Cil.zero ~loc, loc)) in stmt_varset.sid<-(Cil.Sid.next ()); stmt_varset.ghost<-true; begin (* Function adapted from the cil printer *) try let rec skipEmpty = function [] -> [] | {skind=Instr (Skip _);labels=[]} :: rest -> skipEmpty rest | x -> x in match skipEmpty !body_ref.bstmts with | {skind=If(_,tb,fb,_)} as head:: _ -> begin match skipEmpty tb.bstmts, skipEmpty fb.bstmts with | _, {skind=Break _}:: _ | _, {skind=Goto _} :: _ | {skind=Goto _} :: _, _ | {skind=Break _} :: _, _ -> !body_ref.bstmts <- head :: stmt_varset :: List.tl !body_ref.bstmts | _ -> raise Not_found end | _ -> raise Not_found with Not_found -> !body_ref.bstmts<-stmt_varset::!body_ref.bstmts end; (* 2) The associated init variable is set to 1 before the loop *) let new_loop = mkStmt stmt.skind in new_loop.sid<-(Cil.Sid.next ()); let stmt_varset = Cil.mkStmtOneInstr (Set((Var(vi_init),NoOffset), Cil.one ~loc, loc)) in stmt_varset.sid <- Cil.Sid.next (); stmt_varset.ghost <- true; let block = mkBlock [stmt_varset;new_loop] in stmt.skind<-Block(block); (* 3) Generation of the loop invariant *) let mk_imply operator predicate = pimplies (prel(operator, Aorai_utils.mk_term_from_vi vi_init, Aorai_utils.zero_term()), predicate) in (* The loop invariant is : (Global invariant) // all never reached state are set to zero & (Init => Pre1) // external pre-condition & (not Init => Post2) // internal post-condition & counter_invariant // values of counters. (init: fresh variable which indicates if the iteration is the first one). *) condition_to_invariant kf possible_states new_loop; let init_preds = impossible_states_preds possible_states init_state in let treat_init_pred pred = let pred = mk_imply Rneq pred in predicate_to_invariant kf new_loop pred in List.iter treat_init_pred init_preds; let invariant_preds = impossible_states_preds possible_states inv_state in let treat_inv_pred pred = let pred = mk_imply Req pred in predicate_to_invariant kf new_loop pred in List.iter treat_inv_pred invariant_preds; let action_inv_preds = Aorai_utils.all_actions_preds glob_state in List.iter (predicate_to_invariant kf new_loop) action_inv_preds; List.iter (update_loop_assigns kf new_loop (Cil.cvar_to_lvar vi_init)) loop_assigns; (* 4) Keeping in mind to preserve old annotations after visitor end *) Hashtbl.add post_treatment_loops (ref stmt) (ref new_loop); (* 5) Updated stmt is returned *) stmt in self#enter_block (); let after s = if self#leave_block () then let annots = Annotations.code_annot stmt in let _, specs = List.split (Logic_utils.extract_contract annots) in List.iter (update_assigns (Cil_datatype.Stmt.loc stmt) None) specs; s else s in if treatloops then match stmt.skind with | Loop (_,block,_,_,_) -> ChangeDoChildrenPost(stmt, after $ (treat_loop (ref block))) | _ -> ChangeDoChildrenPost(stmt, after) else ChangeDoChildrenPost(stmt,after) method vinst = function | Call _ -> self#call (); DoChildren | _ -> DoChildren end (****************************************************************************) (** This visitor computes the list of ignored functions. A function is ignored if its call is present in the C program, while its definition is not available. *) class visit_computing_ignored_functions () = let declaredFunctions = Data_for_aorai.getFunctions_from_c () in let isDeclaredInC fname = List.exists (fun s -> (String.compare fname s)=0) declaredFunctions in object (*(self) *) inherit Visitor.frama_c_inplace method vfunc _f = DoChildren method vstmt_aux stmt = match stmt.skind with | Instr(Call (_,funcexp,_,_)) -> let name = get_call_name funcexp in (* If the called function is neither ignored, nor declared, then it has to be added to ignored functions. *) if (not (Data_for_aorai.isIgnoredFunction name)) && (not (isDeclaredInC name)) then (Data_for_aorai.addIgnoredFunction name); DoChildren | _ -> DoChildren end let add_pre_post_from_buch file treatloops = let visitor = new visit_adding_pre_post_from_buch treatloops in Cil.visitCilFile (visitor :> Cil.cilVisitor) file; (* Transfer previous annotation on the new loop statement. Variant clause has to be preserved at the end of the annotation.*) Hashtbl.iter (fun old_stmt new_stmt -> let new_s = !new_stmt in let old_s = !old_stmt in let kf = Kernel_function.find_englobing_kf old_s in (* Erasing annotations from the old statement before attaching them with the new one *) let annots = Annotations.fold_code_annot (fun e a acc -> Annotations.remove_code_annot e ~kf old_s a; if (Logic_utils.is_assigns a) then acc else (e, a) :: acc) old_s []; in List.iter (fun (e, a) -> Annotations.add_code_annot e ~kf new_s a) annots) post_treatment_loops let add_sync_with_buch file = let visitor = new visit_adding_code_for_synchronisation in Cil.visitCilFile (visitor :> Cil.cilVisitor) file (* Call of the visitor *) let compute_ignored_functions file = let visitor = new visit_computing_ignored_functions () in Cil.visitCilFile (visitor :> Cil.cilVisitor) file (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/yalexer.ml0000444000175000017500000014033112155634032017663 0ustar mehdimehdi# 27 "src/aorai/yalexer.mll" open Yaparser open Lexing exception Eof let new_line lexbuf = let lcp = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { lcp with pos_lnum = lcp.pos_lnum + 1; pos_bol = lcp.pos_cnum; } ;; exception Error of (Lexing.position * Lexing.position) * string let loc lexbuf = (lexeme_start_p lexbuf, lexeme_end_p lexbuf) let raise_located loc e = raise (Error (loc, e)) # 19 "src/aorai/yalexer.ml" let __ocaml_lex_tables = { Lexing.lex_base = "\000\000\211\255\212\255\213\255\214\255\006\000\217\255\034\000\ \035\000\065\000\066\000\004\000\001\000\230\255\004\000\007\000\ \235\255\236\255\237\255\238\255\239\255\240\255\241\255\069\000\ \243\255\244\255\084\000\028\000\160\000\235\000\054\001\129\001\ \204\001\023\002\254\255\255\255\033\002\108\002\183\002\002\003\ \077\003\152\003\227\003\046\004\121\004\196\004\015\005\090\005\ \165\005\240\005\059\006\134\006\209\006\028\007\103\007\178\007\ \253\007\042\000\029\000\028\000\038\000\031\000\246\255\229\255\ \232\255\231\255\226\255\225\255\218\255\221\255\220\255\219\255\ \215\255"; Lexing.lex_backtrk = "\255\255\255\255\255\255\255\255\255\255\039\000\255\255\044\000\ \033\000\032\000\031\000\028\000\027\000\255\255\022\000\021\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\013\000\ \255\255\255\255\010\000\044\000\010\000\010\000\010\000\010\000\ \010\000\002\000\255\255\255\255\010\000\010\000\010\000\003\000\ \005\000\010\000\010\000\010\000\010\000\004\000\010\000\010\000\ \010\000\006\000\010\000\010\000\007\000\010\000\010\000\010\000\ \008\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"; Lexing.lex_default = "\001\000\000\000\000\000\000\000\000\000\255\255\000\000\255\255\ \255\255\255\255\255\255\255\255\255\255\000\000\255\255\255\255\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\255\255\ \000\000\000\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\000\000\000\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\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\035\000\034\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \035\000\010\000\000\000\000\000\000\000\020\000\012\000\066\000\ \019\000\018\000\022\000\024\000\025\000\023\000\013\000\021\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\005\000\006\000\009\000\007\000\008\000\003\000\ \072\000\026\000\026\000\032\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\031\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\017\000\027\000\016\000\004\000\071\000\ \070\000\026\000\026\000\026\000\026\000\026\000\028\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\030\000\ \026\000\026\000\026\000\026\000\029\000\026\000\026\000\026\000\ \026\000\026\000\026\000\015\000\011\000\014\000\069\000\068\000\ \067\000\065\000\064\000\063\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\057\000\058\000\ \059\000\060\000\061\000\062\000\000\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ \000\000\000\000\000\000\026\000\000\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\000\000\000\000\000\000\000\000\026\000\ \002\000\053\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\000\000\000\000\ \000\000\000\000\026\000\000\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\050\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\000\000\000\000\000\000\000\000\026\000\000\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\046\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\026\000\026\000\026\000\026\000\041\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\000\000\000\000\000\000\000\000\ \026\000\000\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\037\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\036\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ \000\000\000\000\000\000\026\000\000\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\040\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\000\000\000\000\000\000\000\000\ \026\000\000\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \038\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ \000\000\000\000\000\000\026\000\000\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\039\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\000\000\000\000\000\000\000\000\026\000\000\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\000\000\000\000\000\000\ \000\000\026\000\000\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \000\000\000\000\000\000\000\000\026\000\000\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\042\000\026\000\026\000\026\000\ \026\000\026\000\026\000\000\000\000\000\000\000\000\000\026\000\ \000\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \043\000\026\000\026\000\026\000\026\000\026\000\000\000\000\000\ \000\000\000\000\026\000\000\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \044\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\000\000\000\000\000\000\000\000\026\000\000\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\045\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\000\000\000\000\000\000\000\000\ \026\000\000\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ \000\000\000\000\000\000\026\000\000\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\000\000\000\000\000\000\000\000\026\000\000\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\047\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\000\000\000\000\000\000\ \000\000\026\000\000\000\026\000\026\000\026\000\026\000\048\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \000\000\000\000\000\000\000\000\026\000\000\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\049\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\000\000\000\000\000\000\000\000\026\000\ \000\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\000\000\000\000\ \000\000\000\000\026\000\000\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \051\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\000\000\000\000\000\000\000\000\026\000\000\000\026\000\ \026\000\026\000\026\000\052\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\000\000\000\000\000\000\000\000\ \026\000\000\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ \000\000\000\000\000\000\026\000\000\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \054\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\000\000\000\000\000\000\000\000\026\000\000\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\055\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\000\000\000\000\000\000\ \000\000\026\000\000\000\026\000\026\000\026\000\026\000\056\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \000\000\000\000\000\000\000\000\026\000\000\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\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\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\ \000\000\000\000\255\255\255\255\255\255\000\000\000\000\012\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\007\000\ \008\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\009\000\010\000\ \011\000\014\000\015\000\023\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\027\000\057\000\ \058\000\059\000\060\000\061\000\255\255\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\255\255\ \255\255\255\255\255\255\026\000\255\255\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\255\255\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\255\255\255\255\255\255\255\255\028\000\ \000\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\028\000\028\000\028\000\028\000\028\000\ \028\000\028\000\028\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\255\255\255\255\ \255\255\255\255\029\000\255\255\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ \029\000\029\000\029\000\029\000\029\000\029\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\255\255\255\255\255\255\255\255\030\000\255\255\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\030\000\030\000\030\000\030\000\030\000\030\000\030\000\ \030\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\255\255\255\255\255\255\255\255\ \031\000\255\255\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ \031\000\031\000\031\000\031\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\255\255\ \255\255\255\255\255\255\032\000\255\255\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\ \032\000\032\000\032\000\032\000\032\000\032\000\032\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\255\255\255\255\255\255\255\255\ \036\000\255\255\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ \036\000\036\000\036\000\036\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\255\255\ \255\255\255\255\255\255\037\000\255\255\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ \037\000\037\000\037\000\037\000\037\000\037\000\037\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\255\255\255\255\255\255\255\255\038\000\255\255\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\038\000\ \038\000\038\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\255\255\255\255\255\255\ \255\255\039\000\255\255\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\039\000\039\000\039\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \255\255\255\255\255\255\255\255\040\000\255\255\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\255\255\255\255\255\255\255\255\041\000\ \255\255\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\255\255\255\255\ \255\255\255\255\042\000\255\255\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\255\255\255\255\255\255\255\255\043\000\255\255\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \043\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\255\255\255\255\255\255\255\255\ \044\000\255\255\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\255\255\ \255\255\255\255\255\255\045\000\255\255\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\255\255\255\255\255\255\255\255\046\000\255\255\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \046\000\046\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\255\255\255\255\255\255\ \255\255\047\000\255\255\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \255\255\255\255\255\255\255\255\048\000\255\255\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\255\255\255\255\255\255\255\255\049\000\ \255\255\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\255\255\255\255\ \255\255\255\255\050\000\255\255\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\255\255\255\255\255\255\255\255\051\000\255\255\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ \051\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\255\255\255\255\255\255\255\255\ \052\000\255\255\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ \052\000\052\000\052\000\052\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\255\255\ \255\255\255\255\255\255\053\000\255\255\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ \053\000\053\000\053\000\053\000\053\000\053\000\053\000\054\000\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\054\000\255\255\255\255\255\255\255\255\054\000\255\255\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ \054\000\054\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\255\255\255\255\255\255\ \255\255\055\000\255\255\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\055\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \255\255\255\255\255\255\255\255\056\000\255\255\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\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\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 -> # 51 "src/aorai/yalexer.mll" ( token lexbuf ) # 653 "src/aorai/yalexer.ml" | 1 -> # 52 "src/aorai/yalexer.mll" ( new_line lexbuf; token lexbuf ) # 658 "src/aorai/yalexer.ml" | 2 -> let # 53 "src/aorai/yalexer.mll" lxm # 664 "src/aorai/yalexer.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in # 53 "src/aorai/yalexer.mll" ( INT(lxm) ) # 668 "src/aorai/yalexer.ml" | 3 -> # 54 "src/aorai/yalexer.mll" ( CALL_OF ) # 673 "src/aorai/yalexer.ml" | 4 -> # 55 "src/aorai/yalexer.mll" ( RETURN_OF ) # 678 "src/aorai/yalexer.ml" | 5 -> # 56 "src/aorai/yalexer.mll" ( CALLORRETURN_OF ) # 683 "src/aorai/yalexer.ml" | 6 -> # 57 "src/aorai/yalexer.mll" ( OTHERWISE ) # 688 "src/aorai/yalexer.ml" | 7 -> # 58 "src/aorai/yalexer.mll" ( TRUE ) # 693 "src/aorai/yalexer.ml" | 8 -> # 59 "src/aorai/yalexer.mll" ( FALSE ) # 698 "src/aorai/yalexer.ml" | 9 -> let # 60 "src/aorai/yalexer.mll" lxm # 704 "src/aorai/yalexer.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_start_pos + 7) in # 60 "src/aorai/yalexer.mll" ( IDENTIFIER(lxm) ) # 708 "src/aorai/yalexer.ml" | 10 -> let # 61 "src/aorai/yalexer.mll" lxm # 714 "src/aorai/yalexer.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in # 61 "src/aorai/yalexer.mll" ( IDENTIFIER(lxm) ) # 718 "src/aorai/yalexer.ml" | 11 -> # 62 "src/aorai/yalexer.mll" ( COMMA ) # 723 "src/aorai/yalexer.ml" | 12 -> # 63 "src/aorai/yalexer.mll" ( PLUS ) # 728 "src/aorai/yalexer.ml" | 13 -> # 64 "src/aorai/yalexer.mll" ( MINUS ) # 733 "src/aorai/yalexer.ml" | 14 -> # 65 "src/aorai/yalexer.mll" ( STAR ) # 738 "src/aorai/yalexer.ml" | 15 -> # 66 "src/aorai/yalexer.mll" ( SLASH ) # 743 "src/aorai/yalexer.ml" | 16 -> # 67 "src/aorai/yalexer.mll" ( PERCENT ) # 748 "src/aorai/yalexer.ml" | 17 -> # 68 "src/aorai/yalexer.mll" ( LPAREN ) # 753 "src/aorai/yalexer.ml" | 18 -> # 69 "src/aorai/yalexer.mll" ( RPAREN ) # 758 "src/aorai/yalexer.ml" | 19 -> # 70 "src/aorai/yalexer.mll" ( LSQUARE ) # 763 "src/aorai/yalexer.ml" | 20 -> # 71 "src/aorai/yalexer.mll" ( RSQUARE ) # 768 "src/aorai/yalexer.ml" | 21 -> # 72 "src/aorai/yalexer.mll" ( LCURLY ) # 773 "src/aorai/yalexer.ml" | 22 -> # 73 "src/aorai/yalexer.mll" ( RCURLY ) # 778 "src/aorai/yalexer.ml" | 23 -> # 74 "src/aorai/yalexer.mll" ( LBRACELBRACE ) # 783 "src/aorai/yalexer.ml" | 24 -> # 75 "src/aorai/yalexer.mll" ( RBRACERBRACE ) # 788 "src/aorai/yalexer.ml" | 25 -> # 76 "src/aorai/yalexer.mll" ( DOT ) # 793 "src/aorai/yalexer.ml" | 26 -> # 77 "src/aorai/yalexer.mll" ( RARROW ) # 798 "src/aorai/yalexer.ml" | 27 -> # 78 "src/aorai/yalexer.mll" ( AMP ) # 803 "src/aorai/yalexer.ml" | 28 -> # 79 "src/aorai/yalexer.mll" ( PIPE ) # 808 "src/aorai/yalexer.ml" | 29 -> # 80 "src/aorai/yalexer.mll" ( AND ) # 813 "src/aorai/yalexer.ml" | 30 -> # 81 "src/aorai/yalexer.mll" ( OR ) # 818 "src/aorai/yalexer.ml" | 31 -> # 82 "src/aorai/yalexer.mll" ( NOT ) # 823 "src/aorai/yalexer.ml" | 32 -> # 83 "src/aorai/yalexer.mll" ( LT ) # 828 "src/aorai/yalexer.ml" | 33 -> # 84 "src/aorai/yalexer.mll" ( GT ) # 833 "src/aorai/yalexer.ml" | 34 -> # 85 "src/aorai/yalexer.mll" ( LE ) # 838 "src/aorai/yalexer.ml" | 35 -> # 86 "src/aorai/yalexer.mll" ( GE ) # 843 "src/aorai/yalexer.ml" | 36 -> # 87 "src/aorai/yalexer.mll" ( EQ ) # 848 "src/aorai/yalexer.ml" | 37 -> # 88 "src/aorai/yalexer.mll" ( NEQ ) # 853 "src/aorai/yalexer.ml" | 38 -> # 89 "src/aorai/yalexer.mll" ( SEMI_COLON ) # 858 "src/aorai/yalexer.ml" | 39 -> # 90 "src/aorai/yalexer.mll" ( COLON ) # 863 "src/aorai/yalexer.ml" | 40 -> # 91 "src/aorai/yalexer.mll" ( COLUMNCOLUMN ) # 868 "src/aorai/yalexer.ml" | 41 -> # 92 "src/aorai/yalexer.mll" ( CARET ) # 873 "src/aorai/yalexer.ml" | 42 -> # 93 "src/aorai/yalexer.mll" ( QUESTION ) # 878 "src/aorai/yalexer.ml" | 43 -> # 94 "src/aorai/yalexer.mll" ( EOF ) # 883 "src/aorai/yalexer.ml" | 44 -> # 95 "src/aorai/yalexer.mll" ( raise_located (loc lexbuf) "Unknown token" ) # 888 "src/aorai/yalexer.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_token_rec lexbuf __ocaml_lex_state ;; # 97 "src/aorai/yalexer.mll" let parse c = let lb = from_channel c in try Yaparser.main token lb with Parsing.Parse_error | Invalid_argument _ -> (* [VP]: Does not contain more information than what is in the exn. *) (*let (a,b)=(loc lb) in Format.print_string "Syntax error (" ; Format.print_string "l" ; Format.print_int a.pos_lnum ; Format.print_string "c" ; Format.print_int (a.pos_cnum-a.pos_bol) ; Format.print_string " -> l" ; Format.print_int b.pos_lnum ; Format.print_string "c" ; Format.print_int (b.pos_cnum-b.pos_bol) ; Format.print_string ")\n" ; *) raise_located (loc lb) "Syntax error" # 920 "src/aorai/yalexer.ml" frama-c-Fluorine-20130601/src/aorai/aorai_register.ml0000644000175000017500000003410012155630222021204 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 Logic_ptree open Promelaast (* [VP] Need to get rid of those global references at some point. *) let promela_file = ref "" let ya_file = ref "" let c_file = ref "" let output_c_file = ref "" let ltl_tmp_file = ref "" let ltl_file = ref "" let dot_file = ref "" let generatesCFile = ref true let ltl2ba_params = " -l -p -o " let ltl_to_promela = Hashtbl.create 7 let set_ltl_correspondance h = Hashtbl.clear ltl_to_promela; Hashtbl.iter (fun x y -> Hashtbl.add ltl_to_promela x y) h let convert_ltl_exprs t = let rec convert_cond cond = match cond with POr(c1,c2) -> POr (convert_cond c1, convert_cond c2) | PAnd(c1,c2) -> PAnd(convert_cond c1, convert_cond c2) | PNot c -> PNot (convert_cond c) | PCall _ | PReturn _ | PTrue | PFalse -> cond | PRel(Neq,PVar x,PCst _) -> (try let (rel,t1,t2) = Hashtbl.find ltl_to_promela x in PRel(rel,t1,t2) with Not_found -> cond) | PRel _ -> cond in let rec convert_seq_elt e = { e with condition = Extlib.opt_map convert_cond e.condition; nested = convert_seq e.nested; } and convert_seq s = List.map convert_seq_elt s in let convert_parsed c = match c with Seq l -> Seq (convert_seq l) | Otherwise -> Otherwise in let convert_trans t = { t with cross = convert_parsed t.cross } in List.map convert_trans t (* Promela file *) let syntax_error loc msg = Aorai_option.abort "File %S, line %d, characters %d-%d:@\nSyntax error: %s" (fst loc).Lexing.pos_fname (fst loc).Lexing.pos_lnum ((fst loc).Lexing.pos_cnum - (fst loc).Lexing.pos_bol) ((snd loc).Lexing.pos_cnum - (fst loc).Lexing.pos_bol) msg let ltl_to_ltlLight f_ltl f_out = try let c = open_in f_ltl in let (ltl_form,exprs) = Ltllexer.parse c in close_in c; Ltl_output.output ltl_form f_out; set_ltl_correspondance exprs with | Not_found -> Aorai_option.abort "Unknown LTL file %s" f_ltl | Ltllexer.Error (loc,msg) -> syntax_error loc msg let load_ya_file f = try let c = open_in f in let automata = Yalexer.parse c in close_in c; Data_for_aorai.setAutomata automata; with | Not_found -> Aorai_option.abort "Unknown Ya file %s" f | Yalexer.Error (loc,msg) -> syntax_error loc msg let load_promela_file f = try let c = open_in f in let (s,t) = Promelalexer.parse c in let t = convert_ltl_exprs t in close_in c; Data_for_aorai.setAutomata (s,t); with | Not_found -> Aorai_option.abort "Unknown Promela file %s" f | Promelalexer.Error(loc,msg) -> syntax_error loc msg let load_promela_file_withexps f = try let c = open_in f in let automata = Promelalexer_withexps.parse c in close_in c; Data_for_aorai.setAutomata automata; with | Not_found -> Aorai_option.abort "Unknown Promela file %s" f | Promelalexer_withexps.Error(loc,msg) -> syntax_error loc msg let display_status () = if Aorai_option.verbose_atleast 2 then begin Aorai_option.feedback "\n" ; Aorai_option.feedback "C file: '%s'\n" !c_file ; Aorai_option.feedback "Entry point: '%a'\n" Kernel_function.pretty (fst (Globals.entry_point())) ; Aorai_option.feedback "LTL property: '%s'\n" !ltl_file ; Aorai_option.feedback "Files to generate: '%s' (Annotated code)\n" (if !generatesCFile then !output_c_file else "(none)"); if Aorai_option.Dot.get () then Aorai_option.feedback "Dot file: '%s'\n" !dot_file; Aorai_option.feedback "Tmp files: '%s' (Light LTL file)\n" !ltl_tmp_file ; Aorai_option.feedback " '%s' (Promela file)\n" !promela_file ; Aorai_option.feedback "\n" end let init_file_names () = (* Intermediate functions for error display or fresh name of file generation *) let err= ref false in let dispErr mesg f = Aorai_option.error "Error. File '%s' %s.\n" f mesg; err:=true in let freshname pre suf = let rec fn p s n = if not (Sys.file_exists (p^(string_of_int n)^s)) then (p^(string_of_int n)^s) else fn p s (n+1) in let name = if not (Sys.file_exists (pre^suf)) then pre^suf else fn pre suf 0 in name in (* c_file name is given and has to point out a valid file. *) c_file := (match Kernel.Files.get () with | [] -> "dummy.i" | f :: _ -> f); if (!c_file="") then dispErr ": invalid C file name" !c_file; if (not (Sys.file_exists !c_file)) then dispErr "not found" !c_file; (* The output C file has to be a valid file name if it is used. *) output_c_file := (Aorai_option.Output_C_File.get ()) ; if (!output_c_file="") then output_c_file:=freshname ((Filename.chop_extension !c_file)^"_annot") ".c"; (* else if Sys.file_exists !output_c_file then dispErr "already exists" !output_c_file; *) if Aorai_option.Dot.get () then dot_file:=freshname (Filename.chop_extension !c_file) ".dot"; if Aorai_option.Ya.get () = "" then if Aorai_option.Buchi.get () = "" then begin (* ltl_file name is given and has to point out a valid file. *) ltl_file := Aorai_option.Ltl_File.get (); if (!ltl_file="") then dispErr ": invalid LTL file name" !ltl_file; if (not (Sys.file_exists !ltl_file)) then dispErr "not found" !ltl_file; (* The LTL file is always used. *) (* The promela file can be given or not. *) if Aorai_option.To_Buchi.get () <> "" then begin ltl_tmp_file:= freshname (Filename.chop_extension (Aorai_option.promela_file ())) ".ltl"; promela_file:= Aorai_option.promela_file (); Extlib.cleanup_at_exit !ltl_tmp_file end else begin ltl_tmp_file:= (try Extlib.temp_file_cleanup_at_exit (Filename.basename !c_file) ".ltl" with Extlib.Temp_file_error s -> Aorai_option.abort "cannot create temporary file: %s" s); promela_file:= freshname (Filename.chop_extension !ltl_tmp_file) ".promela"; Extlib.cleanup_at_exit !promela_file; end end else begin if Aorai_option.To_Buchi.get () <> "" && Aorai_option.Ltl_File.get () <> "" then begin Aorai_option.error "Error. '-buchi' option is incompatible with '-to-buchi' and '-ltl' \ options."; err:=true end; (* The promela file is used only if the process does not terminate after LTL generation. *) promela_file := Aorai_option.promela_file (); end else begin ya_file := Aorai_option.Ya.get (); if (!ya_file="") then dispErr ": invalid Ya file name" !ya_file; if (not (Sys.file_exists !ya_file)) then dispErr "not found" !ya_file end; display_status (); !err let init_test () = match Aorai_option.Test.get () with | 1 -> generatesCFile := false; | _ -> generatesCFile := true let printverb s = Aorai_option.feedback ~level:2 "%s" s let output () = (* Dot file *) if (Aorai_option.Dot.get()) then begin Promelaoutput.output_dot_automata (Data_for_aorai.getAutomata ()) !dot_file; printverb "Generating dot file : done\n" end; (* C file *) if (not !generatesCFile) then printverb "C file generation : skipped\n" else begin let cout = open_out !output_c_file in let fmt = Format.formatter_of_out_channel cout in Kernel.Unicode.without_unicode (fun () -> File.pretty_ast ~fmt (); close_out cout; printverb "C file generation : done\n"; ) () end; printverb "Finished.\n"; (* Some test traces. *) Data_for_aorai.debug_computed_state (); if !generatesCFile then Kernel.Files.set [!output_c_file] let work () = let file = Ast.get () in Aorai_utils.initFile file; printverb "C file loading : done\n"; if Aorai_option.Ya.get () = "" then if Aorai_option.Buchi.get () = "" then begin ltl_to_ltlLight !ltl_file !ltl_tmp_file; printverb "LTL loading : done\n"; let cmd = Format.sprintf "ltl2ba %s -F %s > %s" ltl2ba_params !ltl_tmp_file !promela_file in if Sys.command cmd <> 0 then Aorai_option.abort "failed to run: %s" cmd ; printverb "LTL ~> Promela (ltl2ba): done\n" end; if Aorai_option.To_Buchi.get () <> "" then printverb ("Finished.\nGenerated file: '"^(!promela_file)^"'\n") else begin (* Step 3 : Loading promela_file and checking the consistency between informations from C code and LTL property *) (* Such as functions name and global variables. *) if Aorai_option.Buchi.get () <> "" then load_promela_file_withexps !promela_file else if Aorai_option.Ya.get () <> "" then load_ya_file !ya_file else load_promela_file !promela_file; printverb "Loading promela : done\n"; (* Computing the list of ignored functions *) (* Aorai_visitors.compute_ignored_functions file; *) (* Promelaoutput.print_raw_automata (Data_for_aorai.getAutomata()); *) (* Data_for_aorai.debug_ltl_expressions (); *) (*let _ = Path_analysis.test (Data_for_aorai.getAutomata())in*) let root = fst (Globals.entry_point ()) in if (Aorai_option.Axiomatization.get()) then begin (* Step 5 : incrementing pre/post conditions with states and transitions information *) printverb "Refining pre/post : \n"; Aorai_dataflow.compute (); (* Step 6 : Removing transitions never crossed *) if (Aorai_option.AutomataSimplification.get()) then begin printverb "Removing unused trans : done\n"; Data_for_aorai.removeUnusedTransitionsAndStates (); end else printverb "Removing unused trans : skipped\n"; (* Step 7 : Labeling abstract file *) (* Finally the information is added into the Cil automata. *) Aorai_utils.initGlobals root (Aorai_option.Axiomatization.get()); Aorai_visitors.add_sync_with_buch file; Aorai_visitors.add_pre_post_from_buch file (Aorai_option.advance_abstract_interpretation ()); printverb "Annotation of Cil : done\n"; end else begin (* Step 4': Computing the set of possible pre-states and post-states of each function *) (* And so for pre/post transitions *) printverb "Abstracting pre/post : skipped\n"; (* Step 5': incrementing pre/post conditions with states and transitions information *) printverb "Refining pre/post : skipped\n"; (* Step 6 : Removing transitions never crossed *) printverb "Removing unused trans : skipped\n"; (* Step 7 : Labeling abstract file *) (* Finally the information is added into the Cil automata. *) Aorai_utils.initGlobals root (Aorai_option.Axiomatization.get()); Aorai_visitors.add_sync_with_buch file; printverb "Annotation of Cil : partial\n" end; (* Step 8 : clearing tables whose information has been invalidated by our transformations. *) Cfg.clearFileCFG ~clear_id:false file; Cfg.computeFileCFG file; Ast.clear_last_decl (); let prj = File.create_project_from_visitor "aorai" (fun prj -> new Visitor.frama_c_copy prj) in Project.copy ~selection:(Plugin.get_selection ()) prj; Project.on prj output () end let run () = Aorai_option.result "Welcome to the Aorai plugin@."; init_test (); (* Step 1 : Capture files names *) let error_status = init_file_names () in (* Treatment is done only if parameters are valid *) if error_status then Aorai_option.error "Generation stopped." else (* Step 2 : Work in our own project, initialized by a copy of the main one. *) let work_prj = File.create_project_from_visitor "aorai_tmp" (fun prj -> new Visitor.frama_c_copy prj) in Project.copy ~selection:(Plugin.get_selection ()) work_prj; Project.on work_prj work (); Project.remove ~project:work_prj () (* Plugin registration *) let run = Dynamic.register ~plugin:"Aorai" "run" (Datatype.func Datatype.unit Datatype.unit) ~journalize:true run let run, _ = State_builder.apply_once "Aorai" (let module O = Aorai_option in [ O.Ltl_File.self; O.To_Buchi.self; O.Buchi.self; O.Ya.self; O.Axiomatization.self; O.ConsiderAcceptance.self; O.AutomataSimplification.self; O.AbstractInterpretation.self; O.AddingOperationNameAndStatusInSpecification.self ]) run let main () = if Aorai_option.is_on () then run () let () = Db.Main.extend main (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/ltlast.mli0000644000175000017500000000676112155630222017675 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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: ltlast.mli,v 1.3 2008-10-13 09:21:24 uid588 Exp $ *) (** The abstract tree of LTL formula. Such tree is used by ltl parser/lexer before its translation into Buchi automata by the LTL2BA external tool. *) (** LTL formula parsed abstract syntax trees *) type formula = | LNext of formula (** 'Next' temporal operator *) | LUntil of formula * formula (** 'Until' temporal operator *) | LFatally of formula (** 'Fatally' temporal operator *) | LGlobally of formula (** 'Globally' temporal operator *) | LRelease of formula * formula (** 'Release' temporal operator (reminder: f1 R f2 <=> !(!f1 U !f2)) *) | LNot of formula (** 'not' logic operator *) | LAnd of formula * formula (** 'and' logic operator *) | LOr of formula * formula (** 'or' logic operator *) | LImplies of formula * formula (** '=>' logic operator *) | LIff of formula * formula (** '<=>' logic operator *) | LTrue (** 'true' logic constant *) | LFalse (** 'false' logic constant *) | LCall of string (** Logic predicate. The String has to be the name of an operation from C program *) | LReturn of string (** Logic predicate. The String has to be the name of an operation from C program *) | LCallOrReturn of string (** Logic predicate. The String has to be the name of an operation from C program *) | LIdent of string (** Logic expression. The String is the name of a fresh variable defined by the expression and used to be in conformance with the input syntax of LTL2BA tool. *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/ltl_output.ml0000644000175000017500000000643512155630222020432 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 open Pervasives open Ltlast let out_fmt=ref (formatter_of_out_channel stdout) let rec ltl_form_to_string = function | LNext (f) -> "X("^(ltl_form_to_string f)^")" | LUntil (f1,f2) -> "("^(ltl_form_to_string f1)^" U "^(ltl_form_to_string f2)^")" | LFatally (f) -> "<>("^(ltl_form_to_string f)^")" | LGlobally (f) -> "[]("^(ltl_form_to_string f)^")" | LRelease (f1,f2) -> "("^(ltl_form_to_string f1)^" V "^(ltl_form_to_string f2)^")" | LNot (f) -> "!("^(ltl_form_to_string f)^")" | LAnd (f1,f2) -> "("^(ltl_form_to_string f1)^" && "^(ltl_form_to_string f2)^")" | LOr (f1,f2) -> "("^(ltl_form_to_string f1)^" || "^(ltl_form_to_string f2)^")" | LImplies (f1,f2) -> "("^(ltl_form_to_string f1)^" -> "^(ltl_form_to_string f2)^")" | LIff (f1,f2) -> "("^(ltl_form_to_string f1)^" <-> "^(ltl_form_to_string f2)^")" | LTrue -> "1" | LFalse -> "0" | LCall (s) -> "callof_"^s | LReturn (s) -> "returnof_"^s | LCallOrReturn (s) -> "callorreturnof_"^s | LIdent (s) -> s let output ltl_form file = let c = open_out file in out_fmt:=formatter_of_out_channel c ; fprintf !out_fmt "%s\n\n" (ltl_form_to_string ltl_form); fprintf !out_fmt "@?"; (* Flush du flux *) close_out c; out_fmt:=formatter_of_out_channel stdout (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/bool3.ml0000644000175000017500000000452512155630222017233 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 t = | True | False | Undefined let bool3and c1 c2 = match c1, c2 with | True, True -> True | _, False | False, _ -> False | Undefined, _ | _, Undefined -> Undefined let bool3or c1 c2 = match c1, c2 with | True, _ | _, True -> True | _, Undefined | Undefined, _ -> Undefined | False, False -> False let bool3not c = match c with | True -> False | False -> True | Undefined -> Undefined let bool3_of_bool b = if b then True else False (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/configure.ac0000644000175000017500000000465612155630222020156 0ustar mehdimehdi########################################################################## # # # This file is part of Aorai plug-in of Frama-C. # # # # Copyright (C) 2007-2013 # # CEA (Commissariat a l'nergie atomique et aux nergies # # alternatives) # # INRIA (Institut National de Recherche en Informatique et en # # Automatique) # # INSA (Institut National des Sciences Appliquees) # # # # 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(aorai,PLUGIN_RELATIVE_PATH(plugin_file),[support for Aorai plug-in],yes,yes) if test "$ENABLE_AORAI" != "no"; then plugin_use_external(aorai,ltltoba) # ltl2ba library configure_tool([LTLTOBA],[ltl2ba],[ltl2ba not found.],no) check_plugin_dependencies fi write_plugin_config(Makefile) frama-c-Fluorine-20130601/src/aorai/promelaparser.mly0000644000175000017500000001664012155630222021263 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of Aorai plug-in of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat a l'nergie atomique et aux nergies */ /* alternatives) */ /* INRIA (Institut National de Recherche en Informatique et en */ /* Automatique) */ /* INSA (Institut National des Sciences Appliquees) */ /* */ /* 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: promelaparser.mly,v 1.2 2008-10-02 13:33:29 uid588 Exp $ */ /* Originated from http://www.ltl2dstar.de/down/ltl2dstar-0.4.2.zip */ %{ open Promelaast open Bool3 let observed_states=Hashtbl.create 1 let to_seq c = [{ condition = Some c; nested = []; min_rep = Some (PCst (Logic_ptree.IntConstant "1")); max_rep = Some (PCst (Logic_ptree.IntConstant "1")); }] %} %token PROMELA_OR %token PROMELA_AND %token PROMELA_NOT PROMELA_TRUE PROMELA_FALSE %right PROMELA_OR %right PROMELA_AND %nonassoc PROMELA_NOT PROMELA_TRUE PROMELA_FALSE %token PROMELA_NEVER PROMELA_IF PROMELA_FI PROMELA_GOTO PROMELA_SKIP %token PROMELA_LABEL %token PROMELA_COLON PROMELA_SEMICOLON PROMELA_DOUBLE_COLON %token PROMELA_LBRACE PROMELA_RBRACE PROMELA_LPAREN %token PROMELA_RPAREN PROMELA_RIGHT_ARROW %token PROMELA_TRUE PROMELA_FALSE %token PROMELA_CALLOF PROMELA_RETURNOF PROMELA_CALLORRETURNOF %token EOF %type promela %start promela %% promela : PROMELA_NEVER PROMELA_LBRACE states PROMELA_RBRACE EOF { let states= Hashtbl.fold (fun _ st l -> if st.acceptation=Undefined or st.init=Undefined then begin Aorai_option.abort "Error: the state %s is used but never defined" st.name; end; st::l ) observed_states [] in (states , $3) } | PROMELA_NEVER PROMELA_LBRACE states PROMELA_SEMICOLON PROMELA_RBRACE EOF { let states= Hashtbl.fold (fun _ st l -> if st.acceptation=Undefined or st.init=Undefined then begin Aorai_option.abort "Error: the state %s is used but never defined" st.name; end; st::l ) observed_states [] in (states , $3) } ; states : states PROMELA_SEMICOLON state { $1@$3 } | state { $1 } ; state : state_labels state_body { let (stl,trans)=$1 in let (trl,force_final)=$2 in if force_final then begin List.iter (fun s -> try (Hashtbl.find observed_states s.name).acceptation <- True with | Not_found -> assert false (* This state has to be in the hashtable -- by construction *) ) stl end; if trl=[] then trans else let tr_list= List.fold_left (fun l1 (cr,stop_st) -> List.fold_left (fun l2 st -> {start=st;stop=stop_st;cross=Seq (to_seq cr);numt=(-1)}::l2 ) l1 stl ) [] trl in (List.rev tr_list)@trans } ; state_labels : label state_labels { let (stl1,trl1)=$1 in let (stl2,trl2)=$2 in (stl1@stl2,trl1@trl2) } | label { $1 } ; label : PROMELA_LABEL PROMELA_COLON { begin (* Step 0 : trans is the set of new transitions and old is the description of the current state *) let trans = ref [] in (* Promela Label is a state. According to its name, we will try to give him its properties (init / accept) *) (* Firstly, if this state is still referenced, then we get it back. Else, we make a new "empty" state *) let old= try Hashtbl.find observed_states $1 with | Not_found -> let s = Data_for_aorai.new_state $1 in Hashtbl.add observed_states $1 s; s in (* Step 1 : setting up the acceptance status *) (* Default status : Non acceptation state *) old.acceptation <- False; (* Accept_all state means acceptance state with a reflexive transition without cross condition *) (* This case is not exclusive with the following. Acceptation status is set in this last. *) if (String.length $1>=10) && (String.compare (String.sub $1 0 10) "accept_all")=0 then trans:= {start=old;stop=old;cross=Seq (to_seq PTrue);numt=(-1)} :: !trans; (* If the name includes accept then this state is an acceptation one. *) if (String.length $1>=7) && (String.compare (String.sub $1 0 7) "accept_")=0 then old.acceptation <- True; (* Step 2 : setting up the init status *) (* If the state name ended with "_init" then it is an initial state. Else, it is not. *) if (String.length $1>=5) && (String.compare (String.sub $1 ((String.length $1)-5) 5) "_init" ) = 0 then old.init <- True else old.init <- False; ([old],!trans) end } ; state_body : PROMELA_IF transitions PROMELA_FI { ($2,false) } | PROMELA_SKIP { ([],false) } | PROMELA_FALSE { ([],true) } | PROMELA_IF PROMELA_DOUBLE_COLON PROMELA_FALSE PROMELA_FI { ([],true) } ; transitions : transitions transition { $1@[$2] } | transition { [$1] } ; transition : PROMELA_DOUBLE_COLON guard PROMELA_RIGHT_ARROW PROMELA_GOTO PROMELA_LABEL { let s= try Hashtbl.find observed_states $5 with Not_found -> let r = Data_for_aorai.new_state $5 in Hashtbl.add observed_states $5 r; r in ($2,s) } ; guard : PROMELA_CALLORRETURNOF { POr(PCall ($1,None), PReturn $1) } | PROMELA_CALLOF { PCall ($1,None) } | PROMELA_RETURNOF { PReturn $1 } | PROMELA_TRUE { PTrue } | PROMELA_FALSE { PFalse } | PROMELA_NOT guard { PNot $2 } | guard PROMELA_AND guard { PAnd ($1,$3) } | guard PROMELA_OR guard { POr ($1,$3) } | PROMELA_LPAREN guard PROMELA_RPAREN { $2 } | PROMELA_LABEL { PRel (Logic_ptree.Neq,PVar $1,PCst(Logic_ptree.IntConstant "0")) } ; frama-c-Fluorine-20130601/src/aorai/ltl_output.mli0000644000175000017500000000376112155630222020602 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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: ltl_output.mli,v 1.2 2008-10-02 13:33:29 uid588 Exp $ *) val output : Ltlast.formula -> string -> unit (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/aorai/promelaparser_withexps.ml0000444000175000017500000007236512155634032023034 0ustar mehdimehditype token = | PROMELA_OR | PROMELA_AND | PROMELA_NOT | PROMELA_TRUE | PROMELA_FALSE | PROMELA_NEVER | PROMELA_IF | PROMELA_FI | PROMELA_GOTO | PROMELA_SKIP | PROMELA_LABEL of (string) | PROMELA_INT of (string) | PROMELA_COLON | PROMELA_SEMICOLON | PROMELA_DOUBLE_COLON | PROMELA_LBRACE | PROMELA_RBRACE | PROMELA_LPAREN | PROMELA_RPAREN | PROMELA_RIGHT_ARROW | PROMELA_EQ | PROMELA_LT | PROMELA_GT | PROMELA_LE | PROMELA_GE | PROMELA_NEQ | PROMELA_PLUS | PROMELA_MINUS | PROMELA_DIV | PROMELA_STAR | PROMELA_MODULO | PROMELA_DOT | PROMELA_LEFT_SQUARE | PROMELA_RIGHT_SQUARE | PROMELA_CALLOF of (string) | PROMELA_RETURNOF of (string) | PROMELA_CALLORRETURNOF of (string) | EOF | PROMELA_FUNC open Parsing;; let _ = parse_error;; # 30 "src/aorai/promelaparser_withexps.mly" open Logic_ptree open Promelaast open Bool3 let observed_states=Hashtbl.create 1 let to_seq c = [{ condition = Some c; nested = []; min_rep = Some (PCst (IntConstant "1")); max_rep = Some (PCst (IntConstant "1")); }] # 58 "src/aorai/promelaparser_withexps.ml" let yytransl_const = [| 257 (* PROMELA_OR *); 258 (* PROMELA_AND *); 259 (* PROMELA_NOT *); 260 (* PROMELA_TRUE *); 261 (* PROMELA_FALSE *); 262 (* PROMELA_NEVER *); 263 (* PROMELA_IF *); 264 (* PROMELA_FI *); 265 (* PROMELA_GOTO *); 266 (* PROMELA_SKIP *); 269 (* PROMELA_COLON *); 270 (* PROMELA_SEMICOLON *); 271 (* PROMELA_DOUBLE_COLON *); 272 (* PROMELA_LBRACE *); 273 (* PROMELA_RBRACE *); 274 (* PROMELA_LPAREN *); 275 (* PROMELA_RPAREN *); 276 (* PROMELA_RIGHT_ARROW *); 277 (* PROMELA_EQ *); 278 (* PROMELA_LT *); 279 (* PROMELA_GT *); 280 (* PROMELA_LE *); 281 (* PROMELA_GE *); 282 (* PROMELA_NEQ *); 283 (* PROMELA_PLUS *); 284 (* PROMELA_MINUS *); 285 (* PROMELA_DIV *); 286 (* PROMELA_STAR *); 287 (* PROMELA_MODULO *); 288 (* PROMELA_DOT *); 289 (* PROMELA_LEFT_SQUARE *); 290 (* PROMELA_RIGHT_SQUARE *); 0 (* EOF *); 294 (* PROMELA_FUNC *); 0|] let yytransl_block = [| 267 (* PROMELA_LABEL *); 268 (* PROMELA_INT *); 291 (* PROMELA_CALLOF *); 292 (* PROMELA_RETURNOF *); 293 (* PROMELA_CALLORRETURNOF *); 0|] let yylhs = "\255\255\ \001\000\001\000\002\000\002\000\003\000\004\000\004\000\006\000\ \005\000\005\000\005\000\005\000\007\000\007\000\008\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\ \011\000\011\000\011\000\012\000\012\000\012\000\012\000\013\000\ \013\000\013\000\013\000\014\000\014\000\015\000\015\000\016\000\ \016\000\016\000\016\000\000\000" let yylen = "\002\000\ \005\000\006\000\003\000\001\000\002\000\002\000\001\000\002\000\ \003\000\001\000\001\000\004\000\002\000\001\000\005\000\001\000\ \001\000\001\000\001\000\001\000\002\000\003\000\003\000\003\000\ \001\000\003\000\003\000\003\000\003\000\003\000\003\000\001\000\ \003\000\003\000\001\000\003\000\003\000\003\000\001\000\001\000\ \002\000\001\000\003\000\003\000\001\000\004\000\001\000\002\000\ \004\000\001\000\003\000\002\000" let yydefred = "\000\000\ \000\000\000\000\000\000\052\000\000\000\000\000\000\000\004\000\ \000\000\000\000\008\000\000\000\000\000\011\000\000\000\010\000\ \005\000\006\000\000\000\003\000\001\000\000\000\000\000\014\000\ \002\000\000\000\019\000\000\000\000\000\040\000\000\000\000\000\ \000\000\017\000\018\000\016\000\000\000\025\000\000\000\000\000\ \039\000\000\000\000\000\047\000\009\000\000\000\013\000\020\000\ \021\000\012\000\000\000\000\000\000\000\000\000\041\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\024\000\043\000\051\000\000\000\000\000\000\000\ \000\000\000\000\026\000\027\000\028\000\029\000\030\000\031\000\ \033\000\034\000\036\000\037\000\038\000\044\000\000\000\049\000\ \015\000\000\000\046\000" let yydgoto = "\002\000\ \004\000\007\000\008\000\009\000\017\000\010\000\023\000\024\000\ \037\000\038\000\039\000\040\000\041\000\042\000\043\000\044\000" let yysindex = "\003\000\ \014\255\000\000\041\255\000\000\085\255\126\255\002\255\000\000\ \139\255\085\255\000\000\001\255\148\000\000\000\143\255\000\000\ \000\000\000\000\159\000\000\000\000\000\010\255\250\254\000\000\ \000\000\038\255\000\000\182\255\164\255\000\000\038\255\192\255\ \037\255\000\000\000\000\000\000\104\255\000\000\039\255\124\255\ \000\000\173\255\176\255\000\000\000\000\038\255\000\000\000\000\ \000\000\000\000\178\255\006\255\076\255\075\255\000\000\037\255\ \173\255\038\255\038\255\202\255\255\254\255\254\255\254\255\254\ \255\254\255\254\255\254\255\254\255\254\255\254\255\254\201\255\ \255\254\203\255\000\000\000\000\000\000\075\255\052\255\211\255\ \204\255\255\254\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\183\255\000\000\ \000\000\197\255\000\000" let yyrindex = "\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\140\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\186\255\057\255\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\004\255\172\255\ \000\000\141\255\091\255\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\068\255\155\255\000\000\000\000\ \107\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\084\255\188\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" let yygindex = "\000\000\ \000\000\000\000\206\000\209\000\000\000\000\000\000\000\197\000\ \013\000\000\000\225\255\000\000\130\000\226\255\000\000\000\000" let yytablesize = 220 let yytable = "\053\000\ \054\000\045\000\057\000\001\000\032\000\032\000\058\000\059\000\ \046\000\029\000\030\000\006\000\026\000\027\000\028\000\012\000\ \082\000\019\000\013\000\003\000\029\000\030\000\032\000\032\000\ \075\000\078\000\032\000\031\000\033\000\083\000\084\000\085\000\ \086\000\087\000\088\000\089\000\090\000\032\000\049\000\033\000\ \026\000\027\000\048\000\052\000\034\000\035\000\036\000\029\000\ \029\000\030\000\098\000\054\000\058\000\059\000\056\000\031\000\ \005\000\050\000\050\000\061\000\062\000\063\000\064\000\065\000\ \066\000\032\000\033\000\033\000\032\000\032\000\079\000\080\000\ \034\000\035\000\036\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\050\000\050\000\050\000\050\000\050\000\ \050\000\050\000\050\000\045\000\045\000\077\000\076\000\006\000\ \061\000\062\000\063\000\064\000\065\000\066\000\023\000\023\000\ \058\000\059\000\072\000\048\000\048\000\045\000\045\000\045\000\ \045\000\045\000\045\000\045\000\045\000\045\000\045\000\045\000\ \045\000\045\000\045\000\060\000\045\000\048\000\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \048\000\048\000\011\000\048\000\048\000\042\000\042\000\014\000\ \007\000\015\000\007\000\021\000\016\000\007\000\067\000\068\000\ \069\000\070\000\071\000\042\000\042\000\022\000\025\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\042\000\042\000\035\000\035\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \042\000\042\000\020\000\020\000\022\000\050\000\035\000\035\000\ \035\000\035\000\035\000\035\000\035\000\035\000\091\000\092\000\ \093\000\051\000\095\000\055\000\072\000\020\000\022\000\022\000\ \073\000\074\000\081\000\094\000\059\000\096\000\097\000\076\000\ \099\000\020\000\018\000\047\000" let yycheck = "\031\000\ \031\000\008\001\033\000\001\000\001\001\002\001\001\001\002\001\ \015\001\011\001\012\001\011\001\003\001\004\001\005\001\014\001\ \018\001\017\001\017\001\006\001\011\001\012\001\019\001\020\001\ \019\001\056\000\028\001\018\001\030\001\061\000\062\000\063\000\ \064\000\065\000\066\000\067\000\068\000\028\001\026\000\030\001\ \003\001\004\001\005\001\031\000\035\001\036\001\037\001\011\001\ \011\001\012\001\082\000\082\000\001\001\002\001\018\001\018\001\ \016\001\001\001\002\001\021\001\022\001\023\001\024\001\025\001\ \026\001\028\001\030\001\030\001\001\001\002\001\058\000\059\000\ \035\001\036\001\037\001\019\001\020\001\021\001\022\001\023\001\ \024\001\025\001\026\001\027\001\028\001\029\001\030\001\031\001\ \032\001\033\001\034\001\001\001\002\001\019\001\019\001\011\001\ \021\001\022\001\023\001\024\001\025\001\026\001\019\001\020\001\ \001\001\002\001\032\001\001\001\002\001\019\001\020\001\021\001\ \022\001\023\001\024\001\025\001\026\001\027\001\028\001\029\001\ \030\001\031\001\032\001\020\001\034\001\019\001\020\001\021\001\ \022\001\023\001\024\001\025\001\026\001\027\001\028\001\029\001\ \030\001\031\001\013\001\033\001\034\001\001\001\002\001\005\001\ \005\001\007\001\007\001\000\000\010\001\010\001\027\001\028\001\ \029\001\030\001\031\001\001\001\002\001\015\001\000\000\019\001\ \020\001\021\001\022\001\023\001\024\001\025\001\026\001\027\001\ \028\001\029\001\030\001\031\001\001\001\002\001\034\001\021\001\ \022\001\023\001\024\001\025\001\026\001\027\001\028\001\029\001\ \030\001\031\001\001\001\002\001\001\001\008\001\019\001\020\001\ \021\001\022\001\023\001\024\001\025\001\026\001\069\000\070\000\ \071\000\038\001\073\000\012\001\032\001\020\001\019\001\020\001\ \033\001\032\001\009\001\011\001\002\001\011\001\011\001\019\001\ \034\001\012\000\010\000\023\000" let yynames_const = "\ PROMELA_OR\000\ PROMELA_AND\000\ PROMELA_NOT\000\ PROMELA_TRUE\000\ PROMELA_FALSE\000\ PROMELA_NEVER\000\ PROMELA_IF\000\ PROMELA_FI\000\ PROMELA_GOTO\000\ PROMELA_SKIP\000\ PROMELA_COLON\000\ PROMELA_SEMICOLON\000\ PROMELA_DOUBLE_COLON\000\ PROMELA_LBRACE\000\ PROMELA_RBRACE\000\ PROMELA_LPAREN\000\ PROMELA_RPAREN\000\ PROMELA_RIGHT_ARROW\000\ PROMELA_EQ\000\ PROMELA_LT\000\ PROMELA_GT\000\ PROMELA_LE\000\ PROMELA_GE\000\ PROMELA_NEQ\000\ PROMELA_PLUS\000\ PROMELA_MINUS\000\ PROMELA_DIV\000\ PROMELA_STAR\000\ PROMELA_MODULO\000\ PROMELA_DOT\000\ PROMELA_LEFT_SQUARE\000\ PROMELA_RIGHT_SQUARE\000\ EOF\000\ PROMELA_FUNC\000\ " let yynames_block = "\ PROMELA_LABEL\000\ PROMELA_INT\000\ PROMELA_CALLOF\000\ PROMELA_RETURNOF\000\ PROMELA_CALLORRETURNOF\000\ " let yyact = [| (fun _ -> failwith "parser") ; (fun __caml_parser_env -> let _3 = (Parsing.peek_val __caml_parser_env 2 : 'states) in Obj.repr( # 80 "src/aorai/promelaparser_withexps.mly" ( let states= Hashtbl.fold (fun _ st l -> if st.acceptation=Undefined or st.init=Undefined then begin Format.print_string ("Error: the state '"^(st.name)^"' is used but never defined.\n"); exit 1 end; st::l ) observed_states [] in (states , _3) ) # 300 "src/aorai/promelaparser_withexps.ml" : Promelaast.parsed_automaton)) ; (fun __caml_parser_env -> let _3 = (Parsing.peek_val __caml_parser_env 3 : 'states) in Obj.repr( # 94 "src/aorai/promelaparser_withexps.mly" ( let states= Hashtbl.fold (fun _ st l -> if st.acceptation=Undefined or st.init=Undefined then begin Aorai_option.abort "Error: state %s is used bug never defined" st.name end; st::l ) observed_states [] in (states , _3) ) # 318 "src/aorai/promelaparser_withexps.ml" : Promelaast.parsed_automaton)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'states) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'state) in Obj.repr( # 109 "src/aorai/promelaparser_withexps.mly" ( _1@_3 ) # 326 "src/aorai/promelaparser_withexps.ml" : 'states)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'state) in Obj.repr( # 110 "src/aorai/promelaparser_withexps.mly" ( _1 ) # 333 "src/aorai/promelaparser_withexps.ml" : 'states)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'state_labels) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'state_body) in Obj.repr( # 114 "src/aorai/promelaparser_withexps.mly" ( let (stl,trans)=_1 in let (trl,force_final)=_2 in if force_final then begin List.iter (fun s -> try (Hashtbl.find observed_states s.name).acceptation <- True with | Not_found -> assert false (* This state has to be in the hashtable -- by construction *) ) stl end; if trl=[] then trans else let tr_list= List.fold_left (fun l1 (cr,stop_st) -> List.fold_left (fun l2 st -> {start=st;stop=stop_st;cross=Seq (to_seq cr);numt=(-1)}::l2 ) l1 stl ) [] trl in (List.rev tr_list)@trans ) # 365 "src/aorai/promelaparser_withexps.ml" : 'state)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'label) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'state_labels) in Obj.repr( # 142 "src/aorai/promelaparser_withexps.mly" ( let (stl1,trl1)=_1 in let (stl2,trl2)=_2 in (stl1@stl2,trl1@trl2) ) # 377 "src/aorai/promelaparser_withexps.ml" : 'state_labels)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'label) in Obj.repr( # 147 "src/aorai/promelaparser_withexps.mly" ( _1 ) # 384 "src/aorai/promelaparser_withexps.ml" : 'state_labels)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in Obj.repr( # 151 "src/aorai/promelaparser_withexps.mly" ( begin (* Step 0 : trans is the set of new transitions and old is the description of the current state *) let trans = ref [] in (* Promela Label is a state. According to its name, we will try to give him its properties (init / accept) *) (* Firstly, if this state is still referenced, then we get it back. Else, we make a new "empty" state *) let old= try Hashtbl.find observed_states _1 with | Not_found -> let s = Data_for_aorai.new_state _1 in Hashtbl.add observed_states _1 s; s in (* Step 1 : setting up the acceptance status *) (* Default status : Non acceptation state *) old.acceptation <- False; (* Accept_all state means acceptance state with a reflexive transition without cross condition *) (* This case is not exclusive with the following. Acceptation status is set in this last. *) if (String.length _1>=10) && (String.compare (String.sub _1 0 10) "accept_all")=0 then trans:= {start=old;stop=old;cross=Seq (to_seq PTrue);numt=(-1)}::!trans; (* If the name includes accept then this state is an acceptation one. *) if (String.length _1>=7) && (String.compare (String.sub _1 0 7) "accept_")=0 then old.acceptation <- True; (* Step 2 : setting up the init status *) (* If the state name ended with "_init" then it is an initial state. Else, it is not. *) if (String.length _1>=5) && (String.compare (String.sub _1 ((String.length _1)-5) 5) "_init" ) = 0 then old.init <- True else old.init <- False; ([old],!trans) end ) # 443 "src/aorai/promelaparser_withexps.ml" : 'label)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'transitions) in Obj.repr( # 208 "src/aorai/promelaparser_withexps.mly" ( (_2,false) ) # 450 "src/aorai/promelaparser_withexps.ml" : 'state_body)) ; (fun __caml_parser_env -> Obj.repr( # 209 "src/aorai/promelaparser_withexps.mly" ( ([],false) ) # 456 "src/aorai/promelaparser_withexps.ml" : 'state_body)) ; (fun __caml_parser_env -> Obj.repr( # 210 "src/aorai/promelaparser_withexps.mly" ( ([],true) ) # 462 "src/aorai/promelaparser_withexps.ml" : 'state_body)) ; (fun __caml_parser_env -> Obj.repr( # 211 "src/aorai/promelaparser_withexps.mly" ( ([],true) ) # 468 "src/aorai/promelaparser_withexps.ml" : 'state_body)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 1 : 'transitions) in let _2 = (Parsing.peek_val __caml_parser_env 0 : 'transition) in Obj.repr( # 216 "src/aorai/promelaparser_withexps.mly" ( _1@[_2] ) # 476 "src/aorai/promelaparser_withexps.ml" : 'transitions)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'transition) in Obj.repr( # 217 "src/aorai/promelaparser_withexps.mly" ( [_1] ) # 483 "src/aorai/promelaparser_withexps.ml" : 'transitions)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 3 : 'guard) in let _5 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 222 "src/aorai/promelaparser_withexps.mly" ( let s= try Hashtbl.find observed_states _5 with Not_found -> let r = Data_for_aorai.new_state _5 in Hashtbl.add observed_states _5 r; r in (_2,s) ) # 502 "src/aorai/promelaparser_withexps.ml" : 'transition)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 237 "src/aorai/promelaparser_withexps.mly" ( POr(PCall (_1,None), PReturn _1) ) # 509 "src/aorai/promelaparser_withexps.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 238 "src/aorai/promelaparser_withexps.mly" ( PCall (_1,None) ) # 516 "src/aorai/promelaparser_withexps.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 239 "src/aorai/promelaparser_withexps.mly" ( PReturn _1 ) # 523 "src/aorai/promelaparser_withexps.ml" : 'guard)) ; (fun __caml_parser_env -> Obj.repr( # 240 "src/aorai/promelaparser_withexps.mly" ( PTrue ) # 529 "src/aorai/promelaparser_withexps.ml" : 'guard)) ; (fun __caml_parser_env -> Obj.repr( # 241 "src/aorai/promelaparser_withexps.mly" ( PFalse ) # 535 "src/aorai/promelaparser_withexps.ml" : 'guard)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'guard) in Obj.repr( # 242 "src/aorai/promelaparser_withexps.mly" ( PNot _2 ) # 542 "src/aorai/promelaparser_withexps.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'guard) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'guard) in Obj.repr( # 243 "src/aorai/promelaparser_withexps.mly" ( PAnd (_1,_3) ) # 550 "src/aorai/promelaparser_withexps.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'guard) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'guard) in Obj.repr( # 244 "src/aorai/promelaparser_withexps.mly" ( POr (_1,_3) ) # 558 "src/aorai/promelaparser_withexps.ml" : 'guard)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'guard) in Obj.repr( # 245 "src/aorai/promelaparser_withexps.mly" ( _2 ) # 565 "src/aorai/promelaparser_withexps.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'logic_relation) in Obj.repr( # 246 "src/aorai/promelaparser_withexps.mly" ( _1 ) # 572 "src/aorai/promelaparser_withexps.ml" : 'guard)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 250 "src/aorai/promelaparser_withexps.mly" ( PRel(Eq, _1, _3) ) # 580 "src/aorai/promelaparser_withexps.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 251 "src/aorai/promelaparser_withexps.mly" ( PRel(Lt, _1, _3) ) # 588 "src/aorai/promelaparser_withexps.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 252 "src/aorai/promelaparser_withexps.mly" ( PRel(Gt, _1, _3) ) # 596 "src/aorai/promelaparser_withexps.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 253 "src/aorai/promelaparser_withexps.mly" ( PRel(Le, _1, _3) ) # 604 "src/aorai/promelaparser_withexps.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 254 "src/aorai/promelaparser_withexps.mly" ( PRel(Ge, _1, _3) ) # 612 "src/aorai/promelaparser_withexps.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 255 "src/aorai/promelaparser_withexps.mly" ( PRel(Neq,_1, _3) ) # 620 "src/aorai/promelaparser_withexps.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 256 "src/aorai/promelaparser_withexps.mly" ( PRel(Neq,_1, PCst(IntConstant "0")) ) # 627 "src/aorai/promelaparser_withexps.ml" : 'logic_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 262 "src/aorai/promelaparser_withexps.mly" ( PBinop(Badd, _1 , _3)) # 635 "src/aorai/promelaparser_withexps.ml" : 'arith_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation) in Obj.repr( # 264 "src/aorai/promelaparser_withexps.mly" ( PBinop(Bsub,_1,_3) ) # 643 "src/aorai/promelaparser_withexps.ml" : 'arith_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'arith_relation_mul) in Obj.repr( # 265 "src/aorai/promelaparser_withexps.mly" ( _1 ) # 650 "src/aorai/promelaparser_withexps.ml" : 'arith_relation)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'access_or_const) in Obj.repr( # 271 "src/aorai/promelaparser_withexps.mly" ( PBinop(Bdiv,_1,_3) ) # 658 "src/aorai/promelaparser_withexps.ml" : 'arith_relation_mul)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'access_or_const) in Obj.repr( # 273 "src/aorai/promelaparser_withexps.mly" ( PBinop(Bmul,_1,_3) ) # 666 "src/aorai/promelaparser_withexps.ml" : 'arith_relation_mul)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'arith_relation_mul) in let _3 = (Parsing.peek_val __caml_parser_env 0 : 'access_or_const) in Obj.repr( # 275 "src/aorai/promelaparser_withexps.mly" ( PBinop(Bmod,_1,_3) ) # 674 "src/aorai/promelaparser_withexps.ml" : 'arith_relation_mul)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'access_or_const) in Obj.repr( # 276 "src/aorai/promelaparser_withexps.mly" ( _1 ) # 681 "src/aorai/promelaparser_withexps.ml" : 'arith_relation_mul)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 280 "src/aorai/promelaparser_withexps.mly" ( PCst(IntConstant _1) ) # 688 "src/aorai/promelaparser_withexps.ml" : 'access_or_const)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 282 "src/aorai/promelaparser_withexps.mly" ( PUnop (Uminus, PCst (IntConstant _2)) ) # 695 "src/aorai/promelaparser_withexps.ml" : 'access_or_const)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'access) in Obj.repr( # 283 "src/aorai/promelaparser_withexps.mly" ( _1 ) # 702 "src/aorai/promelaparser_withexps.ml" : 'access_or_const)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'arith_relation) in Obj.repr( # 284 "src/aorai/promelaparser_withexps.mly" ( _2 ) # 709 "src/aorai/promelaparser_withexps.ml" : 'access_or_const)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 2 : 'access) in let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 288 "src/aorai/promelaparser_withexps.mly" ( PField (_1,_3) ) # 717 "src/aorai/promelaparser_withexps.ml" : 'access)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'access_array) in Obj.repr( # 289 "src/aorai/promelaparser_withexps.mly" (_1) # 724 "src/aorai/promelaparser_withexps.ml" : 'access)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : 'access_array) in let _3 = (Parsing.peek_val __caml_parser_env 1 : 'access_or_const) in Obj.repr( # 293 "src/aorai/promelaparser_withexps.mly" ( PArrget(_1,_3) ) # 732 "src/aorai/promelaparser_withexps.ml" : 'access_array)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : 'access_leaf) in Obj.repr( # 294 "src/aorai/promelaparser_withexps.mly" (_1) # 739 "src/aorai/promelaparser_withexps.ml" : 'access_array)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 0 : 'access) in Obj.repr( # 297 "src/aorai/promelaparser_withexps.mly" ( PUnop(Ustar,_2) ) # 746 "src/aorai/promelaparser_withexps.ml" : 'access_leaf)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in let _4 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 298 "src/aorai/promelaparser_withexps.mly" ( PPrm(_1,_4) ) # 754 "src/aorai/promelaparser_withexps.ml" : 'access_leaf)) ; (fun __caml_parser_env -> let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 299 "src/aorai/promelaparser_withexps.mly" ( PVar _1 ) # 761 "src/aorai/promelaparser_withexps.ml" : 'access_leaf)) ; (fun __caml_parser_env -> let _2 = (Parsing.peek_val __caml_parser_env 1 : 'access) in Obj.repr( # 300 "src/aorai/promelaparser_withexps.mly" ( _2 ) # 768 "src/aorai/promelaparser_withexps.ml" : 'access_leaf)) (* Entry promela *) ; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) |] let yytables = { Parsing.actions=yyact; Parsing.transl_const=yytransl_const; Parsing.transl_block=yytransl_block; Parsing.lhs=yylhs; Parsing.len=yylen; Parsing.defred=yydefred; Parsing.dgoto=yydgoto; Parsing.sindex=yysindex; Parsing.rindex=yyrindex; Parsing.gindex=yygindex; Parsing.tablesize=yytablesize; Parsing.table=yytable; Parsing.check=yycheck; Parsing.error_function=parse_error; Parsing.names_const=yynames_const; Parsing.names_block=yynames_block } let promela (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = (Parsing.yyparse yytables 1 lexfun lexbuf : Promelaast.parsed_automaton) frama-c-Fluorine-20130601/src/aorai/aorai_option.ml0000644000175000017500000001416312155630222020677 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Aorai plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'nergie atomique et aux nergies *) (* alternatives) *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* INSA (Institut National des Sciences Appliquees) *) (* *) (* 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 = "aorai" let shortname = "aorai" let help = "verification of behavioral properties (experimental)" end) module Ltl_File = EmptyString (struct let option_name = "-aorai-ltl" let arg_name = "" let help = "specifies file name for LTL property" end) module To_Buchi = EmptyString (struct let option_name = "-aorai-to-buchi" let arg_name = "f" let help = "only generates the buchi automata (in Promela language) in file " end) module Buchi = EmptyString (struct let option_name = "-aorai-buchi" let arg_name = "f" let help = "considers the property described by the buchi automata \ (in Promela language) from file ." end) module Ya = EmptyString (struct let option_name = "-aorai-automata" let arg_name = "f" let help = "considers the property described by the ya automata \ (in Ya language) from file ." end) module Output_Spec = False(struct let option_name = "-aorai-show-op-spec" let help = "displays computed pre and post-condition of each operation" end) module Output_C_File = EmptyString (struct let option_name = "-aorai-output-c-file" let arg_name = "" let help = "specifies generated file name for annotated C code" end) module Dot = False(struct let option_name = "-aorai-dot" let help = "generates a dot file of the Buchi automata" end) module DotSeparatedLabels = False(struct let option_name = "-aorai-dot-sep-labels" let help = "tells dot to not output guards directly over the edges" end) module AbstractInterpretation = False(struct let option_name = "-aorai-simple-AI" let help = "use simple abstract interpretation" end) module AbstractInterpretationOff = False(struct let option_name = "-aorai-AI-off" let help = "does not use abstract interpretation" end) let () = Plugin.set_negative_option_name "-aorai-spec-off" module Axiomatization = True(struct let option_name = "-aorai-spec-on" let help = "if set, does not axiomatize automata" end) module ConsiderAcceptance = False(struct let option_name = "-aorai-acceptance" let help = "if set, considers acceptation states" end) let () = Plugin.set_negative_option_name "-aorai-raw-auto" module AutomataSimplification= True (struct let option_name = "-aorai-simplified-auto" let help = "If set, does not simplify automata" end) module Test = Zero(struct let option_name = "-aorai-test" let arg_name = "" let help = "Testing mode (0 = no test)" end) module AddingOperationNameAndStatusInSpecification = False (struct let option_name = "-aorai-add-oper" let help = "Adding current operation name (and statut) in pre/post \ conditions" end) module Deterministic= State_builder.Ref (Datatype.Bool) (struct let name = "Aorai_option.Deterministic" let dependencies = [] let default () = false end) let is_on () = not (Ltl_File.is_default () && To_Buchi.is_default () && Buchi.is_default () && Ya.is_default () ) (* [JS 2009/10/04] Preserve the behaviour of svn release <= r5012. However it works only if aorai is run from the command line. *) let init () = if is_on () then begin Kernel.SimplifyCfg.on (); Kernel.KeepSwitch.on () end let () = Cmdline.run_after_configuring_stage init let promela_file () = if Buchi.get () = "" then To_Buchi.get () else Buchi.get () let advance_abstract_interpretation () = not (AbstractInterpretationOff.get ()) && not (AbstractInterpretation.get ()) let emitter = Emitter.create "Aorai" [ Emitter.Code_annot; Emitter.Funspec; Emitter.Global_annot ] ~correctness: [ Ltl_File.parameter; To_Buchi.parameter; Buchi.parameter; Ya.parameter; Axiomatization.parameter; ConsiderAcceptance.parameter; AutomataSimplification.parameter ] ~tuning: [ AbstractInterpretation.parameter; AddingOperationNameAndStatusInSpecification.parameter ] (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/obfuscator/0000755000175000017500000000000012155634043016736 5ustar mehdimehdiframa-c-Fluorine-20130601/src/obfuscator/Obfuscator.mli0000644000175000017500000000341712155630236021555 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Obfuscator plug-in. *) (** No function is directly exported: they are registered via {!Dynamic.register}. *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/obfuscator/configure0000755000175000017500000027434112155634042020657 0ustar mehdimehdi#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME= PACKAGE_TARNAME= PACKAGE_VERSION= PACKAGE_STRING= PACKAGE_BUGREPORT= PACKAGE_URL= ac_unique_file="Makefile.in" ac_subst_vars='LTLIBOBJS LIBOBJS DYNAMIC_OBFUSCATOR ENABLE_OBFUSCATOR ENABLE_GUI FRAMAC_VERSION 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_obfuscator with_obfuscator_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= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures this package to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then cat <<\_ACEOF 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-obfuscator support for Obfuscator 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-obfuscator-static link obfuscator 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.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu 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 FRAMAC_VERSION=`frama-c -version | sed -n -e "s|^Version: *\(.*\)$|\1|p"` # 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 ${ac_cv_prog_ENABLE_GUI+:} false; 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 as_fn_executable_p "$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 ${ac_cv_file_Makefile_in+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "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" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-obfuscator was given. if test "${enable_obfuscator+set}" = set; then : enableval=$enable_obfuscator; 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 $? "obfuscator is not available" "$LINENO" 5 fi FORCE_OBFUSCATOR=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_OBFUSCATOR ENABLE_OBFUSCATOR=$ENABLE NAME_OBFUSCATOR=obfuscator if test "$default" = "no" -a "$FORCE" = "no"; then INFO_OBFUSCATOR=" (not available by default)" fi # Dynamic plug-ins configuration # Check whether --with-obfuscator-static was given. if test "${with_obfuscator_static+set}" = set; then : withval=$with_obfuscator_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_OBFUSCATOR=$is_static if test "$is_static" != "yes"; then USE_NATIVE_DYNLINK="${USE_NATIVE_DYNLINK} obfuscator" DYNAMIC_OBFUSCATOR=yes else DYNAMIC_OBFUSCATOR=no fi echo "obfuscator... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) 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 if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\[/\\&/g s/\]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "./Makefile") 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= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" eval set X " :F $CONFIG_FILES " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac 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 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi frama-c-Fluorine-20130601/src/obfuscator/Makefile.in0000644000175000017500000000442212155630236021005 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## 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 ?=. PLUGIN_ENABLE:=@ENABLE_OBFUSCATOR@ PLUGIN_DYNAMIC:=@DYNAMIC_OBFUSCATOR@ PLUGIN_NAME:=Obfuscator PLUGIN_CMO:= obfuscator_register PLUGIN_HAS_MLI:=yes PLUGIN_DISTRIB_EXTERNAL:= Makefile.in configure.ac configure PLUGIN_NO_TEST:=yes include $(FRAMAC_SHARE)/Makefile.dynamic # Regenerating the Makefile on need ifeq ("$(FRAMAC_INTERNAL)","yes") CONFIG_STATUS_DIR=$(FRAMAC_SRC) else CONFIG_STATUS_DIR=. endif $(Obfuscator_DIR)/Makefile: $(Obfuscator_DIR)/Makefile.in \ $(CONFIG_STATUS_DIR)/config.status cd $(CONFIG_STATUS_DIR) && ./config.status frama-c-Fluorine-20130601/src/obfuscator/obfuscator_register.ml0000644000175000017500000000651612155630236023353 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.Register (struct let name = "obfuscator" let shortname = "obfuscator" let help = "objuscator for confidential code" end) module Run = False (struct let option_name = "-obfuscate" let help = "print an obfuscated version of the input files and exit.\n\ Disable any other Frama-C analysis." end) let disable_other_analyzers () = if Run.get () then let selection = State_selection.Static.diff (Plugin.get_selection ()) (State_selection.Static.union (State_selection.singleton Run.self) (* The command-line options that govern the creation of the AST must be preserved *) (State_selection.Static.with_codependencies Ast.self)) in Project.clear ~selection () let () = Cmdline.run_after_configuring_stage disable_other_analyzers let obfuscate_code code_fmt = let ast = Ast.get () in let dictionary = Obfuscate.obfuscate ast in Format.fprintf code_fmt "// Start of dictionary for obfuscation:@\n"; let sorted_dictionary = Hashtbl.fold Datatype.String.Map.add dictionary Datatype.String.Map.empty in Datatype.String.Map.iter (fun k v -> Format.fprintf code_fmt "#define %s %s@\n" k v) sorted_dictionary; Format.fprintf code_fmt "// End of dictionary for obfuscation.@\n"; Format.fprintf code_fmt "@[%a@]" Printer.pp_file ast let force_run () = Kernel.CodeOutput.output obfuscate_code let force_run = Dynamic.register ~plugin:"Obfuscator" "force_run" (Datatype.func Datatype.unit Datatype.unit) ~journalize:true force_run let run () = if Run.get () then begin force_run (); raise Cmdline.Exit end let () = Db.Main.extend run (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/obfuscator/configure.ac0000644000175000017500000000403512155630236021226 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## 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(obfuscator,PLUGIN_RELATIVE_PATH(plugin_file),[support for Obfuscator plug-in],yes,yes) write_plugin_config(Makefile) frama-c-Fluorine-20130601/src/occurrence/0000755000175000017500000000000012155634040016714 5ustar mehdimehdiframa-c-Fluorine-20130601/src/occurrence/Occurrence.mli0000644000175000017500000000341212155630233021507 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Occurence plug-in. *) (** No function is directly exported: they are registered in {!Db.Occurrence}. *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/occurrence/options.ml0000644000175000017500000000372212155630233020745 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.Register (struct let name = "occurrence" let shortname = "occurrence" let help = "automatically computes where variables are used" end) module Print = False (struct let option_name = "-occurrence" let help = "print results of occurrence analysis" end) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/occurrence/register_gui.mli0000644000175000017500000000354512155630233022116 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* $Id: register_gui.mli,v 1.4 2008-11-26 15:50:25 uid568 Exp $ *) (** Extension of the GUI for the occurrence plugin. *) (** No function is directly exported: this module simply extends the GUI. *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.. -j" End: *) frama-c-Fluorine-20130601/src/occurrence/options.mli0000644000175000017500000000330512155630233021113 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.S module Print: Plugin.Bool (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/occurrence/register.ml0000644000175000017500000002023212155630233021071 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Cil open Visitor open Options module Occurrence_datatype = Datatype.Triple(Datatype.Option(Kernel_function))(Kinstr)(Lval) module Occurrences: sig val add: varinfo -> kernel_function option -> kinstr -> lval -> unit val get: varinfo -> (kernel_function option * kinstr * lval) list val self: State.t val iter: (varinfo -> (kernel_function option * kinstr * lval) list -> unit) -> unit val iter_sorted: (varinfo -> (kernel_function option * kinstr * lval) list -> unit) -> unit end = struct module IState = Cil_state_builder.Varinfo_hashtbl (Occurrence_datatype) (struct let size = 17 let name = "Occurrences.State" let dependencies = [ Db.Value.self ] end) module LastResult = State_builder.Option_ref (Varinfo) (struct let name = "Occurrences.LastResult" let dependencies = [ Ast.self; IState.self ] end) let add vi kf ki lv = IState.add vi (kf, ki, lv) let unsafe_get vi = try IState.find_all vi with Not_found -> [] let get vi = LastResult.set vi; unsafe_get vi let get_last_result () = try let vi = LastResult.get () in Some (unsafe_get vi, vi) with Not_found -> None let () = Db.register Db.Journalization_not_required Db.Occurrence.get_last_result get_last_result let iter_aux fold f = let old, l = 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, []) in Extlib.may (fun v -> f v l) old let fold_sorted f init = let map = IState.fold Varinfo.Map.add Varinfo.Map.empty in Varinfo.Map.fold f map init let iter = iter_aux IState.fold let iter_sorted = iter_aux fold_sorted let self = IState.self end class occurrence = object (self) inherit Visitor.frama_c_inplace as super method vlval lv = let ki = self#current_kinstr in if Db.Value.is_accessible ki then begin let z = !Db.Value.lval_to_zone ki ~with_alarms:CilE.warn_none_mode lv in try Locations.Zone.fold_topset_ok (fun b _ () -> match b with | Base.Var (vi, _) | Base.Initialized_Var (vi, _) -> Occurrences.add vi self#current_kf ki lv | _ -> () ) z () with Locations.Zone.Error_Top -> error ~current:true "Found completely imprecise value (%a). Ignoring@." Printer.pp_lval lv end; DoChildren method vterm_lval tlv = (try let lv = !Db.Properties.Interp.term_lval_to_lval ~result:None tlv in ignore (self#vlval lv) with | Invalid_argument "not an lvalue" -> () (* Translation to lval failed.*) | Invalid_argument msg -> error ~current:true "%s@." msg); DoChildren method vstmt_aux s = !Db.progress (); super#vstmt_aux s initializer !Db.Value.compute () end type access_type = Read | Write | Both (** Try to find [lv] somewhere within a Cil value *) class is_sub_lval lv = object inherit Cil.nopCilVisitor method vlval lv' = if Cil_datatype.Lval.equal lv lv' then raise Exit; DoChildren end (** Occurrence has found the given [lv] somewhere inside [ki]. We try to find whether this was inside a read or a write operation. This is difficult to do directly inside the {!occurrence} class, as the [vlval] method has no information about the origin of the lval it was called on *) let classify_accesses (_kf, ki, lv) = let vis = new is_sub_lval lv in let aux f v = try ignore (f vis v); false with Exit -> true in let is_lv = Cil_datatype.Lval.equal lv in let contained_exp = aux Cil.visitCilExpr in match ki with | Kglobal -> (* Probably initializers *) Read | Kstmt { skind = Instr i } -> (match i with | Set (lv', e, _) -> if is_lv lv' then if contained_exp e then Both else Write else Read | Call (Some lv', f, args, _) -> if is_lv lv' then if contained_exp f || List.exists contained_exp args then Both else Write else Read | Asm (_, _, out, inp, _, _) -> if List.exists (fun (_, _, out) -> is_lv out) out then if List.exists (fun (_, _, inp) -> contained_exp inp) inp then Both else Write else Read | _ -> Read) | _ -> Read let compute, _self = let run () = feedback "beginning analysis"; ignore (visitFramacFile (new occurrence) (Ast.get ())); feedback "analysis done" in State_builder.apply_once "Occurrence.compute" [ Occurrences.self ] run let get vi = compute (); try Occurrences.get vi with Not_found -> assert false let d_ki fmt = function | None, Kglobal -> Format.fprintf fmt "global" | Some kf, Kglobal -> Format.fprintf fmt "specification of %a" Kernel_function.pretty kf | _, Kstmt s -> Format.fprintf fmt "sid %d" s.sid let print_one fmt v l = Format.fprintf fmt "variable %s (%s):@\n" v.vname (if v.vglob then "global" else let kf_name = match l with | [] -> assert false | (Some kf, _, _) :: _ -> Kernel_function.get_name kf | (None,Kstmt _,_)::_ -> assert false | (None,Kglobal,_)::_ -> fatal "inconsistent context for occurence of variable %s" v.vname in if v.vformal then "parameter of " ^ kf_name else "local of " ^ kf_name); List.iter (fun (kf, ki, lv) -> Format.fprintf fmt " %a: %a@\n" d_ki (kf,ki) Printer.pp_lval lv) l let print_all () = compute (); result "%t" (fun fmt -> Occurrences.iter_sorted (print_one fmt)) let main _fmt = if Print.get () then !Db.Occurrence.print_all () let () = Db.Main.extend main let () = Db.register (Db.Journalize ("Occurrence.get", 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(Occurrence_datatype) in L.ty))) Db.Occurrence.get get; Db.register (Db.Journalize ("Occurrence.print_all", Datatype.func Datatype.unit Datatype.unit)) (* pb: print_all should take a formatter as argument *) Db.Occurrence.print_all print_all; Db.Occurrence.self := Occurrences.self (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/occurrence/register_gui.ml0000644000175000017500000002064112155630233021741 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Pretty_source open Gtk_helper open Cil_types open Cil_datatype (* Update the 'Occurrence' column of the gui filetree. *) let update_column = ref (fun _ -> ()) (* Are results shown? *) module Enabled = State_builder.Ref (Datatype.Bool) (struct let name = "Occrrence_gui.State" let dependencies = [!Db.Occurrence.self] let default () = false end) module ShowRead = State_builder.Ref (Datatype.Bool) (struct let name = "Occrrence_gui.ShowRead" let dependencies = [] let default () = true end) module ShowWrite = State_builder.Ref (Datatype.Bool) (struct let name = "Occrrence_gui.ShowWrite" let dependencies = [] let default () = true end) let consider_access () = match ShowRead.get (), ShowWrite.get () with | false, false -> (fun _ -> false) | true, true -> (fun _ -> true) | true, false -> (fun ak -> ak = Register.Read || ak = Register.Both) | false, true -> (fun ak -> ak = Register.Write || ak = Register.Both) let filter_accesses l = match ShowRead.get (), ShowWrite.get () with | false, false -> [] | true, true -> l | true, false | false, true -> let f = consider_access () in List.filter (fun access -> f (Register.classify_accesses access)) l let _ = Dynamic.register ~plugin:"Occurrence" ~journalize:false "Enabled.set" (Datatype.func Datatype.bool Datatype.unit) Enabled.set let _ = Dynamic.register ~plugin:"Occurrence" ~journalize:false "Enabled.get" (Datatype.func Datatype.unit Datatype.bool) Enabled.get let find_occurrence (main_ui:Design.main_window_extension_points) vi () = ignore (!Db.Occurrence.get vi); Enabled.set true; !update_column `Contents; main_ui#rehighlight () let apply_on_vi f localizable = match localizable with | PVDecl(_,vi) | PLval(_, _, (Var vi, NoOffset)) | PTermLval(_, _, (TVar { lv_origin = Some vi }, TNoOffset)) -> if not (Cil.isFunctionType vi.vtype) then f vi | _ -> () let occurrence_highlighter buffer loc ~start ~stop = if Enabled.get () then match !Db.Occurrence.get_last_result () with | None -> (* occurrence not computed *) () | Some (result, vi) -> let result = filter_accesses result in let highlight () = 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 (_kf, 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 (_kf, 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 () | PVDecl(_, vi') when Varinfo.equal vi vi' -> highlight () | PVDecl _ | PStmt _ | PGlobal _ | PIP _ -> () module FollowFocus = State_builder.Ref (Datatype.Bool) (struct let name = "Occurrence_gui.FollowFocus" let dependencies = [] let default () = false end) let occurrence_panel main_ui = let w = GPack.vbox () in (* Selected Var display *) let selected_var_box = GPack.hbox ~packing:w#pack () in ignore (GMisc.label ~xalign:0.0 ~text:"Current var: " ~packing:(selected_var_box#pack ~expand:false) ()); let e = GMisc.label ~xalign:0.0 ~selectable:true ~packing:(selected_var_box#pack ~expand:true ~fill:true) () in e#set_use_markup true; old_gtk_compat e#set_single_line_mode true; (* check_button enabled *) let refresh_enabled_button = on_bool w "Enable" Enabled.get (fun v -> Enabled.set v; !update_column `Visibility; main_ui#rehighlight ()) in (* check_button followFocus *) let refresh_followFocus = on_bool w "Follow focus" FollowFocus.get FollowFocus.set in let h_read_write = GPack.hbox ~packing:w#pack () in let refresh_rw_aux f v = f v; main_ui#file_tree#reset(); main_ui#rehighlight () in let refresh_read = Gtk_helper.on_bool ~tooltip:"Show only occurrences where the zone is read" h_read_write "Read" ShowRead.get (refresh_rw_aux ShowRead.set) in let refresh_write = Gtk_helper.on_bool ~tooltip:"Show only occurrences where the zone is written" h_read_write "Write" ShowWrite.get (refresh_rw_aux ShowWrite.set) in let refresh = let old_vi = ref (-2) in (fun () -> refresh_read(); refresh_write (); refresh_followFocus (); refresh_enabled_button (); let new_result = !Db.Occurrence.get_last_result () in (match new_result with | None when !old_vi<> -1 -> old_vi := -1; e#set_label "None" | Some (_,vi) when vi.vid<> !old_vi-> old_vi := vi.vid; e#set_label vi.vname | _ -> ())) in "Occurrence",w#coerce,Some refresh let occurrence_selector (popup_factory:GMenu.menu GMenu.factory) main_ui ~button localizable = apply_on_vi (fun vi -> if button = 3 || FollowFocus.get () then begin 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)) end) localizable let file_tree_decorate (file_tree:Filetree.t) = update_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 (kf,ki,_ as access) = (let ak = Register.classify_accesses access in consider_access () ak) && match ki with | Kglobal -> false | Kstmt _ -> let kf = Extlib.the kf in let v0 = Kernel_function.get_vi kf in List.exists (fun glob -> match glob with | GFun ({svar =v1},_ ) -> Varinfo.equal v1 v0 | _ -> false) globs in if List.exists in_globals result then [`STOCK_ID "gtk-apply"] else [`STOCK_ID ""]) (fun () -> Enabled.get ()); !update_column `Visibility 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; ;; let () = Design.register_extension main (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/constant_propagation/0000755000175000017500000000000012155634040021020 5ustar mehdimehdiframa-c-Fluorine-20130601/src/constant_propagation/propagationParameters.mli0000644000175000017500000000336212155630235026100 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Plugin module SemanticConstFolding: Bool module SemanticConstFold: String_set module CastIntro: Bool module ExpandLogicContext: Bool include Log.Messages frama-c-Fluorine-20130601/src/constant_propagation/Constant_Propagation.mli0000644000175000017500000000344512155630235025667 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* $Id: Constant_Propagation.mli,v 1.6 2008-04-01 09:25:20 uid568 Exp $ *) (** Constant propagation analysis. *) (** No function is directly exported: they are registered in {!Db.Constant_Propagation}. *) frama-c-Fluorine-20130601/src/constant_propagation/register.ml0000644000175000017500000002702612155630235023207 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Cil_types module FC_file = File open Cil_datatype open Db exception Cannot_expand (** This visitor also performs a deep copy. *) class propagate project fnames ~cast_intro = object(self) inherit Visitor.frama_c_copy project val mutable operate = false val mutable known_globals = Varinfo.Set.empty val mutable must_add_decl = Varinfo.Set.empty method private on_current_stmt nothing f = match self#current_stmt with | None | Some ({ skind = Return _}) -> nothing | Some _ when not operate -> nothing | Some stmt -> f (Kstmt stmt) method vfunc fundec = let name = fundec.svar.vname in operate <- Datatype.String.Set.is_empty fnames || Datatype.String.Set.mem name fnames; if operate then PropagationParameters.feedback ~level:2 "propagated constant in function %s" (fundec.svar.vname); DoChildren method vexpr expr = self#on_current_stmt DoChildren (fun ki -> PropagationParameters.debug ~level:2 "Replacing %a?" Printer.pp_exp expr; let type_of_expr = typeOf expr in try begin match unrollType type_of_expr with | (TInt _ | TFloat _ | TPtr _ | TEnum _) -> () | _ -> raise Cannot_expand end; let mkCast ~e ~newt = (* introduce a new cast or do not expand [e] *) let exp = mkCast e newt in if cast_intro then exp else match exp.enode with | CastE _ -> if exp == e (* older cast, no new cast added *) then exp else (* without [cast_intro], introducing such a cast is not allowed: do not expand [e] *) raise Cannot_expand | _ -> (* remember the change done by [mkCast] (if any). note that [mkCast] make some modifications, even if it does not introduce a new cast. *) exp in let evaled = !Value.access_expr ki expr in let k,m = Cvalue.V.find_lonely_binding evaled in let can_replace vi = vi.vglob || Extlib.may_map (Kernel_function.is_formal_or_local vi) ~dft:false self#current_kf in begin match k with | Base.Var(vi,_) | Base.Initialized_Var (vi,_) when (PropagationParameters.ExpandLogicContext.get () || not vi.vlogic) && can_replace vi -> if vi.vglob && not (Varinfo.Set.mem vi known_globals) then begin let vi = Visitor.visitFramacVarDecl (self :> Visitor.frama_c_visitor) vi in must_add_decl <- Varinfo.Set.add vi must_add_decl end; (* This is a pointer coming for C code *) PropagationParameters.debug "Trying replacing %a from a pointer value {&%a + %a}" Printer.pp_exp expr Base.pretty k Ival.pretty m; let base = mkAddrOrStartOf ~loc:expr.eloc (var vi) in let offset = Ival.project_int m in (* these are bytes *) let shifted = if Abstract_interp.Int.is_zero offset then base else let offset,rem = let sizeof_pointed = try Int_Base.project (if isArrayType vi.vtype then Bit_utils.osizeof_pointed vi.vtype else Bit_utils.osizeof vi.vtype) with | Int_Base.Error_Top -> raise Cannot_expand in (Abstract_interp.Int.pos_div offset sizeof_pointed), (Abstract_interp.Int.pos_rem offset sizeof_pointed) in let shifted = if Abstract_interp.Int.is_zero offset then base else let v1 = Abstract_interp.Int.cast ~signed:true ~size:(Abstract_interp.Int.of_int 64) ~value:offset in increm64 base v1 in if Abstract_interp.Int.is_zero rem then shifted else let v1 = Abstract_interp.Int.cast ~signed:true ~size:(Abstract_interp.Int.of_int 64) ~value:rem in increm64 (mkCast ~e:shifted ~newt:Cil.charPtrType) v1 in let change_to = (* Give it the right type! *) mkCast ~e:shifted ~newt:type_of_expr in PropagationParameters.debug "Replacing %a with %a" Printer.pp_exp expr Printer.pp_exp change_to; ChangeDoChildrenPost (change_to, fun x -> x) | Base.Null -> let e = begin try (* This is an integer *) let v = Ival.project_int m in PropagationParameters.debug "Trying to replace %a with a numeric value: %a" Printer.pp_exp expr Abstract_interp.Int.pretty v; try let v1 = Abstract_interp.Int.cast ~signed:true ~size:(Abstract_interp.Int.of_int 64) ~value:v in PropagationParameters.debug ~level:2 "Before v=%a after as signed int64 v1=%a" Abstract_interp.Int.pretty v Abstract_interp.Int.pretty v1; kinteger64 ~loc:expr.eloc IULongLong v1 with Failure _ -> raise Cannot_expand with Ival.Not_Singleton_Int-> (* TODO: floats *) raise Cannot_expand end in let change_to = (* Give it the right type ! *) mkCast ~e ~newt:(type_of_expr) in PropagationParameters.debug "Replacing %a with %a (was %a)" Printer.pp_exp expr Printer.pp_exp change_to Printer.pp_exp e; ChangeDoChildrenPost(change_to,fun x -> x) | Base.String _ | Base.Var _ | Base.Initialized_Var _ -> DoChildren end with Not_found | Cannot_expand -> DoChildren) method vvdec v = if v.vglob then known_globals <- Varinfo.Set.add v known_globals; DoChildren method vglob_aux _ = must_add_decl <- Varinfo.Set.empty; let add_decl l = Varinfo.Set.fold (fun x l -> PropagationParameters.feedback ~level:2 "Adding declaration of global %a" Printer.pp_varinfo x; GVarDecl(Cil.empty_funspec(),x,x.vdecl)::l) must_add_decl l in DoChildrenPost add_decl method vlval lv = let simplify (host,offs as lv) = match host with | Mem e -> mkMem e offs (* canonicalize *) | Var _ -> lv in ChangeDoChildrenPost(lv, simplify) end module Result_pair = Datatype.Pair_with_collections(Datatype.String.Set)(Datatype.Bool) (struct let module_name = "Constant_propagation.Register.Result_pair.t" end) module Result = State_builder.Hashtbl (Datatype.Hashtbl (Result_pair.Hashtbl) (Result_pair) (struct let module_name = "Semantical constant propagation" end)) (Project.Datatype) (struct let size = 7 let name = "Semantical constant propagation" let dependencies = [ Value.self; PropagationParameters.CastIntro.self ] end) let journalized_get = let get fnames cast_intro = Result.memo (fun _ -> !Value.compute (); let fresh_project = FC_file.create_project_from_visitor "propagated" (fun prj -> new propagate prj fnames cast_intro) in let ctx = Plugin.get_selection_context () in Project.copy ~selection:ctx fresh_project; fresh_project) (fnames, cast_intro) in Journal.register "!Db.Constant_Propagation.get" (Datatype.func2 Datatype.String.Set.ty ~label2:("cast_intro",None) Datatype.bool Project.ty) get (* add labels *) let get fnames ~cast_intro = journalized_get fnames cast_intro (** Constant Propagation *) let compute () = PropagationParameters.feedback "beginning constant propagation"; let fnames = PropagationParameters.SemanticConstFold.get () in let cast_intro = PropagationParameters.CastIntro.get () in let propagated = !Db.Constant_Propagation.get fnames cast_intro in if PropagationParameters.SemanticConstFolding.get () then FC_file.pretty_ast ~prj:propagated (); PropagationParameters.feedback "constant propagation done" let main () = let force_semantic_folding = PropagationParameters.SemanticConstFolding.get () || not (Datatype.String.Set.is_empty (PropagationParameters.SemanticConstFold.get ())) in (* must called the function stored in [Db] for journalisation purpose *) if force_semantic_folding then !Db.Constant_Propagation.compute () let () = Db.Main.extend main; Db.register Db.Journalization_not_required Db.Constant_Propagation.get get; let _self = Db.register_compute "Constant_Propagation.compute" [ PropagationParameters.SemanticConstFold.self; PropagationParameters.SemanticConstFolding.self; Result.self ] Db.Constant_Propagation.compute compute; in () (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/constant_propagation/propagationParameters.ml0000644000175000017500000000563512155630235025734 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Constant Propagation *) include Plugin.Register (struct let name = "semantic constant folding" let shortname = "scf" let help = "propagates constants semantically" end) module SemanticConstFolding = False (struct let option_name = "-scf" let help = "pretty print a version of the source code where each constant expression is replaced by its value" end) let () = SemanticConstFolding.add_aliases ["-semantic-const-folding"] module SemanticConstFold = StringSet (struct let option_name = "-scf-fct" let arg_name = "f1, ..., fn" let help = "propagate constants only into functions f1,...,fn" end) let () = SemanticConstFold.add_aliases ["-semantic-const-fold"] module CastIntro = False (struct let option_name = "-scf-allow-cast" let help = "replace expressions by constants even when doing so \ requires a pointer cast" end) let () = CastIntro.add_aliases ["-cast-from-constant"] module ExpandLogicContext = False (struct let option_name = "-scf-logic" let help = "replace values from logical context and create corresponding variables (HIGHLY EXPERIMENTAL)" end) let () = ExpandLogicContext.add_aliases ["-semantic-const-fold-logic"] (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/constant_propagation/register.mli0000644000175000017500000000323112155630235023350 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Nothing is exported here Functions are registered in {!Db}. *) frama-c-Fluorine-20130601/src/slicing/0000755000175000017500000000000012155634040016214 5ustar mehdimehdiframa-c-Fluorine-20130601/src/slicing/fct_slice.mli0000644000175000017500000000733312155630217020662 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 SlicingInternals open Cil_types (** * @raise SlicingTypes.ExternalFunction if the function has no source code, * because there cannot be any slice for it. * @raise SlicingTypes.NoPdg when there is no PDG for the function. *) val make_new_ff : fct_info -> bool -> fct_slice * criterion list val merge_slices : fct_slice -> fct_slice -> fct_slice * criterion list val copy_slice : fct_slice -> fct_slice val filter_already_in : fct_slice -> fct_base_criterion -> fct_base_criterion val apply_add_marks : fct_slice -> fct_base_criterion -> criterion list val add_marks_to_fi : project -> fct_info -> fct_base_criterion -> bool -> criterion list -> bool * criterion list val add_top_mark_to_fi : fct_info -> pdg_mark -> bool -> criterion list -> criterion list val check_outputs_before_change_call : project -> fct_slice -> stmt -> fct_slice -> criterion list val apply_change_call : project -> fct_slice -> stmt -> called_fct -> criterion list val apply_choose_call : project -> fct_slice -> stmt -> criterion list val apply_missing_inputs : project -> fct_slice -> stmt -> (fct_base_criterion * bool) -> criterion list val apply_missing_outputs : project -> fct_slice -> stmt -> fct_base_criterion -> bool -> criterion list val apply_examine_calls : fct_slice -> pdg_mark PdgMarks.info_called_outputs -> criterion list val get_called_slice : fct_slice -> stmt -> (fct_slice option * bool) val get_node_mark : fct_slice -> PdgTypes.Node.t -> pdg_mark val get_node_key_mark : fct_slice -> PdgIndex.Key.t -> pdg_mark val get_top_input_mark : fct_info -> pdg_mark val get_stmt_mark : fct_slice -> stmt -> pdg_mark val get_label_mark : fct_slice -> stmt -> label -> pdg_mark val get_param_mark : fct_slice -> int -> pdg_mark val get_local_var_mark : fct_slice -> varinfo -> pdg_mark val get_input_loc_under_mark : fct_slice -> Locations.Zone.t -> pdg_mark val get_mark_from_src_fun : project -> Kernel_function.t -> pdg_mark val merge_inputs_m1_mark : fct_slice -> pdg_mark val clear_ff : project -> fct_slice -> unit val print_ff_sig : Format.formatter -> fct_slice -> unit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/slicing/slicingParameters.mli0000644000175000017500000000470412155630217022402 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Slicing *) (* include Log.Messages *) include Plugin.S (* 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 end module Mode : sig module Callers: Plugin.Bool module Calls: Plugin.Int module SliceUndef: Plugin.Bool module KeepAnnotations: Plugin.Bool end (** @since Carbon-20110201 *) module ProjectName: Plugin.String (** @since Carbon-20110201 *) module ExportedProjectPostfix: Plugin.String module Print: Plugin.Bool val is_on: unit -> bool val set_off: unit -> unit val clear: unit -> unit frama-c-Fluorine-20130601/src/slicing/slicingMarks.mli0000644000175000017500000000655012155630217021355 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 SlicingTypes val bottom_mark : sl_mark val mk_user_mark : data:bool -> addr:bool -> ctrl:bool -> sl_mark (** generated [spare] = the smallest visible mark *) val mk_gen_spare : sl_mark val mk_user_spare : sl_mark val is_bottom_mark : sl_mark -> bool val is_top_mark : sl_mark -> bool val is_spare_mark : sl_mark -> bool val is_ctrl_mark : sl_mark -> bool val is_addr_mark : sl_mark -> bool val is_data_mark : sl_mark -> bool val merge_marks : sl_mark list -> sl_mark val inter_marks : sl_mark list -> sl_mark (** [combine_marks] add a new information to the old value. * @return (new_mark, is_new) where [is_new=true] if the new mark is not included in the old one. *) val combine_marks : sl_mark -> sl_mark -> (sl_mark * sl_mark) val minus_marks : sl_mark -> sl_mark -> sl_mark val compare_marks : sl_mark -> sl_mark -> int val mark_to_string : sl_mark -> string val pretty_mark : Format.formatter -> sl_mark -> unit val missing_input_mark : call:sl_mark -> called:sl_mark -> sl_mark option val missing_output_mark : call:sl_mark -> called:sl_mark -> sl_mark option type sig_marks = sl_mark PdgIndex.Signature.t val empty_sig : sig_marks val get_input_mark : sig_marks -> int -> sl_mark val get_all_input_marks : sig_marks -> (PdgIndex.Signature.in_key * sl_mark) list val get_matching_input_marks : sig_marks -> Locations.Zone.t -> (PdgIndex.Signature.in_key * sl_mark) list val merge_inputs_m1_mark : sig_marks -> sl_mark val get_input_loc_under_mark : sig_marks -> Locations.Zone.t -> sl_mark val get_in_ctrl_mark : sig_marks -> sl_mark val something_visible : sig_marks -> bool val some_visible_out : sig_marks -> bool val is_topin_visible : sig_marks -> bool val get_marked_out_zone : sig_marks -> bool * Locations.Zone.t val pretty_sig : Format.formatter -> sig_marks -> unit frama-c-Fluorine-20130601/src/slicing/slicingTransform.mli0000644000175000017500000000467212155630217022256 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Export a CIL application from a slicing project *) 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:(Cil_types.kernel_function -> bool -> int -> string) -> string -> Db.Slicing.Project.t -> Project.t (** 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 -> 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 -> Cil_types.kernel_function -> bool frama-c-Fluorine-20130601/src/slicing/slicingParameters.ml0000644000175000017500000002157412155630217022235 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ************************************************************************* *) (** {2 Slicing options} *) (* ************************************************************************* *) include Plugin.Register (struct let name = "slicing" let shortname = "slicing" let help = "code slicer" end) module Select = struct 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" 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" end) module Threat = StringSet (struct let option_name = "-slice-threat" let arg_name = "f1, ..., fn" let help = "select the threats of functions f1,...,fn" end) module Assert = StringSet (struct let option_name = "-slice-assert" let arg_name = "f1, ..., fn" let help = "select the assertions of functions f1,...,fn" 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" 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" end) module Pragma = StringSet (struct let option_name = "-slice-pragma" let arg_name = "f1, ..., fn" let help = "use the slicing pragmas in the code of functions f1,...,fn as \ slicing criteria:\n\ //@ slice pragma ctrl; to reach this control-flow point\n\ //@ slice pragma expr to preserve the value of an expression at \ this control-flow point\n\ //@ slice pragma stmt; to preserve the effect of the next statement" end) module RdAccess = StringSet (struct 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) module WrAccess = StringSet (struct 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) module Value = StringSet (struct 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 module Mode = struct module Callers = True(struct let option_name = "-slice-callers" let help = "propagate the slicing to the function callers" 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 \ 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\ note: this value (defaults to 2) is not used for calls to undefined \ functions\n\ except when '-slice-undef-functions' option is set" 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 \ to undefined functions" end) module KeepAnnotations = False(struct 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)" end) end module ProjectName = String(struct let option_name = "-slicing-project-name" let arg_name = "ident" let help = "name of the slicing project (defaults to \"Slicing\").\ This name is used as basename when building the name of the exported project (see -slicing-exported-project-postfix option)" let default = "Slicing" end) module ExportedProjectPostfix = String(struct let option_name = "-slicing-exported-project-postfix" let arg_name = "postfix" let help = "postfix added to the slicing project name for building \ the name of the exported project (defaults to \" export\")" let default = " export" end) module Print = struct let new_command = " -then-on 'Slicing export' -print" include False(struct let option_name = "-slice-print" let help = "deprecated. Use instead " ^ new_command 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" end) module OptionModified = State_builder.Ref (Datatype.Bool) (struct let name = "Slicing.OptionModified" let dependencies = [] let default () = true end) let () = State_dependency_graph.add_codependencies ~onto:OptionModified.self [ Select.Calls.self; Select.Return.self; Select.Threat.self; Select.Assert.self; Select.LoopInv.self; Select.LoopVar.self; Select.Pragma.self; Select.RdAccess.self; Select.WrAccess.self; Select.Value.self; Mode.Callers.self; Mode.Calls.self; Mode.SliceUndef.self; Mode.KeepAnnotations.self; Print.self ] let is_on () = (Force.get () || OptionModified.get ()) && (not (Select.Calls.is_empty () && Select.Return.is_empty () && Select.Threat.is_empty () && Select.Assert.is_empty () && Select.LoopInv.is_empty () && Select.LoopVar.is_empty () && Select.Pragma.is_empty () && Select.RdAccess.is_empty () && Select.WrAccess.is_empty () && Select.Value.is_empty ())) let set_off () = Force.off () ; 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: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/slicing/slicingTransform.ml0000644000175000017500000004520212155630217022077 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Export the slicing project *) (**/**) open Cil_types open Cil (**/**) (* Look at (only once) the callers of [kf] ([kf] included). *) let exists_fun_callers fpred kf = let table = ref Cil_datatype.Varinfo.Set.empty in let rec exists_fun_callers kf = if fpred kf then true else let vf = Kernel_function.get_vi kf in if Cil_datatype.Varinfo.Set.mem vf !table then false (* no way to call the initial [kf]. *) else begin table := Cil_datatype.Varinfo.Set.add vf !table ; List.exists (fun (kf,_) -> exists_fun_callers kf) (!Db.Value.callers kf) end in exists_fun_callers kf let is_src_fun_visible prj = exists_fun_callers (SlicingMacros.is_src_fun_visible prj) let is_src_fun_called prj kf = let kf_entry, _library = Globals.entry_point () in let fpred f = if (kf_entry == f) then SlicingMacros.is_src_fun_visible prj f (* for the entry point *) else SlicingMacros.is_src_fun_called prj f (* for the others *) in exists_fun_callers fpred kf module Visibility (SliceName : sig val get : kernel_function -> bool -> int -> string end) = struct exception EraseAssigns exception EraseAllocation type proj = SlicingInternals.project type fct = | Iff of (SlicingInternals.fct_slice * bool) (* the boolean says if the src function of the slice is visible * and can be used to give names *) | Isrc | Iproto let fct_info project kf = let fi = SlicingMacros.get_kf_fi project kf in let slices = SlicingMacros.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 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 let info_list = List.map (fun ff -> Iff (ff, src_name_used)) slices in if src_visible then Isrc :: info_list else if need_addr then Iproto :: info_list (* TODO for #344 *) else info_list let fct_name svar ff = let name = match ff with | Isrc -> svar.vname | Iproto -> svar.vname | Iff (ff, src_visible) -> let kf = SlicingMacros.get_ff_kf ff in let ff_num = ff.SlicingInternals.ff_id in SliceName.get kf src_visible ff_num in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fct_name] get fct_name = %s" name; name let visible_mark m = not (!Db.Slicing.Mark.is_bottom m) let param_visible ff_opt n = match ff_opt with | Isrc | Iproto -> true | Iff (ff,_) -> visible_mark (Fct_slice.get_param_mark ff n) let body_visible ff_opt = match ff_opt with | Iproto -> false | Isrc | Iff _ -> true let inst_visible ff_opt inst = match ff_opt with | Isrc -> true | Iproto -> false | Iff (ff,_) -> let m = !Db.Slicing.Slice.get_mark_from_stmt ff inst in visible_mark m let label_visible ff_opt inst label = match ff_opt with | Isrc -> true | Iproto -> false | Iff (ff,_) -> let m = !Db.Slicing.Slice.get_mark_from_label ff inst label in let v = visible_mark m in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.label_visible] label %a is %svisible" Printer.pp_label label (if v then "" else "in"); v let data_in_visible ff data_in = match data_in with | None -> true | Some data_in -> (* it is too difficult to know if the callers of this slice * 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 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 = let m = Fct_slice.get_node_mark ff n in if !Db.Slicing.Mark.is_bottom m then begin SlicingParameters.debug ~level:3 "[SlicingTransform.Visibility.all_nodes_visible] node %a invisible" (!Db.Pdg.pretty_node true) n; false end else visi in List.fold_left is_visible true nodes exception NoDataInfo let data_nodes_visible ff (decl_nodes, data_info) = let keep_annots = SlicingParameters.Mode.KeepAnnotations.get () in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.data_nodes_visible (with keep_annots = %s)] ?" (if keep_annots then "true" else "false"); let decls_visible = all_nodes_visible ff decl_nodes in if keep_annots then decls_visible else match data_info with | None -> raise NoDataInfo | Some (data_nodes, data_in) -> let is_data_visible visi (n,z) = let key = PdgTypes.Node.elem_key n in let key = match z, key with | Some z, PdgIndex.Key.SigCallKey (call, PdgIndex.Signature.Out (PdgIndex.Signature.OutLoc out_z)) -> let z = Locations.Zone.narrow z out_z in PdgIndex.Key.call_output_key (PdgIndex.Key.call_from_id call) z | _, _ -> key in let m = Fct_slice.get_node_key_mark ff key in if !Db.Slicing.Mark.is_bottom m then begin SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.data_nodes_visible]@\n\ node %a invisible" (!Db.Pdg.pretty_node true) n; false end else visi in let visible = decls_visible && data_in_visible ff data_in in let data_visible = List.fold_left is_data_visible visible data_nodes in data_visible (* work-around to avoid outputting annotations with type errors: 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_identified_term, 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 inherit Visitor.frama_c_inplace method vlogic_var_use v = match v.lv_origin with None -> DoChildren | Some v when v.vformal && not (visible_mark (Fct_slice.get_param_mark ff (Kernel_function.get_formal_position v (SlicingMacros.get_ff_kf ff)+1))) (* For some reason, pdg counts parameters starting from 1 *) -> raise Exn.Invisible | Some v when not v.vglob && not (visible_mark (Fct_slice.get_local_var_mark ff v)) -> raise Exn.Invisible | Some _ -> DoChildren end in (fun ff pred -> try ignore (Visitor.visitFramacPredicate (vis ff) pred); true with Exn.Invisible -> false), (fun ff term -> try ignore (Visitor.visitFramacIdTerm (vis ff) term); true with Exn.Invisible -> false), (fun ff term -> try ignore (Visitor.visitFramacTerm (vis ff) term); true with Exn.Invisible -> false), (fun ff (b,_) -> try ignore (Visitor.visitFramacTerm (vis ff) b.it_content); true with Exn.Invisible -> false), (fun ff d -> try ignore (Visitor.visitFramacTerm (vis ff) d.it_content); true with Exn.Invisible -> false) let annotation_visible ff_opt stmt annot = SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.annotation_visible] ?"; Db.Value.is_reachable_stmt stmt && Alarms.find annot = None && (* Always drop alarms: the alarms table in the new project is not synchronized *) match ff_opt with | Isrc -> true | Iproto -> false | Iff (ff,_) -> let kf = SlicingMacros.get_ff_kf ff in let pdg = !Db.Pdg.get kf in try let ctrl_nodes, decl_nodes, data_info = !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 SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.annotation_visible] -> %s" (if visible then "yes" else "no"); visible with | NoDataInfo -> SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.annotation_visible] \ not implemented -> invisible"; false | Logic_interp.To_zone.NYI msg -> SlicingParameters.warning ~current:true ~once:true "Dropping unsupported ACSL annotation"; SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.annotation_visible] \ %s -> invisible" msg; false let fun_precond_visible ff_opt p = SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_precond_visible] %a ?" Printer.pp_predicate_named { name = []; loc = Cil_datatype.Location.unknown; content = p }; let visible = match ff_opt with | Isrc -> true | Iproto -> true | Iff (ff,_) -> let kf = SlicingMacros.get_ff_kf ff in let pdg = !Db.Pdg.get kf in try let nodes = !Db.Pdg.find_fun_precond_nodes pdg p in data_nodes_visible ff nodes with NoDataInfo -> all_logic_var_visible ff p in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.precond_visible] -> %s" (if visible then "yes" else "no"); visible let fun_postcond_visible ff_opt p = SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_postcond_visible] %a ?" Printer.pp_predicate_named { name = []; loc = Cil_datatype.Location.unknown; content = p }; let visible = match ff_opt with | Isrc -> true | Iproto -> true | Iff (ff,_) -> let kf = SlicingMacros.get_ff_kf ff in let pdg = !Db.Pdg.get kf in try let nodes = !Db.Pdg.find_fun_postcond_nodes pdg p in data_nodes_visible ff nodes with NoDataInfo -> all_logic_var_visible ff p in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_postcond_visible] -> %s" (if visible then "yes" else "no"); visible let fun_variant_visible ff_opt v = SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_variant_visible] %a ?" Printer.pp_term v ; let visible = match ff_opt with | Isrc -> true | Iproto -> true | Iff (ff,_) -> let kf = SlicingMacros.get_ff_kf ff in let pdg = !Db.Pdg.get kf in try let nodes = !Db.Pdg.find_fun_variant_nodes pdg v in data_nodes_visible ff nodes with NoDataInfo -> all_logic_var_visible_term ff v in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_variant_visible] -> %s" (if visible then "yes" else "no"); visible let fun_frees_visible ff_opt v = let keep_annots = SlicingParameters.Mode.KeepAnnotations.get () in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_frees_visible \ (with keep_annots = %B)] ?" keep_annots; if not keep_annots then raise EraseAllocation; let visible = match ff_opt with | Isrc -> true | Iproto -> true | Iff (ff,_) -> all_logic_var_visible_identified_term ff v in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_frees_visible] -> %s" (if visible then "yes" else "no"); visible let fun_allocates_visible ff_opt v = let keep_annots = SlicingParameters.Mode.KeepAnnotations.get () in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_allocates_visible \ (with keep_annots = %B)] ?" keep_annots; if not keep_annots then raise EraseAllocation; let visible = match ff_opt with | Isrc -> true | Iproto -> true | Iff (ff,_) -> all_logic_var_visible_identified_term ff v in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_allocates_visible] -> %s" (if visible then "yes" else "no"); visible let fun_assign_visible ff_opt v = let keep_annots = SlicingParameters.Mode.KeepAnnotations.get () in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_assign_visible \ (with keep_annots = %B)] ?" keep_annots; if not keep_annots then raise EraseAssigns; let visible = match ff_opt with | Isrc -> true | Iproto -> true | Iff (ff,_) -> all_logic_var_visible_assigns ff v in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_assign_visible] -> %s" (if visible then "yes" else "no"); visible let fun_deps_visible ff_opt v = let keep_annots = SlicingParameters.Mode.KeepAnnotations.get () in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_deps_visible \ (with keep_annots = %B)] ?" keep_annots; let visible = match ff_opt with | Isrc -> true | Iproto -> true | Iff (ff,_) -> all_logic_var_visible_deps ff v in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_deps_visible] -> %s" (if visible then "yes" else "no"); visible let loc_var_visible ff_opt var = match ff_opt with | Isrc -> true | Iproto -> false | Iff (ff,_) -> let m = !Db.Slicing.Slice.get_mark_from_local_var ff var in visible_mark m let res_call_visible ff call_stmt = match ff with | Isrc -> true | Iproto -> false | Iff (slice, _) -> let key = PdgIndex.Key.call_outret_key call_stmt in let _, ff_marks = slice.SlicingInternals.ff_marks in try let m = PdgIndex.FctIndex.find_info ff_marks key in visible_mark m with Not_found -> false let result_visible _kf ff = match ff with | Isrc | Iproto -> true | Iff (slice, _) -> let key = PdgIndex.Key.output_key in let _, ff_marks = slice.SlicingInternals.ff_marks in try let m = PdgIndex.FctIndex.find_info ff_marks key in visible_mark m with Not_found -> false let called_info (project, ff) call_stmt = let info = match ff with | Isrc | Iproto -> None | Iff (slice, _) -> try let _, ff_marks = slice.SlicingInternals.ff_marks in let called, _ = PdgIndex.FctIndex.find_call ff_marks call_stmt in match called with | None | Some (None) -> SlicingParameters.error "Undefined called function call-%d\n" call_stmt.sid; assert false | Some (Some (SlicingInternals.CallSrc _)) -> None | Some (Some (SlicingInternals.CallSlice ff)) -> let kf_ff = SlicingMacros.get_ff_kf ff in let src_visible = is_src_fun_visible project kf_ff in (Some (kf_ff, Iff (ff, src_visible))) with Not_found -> (* the functor should call [called_info] only for visible calls *) assert false in SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.called_info] called_info stmt %d -> %s@." call_stmt.sid (if info = None then "src" else "some slice"); info let cond_edge_visible _ff_opt s = Db.Value.condition_truth_value s end let default_slice_names kf _src_visible ff_num = let fname = Kernel_function.get_name kf in let kf_entry,_ = Globals.entry_point () in if Kernel_function.equal kf kf_entry then fname else Printf.sprintf "%s_slice_%d" fname ff_num let extract ~f_slice_names new_proj_name slicing_project = SlicingParameters.feedback ~level:1 "exporting project to '%s'..." new_proj_name; !Db.Slicing.Request.apply_all_internal slicing_project; 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 ~project:tmp_prj () in Project.remove ~project:tmp_prj (); 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; new_prj (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/slicing/slicingMacros.mli0000644000175000017500000000632512155630217021524 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** This .mli exists mainly to facilitate 'make -j'. A lot of the [get_] functions below should be inlined, as there is no good reason to treat those types as semi-private *) open SlicingInternals val str_level_option : level_option -> string val get_default_level_option : bool -> level_option val fi_svar : fct_info -> Cil_types.varinfo val ff_svar : fct_slice -> Cil_types.varinfo val get_kf_fi : project -> Kernel_function.t -> fct_info val fold_fi : ('a -> fct_info -> 'a) -> 'a -> project -> 'a val get_ff_id : fct_slice -> int val fi_name : fct_info -> string val ff_name : fct_slice -> string val f_name : fct_id -> string val ff_src_name : fct_slice -> string val get_fi_kf : fct_info -> Cil_types.kernel_function val get_ff_kf : fct_slice -> Cil_types.kernel_function val get_pdg_kf : PdgTypes.Pdg.t -> Kernel_function.t val get_fi_pdg : fct_info -> Db.Pdg.t val get_ff_pdg : fct_slice -> Db.Pdg.t val ff_slicing_level : fct_slice -> level_option val change_fi_slicing_level : fct_info -> level_option -> unit val change_slicing_level : project -> Kernel_function.t -> int -> unit val fi_slices : fct_info -> fct_slice list val equal_fi : fct_info -> fct_info -> bool val equal_ff : fct_slice -> fct_slice -> bool val same_ff_call : fct_slice * Cil_types.stmt -> fct_slice * Cil_types.stmt -> bool val is_call_stmt : Cil_types.stmt -> bool val get_fi_call : project -> Cil_types.stmt -> fct_info option val is_src_fun_called : project -> Kernel_function.t -> bool val is_src_fun_visible : project -> Kernel_function.t -> bool val fi_has_persistent_selection : fct_info -> bool val has_persistent_selection : project -> Kernel_function.t -> bool frama-c-Fluorine-20130601/src/slicing/printSlice.mli0000644000175000017500000000401712155630217021037 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 print_fct_from_pdg : Format.formatter -> ?ff:SlicingInternals.fct_slice -> PdgTypes.Pdg.t -> unit val print_marked_ff : Format.formatter -> SlicingInternals.fct_slice -> unit val print_original_glob : Format.formatter -> Cil_types.global -> unit val print_fct_stmts : Format.formatter -> (SlicingTypes.sl_project * Cil_types.kernel_function) -> unit val build_dot_project : string -> string -> SlicingInternals.project -> unit frama-c-Fluorine-20130601/src/slicing/register_gui.mli0000644000175000017500000000350412155630217021413 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* $Id: register_gui.mli,v 1.1 2008-08-19 09:28:36 uid568 Exp $ *) (** Extension of the GUI in order to support slicing visualization. No function is exported. *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.. -j" End: *) frama-c-Fluorine-20130601/src/slicing/slicingProject.ml0000644000175000017500000003656412155630217021545 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Handle the project global object. *) (**/**) module T = SlicingInternals module M = SlicingMacros (**/**) (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (** {2 Building project } *) (** API function : see {!val: Db.Slicing.Project.mk_project}. *) let mk_project name = SlicingParameters.feedback ~level:1 "making slicing project '%s'..." name; let r = { T.name = name ; T.application = Project.current () ; T.functions = Cil_datatype.Varinfo.Hashtbl.create 17; T.actions = []; } in SlicingParameters.feedback ~level:2 "done (making slicing project '%s')." name; r let get_name proj = proj.T.name (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (** {2 Managing the slices} *) let add_proj_actions proj actions = proj.T.actions <- actions @ proj.T.actions (** Add a new slice for the function. It can be the case that it create actions * if the function has some persistent selection, that make function calls to * choose. * @raise SlicingTypes.NoPdg when the function has no PDG. * *) let create_slice proj kf = let ff, actions = Fct_slice.make_new_ff (M.get_kf_fi proj kf) true in add_proj_actions proj actions; ff (** Delete [ff_to_remove] if it is not called. * @raise T.CantRemoveCalledFf if it is. *) let remove_ff proj ff_to_remove = let rec remove ff_list ff_num = match ff_list with | [] -> raise Not_found | ff :: tail -> if ff.T.ff_id = ff_num then (Fct_slice.clear_ff proj ff; tail) else ff :: (remove tail ff_num) in let fi = ff_to_remove.T.ff_fct in let ff_num = ff_to_remove.T.ff_id in let new_ff_list = remove fi.T.fi_slices ff_num in fi.T.fi_slices <- new_ff_list let call_src_and_remove_all_ff proj fi = let do_call actions (ff_caller, call_id) = let new_actions = Fct_slice.apply_change_call proj ff_caller call_id (T.CallSrc (Some fi)) in new_actions @ actions in let do_ff actions ff = let calls = ff.SlicingInternals.ff_called_by in let actions = List.fold_left do_call actions calls in remove_ff proj ff; actions in List.fold_left do_ff [] fi.T.fi_slices let rec remove_uncalled_slices proj = let kf_entry, _ = Globals.entry_point () in let entry_name = Kernel_function.get_name kf_entry in let check_ff changes ff = match ff.T.ff_called_by with [] -> remove_ff proj ff; true | _ -> changes in let check_fi changes fi = if (M.fi_name fi) <> entry_name then List.fold_left check_ff changes (M.fi_slices fi) else changes in let changes = M.fold_fi check_fi false proj in if changes then remove_uncalled_slices proj else () (** Build a new slice [ff] which contains the marks of [ff1] and [ff2] * and generate everything that is needed to choose the calls in [ff]. * If [replace] also generate requests call [ff] instead of [ff1] and [ff2]. *) let merge_slices proj ff1 ff2 replace = let ff, ff_actions = Fct_slice.merge_slices ff1 ff2 in if replace then begin let add actions (caller, call) = let rq = SlicingActions.mk_crit_change_call caller call (T.CallSlice ff) in rq :: actions in let actions = List.fold_left add [] ff2.T.ff_called_by in let actions = List.fold_left add actions ff1.T.ff_called_by in add_proj_actions proj actions end; add_proj_actions proj ff_actions; ff let split_slice proj ff = let add (actions, slices) (caller, call) = let new_ff = Fct_slice.copy_slice ff in let rq = SlicingActions.mk_crit_change_call caller call (T.CallSlice new_ff) in rq::actions, new_ff::slices in let calls = List.tl ff.T.ff_called_by in (* keep ff for the first call *) let actions, slices = List.fold_left add ([], [ff]) calls in add_proj_actions proj actions; slices (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (** {2 Getting information } *) let get_slices proj kf = M.fi_slices (M.get_kf_fi proj kf) let get_slice_callers ff = List.map (fun (ff, _) -> ff) ff.T.ff_called_by (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (** {2 Adding requests } *) let add_filter proj filter = proj.T.actions <- filter :: proj.T.actions (* let add_fct_filter proj f_id criterion = let ff_res = match f_id with | T.FctSrc fi -> Fct_slice.make_new_ff fi | T.FctSliced ff -> ff in let filter = SlicingActions.mk_ff_user_crit ff_res criterion in let _ = add_filter proj filter in ff_res *) (** Add an action to the action list to filter the function [fct_id] with the given criterion. The filter gives a name to the result of the filter which is a new slice if the function to filter is the source one, or the given slice otherwise. *) let add_fct_src_filter proj fi to_select = match to_select with (* T.CuSelect [] : don't ignore empty selection because the input control node has to be selected anyway... *) | T.CuSelect select -> let filter = SlicingActions.mk_crit_fct_user_select fi select in add_filter proj filter | T.CuTop m -> let filter = SlicingActions.mk_crit_fct_top fi m in add_filter proj filter (* let add_fct_src_filters proj fi actions = List.iter (fun a -> ignore (add_fct_src_filter proj fi a)) actions *) let add_fct_ff_filter proj ff to_select = match to_select with | T.CuSelect [] -> SlicingParameters.debug ~level:1 "[SlicingProject.add_fct_ff_filter] (ignored empty selection)" | T.CuSelect select -> let filter = SlicingActions.mk_ff_user_select ff select in add_filter proj filter | T.CuTop _ -> assert false (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (** {2 Print} *) let print_project fmt proj = let get_slices var_fct = let kf = Globals.Functions.get var_fct in let fct_info = M.get_kf_fi proj kf in M.fi_slices fct_info in let print_var_decl glob var _spec = (* might be a function prototype *) (* TODO: print the spec also *) match var.Cil_types.vtype with | Cil_types.TFun _ -> (* function prototype TODO *) PrintSlice.print_original_glob fmt glob | _ -> PrintSlice.print_original_glob fmt glob (* TODO use global marks *) in let print glob = match glob with | Cil_types.GVarDecl (spec, var, _) -> print_var_decl glob var spec | Cil_types.GFun (func, _) -> (* function definition *) let slices = get_slices func.Cil_types.svar in List.iter (PrintSlice.print_marked_ff fmt) slices (* TODO see if we have to print the original function *) | _ -> PrintSlice.print_original_glob fmt glob in let source = Ast.get () in let global_decls = source.Cil_types.globals in List.iter print global_decls let print_proj_worklist fmt proj = Format.fprintf fmt "Slicing project worklist [%s/%s] =@\n%a@.@." (Project.get_name proj.T.application) proj.T.name SlicingActions.print_list_crit proj.T.actions let print_project_and_worklist fmt proj = print_project fmt proj; print_proj_worklist fmt proj let pretty_slice fmt ff = PrintSlice.print_marked_ff fmt ff; Format.pp_print_newline fmt () (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (** {2 Managing (and applying) requests} *) (** apply the given criterion and returns the list of new criterions to add to the project worklist. *) let apply_fct_crit ff to_select = let actions = Fct_slice.apply_add_marks ff to_select in actions let apply_appli_crit proj appli_crit = match appli_crit with | T.CaCall fi_to_call -> let kf_to_call = M.get_fi_kf fi_to_call in let add_actions actions (kf_caller,_) = let fi_caller = M.get_kf_fi proj kf_caller in let mark = SlicingMarks.mk_user_spare in let action = SlicingActions.mk_crit_mark_calls fi_caller kf_to_call mark in action :: actions in List.fold_left add_actions [] (!Db.Value.callers kf_to_call) | _ -> SlicingParameters.not_yet_implemented "This slicing criterion on application" (** Add persistent the marks [node_marks] in [fi] and also add the marks * to existing slices if any. * If the propagation is ON, some actions are generated to propagate the * persistent marks to the callers, and other actions are generated to * make all the calls to [fi] visible. * If there is no slice for [fi] we create a new one * if it is the original request. * It will be automatically created with the persistent marks. * If it is a propagation, no need to create a new slice * because it will be created when the call will be selected anyway. * *) let add_persistant_marks proj fi node_marks orig propagate actions = let new_fi_marks, actions = Fct_slice.add_marks_to_fi proj fi node_marks propagate actions in let actions = match M.fi_slices fi with | [] -> (* no slice *) let actions = if orig then let _ff, new_actions = Fct_slice.make_new_ff fi true in (* TODO catch NoPdg and mark fi as Top *) new_actions @ actions else actions in actions | slices -> let add_filter acc ff = let a = SlicingActions.mk_ff_user_select ff node_marks in a::acc in List.fold_left add_filter actions slices in let actions = if propagate && new_fi_marks then let a = SlicingActions.mk_appli_select_calls fi in actions @ [a] else actions in actions let apply_fct_action proj fct_crit = match fct_crit.T.cf_fct with | T.FctSliced ff -> let _ = M.get_ff_pdg ff in let new_filters = match fct_crit.T.cf_info with | T.CcUserMark (T.CuSelect []) -> SlicingParameters.debug ~level:1 "[apply_fct_action] ignore empty selection on existing slice"; [] | T.CcUserMark (T.CuSelect crit) -> apply_fct_crit ff crit | T.CcUserMark (T.CuTop _) -> assert false (* impossible on ff ! *) | T.CcChangeCall (call, f) -> Fct_slice.apply_change_call proj ff call f | T.CcChooseCall call -> Fct_slice.apply_choose_call proj ff call | T.CcMissingInputs (call, input_marks, more_inputs) -> Fct_slice.apply_missing_inputs proj ff call (input_marks, more_inputs) | T.CcMissingOutputs (call, output_marks, more_outputs) -> Fct_slice.apply_missing_outputs proj ff call output_marks more_outputs | T.CcPropagate _ -> assert false (* not for ff at the moment *) | T.CcExamineCalls marks -> Fct_slice.apply_examine_calls ff marks in SlicingParameters.debug ~level:4 "[slicingProject.apply_fct_action] result =@\n%a" PrintSlice.print_marked_ff ff; new_filters | T.FctSrc fi -> (* the marks have to be added to all slices *) let propagate = SlicingParameters.Mode.Callers.get () in match fct_crit.T.cf_info with | T.CcUserMark (T.CuSelect to_select) -> add_persistant_marks proj fi to_select true propagate [] | T.CcUserMark (T.CuTop m) -> SlicingParameters.result ~level:1 "unable to slice %s (-> TOP)" (M.fi_name fi); let filters = call_src_and_remove_all_ff proj fi in Fct_slice.add_top_mark_to_fi fi m propagate filters | T.CcPropagate [] -> SlicingParameters.debug ~level:1 "[apply_fct_action] nothing to propagate"; [] | T.CcPropagate node_marks -> add_persistant_marks proj fi node_marks false propagate [] | T.CcExamineCalls _ | _ -> SlicingParameters.not_yet_implemented "This slicing criterion on source function" (** apply [filter] and return a list of generated filters *) let apply_action proj filter = SlicingParameters.debug ~level:1 "[SlicingProject.apply_action] : %a" SlicingActions.print_crit filter; let new_filters = try match filter with | T.CrFct fct_crit -> begin try (apply_fct_action proj fct_crit) with PdgTypes.Pdg.Bottom -> SlicingParameters.debug ~level:1 " -> action ABORTED (PDG is bottom)" ; [] end | T.CrAppli appli_crit -> apply_appli_crit proj appli_crit with Not_found -> (* catch unprocessed Not_found here *) assert false in SlicingParameters.debug ~level:1 " -> %d generated filters : %a@." (List.length new_filters) SlicingActions.print_list_crit new_filters; new_filters let get_next_filter proj = match proj.T.actions with | [] -> SlicingParameters.debug ~level:2 "[SlicingProject.get_next_filter] No more filter"; raise Not_found | f :: tail -> proj.T.actions <- tail; f let apply_next_action proj = SlicingParameters.debug ~level:2 "[SlicingProject.apply_next_action]"; let filter = get_next_filter proj in let new_filters = apply_action proj filter in proj.T.actions <- new_filters @ proj.T.actions let is_request_empty proj = proj.T.actions = [] let apply_all_actions proj = let nb_actions = List.length proj.T.actions in let rec apply actions = match actions with [] -> () | a::actions -> SlicingParameters.feedback ~level:2 "applying sub action..."; let new_filters = apply_action proj a in 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 (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/slicing/slicingProject.mli0000644000175000017500000000534312155630217021705 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* TODO: This .mli exists mainly to avoid problems with 'make -j'. Most of those functions are only exported to be registered in Register, and this should be done here instead. *) open SlicingInternals val mk_project : string -> project val get_name : project -> string val create_slice : project -> Kernel_function.t -> fct_slice val remove_ff : project -> fct_slice -> unit val remove_uncalled_slices : project -> unit val merge_slices : project -> fct_slice -> fct_slice -> bool -> fct_slice val split_slice : project -> fct_slice -> fct_slice list val get_slices : project -> Kernel_function.t -> fct_slice list val get_slice_callers : fct_slice -> fct_slice list val add_filter : project -> criterion -> unit val add_fct_src_filter : project -> fct_info -> fct_user_crit -> unit val add_fct_ff_filter : project -> fct_slice -> fct_user_crit -> unit val print_proj_worklist : Format.formatter -> project -> unit val print_project_and_worklist : Format.formatter -> project -> unit val pretty_slice : Format.formatter -> fct_slice -> unit val apply_next_action : project -> unit val is_request_empty : project -> bool val apply_all_actions : project -> unit frama-c-Fluorine-20130601/src/slicing/slicingActions.mli0000644000175000017500000000715612155630217021703 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 SlicingTypes open Cil_types open SlicingInternals type select = sl_mark PdgMarks.select (** selection mode (ie which mark to associate to the node and how to propagate in the different kinds of dependencies) *) type n_or_d_marks val build_simple_node_selection : ?nd_marks:n_or_d_marks -> sl_mark -> n_or_d_marks val build_addr_dpds_selection : ?nd_marks:n_or_d_marks -> sl_mark -> n_or_d_marks val build_data_dpds_selection : ?nd_marks:n_or_d_marks -> sl_mark -> n_or_d_marks val build_ctrl_dpds_selection : ?nd_marks:n_or_d_marks -> sl_mark -> n_or_d_marks val build_node_and_dpds_selection : ?nd_marks:n_or_d_marks -> sl_mark -> n_or_d_marks val translate_crit_to_select : Db.Pdg.t -> ?to_select:select -> ((PdgTypes.Node.t * Locations.Zone.t option) list * n_or_d_marks) list -> select val mk_fct_crit : fct_info -> fct_crit -> criterion val mk_crit_fct_user_select : fct_info -> select -> criterion val mk_crit_fct_top : fct_info -> sl_mark -> criterion val mk_crit_prop_persit_marks : fct_info -> select -> criterion val mk_ff_user_select : fct_slice -> select -> criterion val mk_crit_choose_call : fct_slice -> stmt -> criterion val mk_crit_change_call : fct_slice -> stmt -> called_fct -> criterion val mk_crit_missing_inputs : fct_slice -> stmt -> select * bool -> criterion val mk_crit_missing_outputs : fct_slice -> stmt -> select * bool -> criterion val mk_crit_examines_calls : fct_slice -> sl_mark PdgMarks.info_called_outputs -> criterion val mk_appli_select_calls : fct_info -> criterion val mk_crit_mark_calls : fct_info -> kernel_function -> sl_mark -> criterion val mk_crit_add_output_marks : fct_slice -> select -> criterion (** Printing *) val print_nd_and_mark_list : Format.formatter -> n_or_d_marks -> unit val print_nodes : Format.formatter -> PdgTypes.Node.t list -> unit val print_sel_marks_list : Format.formatter -> select -> unit val print_crit : Format.formatter -> criterion -> unit val print_f_crit : Format.formatter -> fct_user_crit -> unit val print_list_crit : Format.formatter -> criterion list -> unit frama-c-Fluorine-20130601/src/slicing/register.ml0000644000175000017500000014315512155630217020405 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 module FC_file = File open Cil_datatype let check_call stmt is_call = let err = match stmt.skind with | Instr (Call _) -> not is_call | _ -> is_call in if err then let str = if is_call then "not" else "" in let msg = "This statement is "^str^" a call" in raise (Invalid_argument msg) else stmt let _pretty_list pretty fmt l = List.iter (pretty fmt) l let print_select fmt db_select = let db_fvar, select = db_select in Format.fprintf fmt "In %a : %a" Varinfo.pretty_vname db_fvar SlicingActions.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 not (Cil_datatype.Varinfo.equal db_fvar fvar) then begin SlicingParameters.debug "slice name = %s <> select = %a@." (fvar.vname) print_select db_select ; raise (Invalid_argument "This selection doesn't belong to the given function"); end; fvar, select let empty_db_select kf = (Kernel_function.get_vi kf, SlicingInternals.CuSelect []) let top_db_select kf m = (Kernel_function.get_vi kf, SlicingInternals.CuTop m) let check_kf_db_select kf = check_db_select (Kernel_function.get_vi kf) let _check_fi_db_select fi = check_db_select (SlicingMacros.fi_svar fi) let check_ff_db_select ff = check_db_select (SlicingMacros.ff_svar ff) let bottom_msg kf = SlicingParameters.feedback "bottom PDG for function '%s': ignore selection" (Kernel_function.get_name kf) let basic_add_select kf select nodes ?(undef) nd_marks = let fvar, sel = check_kf_db_select kf select in match sel with | SlicingInternals.CuTop _ -> select | SlicingInternals.CuSelect sel -> let pdg = !Db.Pdg.get kf in let nodes = List.map (fun n -> (n, None) (*TODO: add z_part ? *)) nodes in (* let nd_marks = SlicingActions.build_node_and_dpds_selection mark in *) (* let nd_marks = SlicingActions.build_simple_node_selection mark in *) let crit = [(nodes, nd_marks)] in let sel = SlicingActions.translate_crit_to_select pdg ~to_select:sel crit in let sel = match undef with None -> sel | Some (undef, mark) -> PdgMarks.add_undef_in_to_select sel undef mark in let sel = SlicingInternals.CuSelect sel in (fvar, sel) let select_pdg_nodes kf ?(select=empty_db_select kf) nodes mark = SlicingParameters.debug ~level:1 "[Register.select_pdg_nodes]" ; let nd_marks = SlicingActions.build_node_and_dpds_selection mark in try basic_add_select kf select nodes nd_marks with Db.Pdg.Top | Db.Pdg.Bottom -> assert false (* if we have node, we must have a pdg somewhere ! *) let mk_select pdg sel nodes undef mark = let nd_marks = SlicingActions.build_simple_node_selection mark in let crit = [(nodes, nd_marks)] in let sel = SlicingActions.translate_crit_to_select pdg ~to_select:sel crit in let sel = PdgMarks.add_undef_in_to_select sel undef mark in let sel = SlicingInternals.CuSelect sel in sel let select_stmt_zone kf ?(select=empty_db_select kf) stmt ~before loc mark = SlicingParameters.debug ~level:1 "[Register.select_stmt_zone] %a %s stmt %d (m=%a)" Locations.Zone.pretty loc (if before then "before" else "after") stmt.sid SlicingMarks.pretty_mark mark; let fvar, sel = check_kf_db_select kf select in match sel with | SlicingInternals.CuTop _ -> select | SlicingInternals.CuSelect sel -> try let pdg = !Db.Pdg.get kf in let nodes, undef = !Db.Pdg.find_location_nodes_at_stmt pdg stmt before loc in let sel = mk_select pdg sel nodes undef mark in (fvar, sel) with | 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 | Db.Pdg.Top -> top_db_select kf mark | Db.Pdg.Bottom -> bottom_msg kf; select (** this one is similar to [select_stmt_zone] with the return statement * when the function is defined, but it can also be used for undefined functions. *) let select_in_out_zone ~at_end ~use_undef kf select loc mark = 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 kf; let fvar, sel = check_kf_db_select kf select in match sel with | SlicingInternals.CuTop _ -> select | SlicingInternals.CuSelect sel -> try let pdg = !Db.Pdg.get kf in let find = if at_end then !Db.Pdg.find_location_nodes_at_end else !Db.Pdg.find_location_nodes_at_begin in let nodes, undef = find pdg loc in let undef = if use_undef then undef else None in let sel = mk_select pdg sel nodes undef mark in (fvar, sel) with | Not_found -> assert false | Db.Pdg.Top -> top_db_select kf mark | Db.Pdg.Bottom -> bottom_msg kf; select let select_zone_at_end kf ?(select=empty_db_select kf) loc mark = select_in_out_zone ~at_end:true ~use_undef:true kf select loc mark let select_modified_output_zone kf ?(select=empty_db_select kf) loc mark = select_in_out_zone ~at_end:true ~use_undef:false kf select loc mark let select_zone_at_entry kf ?(select=empty_db_select kf) loc mark = select_in_out_zone ~at_end:false ~use_undef:true kf select loc mark let stmt_nodes_to_select pdg stmt = let stmt_nodes = 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 = if List.length stmt_nodes > 1 then begin (* this is surely a call statement *) let out_and_ctrl node = let key = PdgTypes.Node.elem_key node in match key with | PdgIndex.Key.SigCallKey (_, (PdgIndex.Signature.In _)) -> false | PdgIndex.Key.SigCallKey (_, (PdgIndex.Signature.InCtrl)) | PdgIndex.Key.SigCallKey (_, (PdgIndex.Signature.Out _)) -> true | _ -> assert false in List.filter out_and_ctrl stmt_nodes end else stmt_nodes in *) SlicingParameters.debug ~level:2 "[Register.stmt_nodes_to_select] results on stmt %d (%a)" stmt.sid (fun fmt l -> List.iter (!Db.Pdg.pretty_node true fmt) l) stmt_nodes; stmt_nodes let select_stmt_computation kf ?(select=empty_db_select kf) stmt mark = SlicingParameters.debug ~level:1 "[Register.select_stmt_computation] on stmt %d" stmt.sid; try let pdg = !Db.Pdg.get kf in let stmt_nodes = stmt_nodes_to_select pdg stmt in let nd_marks = SlicingActions.build_node_and_dpds_selection mark in basic_add_select kf select stmt_nodes nd_marks with Db.Pdg.Top -> top_db_select kf mark | Db.Pdg.Bottom -> bottom_msg kf; select let select_label kf ?(select=empty_db_select kf) label mark = SlicingParameters.debug ~level:1 "[Register.select_label] on label " (* Logic_label.pretty label *); try let pdg = !Db.Pdg.get kf in let nodes = let add_label_nodes l acc = match l with | StmtLabel stmt -> let add acc l = try (!Db.Pdg.find_label_node pdg !stmt l)::acc with Not_found -> acc in List.fold_left add acc (!stmt).labels | LogicLabel (Some stmt, str) -> let add acc l = match l with | Label (sl, _, _) when sl = str -> (try (!Db.Pdg.find_label_node pdg stmt l)::acc with Not_found -> acc) | _ -> acc in List.fold_left add acc stmt.labels | LogicLabel (None, _) -> acc in (* Logic_label.Set.fold add_label_nodes labels [] *) add_label_nodes label [] in let nd_marks = SlicingActions.build_node_and_dpds_selection mark in basic_add_select kf select nodes nd_marks with Db.Pdg.Top -> top_db_select kf mark | Db.Pdg.Bottom -> bottom_msg kf; select (** marking a call node means that a [choose_call] will have to decide that to * call according to the slicing-level, but anyway, the call will be visible. *) let select_minimal_call kf ?(select=empty_db_select kf) stmt m = SlicingParameters.debug ~level:1 "[Register.select_minimal_call]"; try let pdg = !Db.Pdg.get kf in let call = check_call stmt true in let call_node = !Db.Pdg.find_call_ctrl_node pdg call in let nd_marks = SlicingActions.build_simple_node_selection m in basic_add_select kf select [call_node] nd_marks with Db.Pdg.Top -> top_db_select kf m | Db.Pdg.Bottom -> bottom_msg kf; select let select_stmt_ctrl kf ?(select=empty_db_select kf) stmt = SlicingParameters.debug ~level:1 "[Register.select_stmt_ctrl] of sid:%d" stmt.sid; let mark = SlicingMarks.mk_user_mark ~ctrl:true ~data:false ~addr:false in try let pdg = !Db.Pdg.get kf in let stmt_nodes = !Db.Pdg.find_simple_stmt_nodes pdg stmt in let nd_marks = SlicingActions.build_ctrl_dpds_selection mark in basic_add_select kf select stmt_nodes nd_marks with Db.Pdg.Top -> top_db_select kf mark | Db.Pdg.Bottom -> bottom_msg kf; empty_db_select kf let select_entry_point kf ?(select=empty_db_select kf) mark = SlicingParameters.debug ~level:1 "[Register.select_entry_point] of %a" Kernel_function.pretty kf; try let pdg = !Db.Pdg.get kf in let node = !Db.Pdg.find_entry_point_node pdg in let nd_marks = SlicingActions.build_simple_node_selection mark in basic_add_select kf select [node] nd_marks with Db.Pdg.Top -> top_db_select kf mark | Db.Pdg.Bottom -> bottom_msg kf; empty_db_select kf let select_return kf ?(select=empty_db_select kf) mark = SlicingParameters.debug ~level:1 "[Register.select_return] of %a" 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 = SlicingActions.build_simple_node_selection mark in basic_add_select kf select [node] nd_marks with | 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 kf; if vi.Cil_types.vglob (* no slicing request on globals *) then select else try let pdg = !Db.Pdg.get kf in let node = !Db.Pdg.find_decl_var_node pdg vi in let nd_marks = SlicingActions.build_simple_node_selection mark in basic_add_select kf select [node] nd_marks with | Not_found -> (* unreachable ? *) select | Db.Pdg.Top -> top_db_select kf mark | Db.Pdg.Bottom -> bottom_msg kf; empty_db_select kf let merge_select select1 select2 = let select = match select1, select2 with | SlicingInternals.CuTop m, _ | _, SlicingInternals.CuTop m -> SlicingInternals.CuTop m | SlicingInternals.CuSelect select1, SlicingInternals.CuSelect select2 -> (* TODO : we can probably do better...*) SlicingInternals.CuSelect (select1 @ select2) in select let merge_db_select db_select1 db_select2 = let fvar, select1 = db_select1 in let _, select2 = check_db_select fvar db_select2 in let select = merge_select select1 select2 in (fvar, select) module Selections = struct let add_to_selects db_select set = let vf, select = db_select in let select = try merge_select (Cil_datatype.Varinfo.Map.find vf set) select with Not_found -> select in Cil_datatype.Varinfo.Map.add vf select set let iter_selects_internal f set = Cil_datatype.Varinfo.Map.iter (fun v sel -> f (v, sel)) set end let add_crit_ff_change_call proj ff_caller call f_to_call = let crit = SlicingActions.mk_crit_change_call ff_caller call f_to_call in SlicingProject.add_filter proj crit (** change the call to call the given slice. * This is a user request, so it might be the case that * the new function doesn't compute enough outputs : * in that case, add outputs first. *) let call_ff_in_caller proj ~caller ~to_call = let kf_caller = SlicingMacros.get_ff_kf caller in let kf_to_call = SlicingMacros.get_ff_kf to_call in let call_stmts = !Db.Pdg.find_call_stmts ~caller:kf_caller kf_to_call in let ff_to_call = SlicingInternals.CallSlice to_call in let add_change_call stmt = add_crit_ff_change_call proj caller stmt ff_to_call ; match Fct_slice.check_outputs_before_change_call proj caller stmt to_call with | [] -> () | [c] -> SlicingProject.add_filter proj c | _ -> assert false in List.iter add_change_call call_stmts let call_fsrc_in_caller proj ~caller ~to_call = let kf_caller = SlicingMacros.get_ff_kf caller in let fi_to_call = SlicingMacros.get_kf_fi proj to_call in let kf_to_call = SlicingMacros.get_fi_kf fi_to_call in let call_stmts = !Db.Pdg.find_call_stmts ~caller:kf_caller kf_to_call in let add_change_call stmt = add_crit_ff_change_call proj caller stmt (SlicingInternals.CallSrc (Some fi_to_call)) in List.iter add_change_call call_stmts let call_min_f_in_caller proj ~caller ~to_call = let kf_caller = SlicingMacros.get_ff_kf caller in let pdg = SlicingMacros.get_ff_pdg caller in let call_stmts = !Db.Pdg.find_call_stmts ~caller:kf_caller to_call in let call_nodes = List.map (fun call -> (!Db.Pdg.find_call_ctrl_node pdg call),None) call_stmts in let m = SlicingMarks.mk_user_spare in let nd_marks = SlicingActions.build_simple_node_selection m in let select = SlicingActions.translate_crit_to_select pdg [(call_nodes, nd_marks)] in SlicingProject.add_fct_ff_filter proj caller (SlicingInternals.CuSelect select) let is_already_selected ff db_select = let _, select = check_ff_db_select ff db_select in match select with | SlicingInternals.CuTop _ -> assert false | SlicingInternals.CuSelect to_select -> (* let pdg = !Db.Pdg.get (Globals.Functions.get fvar) in *) let new_marks = Fct_slice.filter_already_in ff to_select in let ok = if new_marks = [] then true else false in if ok then SlicingParameters.debug ~level:1 "[Register.is_already_selected] %a ?\t--> yes" !Db.Slicing.Select.pretty db_select else SlicingParameters.debug ~level:1 "[Register.is_already_selected] %a ?\t--> no (missing %a)" !Db.Slicing.Select.pretty db_select SlicingActions.print_sel_marks_list new_marks; ok let add_ff_selection proj ff db_select = SlicingParameters.debug ~level:1 "[Register.add_ff_selection] %a to %s" !Db.Slicing.Select.pretty db_select (SlicingMacros.ff_name ff); let _, select = check_ff_db_select ff db_select in SlicingProject.add_fct_ff_filter proj ff select (** add a persistent selection to the function. * This might change its slicing level in order to call slices later on. *) let add_fi_selection proj db_select = SlicingParameters.debug ~level:1 "[Register.add_fi_selection] %a" !Db.Slicing.Select.pretty db_select; let kf = get_select_kf db_select in let fi = SlicingMacros.get_kf_fi proj kf in let _, select = db_select in SlicingProject.add_fct_src_filter proj fi select; match fi.SlicingInternals.fi_level_option with | SlicingInternals.DontSlice | SlicingInternals.DontSliceButComputeMarks -> SlicingMacros.change_fi_slicing_level fi SlicingInternals.MinNbSlice; SlicingParameters.debug ~level:1 "[Register.add_fi_selection] changing %s slicing level to %s@." (SlicingMacros.fi_name fi) (SlicingMacros.str_level_option fi.SlicingInternals.fi_level_option) | SlicingInternals.MinNbSlice | SlicingInternals.MaxNbSlice -> () let get_mark_from_param ff var = let kf = SlicingMacros.get_ff_kf ff in 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 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 let get_called_slice ff stmt = match stmt.skind with | Instr (Call _) -> fst (Fct_slice.get_called_slice ff stmt) | _ -> None let get_called_funcs ff stmt = match stmt.skind with | 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 (Kstmt stmt) ~with_alarms:CilE.warn_none_mode ~deps:None expr_f)) else [] | _ -> [] let _db_pretty fmt (_project, kf) = try !Db.Pdg.pretty fmt (!Db.Pdg.get kf) with Not_found -> () let create_slice s = SlicingParameters.debug ~level:1 "[Register.create_slice]"; SlicingProject.create_slice s let copy_slice _proj ff = SlicingParameters.debug ~level:1 "[Register.copy_slice]"; Fct_slice.copy_slice ff let split_slice s = SlicingParameters.debug ~level:1 "[Register.split_slice]"; SlicingProject.split_slice s let merge_slices proj ff_1 ff_2 ~replace = SlicingParameters.debug ~level:1 "[Register.merge_slices]"; SlicingProject.merge_slices proj ff_1 ff_2 replace let remove_slice s = SlicingParameters.debug ~level:1 "[Register.remove_slice]"; SlicingProject.remove_ff s let is_request_empty p = SlicingParameters.debug ~level:1 "[Register.is_request_empty]"; SlicingProject.is_request_empty p let apply_next_action s = SlicingParameters.debug ~level:1 "[Register.apply_next_action]"; SlicingProject.apply_next_action s let apply_all_actions p = SlicingParameters.debug ~level:1 "[Register.apply_all_actions]"; SlicingParameters.feedback ~level:1 "applying all slicing requests..."; SlicingParameters.debug ~level:2 "pending requests:@\n %a@\n" !Db.Slicing.Request.pretty p ; let r = SlicingProject.apply_all_actions p in SlicingParameters.feedback ~level:2 "done (applying all slicing requests)."; r let print_extracted_project ?fmt ~extracted_prj = if SlicingParameters.Print.get () then FC_file.pretty_ast ?fmt ~prj:extracted_prj () (** Global data managment *) module P = State_builder.Ref (Datatype.Pair (Datatype.List(SlicingTypes.Sl_project)) (Datatype.Option(SlicingTypes.Sl_project))) (struct let name = "Slicing.Project" let dependencies = [] (* others delayed below *) let default () = [], None end) let get_all () = let all,_current = P.get () in all let get_project () = let _all,current = P.get () in current let set_project proj_opt = P.set (get_all (), proj_opt) let from_unique_name name = let all = get_all () in try List.find (fun p -> name = SlicingProject.get_name p) all with Not_found -> raise Db.Slicing.No_Project let mk_project name = (* try let _ = from_unique_name name in raise Db.Slicing.Existing_Project with Db.Slicing.No_Project -> *) !Db.Value.compute () ; let project = (SlicingProject.mk_project name) in let all,current = P.get () in P.set ((project :: all), current); project let from_num_id proj kf num = List.find (fun f -> num = !Db.Slicing.Slice.get_num_id f) (!Db.Slicing.Slice.get_all proj kf) (** {2 For the journalization of the slicing plug-in } *) (** {3 For the journalization of the Db.Slicing.Project.functions} *) let dot_project = PrintSlice.build_dot_project let dot_project = Journal.register "Slicing.Project.print_dot" (Datatype.func3 ~label1:("filename", None) Datatype.string ~label2:("title", None) Datatype.string Db.Slicing.Project.dyn_t Datatype.unit) dot_project let dot_project ~filename ~title project = dot_project filename title project let extract f_slice_names = SlicingTransform.extract ~f_slice_names let extract = Journal.register "!Db.Slicing.Project.extract" (Datatype.func3 ~label1:("f_slice_names", Some (fun () -> !Db.Slicing.Project.default_slice_names)) (Datatype.func3 Kernel_function.ty Datatype.bool Datatype.int Datatype.string) Datatype.string Db.Slicing.Project.dyn_t Project.ty) extract let extract new_proj_name ?(f_slice_names=(!Db.Slicing.Project.default_slice_names)) = extract f_slice_names new_proj_name let default_slice_names = SlicingTransform.default_slice_names let () = Journal.Binding.add (Datatype.func3 Kernel_function.ty Datatype.bool Datatype.int Datatype.string) default_slice_names "!Db.Slicing.Project.default_slice_names" (** {3 For the journalization of the Db.Slicing.Select.functions} *) let higher_select_stmt set spare = SlicingCmds.select_stmt set ~spare let higher_select_stmt = Journal.register "!Db.Slicing.Select.select_stmt" (Datatype.func4 Db.Slicing.Select.dyn_set ~label2:("spare", None) Datatype.bool Stmt.ty Kernel_function.ty Db.Slicing.Select.dyn_set) higher_select_stmt let higher_select_stmt set ~spare = higher_select_stmt set spare let higher_select_stmt_ctrl set spare = SlicingCmds.select_stmt_ctrl set ~spare let higher_select_stmt_ctrl = Journal.register "!Db.Slicing.Select.select_stmt_ctrl" (Datatype.func4 Db.Slicing.Select.dyn_set ~label2:("spare", None) Datatype.bool Stmt.ty Kernel_function.ty Db.Slicing.Select.dyn_set) higher_select_stmt_ctrl let higher_select_stmt_ctrl set ~spare = higher_select_stmt_ctrl set spare let higher_select_stmt_lval_rw set mark rd wr stmt scope eval = SlicingCmds.select_stmt_lval_rw set mark ~rd ~wr stmt ~scope ~eval let higher_select_stmt_lval_rw = Journal.register "!Db.Slicing.Select.select_stmt_lval_rw" (Datatype.func4 Db.Slicing.Select.dyn_set Db.Slicing.Mark.dyn_t ~label3:("rd", None) Datatype.String.Set.ty ~label4:("wr", None) Datatype.String.Set.ty (Datatype.func4 Stmt.ty ~label2:("scope", None) Stmt.ty ~label3:("eval", None) Stmt.ty Kernel_function.ty Db.Slicing.Select.dyn_set)) higher_select_stmt_lval_rw let higher_select_stmt_lval_rw set mark ~rd ~wr stmt ~scope ~eval = higher_select_stmt_lval_rw set mark rd wr stmt scope eval let higher_select_stmt_lval set mark lval before stmt scope eval = SlicingCmds.select_stmt_lval set mark lval ~before stmt ~scope ~eval let higher_select_stmt_lval = Journal.register "!Db.Slicing.Select.select_stmt_lval" (Datatype.func4 Db.Slicing.Select.dyn_set Db.Slicing.Mark.dyn_t Datatype.String.Set.ty ~label4:("before", None) Datatype.bool (Datatype.func4 Stmt.ty ~label2:("scope", None) Stmt.ty ~label3:("eval", None) Stmt.ty Kernel_function.ty Db.Slicing.Select.dyn_set)) higher_select_stmt_lval let higher_select_stmt_lval set mark lval ~before stmt ~scope ~eval = higher_select_stmt_lval set mark lval before stmt scope eval let higher_select_stmt_annots set mark spare threat user_assert slicing_pragma loop_inv loop_var = SlicingCmds.select_stmt_annots set mark ~spare ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var let higher_select_stmt_annots = Journal.register "!Db.Slicing.Select.select_stmt_annots" (Datatype.func4 Db.Slicing.Select.dyn_set Db.Slicing.Mark.dyn_t ~label3:("spare", None) Datatype.bool ~label4:("threat", None) Datatype.bool (Datatype.func4 ~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 Kernel_function.ty Db.Slicing.Select.dyn_set))) higher_select_stmt_annots let higher_select_stmt_annots set mark ~spare ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var = higher_select_stmt_annots set mark spare threat user_assert slicing_pragma loop_inv loop_var let higher_select_func_lval_rw set mark rd wr scope eval = SlicingCmds.select_func_lval_rw set mark ~rd ~wr ~scope ~eval let higher_select_func_lval_rw = Journal.register "!Db.Slicing.Select.select_func_lval_rw" (Datatype.func4 Db.Slicing.Select.dyn_set Db.Slicing.Mark.dyn_t ~label3:("rd", None) Datatype.String.Set.ty ~label4:("wr", None) Datatype.String.Set.ty (Datatype.func3 ~label1:("scope", None) Stmt.ty ~label2:("eval", None) Stmt.ty Kernel_function.ty Db.Slicing.Select.dyn_set)) higher_select_func_lval_rw let higher_select_func_lval_rw set mark ~rd ~wr ~scope ~eval = higher_select_func_lval_rw set mark rd wr scope eval let higher_select_func_return set spare = SlicingCmds.select_func_return set ~spare let higher_select_func_return = Journal.register "!Db.Slicing.Select.select_func_return" (Datatype.func3 Db.Slicing.Select.dyn_set ~label2:("spare", None) Datatype.bool Kernel_function.ty Db.Slicing.Select.dyn_set) higher_select_func_return let higher_select_func_return set ~spare = higher_select_func_return set spare let higher_select_func_calls_to set spare = SlicingCmds.select_func_calls_to set ~spare let higher_select_func_calls_to = Journal.register "!Db.Slicing.Select.select_func_calls_to" (Datatype.func3 Db.Slicing.Select.dyn_set ~label2:("spare", None) Datatype.bool Kernel_function.ty Db.Slicing.Select.dyn_set) higher_select_func_calls_to let higher_select_func_calls_to set ~spare = higher_select_func_calls_to set spare let higher_select_func_calls_into set spare = SlicingCmds.select_func_calls_into set ~spare let higher_select_func_calls_into = Journal.register "!Db.Slicing.Select.select_func_calls_into" (Datatype.func3 Db.Slicing.Select.dyn_set ~label2:("spare", None) Datatype.bool Kernel_function.ty Db.Slicing.Select.dyn_set) higher_select_func_calls_into let higher_select_func_calls_into set ~spare = higher_select_func_calls_into set spare let higher_select_func_annots set mark spare threat user_assert slicing_pragma loop_inv loop_var = SlicingCmds.select_func_annots set mark ~spare ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var let higher_select_func_annots = Journal.register "!Db.Slicing.Select.select_func_annots" (Datatype.func4 Db.Slicing.Select.dyn_set Db.Slicing.Mark.dyn_t ~label3:("spare", None) Datatype.bool ~label4:("threat", None) Datatype.bool (Datatype.func4 ~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.func Kernel_function.ty Db.Slicing.Select.dyn_set))) higher_select_func_annots let higher_select_func_annots set mark ~spare ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var = higher_select_func_annots set mark spare threat user_assert slicing_pragma loop_inv loop_var (** {3 For the journalization of the Db.Slicing.Request.functions} *) let apply_all project propagate_to_callers = SlicingCmds.apply_all project ~propagate_to_callers let apply_all = Journal.register "!Db.Slicing.Request.apply_all" (Datatype.func2 Db.Slicing.Project.dyn_t ~label2:("propagate_to_callers", None) Datatype.bool Datatype.unit) apply_all let apply_all project ~propagate_to_callers = apply_all project propagate_to_callers let merge_slices proj ff_1 ff_2 replace = merge_slices proj ff_1 ff_2 ~replace let merge_slices = Journal.register "!Db.Slicing.Request.merge_slices" (Datatype.func4 Db.Slicing.Project.dyn_t Db.Slicing.Slice.dyn_t Db.Slicing.Slice.dyn_t ~label4:("replace", None) Datatype.bool Db.Slicing.Slice.dyn_t) merge_slices let merge_slices proj ff_1 ff_2 ~replace = merge_slices proj ff_1 ff_2 replace let call_ff_in_caller proj caller to_call = call_ff_in_caller proj ~caller ~to_call let call_ff_in_caller = Journal.register "!Db.Slicing.Request.add_call_slice" (Datatype.func3 Db.Slicing.Project.dyn_t ~label2:("caller", None) Db.Slicing.Slice.dyn_t ~label3:("to_call", None) Db.Slicing.Slice.dyn_t Datatype.unit) call_ff_in_caller let call_ff_in_caller proj ~caller ~to_call = call_ff_in_caller proj caller to_call let call_fsrc_in_caller proj caller to_call = call_fsrc_in_caller proj ~caller ~to_call let call_fsrc_in_caller = Journal.register "!Db.Slicing.Request.add_call_fun" (Datatype.func3 Db.Slicing.Project.dyn_t ~label2:("caller", None) Db.Slicing.Slice.dyn_t ~label3:("to_call", None) Kernel_function.ty Datatype.unit) call_fsrc_in_caller let call_fsrc_in_caller proj ~caller ~to_call = call_fsrc_in_caller proj caller to_call let call_min_f_in_caller proj caller to_call = call_min_f_in_caller proj ~caller ~to_call let call_min_f_in_caller = Journal.register "!Db.Slicing.Request.add_call_min_fun" (Datatype.func3 Db.Slicing.Project.dyn_t ~label2:("caller", None) Db.Slicing.Slice.dyn_t ~label3:("to_call", None) Kernel_function.ty Datatype.unit) call_min_f_in_caller let call_min_f_in_caller proj ~caller ~to_call = call_min_f_in_caller proj caller to_call (** {3 For the journalization of the Db.Slicingfunctions} *) let set_modes calls callers sliceUndef keepAnnotations print () = SlicingParameters.Mode.Calls.set calls ; SlicingParameters.Mode.Callers.set callers ; SlicingParameters.Mode.SliceUndef.set sliceUndef; SlicingParameters.Mode.KeepAnnotations.set keepAnnotations; SlicingParameters.Print.set print let set_modes = Journal.register "!Db.Slicing.set_modes" (Datatype.func4 ~label1:("calls", None) Datatype.int ~label2:("callers", None) Datatype.bool ~label3:("sliceUndef", None) Datatype.bool ~label4:("keepAnnotation", None) Datatype.bool (Datatype.func2 ~label1:("print", None) Datatype.bool Datatype.unit Datatype.unit)) set_modes let set_modes ?(calls=SlicingParameters.Mode.Calls.get ()) ?(callers=SlicingParameters.Mode.Callers.get ()) ?(sliceUndef=SlicingParameters.Mode.SliceUndef.get ()) ?(keepAnnotations=SlicingParameters.Mode.KeepAnnotations.get ()) ?(print=SlicingParameters.Print.get ()) () = set_modes calls callers sliceUndef keepAnnotations print () (** {2 Initialisation of the slicing plug-in} *) let () = Cmdline.run_after_extended_stage (fun () -> State_dependency_graph.add_codependencies ~onto:P.self [ !Db.Pdg.self; !Db.Inputs.self_external; !Db.Outputs.self_external ]) (** {3 Register external functions into Db.Slicing} *) let () = Db.Slicing.self := P.self; Db.Slicing.set_modes := set_modes (* Journalized *) (** {3 Register external functions into Db.Slicing.Project} *) let () = Db.Slicing.Project.print_dot := dot_project; (* Journalized *) Db.Slicing.Project.extract := extract ; (* Journalized *) Db.Slicing.Project.default_slice_names := default_slice_names ; (* Journalized *) Db.register (Db.Journalize ("Slicing.Project.mk_project", Datatype.func Datatype.string Db.Slicing.Project.dyn_t)) Db.Slicing.Project.mk_project mk_project; Db.register (Db.Journalize ("Slicing.Project.set_project", Datatype.func (Datatype.option Db.Slicing.Project.dyn_t) Datatype.unit)) Db.Slicing.Project.set_project set_project; Db.register (Db.Journalize ("Slicing.Project.change_slicing_level", Datatype.func3 Db.Slicing.Project.dyn_t Kernel_function.ty Datatype.int Datatype.unit)) Db.Slicing.Project.change_slicing_level SlicingMacros.change_slicing_level ; (* No needs of Journalization for others Db.Slicing.Project.functions *) Db.register Db.Journalization_not_required Db.Slicing.Project.print_extracted_project print_extracted_project; Db.register Db.Journalization_not_required Db.Slicing.Project.from_unique_name from_unique_name; Db.register Db.Journalization_not_required Db.Slicing.Project.get_all get_all; Db.register Db.Journalization_not_required Db.Slicing.Project.get_project get_project; Db.register Db.Journalization_not_required Db.Slicing.Project.get_name SlicingProject.get_name; Db.register Db.Journalization_not_required Db.Slicing.Project.pretty SlicingProject.print_project_and_worklist ; Db.register Db.Journalization_not_required Db.Slicing.Project.is_directly_called_internal SlicingMacros.is_src_fun_called ; Db.register Db.Journalization_not_required Db.Slicing.Project.is_called SlicingTransform.is_src_fun_called ; Db.register Db.Journalization_not_required Db.Slicing.Project.has_persistent_selection SlicingMacros.has_persistent_selection (** {3 Register external functions into Db.Slicing.Select} *) let () = (* No needs of Journalization for low-level Db.Slicing.Select.functions. * [Note:] They can be Journalized. In that case, functions computing [Db.Slicing.Select.t] * values have to be Journalized *) Db.register (Db.Journalization_must_not_happen "Slicing.Select.add_to_selects_internal") Db.Slicing.Select.add_to_selects_internal Selections.add_to_selects; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_stmt_internal") Db.Slicing.Select.select_stmt_internal select_stmt_computation; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_label_internal") Db.Slicing.Select.select_label_internal select_label; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_stmt_ctrl_internal") Db.Slicing.Select.select_stmt_ctrl_internal select_stmt_ctrl ; (* TODO? Journalized *) Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_entry_point_internal") Db.Slicing.Select.select_entry_point_internal select_entry_point; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_return_internal") Db.Slicing.Select.select_return_internal select_return; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_decl_var_internal") Db.Slicing.Select.select_decl_var_internal select_decl_var; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_min_call_internal") Db.Slicing.Select.select_min_call_internal select_minimal_call; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_merge_internal") Db.Slicing.Select.merge_internal merge_db_select; (* No needs of Journalization for low-level Db.Slicing.Select.functions. * [Note:] They can be Journalized. In that case, functions computing [Db.Slicing.Select.t] * [Pdg.node] values have to be Journalized *) Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_pdg_nodes_internal") Db.Slicing.Select.select_pdg_nodes_internal select_pdg_nodes; (* No needs of Journalization for low-level Db.Slicing.Select.functions. * [Note:] They can be Journalized. In that case, functions computing [Db.Slicing.Select.t] * [Location.Zone.t] values have to be Journalized *) Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_stmt_zone_internal") Db.Slicing.Select.select_stmt_zone_internal select_stmt_zone; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_zone_at_entry_internal") Db.Slicing.Select.select_zone_at_entry_point_internal select_zone_at_entry; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_zone_at_end_internal") Db.Slicing.Select.select_zone_at_end_internal select_zone_at_end; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_modified_output_zone_internal") Db.Slicing.Select.select_modified_output_zone_internal select_modified_output_zone; (* No needs of Journalization for intermediate-level Db.Slicing.Select.functions *) Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_stmt_term") (* [Note] Can be Journalized -> Functions computing [term] values have to be Journalized *) Db.Slicing.Select.select_stmt_term SlicingCmds.select_stmt_term ; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_stmt_pred") (* [Note] Can be Journalized -> Functions computing [predicate named] values have to be Journalized *) Db.Slicing.Select.select_stmt_pred SlicingCmds.select_stmt_pred ; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_stmt_annot") (* [Note] Can be Journalized -> Functions computing [code_annotation] values have to be Journalized *) Db.Slicing.Select.select_stmt_annot SlicingCmds.select_stmt_annot ; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_pdg_nodes") (* [Note] Can be Journalized -> Functions computing [Pdg.node] values have to be Journalized *) Db.Slicing.Select.select_pdg_nodes SlicingCmds.select_pdg_nodes ; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_stmt_zone") (* [Note] Can be Journalized -> Functions computing [Locations.Zone.t] values have to be Journalized *) Db.Slicing.Select.select_stmt_zone SlicingCmds.select_stmt_zone ; Db.register (Db.Journalization_must_not_happen "Slicing.Select.select_func_zone") (* [Note] Can be Journalized -> Functions computing [Locations.Zone.t] values have to be Journalized *) Db.Slicing.Select.select_func_zone SlicingCmds.select_func_zone ; (* higher level function from slicingCmds *) Db.Slicing.Select.select_stmt := higher_select_stmt ; (* Journalized *) Db.Slicing.Select.select_stmt_ctrl := higher_select_stmt_ctrl ; (* Journalized *) Db.Slicing.Select.select_stmt_lval_rw := higher_select_stmt_lval_rw ; (* Journalized *) Db.Slicing.Select.select_stmt_lval := higher_select_stmt_lval ; (* Journalized *) Db.Slicing.Select.select_stmt_annots := higher_select_stmt_annots ; (* Journalized *) Db.Slicing.Select.select_func_lval_rw := higher_select_func_lval_rw ; (* Journalized *) Db.register (Db.Journalize ("Slicing.Select.select_func_lval", Datatype.func4 Db.Slicing.Select.dyn_set Db.Slicing.Mark.dyn_t Datatype.String.Set.ty Kernel_function.ty Db.Slicing.Select.dyn_set)) Db.Slicing.Select.select_func_lval SlicingCmds.select_func_lval ; Db.Slicing.Select.select_func_return := higher_select_func_return ; (* Journalized *) Db.Slicing.Select.select_func_calls_to := higher_select_func_calls_to ; (* Journalized *) Db.Slicing.Select.select_func_calls_into := higher_select_func_calls_into ; (* Journalized *) Db.Slicing.Select.select_func_annots := higher_select_func_annots ; (* Journalized *) (* No needs of Journalization for others Db.Slicing.Select.functions *) Db.register Db.Journalization_not_required Db.Slicing.Select.iter_selects_internal Selections.iter_selects_internal ; Db.register Db.Journalization_not_required Db.Slicing.Select.get_function get_select_kf; Db.register Db.Journalization_not_required Db.Slicing.Select.pretty print_select (** {3 Register external functions into Db.Slicing.Slice} *) let () = Db.register (Db.Journalize ("Slicing.Slice.create", Datatype.func2 Db.Slicing.Project.dyn_t Kernel_function.ty Db.Slicing.Slice.dyn_t)) Db.Slicing.Slice.create create_slice ; Db.register (Db.Journalize ("Slicing.Slice.remove", Datatype.func2 Db.Slicing.Project.dyn_t Db.Slicing.Slice.dyn_t Datatype.unit)) Db.Slicing.Slice.remove remove_slice ; (* higher level function from slicingCmds *) Db.register (Db.Journalize ("Slicing.Slice.remove_uncalled", Datatype.func Db.Slicing.Project.dyn_t Datatype.unit)) Db.Slicing.Slice.remove_uncalled SlicingProject.remove_uncalled_slices ; (* No needs of Journalization for others Db.Slicing.Slice.functions *) Db.register Db.Journalization_not_required Db.Slicing.Slice.get_all SlicingProject.get_slices ; Db.register Db.Journalization_not_required Db.Slicing.Slice.get_callers SlicingProject.get_slice_callers ; Db.register Db.Journalization_not_required Db.Slicing.Slice.get_called_slice get_called_slice ; Db.register Db.Journalization_not_required Db.Slicing.Slice.get_called_funcs get_called_funcs ; Db.register Db.Journalization_not_required Db.Slicing.Slice.pretty SlicingProject.pretty_slice ; Db.register Db.Journalization_not_required Db.Slicing.Slice.get_mark_from_stmt Fct_slice.get_stmt_mark; Db.register Db.Journalization_not_required Db.Slicing.Slice.get_mark_from_label Fct_slice.get_label_mark ; Db.register Db.Journalization_not_required Db.Slicing.Slice.get_mark_from_formal get_mark_from_param ; Db.register Db.Journalization_not_required Db.Slicing.Slice.get_mark_from_local_var Fct_slice.get_local_var_mark ; Db.register Db.Journalization_not_required Db.Slicing.Slice.get_user_mark_from_inputs Fct_slice.merge_inputs_m1_mark ; Db.register Db.Journalization_not_required Db.Slicing.Slice.get_callers SlicingProject.get_slice_callers ; Db.register Db.Journalization_not_required Db.Slicing.Slice.get_function SlicingMacros.get_ff_kf; Db.register Db.Journalization_not_required Db.Slicing.Slice.get_num_id SlicingMacros.get_ff_id; Db.register Db.Journalization_not_required Db.Slicing.Slice.from_num_id from_num_id (** {3 Register external functions into Db.Slicing.Request} *) let () = (* intermediate-level Db.Slicing.Request.functions *) Db.register (Db.Journalization_must_not_happen "Db.Slicing.Request.add_slice_selection_internal") (* [Note] Can be Journalized -> Functions computing [Db.Slicing.Select.t] values have to be Journalized *) Db.Slicing.Request.add_slice_selection_internal add_ff_selection ; Db.register (Db.Journalization_must_not_happen "Db.Slicing.Request.add_selection_internal") (* [Note] Can be Journalized -> Functions computing [Db.Slicing.Select.t] values have to be Journalized *) Db.Slicing.Request.add_selection_internal add_fi_selection ; (* higher level Db.Slicing.Request.functions *) Db.register (Db.Journalize ("Slicing.Request.propagate_user_marks", Datatype.func Db.Slicing.Project.dyn_t Datatype.unit)) Db.Slicing.Request.propagate_user_marks SlicingCmds.topologic_propagation ; Db.register (Db.Journalize ("Slicing.Request.add_selection", Datatype.func2 Db.Slicing.Project.dyn_t Db.Slicing.Select.dyn_set Datatype.unit)) Db.Slicing.Request.add_selection SlicingCmds.add_selection ; Db.register (Db.Journalize ("Slicing.Request.add_persistent_selection", Datatype.func2 Db.Slicing.Project.dyn_t Db.Slicing.Select.dyn_set Datatype.unit)) Db.Slicing.Request.add_persistent_selection SlicingCmds.add_persistent_selection ; Db.register (Db.Journalize ("Slicing.Request.add_persistent_cmdline", Datatype.func Db.Slicing.Project.dyn_t Datatype.unit)) Db.Slicing.Request.add_persistent_cmdline SlicingCmds.add_persistent_cmdline ; Db.Slicing.Request.add_call_slice := call_ff_in_caller ; (* Journalized *) Db.Slicing.Request.add_call_fun := call_fsrc_in_caller ; (* Journalized *) Db.Slicing.Request.add_call_min_fun := call_min_f_in_caller ; (* Journalized *) Db.Slicing.Request.merge_slices := merge_slices ; (* Journalized *) Db.register (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.Request.copy_slice copy_slice ; Db.register (Db.Journalize ("Slicing.Request.split_slice", Datatype.func2 Db.Slicing.Project.dyn_t Db.Slicing.Slice.dyn_t (Datatype.list Db.Slicing.Slice.dyn_t))) Db.Slicing.Request.split_slice split_slice ; Db.Slicing.Request.apply_all := apply_all ; (* Journalized *) Db.register (Db.Journalize ("Slicing.Request.apply_next_internal", Datatype.func Db.Slicing.Project.dyn_t Datatype.unit)) Db.Slicing.Request.apply_next_internal apply_next_action ; Db.register (Db.Journalize ("Slicing.Request.apply_all_internal", Datatype.func Db.Slicing.Project.dyn_t Datatype.unit)) Db.Slicing.Request.apply_all_internal apply_all_actions; (* No needs of Journalization for Db.Slicing.Request.functions *) Db.register Db.Journalization_not_required Db.Slicing.Request.is_request_empty_internal is_request_empty; Db.register Db.Journalization_not_required Db.Slicing.Request.is_already_selected_internal is_already_selected ; Db.register Db.Journalization_not_required Db.Slicing.Request.pretty SlicingProject.print_proj_worklist (** {3 Register external functions into Db.Slicing.Mark} *) let () = (* No needs of Journalization for Db.Slicing.Mark.functions *) Db.register Db.Journalization_not_required Db.Slicing.Mark.compare SlicingMarks.compare_marks ; Db.register Db.Journalization_not_required Db.Slicing.Mark.pretty SlicingMarks.pretty_mark ; Db.register Db.Journalization_not_required Db.Slicing.Mark.make SlicingMarks.mk_user_mark ; Db.register Db.Journalization_not_required Db.Slicing.Mark.is_bottom SlicingMarks.is_bottom_mark ; Db.register Db.Journalization_not_required Db.Slicing.Mark.is_spare SlicingMarks.is_spare_mark ; Db.register Db.Journalization_not_required Db.Slicing.Mark.is_ctrl SlicingMarks.is_ctrl_mark ; Db.register Db.Journalization_not_required Db.Slicing.Mark.is_addr SlicingMarks.is_addr_mark ; Db.register Db.Journalization_not_required Db.Slicing.Mark.is_data SlicingMarks.is_data_mark ; Db.register Db.Journalization_not_required Db.Slicing.Mark.is_data SlicingMarks.is_data_mark ; Db.register Db.Journalization_not_required Db.Slicing.Mark.get_from_src_func Fct_slice.get_mark_from_src_fun let main () = if SlicingParameters.is_on () then begin SlicingParameters.feedback ~level:1 "slicing requests in progress..."; (* have to do the value analysis before the selections * 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); !Db.Slicing.Request.add_persistent_cmdline project; (* Apply all pending requests. *) if !Db.Slicing.Request.is_request_empty_internal project then begin SlicingParameters.warning "No internal slicing request from the command line." ; if SlicingParameters.Mode.Callers.get () then let select_entry = let spare_mark = !Db.Slicing.Mark.make ~data:false ~addr:false ~ctrl:false in let kf_entry, _library = Globals.entry_point () in SlicingParameters.warning "Adding an extra request on the entry point of function: %a." Kernel_function.pretty kf_entry; !Db.Slicing.Select.select_entry_point_internal kf_entry spare_mark in !Db.Slicing.Request.add_selection_internal project select_entry end; !Db.Slicing.Request.apply_all_internal project; if SlicingParameters.Mode.Callers.get () then !Db.Slicing.Slice.remove_uncalled project; let sliced_project_name = project_name ^ (SlicingParameters.ExportedProjectPostfix.get ()) 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 end; SlicingParameters.feedback ~level:2 "done (slicing requests in progress)."; end (** Register the function [main] as a main entry point. *) let () = Db.Main.extend main frama-c-Fluorine-20130601/src/slicing/register_gui.ml0000644000175000017500000006721112155630217021247 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (* Update the 'Slicing' column of the gui filetree. *) let update_column = ref (fun _ -> ()) (* Are results shown? *) module Enabled = struct include State_builder.Ref (Datatype.Bool) (struct let name = "Slicing_gui.State" let dependencies = [!Db.Slicing.self] let default () = false end) end (* for slicing callback *) let mk_selection fselect = fselect Db.Slicing.Select.empty_selects (* for slicing callback *) let mk_selection_cad fselect = mk_selection fselect (!Db.Slicing.Mark.make ~ctrl:true ~addr:true ~data:true) (* for slicing callback *) let mk_selection_all fselect = mk_selection fselect ~spare:false (* for slicing callback *) let mk_slice selection = let n = string_of_int (1 + List.length (!Db.Slicing.Project.get_all ())) in let project_name = (SlicingParameters.ProjectName.get ()) ^ n in let project = !Db.Slicing.Project.mk_project project_name in !Db.Slicing.Request.add_persistent_selection project selection ; !Db.Slicing.Request.apply_all_internal project; if SlicingParameters.Mode.Callers.get () then !Db.Slicing.Slice.remove_uncalled project; let sliced_project_name = project_name ^ (SlicingParameters.ExportedProjectPostfix.get ()) in let new_project = !Db.Slicing.Project.extract sliced_project_name project in !Db.Slicing.Project.set_project (Some project); new_project (* To add a sensitive/unsensitive menu item to a [factory] *) let add_item (factory:GMenu.menu GMenu.factory) ~callback name arg_opt = 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)) (* To inform the user about a status. *) let gui_annot_info (main_ui:Design.main_window_extension_points) ~level txt = if (SlicingParameters.verbose_atleast level) then begin main_ui#annot_window#buffer#insert ((txt ()) ^ ".\n") end (* To inform the user about an action. *) let gui_annot_action (main_ui:Design.main_window_extension_points) txt = if SlicingParameters.verbose_atleast 2 then let tag_style_italic = Gtk_helper.make_tag main_ui#annot_window#buffer ~name:"slicing:style italic" [`STYLE `ITALIC] in main_ui#annot_window#buffer#insert ~tags:[tag_style_italic] ((txt ())^"\n") (* To inform the user about an error. *) let gui_mk_slice (main_ui:Design.main_window_extension_points) selection ~info = gui_annot_action main_ui info; let new_project = mk_slice selection in (* ... slicing computation *) gui_annot_action main_ui (fun () -> "Slice exported to project: " ^ (Project.get_name new_project)); main_ui#rehighlight () let _msg_appl_compute_values = "Activating Slicing Plug-in by running Value Analysis first" let msg_help_compute_values = "Activates Slicing Plug-in by running Value Analysis first." let msg_help_enable_gui = "Enables/Disables the Slicing GUI." let msg_help_libraries = "Allows/Disallows the use of the -slicing-level option for calls to \ undefined functions." let gui_compute_values (main_ui:Design.main_window_extension_points) = 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 ; ] in main_ui#annot_window#buffer#insert "[Slicing] activation requires an execution of a "; main_ui#annot_window#buffer#insert ~tags:[tag_style_oblique] "value analysis"; main_ui#annot_window#buffer#insert ". Selects "; main_ui#annot_window#buffer#insert ~tags:[tag_style_oblique] "-val"; main_ui#annot_window#buffer#insert " option and sets parameters before pushing " ; main_ui#annot_window#buffer#insert ~tags:[tag_style_oblique] "Execute" ; main_ui#annot_window#buffer#insert " button.\n" ; main_ui#launcher () end (* To do an action and inform the user. *) let gui_apply_action (main_ui:Design.main_window_extension_points) f x ~info = f x ; gui_annot_action main_ui info let get_setting_option_text txt = "Setting option " ^ txt ^ " for the current project" let gui_set_project (main_ui:Design.main_window_extension_points) proj_opt = gui_apply_action main_ui !Db.Slicing.Project.set_project proj_opt ~info:(fun () -> Extlib.may_map ~dft:"Clear slicing highlighting" (fun project -> ("Highlighting for " ^ (!Db.Slicing.Project.get_name project))) proj_opt) ; main_ui#rehighlight () 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 (Enabled.get ()) then ignore (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; !update_column `Visibility) )) else let slicing_project = !Db.Slicing.Project.get_project () in if button = 1 then begin let level = 1 in let slicing_view project = gui_annot_info main_ui ~level (fun () -> "Highlighting for " ^ (!Db.Slicing.Project.get_name project)) in Extlib.may slicing_view slicing_project; if SlicingParameters.verbose_atleast level then begin let slicing_mark project = let slicing_mark kf get_mark = (* use -slicing-debug -verbose to get slicing mark information *) let add_mark_info txt = gui_annot_info ~level main_ui (fun () -> "Tag: " ^ (txt ())) in let slices = !Db.Slicing.Slice.get_all project kf in match slices with | [] -> (* No slice for this kf *) add_mark_info (fun () -> if !Db.Slicing.Project.is_called project kf then (* but the source function is called *) (Pretty_utils.sfprintf "%a" !Db.Slicing.Mark.pretty (!Db.Slicing.Mark.get_from_src_func project kf)) else "< >< >") | slices -> if !Db.Slicing.Project.is_called project kf then begin (* The source function is also called *) assert (not (kf == fst (Globals.entry_point ()))) ; add_mark_info (fun () -> Pretty_utils.sfprintf "%a" !Db.Slicing.Mark.pretty (!Db.Slicing.Mark.get_from_src_func project kf)) end ; let mark_slice slice = add_mark_info (fun () -> Pretty_utils.sfprintf "%a" !Db.Slicing.Mark.pretty (get_mark slice)) in List.iter mark_slice slices in match localizable with | Pretty_source.PTermLval(Some kf,(Kstmt ki),_) (* as for the statement *) | Pretty_source.PLval (Some kf,(Kstmt ki),_) (* as for the statement *) | Pretty_source.PStmt (kf,ki) -> slicing_mark kf (fun slice -> !Db.Slicing.Slice.get_mark_from_stmt slice ki) | Pretty_source.PVDecl (Some kf,vi) -> slicing_mark kf (fun slice -> !Db.Slicing.Slice.get_mark_from_local_var slice vi) | _ -> () in Extlib.may slicing_mark slicing_project end end else if button = 3 then begin let submenu = popup_factory#add_submenu "Slicing" in let slicing_factory = new Design.protected_menu_factory (main_ui:>Gtk_helper.host) submenu in (* definitions for slicing plug-in *) let add_slicing_item name ~callback v = let callback v = callback v; !update_column `Contents in add_item slicing_factory name ~callback v in let mk_slice = gui_mk_slice main_ui in let add_slice_menu kf_opt kf_ki_opt = (let callback kf = mk_slice ~info:(fun () -> 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 add_slicing_item "Slice calls to" kf_opt ~callback); (let callback kf = mk_slice ~info:(fun () -> 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 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 kf) (mk_selection_all !Db.Slicing.Select.select_func_return kf) in add_slicing_item "Slice result" (Extlib.opt_filter (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)) kf_opt) ~callback); (let callback (kf, ki) = mk_slice ~info:(fun () -> Pretty_utils.sfprintf "Request for slicing effects of statement %d" ki.sid) (mk_selection_all !Db.Slicing.Select.select_stmt ki kf) in add_slicing_item "Slice stmt" kf_ki_opt ~callback); (let callback (kf, ki) = let do_with_txt txt = try let lval_str = 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" 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) in let txt = GToolbox.input_string ~title:"Input a pure Lvalue expression to slice before current \ statement" "" in Extlib.may do_with_txt txt in add_slicing_item "Slice lval" kf_ki_opt ~callback); (let callback (kf, ki) = let do_with_txt txt = try let lval_str = 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" txt) (mk_selection_cad !Db.Slicing.Select.select_func_lval_rw ~rd:lval_str ~wr:Datatype.String.Set.empty ~scope:ki ~eval:ki kf) with 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 add_slicing_item "Slice rd" kf_ki_opt ~callback); (let callback (kf, ki) = let do_with_txt txt = try let lval_str = 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" txt) (mk_selection_cad !Db.Slicing.Select.select_func_lval_rw ~rd:Datatype.String.Set.empty ~wr:lval_str ~scope:ki ~eval:ki kf) with 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 add_slicing_item "Slice wr" kf_ki_opt ~callback); let callback (kf, ki) = mk_slice ~info:(fun () -> Pretty_utils.sfprintf "Request for slicing accessibility to statement %d" ki.sid) (mk_selection_all !Db.Slicing.Select.select_stmt_ctrl ki kf) 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 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 stmt = if Enabled.get () && !Db.Value.is_called kf && 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) -> add_slice_menu (some_kf_from_lv lv) (some_kf_ki kf stmt) | Pretty_source.PTermLval(Some kf,(Kstmt ki),_) (* as for the statement *) | Pretty_source.PStmt (kf,ki) -> add_slice_menu None (some_kf_ki kf ki) | Pretty_source.PVDecl (_,vi) -> add_slice_menu (some_kf_from_vi vi) None | _ -> add_slice_menu None None end; let projects = !Db.Slicing.Project.get_all() in ignore (slicing_factory#add_separator ()); add_slicing_item "_Disable" (Some ()) ~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) ; List.iter (fun proj -> let add_highlight_menu sensitive = add_slicing_item ("Highlight " ^ (Pretty_utils.escape_underscores (!Db.Slicing.Project.get_name proj))) sensitive ~callback:(fun () -> gui_set_project main_ui (Some proj)) in match slicing_project with | Some project -> add_highlight_menu (if (proj == project) then None else Some ()) | None -> add_highlight_menu (Some())) projects; end let slicing_highlighter (buffer:GSourceView2.source_buffer) localizable ~start ~stop = 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 ~name:"slicing_unused" [`STRIKETHROUGH true ] in let spare_code_area = Gtk_helper.make_tag buffer ~name:"slicing_spare" [`UNDERLINE `LOW] in let necessary_code_area = 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" !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) then Gtk_helper.apply_tag buffer necessary_code_area pb pe in let slices = !Db.Slicing.Slice.get_all project kf in begin match slices with | [] -> (* No slice for this kf *) if !Db.Slicing.Project.is_called project kf then begin SlicingParameters.debug "Got source code@." ; apply_mark (!Db.Slicing.Mark.get_from_src_func project kf) end else Gtk_helper.apply_tag buffer unused_code_area pb pe | slices -> if !Db.Slicing.Project.is_called project kf then begin assert (not (kf == fst (Globals.entry_point ()))) ; SlicingParameters.debug "Got source code" ; apply_mark (!Db.Slicing.Mark.get_from_src_func project kf) end ; if SlicingParameters.debug_atleast 1 then begin let l = List.length slices in if l >=2 then SlicingParameters.debug "Got %d slices" (List.length slices) end; let mark_slice slice = let mark = mark_of_slice project slice in apply_mark mark in List.iter mark_slice slices end in let tag_stmt kf stmt pb pe = 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) 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) in match localizable with | Pretty_source.PStmt (kf,stmt) -> tag_stmt kf stmt start stop | Pretty_source.PVDecl (Some kf,vi) -> tag_vdecl kf vi start stop | Pretty_source.PVDecl (None,_) | Pretty_source.PLval _ | Pretty_source.PTermLval _ | Pretty_source.PGlobal _ | Pretty_source.PIP _ -> () in let slicing_project = !Db.Slicing.Project.get_project () in (* 2. Highlights the 'Slicing' *) Extlib.may highlight slicing_project end let none_text = "None" let rebuild_model ((_, (model, _column)) as combo_box_text) = model#clear (); GEdit.text_combo_add combo_box_text none_text; List.iter (fun p -> GEdit.text_combo_add combo_box_text (!Db.Slicing.Project.get_name p)) (List.rev (!Db.Slicing.Project.get_all())) let refresh_combo_box ((combo_box, (model, _column)) as combo_box_text) slicing_project sensitive = let nb_combo_elts = model#iter_n_children None in let projects = List.rev (!Db.Slicing.Project.get_all()) in if nb_combo_elts<>(1+(List.length projects)) then rebuild_model combo_box_text; (* Reset the active project as active in the combo box *) let nth_proj = ref 0 in let i = ref 1 in List.iter (fun proj -> Extlib.may (fun slicing_proj -> if proj == slicing_proj then nth_proj := !i) slicing_project; incr i) projects; combo_box#set_active !nth_proj; combo_box#misc#set_sensitive sensitive let gui_set_slicing_debug (main_ui:Design.main_window_extension_points) v = let old = SlicingParameters.Verbose.get () in if v <> old then (* Otherwise set is done at every refreshing *) gui_apply_action main_ui SlicingParameters.Verbose.set v ~info:(fun () -> get_setting_option_text ("-slicing-debug \"-debug " ^ (string_of_int v) ^ "\"")) let gui_set_slicing_level (main_ui:Design.main_window_extension_points) v = let old = SlicingParameters.Mode.Calls.get () in if v != old then (* Otherwise set is done at every refreshing *) gui_apply_action main_ui SlicingParameters.Mode.Calls.set v ~info:(fun () -> get_setting_option_text ("-slicing-level " ^ (string_of_int v))) let gui_set_slicing_undef_functions (main_ui:Design.main_window_extension_points) v = let old = SlicingParameters.Mode.SliceUndef.get () in if v != old then (* Otherwise set is done at every refreshing *) gui_apply_action main_ui SlicingParameters.Mode.SliceUndef.set v ~info:(fun () -> get_setting_option_text (if v then "-slicing-undef-functions" else "-no-slice-undef-functions")) let slicing_panel (main_ui:Design.main_window_extension_points) = let w = GPack.vbox () in let hbox1 = GPack.hbox ~packing:w#pack () in let activate_button = let b = GButton.button ~label:"Activate" ~packing:hbox1#pack () in main_ui#help_message b "%s" msg_help_compute_values ; ignore (b#connect#pressed (fun () -> gui_compute_values main_ui )); b in let combo_box_text = let ((combo_box, (_model, column)) as combo_box_text) = GEdit.combo_box_text ~strings:[ none_text ] ~wrap_width:3 ~use_markup:true ~packing:(hbox1#pack ~expand:true ~fill:true) () in combo_box#set_active 0 ; ignore (combo_box#connect#changed (fun () -> match combo_box#active_iter with | None -> () | Some row -> let slicing_project_name = (* get the text entry related to the current slicing project *) Extlib.may_map !Db.Slicing.Project.get_name ~dft:none_text (!Db.Slicing.Project.get_project ()) and selected_name = combo_box#model#get ~row ~column in if (selected_name != slicing_project_name) then let proj_opt = try Some (List.find (fun proj -> selected_name = !Db.Slicing.Project.get_name proj) (!Db.Slicing.Project.get_all ())) with Not_found -> None in gui_set_project main_ui proj_opt)); combo_box_text in let table = GPack.table ~columns:2 ~rows:2 ~homogeneous:true ~packing:w#pack () in let hbox2 = GPack.hbox ~packing:(table#attach ~left:1 ~top:0) () in (* [enabled_button] to give slicing menu available *) let do_refresh to_enable = if to_enable then gui_compute_values main_ui; !update_column `Visibility; main_ui#rehighlight (); in let enabled_button = let b = GButton.check_button ~label:"Enable" ~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 () -> Enabled.set b#active; do_refresh b#active)); b in let verbose_refresh = Gtk_helper.on_int ~lower:0 ~upper:3 hbox2 "Verbosity" ~sensitive:Enabled.get SlicingParameters.Verbose.get (gui_set_slicing_debug main_ui) in let hbox3 = GPack.hbox ~packing:(table#attach ~left:1 ~top:1) () in (* [slice_undef_button] related to -slice-undef option *) let slice_undef_button = let b = GButton.check_button ~label:"Libraries" ~active:(Enabled.get ()) ~packing:(table#attach ~left:0 ~top:1) () in main_ui#help_message b "%s" msg_help_libraries ; ignore (b#connect#toggled (fun () -> gui_set_slicing_undef_functions main_ui b#active)); b in let level_refresh = Gtk_helper.on_int ~lower:0 ~upper:3 hbox3 "Level" ~sensitive:Enabled.get SlicingParameters.Mode.Calls.get (gui_set_slicing_level main_ui) in Project.register_after_set_current_hook ~user_only:true (fun _ -> rebuild_model combo_box_text); let refresh () = let value_is_computed = Db.Value.is_computed () in let slicing_project = !Db.Slicing.Project.get_project () 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.get () <> enabled_button#active then ( enabled_button#set_active (Enabled.get ()); !update_column `Contents; ); slice_undef_button#set_active (SlicingParameters.Mode.SliceUndef.get()); 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) = update_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) globs) then [`STOCK_ID "gtk-apply"] else [`STOCK_ID ""]) ~dft:[`STOCK_ID ""] (!Db.Slicing.Project.get_project ())) (fun () -> Enabled.get ()); !update_column `Visibility let main (main_ui:Design.main_window_extension_points) = main_ui#register_source_selector slicing_selector; main_ui#register_source_highlighter slicing_highlighter; main_ui#register_panel slicing_panel; file_tree_decorate main_ui#file_tree let () = Design.register_extension main (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/slicing/slicingCmds.ml0000644000175000017500000007706312155630217021024 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Those functions were previously outside the slicing module to show how to * use the slicing API. So, they are supposed to use the slicing module through * Db.Slicing only. There are mainly high level functions which make easier * to achieve simple tasks. *) open Cil open Cil_types open Db (** Utilities for [kinstr]. *) module Kinstr: sig val iter_from_func : (stmt -> unit) -> kernel_function -> unit val fold_from_func : ('a -> stmt -> 'a) -> 'a -> kernel_function -> 'a val is_call_to : stmt -> kernel_function -> bool val is_rw_zone : (Locations.Zone.t option * Locations.Zone.t option) -> stmt -> Locations.Zone.t option * Locations.Zone.t option end = struct (** Iter on statements of a kernel function *) let iter_from_func f kf = let definition = Kernel_function.get_definition kf and visitor = object inherit nopCilVisitor as super method vstmt stmt = f stmt; super#vstmt stmt (* speed up *) method vvdec _ = SkipChildren (* via visitCilFunction *) method vspec _ = SkipChildren (* via visitCilFunction *) method vcode_annot _ = SkipChildren (* via Code_annot stmt *) method vloop_annot _ = SkipChildren (* via Loop stmt *) method vexpr _ = SkipChildren (* via stmt such as Return, IF, ... *) method vlval _ = SkipChildren (* via stmt such as Set, Call, Asm, ... *) method vattr _ = SkipChildren (* via Asm stmt *) method vvrbl _ = assert false method voffs _ = assert false method vinitoffs _ = assert false method vglob _ = assert false method vinit _ = assert false method vtype _ = assert false method vattrparam _ = assert false method vlogic_type _ = assert false method vterm _ = assert false method vterm_node _ = assert false method vterm_lval _ = assert false method vterm_lhost _ = assert false method vterm_offset _ = assert false method vlogic_info _ = assert false method vlogic_var _ = assert false method vquantifiers _ = assert false method vpredicate _ = assert false method vpredicate_named _ = assert false method vpredicate_info _ = assert false method vc_initializer _ = assert false method vbehavior _ = assert false method vtype_annot _ = assert false (*method vmodel_annot _ = assert false*) method vannotation _ = assert false end in ignore (visitCilFunction (visitor:>cilVisitor) definition) (** Fold on statements of a kernel function *) let fold_from_func f acc kf = let ac = ref acc in let fold ki = ignore (ac := f (!ac) ki) in iter_from_func fold kf ; !ac (** Functions that may be called (directly or indirectly via pointer) by the statement.*) let get_called_funcs ki = match ki.skind with | Instr (Call (_,expr_f,_,_)) -> Kernel_function.Hptset.elements (snd (!Value.expr_to_kernel_function (Kstmt ki) ~with_alarms:CilE.warn_none_mode ~deps:None expr_f)) | _ -> [] (** Is statement call (direct or indirect via pointer) to [kf] *) let is_call_to ki kf = List.exists (fun caller -> caller == kf) (get_called_funcs ki) (** 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 stmt = (* returns [Zone.t read],[Zone.t writen] *) assert (Db.Value.is_computed ()); 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 function of [deps]. *) !Db.Value.lval_to_loc_with_deps ~with_alarms:CilE.warn_none_mode ~deps:read_zone (Kstmt stmt) lv in deps, Locations.enumerate_valid_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 stmt exp, Locations.Zone.bottom | Instr (Set (lv,exp,_)) -> (* returns [Zone.t read] by [exp, lv], [Zone.t writen] by [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 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 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 stmt lv in read_zone,write_zone | _ -> Locations.Zone.bottom, Locations.Zone.bottom (** Look at intersection of [rd_zone_opt]/[wr_zone_opt] with the 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) stmt = let rd_zone, wr_zone = get_rw_zone stmt in let inter_zone zone_opt zone = match zone_opt with | None -> zone_opt | Some zone_requested -> if Locations.Zone.intersects zone_requested zone then let inter = Locations.Zone.narrow zone_requested zone in Some inter else None in inter_zone rd_zone_opt rd_zone, inter_zone wr_zone_opt wr_zone end (** Topologically propagate user marks to callers in whole project *) let topologic_propagation project = !Slicing.Request.apply_all_internal project; !Db.Semantic_Callgraph.topologically_iter_on_functions (fun kf -> SlicingParameters.debug ~level:3 "doing topologic propagation for function: %a" Kernel_function.pretty kf; !Slicing.Request.apply_all_internal project) let add_to_selection set selection = !Db.Slicing.Select.add_to_selects_internal selection set (** Registered as a slicing selection function: Add a selection of the pdg nodes. *) let select_pdg_nodes set mark nodes kf = let selection = !Db.Slicing.Select.select_pdg_nodes_internal kf nodes mark in add_to_selection set selection (** Registered as a slicing selection function: Add a selection of the statement. *) 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 stmt stmt_mark in add_to_selection set selection (** Add a selection to the entrance of the function [kf] and add a selection to its return if [~return] is true and add a selection to [~inputs] parts of its inputs and add a selection to [~ouputs] parts of its outputs*) 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 kf ; let set = let selection = !Db.Slicing.Select.select_entry_point_internal kf mark in add_to_selection set selection in let set = if (Locations.Zone.equal Locations.Zone.bottom outputs) then set else let selection = !Db.Slicing.Select.select_modified_output_zone_internal kf outputs mark in add_to_selection set selection in let set = if (Locations.Zone.equal Locations.Zone.bottom inputs) then set else let selection = !Db.Slicing.Select.select_zone_at_entry_point_internal kf inputs mark in add_to_selection set selection in if return then let selection = !Db.Slicing.Select.select_return_internal kf mark in add_to_selection set selection else set (** Add a selection to the entrance of the function [kf] and add a selection to its outputs if [~outputs] is true *) let select_entry_point set ~spare kf ~outputs = if !Db.Value.is_called kf then let mark = !Db.Slicing.Mark.make ~data:(not spare) ~addr:(not spare) ~ctrl:(not spare) in assert (!Db.Value.is_called kf) ; (* otherwise [!Db.Outputs.get_external kf] gives weird results *) select_entry_point_and_some_inputs_outputs set ~mark kf ~return:outputs ~outputs:(if outputs then !Db.Outputs.get_external kf else Locations.Zone.bottom) ~inputs:Locations.Zone.bottom else set (** Registered as a slicing selection function: Add a selection of calls to a [kf]. *) let select_func_calls_to set ~spare kf = assert (Db.Value.is_computed ()); let kf_entry, _library = Globals.entry_point () in if (kf_entry == kf) then select_entry_point set ~spare kf ~outputs:true else let callers = !Db.Value.callers kf in let select_calls (caller,_) acc = Kinstr.fold_from_func (fun set ki -> if Kinstr.is_call_to ki kf then select_stmt set ~spare ki caller else set) acc caller in List.fold_right select_calls callers set let select_min_call set ~spare ki kf = let stmt_mark = !Db.Slicing.Mark.make ~data:(not spare) ~addr:(not spare) ~ctrl:(not spare) in let selection = !Db.Slicing.Select.select_min_call_internal kf ki stmt_mark in add_to_selection set selection (** Registered as a slicing selection function: Add a selection of calls to a [kf]. *) let select_func_calls_into set ~spare kf = assert (Db.Value.is_computed ()); let kf_entry, _library = Globals.entry_point () in if (kf_entry == kf) then select_entry_point set ~spare kf ~outputs:false else let callers = !Db.Value.callers kf in let select_calls (caller,_) acc = Kinstr.fold_from_func (fun set ki -> if Kinstr.is_call_to ki kf then select_min_call set ~spare ki caller else set) acc caller in List.fold_right select_calls callers set (** Registered as a slicing selection function: Add selection of function ouputs. *) let select_func_zone set mark zone kf = let selection = !Db.Slicing.Select.select_zone_at_end_internal kf zone mark in add_to_selection set selection (** Registered as a slicing selection function: Add a selection of the [kf] return statement. *) let select_func_return set ~spare kf = try let ki = Kernel_function.find_return kf in select_stmt set ~spare ki kf 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 (** Registered as a slicing selection function: Add a selection of the statement reachability. Note: add also a transparent selection on the whole statement. *) let select_stmt_ctrl set ~spare ki kf = let ctrl_mark = !Db.Slicing.Mark.make ~data:false ~addr:false ~ctrl:(not spare) in let selection = !Db.Slicing.Select.select_stmt_internal kf ki ctrl_mark in add_to_selection set selection (** Registered as a slicing selection function: Add a selection of data relative to a statement. Note: add also a transparent selection on the whole statement. *) let select_stmt_zone set mark zone ~before ki kf = let selection = !Db.Slicing.Select.select_stmt_zone_internal kf ki ~before zone mark in let set = add_to_selection set selection in select_stmt_ctrl set ~spare:true ki kf (** Registered as a slicing selection function: Add a selection of data relative to a statement. Variables of [lval_str] string are bounded relatively to the scope of the statement [~scope]. The interpretation of the address of the lvalues is done just before the execution of the statement [~eval]. The selection preserve the value of these lvalues before or after (c.f. boolean [~before]) the statement [ki]. Note: add also a transparent selection on the whole statement. *) let select_stmt_lval set mark lval_str ~before ki ~scope ~eval kf = assert (Db.Value.is_computed ()); if Datatype.String.Set.is_empty lval_str then set else let zone = Datatype.String.Set.fold (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 let loc = !Db.Value.lval_to_loc ~with_alarms:CilE.warn_none_mode (Kstmt eval) lval in let zone = Locations.enumerate_valid_bits ~for_writing:false loc in Locations.Zone.join zone acc) lval_str Locations.Zone.bottom in select_stmt_zone set mark zone ~before ki kf (** Add a selection of data relative to read/write accesses. Interpret the [~rd] lvalues and the [~wr] lvalues from [~scope], [~eval] statements of [kf]: - Variables of [lval_str] string are bounded relatively to the scope of the statement [~scope]. - The interpretation of the address of the lvalues is done just before the execution of the statement [~eval]. Find read/write accesses from the whole project if [ki_opt]=None. Otherwise, restrict the research among the direct effect of [ki_opt] statement. i.e. when [ki_opt] is a call, the selection doesn't look at the assigns clause of a call. *) let select_lval_rw set mark ~rd ~wr ~scope ~eval kf ki_opt= assert (Db.Value.is_computed ()); let zone_option ~for_writing lval_str = if Datatype.String.Set.is_empty lval_str then None else let zone = Datatype.String.Set.fold (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 let loc = !Db.Value.lval_to_loc ~with_alarms:CilE.warn_none_mode (Kstmt eval) lval in let zone = Locations.enumerate_valid_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 kf Locations.Zone.pretty zone; Some zone in 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 let select_rw_from_stmt kf ki = let rd_zone_opt, wr_zone_opt = Kinstr.is_rw_zone zone_option_rw ki in let select_zone ~before zone_opt = match zone_opt with | None -> !ac | Some zone -> SlicingParameters.debug ~level:3 "select_lval_rw sid=%d before=%b zone=%a" ki.sid before Locations.Zone.pretty zone; select_stmt_zone !ac mark zone ~before ki kf ; in ac := select_zone ~before:true rd_zone_opt ; ac := select_zone ~before:false wr_zone_opt in (match ki_opt with | Some ki -> select_rw_from_stmt kf ki | None -> Globals.Functions.iter (fun kf -> if !Db.Value.is_called kf then 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 | None -> () | Some zone_requested -> (* Format.printf "@\nselect_lval_rw zone_req=%a zone=%a@." Locations.Zone.pretty zone_requested Locations.Zone.pretty zone; *) if Locations.Zone.intersects zone_requested zone then let inter = Locations.Zone.narrow zone_requested zone in fsel inter else () in let select_wr outputs = ac := select_entry_point_and_some_inputs_outputs !ac ~mark kf ~return:false ~outputs ~inputs:Locations.Zone.bottom and select_rd inputs = ac := select_entry_point_and_some_inputs_outputs !ac ~mark kf ~return:false ~inputs ~outputs:Locations.Zone.bottom in assert (!Db.Value.is_called kf) ; (* otherwise [!Db.Outputs.get_external kf] gives weird results *) select_inter_zone select_wr zone_wr_opt (!Db.Outputs.get_external kf) ; select_inter_zone select_rd zone_rd_opt (!Db.Inputs.get_external kf) end )); !ac (** Registered as a slicing selection function: Add a selection of rw accesses to lvalues relative to a statement. Variables of [~rd] and [~wr] string are bounded relatively to the scope of the statement [~scope]. The interpretation of the address of the lvalues is done just before the execution of the statement [~eval]. The selection preserve the [~rd] and ~[wr] accesses directly contained into the statement [ki]. i.e. when [ki] is a call, the selection doesn't look at the assigns clause of the called function. Note: add also a transparent selection on the whole statement.*) let select_stmt_lval_rw set mark ~rd ~wr ki ~scope ~eval kf = select_lval_rw set mark ~rd ~wr ~scope ~eval kf (Some ki) (** Add a selection of the declaration of [vi]. *) let select_decl_var set mark vi kf = let selection = !Db.Slicing.Select.select_decl_var_internal kf vi mark in add_to_selection set selection let select_ZoneAnnot_pragmas set ~spare pragmas kf = let set = Cil_datatype.Stmt.Set.fold (* selection related to statement assign and //@ slice pragma stmt *) (fun ki' acc -> select_stmt acc ~spare ki' kf) pragmas.Properties.Interp.To_zone.stmt set in Cil_datatype.Stmt.Set.fold (* selection related to //@ slice pragma ctrl/expr *) (fun ki' acc -> select_stmt_ctrl acc ~spare ki' kf) pragmas.Properties.Interp.To_zone.ctrl set let select_ZoneAnnot_zones_decl_vars set mark (zones,decl_vars) kf = let set = Cil_datatype.Varinfo.Set.fold (fun vi acc -> select_decl_var acc mark vi kf) decl_vars.Db.Properties.Interp.To_zone.var set in let set = Cil_datatype.Logic_label.Set.fold (fun l acc -> let selection = !Db.Slicing.Select.select_label_internal kf l mark in add_to_selection acc selection) decl_vars.Db.Properties.Interp.To_zone.lbl set in List.fold_right (fun z acc -> (* selection related to the parsing/compilation of the annotation *) select_stmt_zone acc mark z.Properties.Interp.To_zone.zone ~before:z.Properties.Interp.To_zone.before z.Properties.Interp.To_zone.ki kf) zones set let get_or_raise (info_data_opt, info_decl) = match info_data_opt with | None -> (* TODO: maybe we can know how to use [info_decl] ? *) SlicingParameters.not_yet_implemented "%s" !Logic_interp.To_zone.not_yet_implemented | Some info_data -> info_data, info_decl (** 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 ki kf = let zones_decl_vars = !Properties.Interp.To_zone.from_pred pred (!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 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 ki kf = let zones_decl_vars,pragmas = !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 (** 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_annots set mark ~spare ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var ki kf = let zones_decl_vars,pragmas = !Properties.Interp.To_zone.from_stmt_annots (Some (!Properties.Interp.To_zone.code_annot_filter ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var ~others:false)) (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 (** Registered as a slicing selection function: Add a selection of the annotations related to a function. *) let select_func_annots set mark ~spare ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var kf = let zones_decl_vars,pragmas = !Properties.Interp.To_zone.from_func_annots Kinstr.iter_from_func (Some (!Properties.Interp.To_zone.code_annot_filter ~threat ~user_assert ~slicing_pragma ~loop_inv ~loop_var ~others:false)) 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 (** Registered as a slicing selection function: Add selection of function ouputs. Variables of [lval_str] string are bounded relatively to the scope of the first statement of [kf]. The interpretation of the address of the lvalues is done just before the execution of the first statement [kf]. The selection preserve the value of these lvalues before execution of the return statement. *) let select_func_lval set mark lval_str kf = if Datatype.String.Set.is_empty lval_str then set else let ki_scope_eval = Kernel_function.find_first_stmt kf in select_stmt_lval set mark lval_str ~before:false (Kernel_function.find_return kf) ~scope:ki_scope_eval ~eval:ki_scope_eval kf (** Registered as a slicing selection function: Add a selection of data relative to read/write accesses. Interpret the [~rd] lvalues and the [~wr] lvalues from [~scope], [~eval] statements of [kf]: - Variables of [lval_str] string are bounded relatively to the scope of the statement [~scope]. - The interpretation of the address of the lvalues is done just before the execution of the statement [~eval]. Find read/write accesses from the whole project if [ki_opt]=None. *) let select_func_lval_rw set mark ~rd ~wr ~scope ~eval kf = if Datatype.String.Set.is_empty rd && Datatype.String.Set.is_empty wr then set else select_lval_rw set mark ~rd ~wr ~scope ~eval kf None (** Registered as a slicing request function: Add selections to all concerned slices, as slicing requests and apply them, kernel function by kernel function. Note: - the function begins by applying the remaining internal requests. - the requests added for the last kernel function are not applied. *) let add_selection project set = let add_selection prev selection = let kf = !Slicing.Select.get_function selection in let r = match prev with None -> !Slicing.Request.apply_all_internal project ; Some (kf) | Some prev_kf -> if prev_kf == kf then prev else None and make_request slice = !Slicing.Request.add_slice_selection_internal project slice selection and slices = let slices = !Slicing.Slice.get_all project kf in if slices = [] then [!Slicing.Slice.create project kf] else slices in List.iter make_request slices ; r in ignore (Slicing.Select.fold_selects_internal add_selection None set) (** Registered as a slicing request function: Add selections that will be applied to all the slices of the function (already existing or created later) Note: - the function begins by applying the remaining internal requests. - the requests added for the last kernel function are not applied. *) let add_persistent_selection project set = (* Format.printf "@\nadd_persistent_selection@."; *) let add_selection prev selection = let kf = !Slicing.Select.get_function selection in let r = match prev with None -> !Slicing.Request.apply_all_internal project ; Some (kf) | Some prev_kf -> if prev_kf == kf then prev else None in !Slicing.Request.add_selection_internal project selection; r in ignore (Slicing.Select.fold_selects_internal add_selection None set) (** Registered as a slicing request function: Add selections that will be applied to all the slices of the function (already existing or created later) Note: - the function begins by applying the remaining internal requests. - the requests added for the last kernel function are not applied. *) let add_persistent_cmdline project = SlicingParameters.feedback ~level:1 "interpreting slicing requests from the command line..."; begin try let selection = ref Db.Slicing.Select.empty_selects in let top_mark = !Db.Slicing.Mark.make ~addr:true ~ctrl:true ~data:true in 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 in add_selection SlicingParameters.Select.Return.get !Db.Slicing.Select.select_func_return; add_selection 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 ~threat:false ~user_assert:false ~slicing_pragma:true ~loop_inv:false ~loop_var:false); add_selection SlicingParameters.Select.Threat.get (fun s -> !Db.Slicing.Select.select_func_annots s top_mark ~threat:true ~user_assert:false ~slicing_pragma:false ~loop_inv:false ~loop_var:false); add_selection SlicingParameters.Select.Assert.get (fun s -> !Db.Slicing.Select.select_func_annots s top_mark ~threat:false ~user_assert:true ~slicing_pragma:false ~loop_inv:false ~loop_var:false); add_selection SlicingParameters.Select.LoopInv.get (fun s -> !Db.Slicing.Select.select_func_annots s top_mark ~threat:false ~user_assert:false ~slicing_pragma:false ~loop_inv:true ~loop_var:false); add_selection SlicingParameters.Select.LoopVar.get (fun s -> !Db.Slicing.Select.select_func_annots s top_mark ~threat:false ~user_assert:false ~slicing_pragma:false ~loop_inv:false ~loop_var:true); ); if not (Datatype.String.Set.is_empty (SlicingParameters.Select.Value.get ())) || not (Datatype.String.Set.is_empty (SlicingParameters.Select.RdAccess.get ())) || not (Datatype.String.Set.is_empty (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; *) let kf = fst (Globals.entry_point ()) in let ki_scope_eval = Kernel_function.find_first_stmt kf in selection := !Db.Slicing.Select.select_func_lval !selection top_mark (SlicingParameters.Select.Value.get ()) kf; selection := !Db.Slicing.Select.select_func_lval_rw !selection top_mark ~rd:(SlicingParameters.Select.RdAccess.get ()) ~wr:(SlicingParameters.Select.WrAccess.get ()) ~scope:ki_scope_eval ~eval:ki_scope_eval kf ; SlicingParameters.Select.Value.clear () ; SlicingParameters.Select.RdAccess.clear () ; SlicingParameters.Select.WrAccess.clear () ; end; !Db.Slicing.Request.add_persistent_selection project !selection; with Logic_interp.Error(_loc,msg) -> SlicingParameters.error "%s. Slicing requests from the command line are ignored." msg end; SlicingParameters.feedback ~level:2 "done (interpreting slicing requests from the command line)." let apply_all project ~propagate_to_callers = assert (not propagate_to_callers) ; try while (true) do (* Format.printf "@\napply_next_internal@."; *) !Db.Slicing.Request.apply_next_internal project done with Not_found -> () (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/slicing/slicingActions.ml0000644000175000017500000002723312155630217021530 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** 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. *) (**/**) type select = SlicingTypes.sl_mark PdgMarks.select type n_or_d_marks = (SlicingInternals.node_or_dpds * SlicingInternals.pdg_mark) list (**/**) (*============================================================================*) (** {2 Build} *) (** {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 * their dependencies. (see also {!build_node_and_dpds_selection}) *) let build_simple_node_selection ?(nd_marks=[]) mark = (SlicingInternals.CwNode, mark)::nd_marks (** Only the control dependencies of the nodes will be marked *) let build_addr_dpds_selection ?(nd_marks=[]) mark = (SlicingInternals.CwAddrDpds, mark)::nd_marks (** Only the control dependencies of the nodes will be marked *) let build_data_dpds_selection ?(nd_marks=[]) mark = (SlicingInternals.CwDataDpds, mark)::nd_marks (** Only the control dependencies of the nodes will be marked *) let build_ctrl_dpds_selection ?(nd_marks=[]) mark = (SlicingInternals.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.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, * 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 = SlicingMarks.mk_user_spare in let nd_marks = build_simple_node_selection ~nd_marks:nd_marks m_spare in let nd_marks = if SlicingMarks.is_ctrl_mark mark then let m_ctrl = SlicingMarks.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 = if SlicingMarks.is_addr_mark mark then let m_addr = SlicingMarks.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 = if SlicingMarks.is_data_mark mark then let m_data = SlicingMarks.mk_user_mark ~ctrl:false ~data:true ~addr:false in build_data_dpds_selection ~nd_marks:nd_marks m_data else nd_marks in nd_marks (** {3 Translations to a mapping between marks and program elements} *) 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 in List.fold_left (add m) acc nodes in let add_node_dpds dpd_mark f_dpds acc (node, _node_z_part) = let nodes = f_dpds node in add_nodes dpd_mark acc nodes in let acc = match nd with | SlicingInternals.CwNode -> add_nodes mark acc nodes | SlicingInternals.CwAddrDpds -> let f = PdgTypes.Pdg.get_x_direct_dpds PdgTypes.Dpd.Addr pdg in List.fold_left (add_node_dpds mark f) acc nodes | SlicingInternals.CwCtrlDpds -> let f = PdgTypes.Pdg.get_x_direct_dpds PdgTypes.Dpd.Ctrl pdg in List.fold_left (add_node_dpds mark f) acc nodes | SlicingInternals.CwDataDpds -> let f = PdgTypes.Pdg.get_x_direct_dpds PdgTypes.Dpd.Data pdg in List.fold_left (add_node_dpds mark f) acc nodes in acc in List.fold_left add_pdg_mark acc nd_mark in List.fold_left translate to_select list_crit (** {3 Function criteria} *) (** 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 = SlicingInternals.CrFct { SlicingInternals.cf_fct = SlicingInternals.FctSrc fi ; SlicingInternals.cf_info = crit } let mk_fct_user_crit fi crit = mk_fct_crit fi (SlicingInternals.CcUserMark crit) let mk_crit_fct_top fi m = mk_fct_user_crit fi (SlicingInternals.CuTop m) let mk_crit_fct_user_select fi select = mk_fct_user_crit fi (SlicingInternals.CuSelect select) let mk_crit_prop_persit_marks fi node_marks = mk_fct_crit fi (SlicingInternals.CcPropagate node_marks) (** build an action to apply the criteria to the given slice. *) let mk_ff_crit ff crit = SlicingInternals.CrFct { SlicingInternals.cf_fct = SlicingInternals.FctSliced ff ; SlicingInternals.cf_info = crit } let mk_ff_user_select ff crit = mk_ff_crit ff (SlicingInternals.CcUserMark (SlicingInternals.CuSelect crit)) let mk_crit_choose_call ff call = mk_ff_crit ff (SlicingInternals.CcChooseCall call) let mk_crit_change_call ff call f = mk_ff_crit ff (SlicingInternals.CcChangeCall (call, f)) let mk_crit_missing_inputs ff call (input_marks, more_inputs) = mk_ff_crit ff (SlicingInternals.CcMissingInputs (call, input_marks, more_inputs)) let mk_crit_missing_outputs ff call (output_marks, more_outputs) = mk_ff_crit ff (SlicingInternals.CcMissingOutputs (call, output_marks, more_outputs)) let mk_crit_examines_calls ff call_out_marks = mk_ff_crit ff (SlicingInternals.CcExamineCalls call_out_marks) let mk_appli_select_calls fi = SlicingInternals.CrAppli (SlicingInternals.CaCall fi) (** {3 Shortcut functions for previous things} *) let mk_crit_mark_calls fi_caller to_call mark = let select = try let caller = SlicingMacros.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_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 SlicingInternals.CuSelect select with PdgTypes.Pdg.Top -> SlicingInternals.CuTop mark in mk_fct_user_crit fi_caller select let mk_crit_add_output_marks ff select = (* let pdg = SlicingMacros.get_ff_pdg ff in 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 in let select = List.fold_left add [] output_marks in *) mk_ff_user_select ff select (* let mk_crit_add_all_outputs_mark ff mark = let pdg = SlicingMacros.get_ff_pdg ff in let nodes = !Db.Pdg.find_all_outputs_nodes pdg in let nd_m = build_simple_node_selection mark in let select = mk_mark_nodes nodes nd_m in mk_ff_user_crit ff select *) (*============================================================================*) (** {2 Print} *) let print_nd_and_mark f (nd, m) = let str = match nd with | SlicingInternals.CwNode -> "" | SlicingInternals.CwAddrDpds -> "addr->" | SlicingInternals.CwDataDpds -> "data->" | SlicingInternals.CwCtrlDpds -> "ctrl->" in Format.fprintf f "%s%a" str SlicingMarks.pretty_mark m let rec print_nd_and_mark_list fmt ndm_list = match ndm_list with | [] -> () | 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 "%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)" (PdgTypes.Node.pretty_with_part) (n, z) SlicingMarks.pretty_mark m let print_sel_marks_list fmt to_select = 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)" Locations.Zone.pretty l SlicingMarks.pretty_mark m in match to_select with [] -> Format.fprintf fmt "" | _ -> List.iter print_sel to_select let _print_ndm fmt (nodes, ndm_list) = 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 | SlicingInternals.CuTop m -> Format.fprintf fmt "top(%a)" SlicingMarks.pretty_mark m | SlicingInternals.CuSelect to_select -> print_sel_marks_list fmt to_select let print_crit fmt crit = match crit with | SlicingInternals.CrFct fct_crit -> let fct = fct_crit.SlicingInternals.cf_fct in let name = SlicingMacros.f_name fct in Format.fprintf fmt "[%s = " name; let _ = match fct_crit.SlicingInternals.cf_info with | SlicingInternals.CcUserMark info -> print_f_crit fmt info | SlicingInternals.CcMissingInputs (call, _input_marks, more_inputs) -> Format.fprintf fmt "missing_inputs for call %d (%s)" call.Cil_types.sid (if more_inputs then "more_inputs" else "marks only") | SlicingInternals.CcMissingOutputs (call, _output_marks, more_outputs) -> Format.fprintf fmt "missing_outputs for call %d (%s)" call.Cil_types.sid (if more_outputs then "more_outputs" else "marks only") | SlicingInternals.CcChooseCall call -> Format.fprintf fmt "choose_call for call %d" call.Cil_types.sid | SlicingInternals.CcChangeCall (call,f) -> let fname = match f with | SlicingInternals.CallSlice ff -> SlicingMacros.ff_name ff | SlicingInternals.CallSrc (Some fi) -> ("(src:"^( SlicingMacros.fi_name fi)^")") | SlicingInternals.CallSrc None -> "(src)" in Format.fprintf fmt "change_call for call %d -> %s" call.Cil_types.sid fname | SlicingInternals.CcPropagate nl -> Format.fprintf fmt "propagate %a" print_sel_marks_list nl | SlicingInternals.CcExamineCalls _ -> Format.fprintf fmt "examine_calls" in Format.fprintf fmt "]" | SlicingInternals.CrAppli (SlicingInternals.CaCall fi) -> let name = SlicingMacros.fi_name fi in Format.fprintf fmt "[Appli : calls to %s]" name | _ -> SlicingParameters.not_yet_implemented "Printing this slicing criterion " let print_list_crit fmt list_crit = List.iter (print_crit fmt) list_crit (*============================================================================*) frama-c-Fluorine-20130601/src/slicing/printSlice.ml0000644000175000017500000003022312155630217020664 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Everything needed to print the result *) (**/**) open Cil_types (**/**) let find_sub_stmts st = match st.skind with | If(_,bl1,bl2,_) | TryExcept (bl1, _, bl2, _) | TryFinally (bl1, bl2, _) -> bl1.bstmts@bl2.bstmts | Block bl | Loop (_,bl, _, _, _) | Switch (_, bl, _, _) -> bl.bstmts | UnspecifiedSequence seq -> List.map (fun (x,_,_,_,_) -> x) seq | Continue _|Break _|Goto (_, _)|Return (_, _)|Instr _ -> [] let str_call_sig ff call fmt = try let _, ff_marks = ff.SlicingInternals.ff_marks in let called, sgn = PdgIndex.FctIndex.find_call ff_marks call in let print_called fmt = match called with | None | Some (None) -> Format.fprintf fmt "@[/* undetermined call */@]" | Some (Some (SlicingInternals.CallSlice ff)) -> Format.fprintf fmt "@[/* call to@ %a */@]" Fct_slice.print_ff_sig ff | Some (Some(SlicingInternals.CallSrc _)) -> Format.fprintf fmt "@[/* call to source function */@]" in Format.fprintf fmt "@[@[/* sig call:@ %a */@]@ %t@]" SlicingMarks.pretty_sig sgn print_called with Not_found -> Format.fprintf fmt "@[/* invisible call */@]" class printerClass optional_ff = object(self) inherit Printer.extensible_printer () as super val opt_ff = optional_ff method vdecl fmt var = match opt_ff with | None -> super#vdecl fmt var | Some ff -> if var.vglob then Format.fprintf fmt "@[/**/%a@]" super#vdecl var else let str_m = try let m = Fct_slice.get_local_var_mark ff var in SlicingMarks.mark_to_string m with Not_found -> "[---]" in Format.fprintf fmt "@[/* %s */@ %a@]" str_m super#vdecl var method stmtkind next fmt kind = let stmt_info fmt stmt = match opt_ff with | None -> Format.fprintf fmt "@[/* %d */@]" stmt.Cil_types.sid | Some ff -> let str_m = try let m = Fct_slice.get_stmt_mark ff stmt in SlicingMarks.mark_to_string m with Not_found -> "[---]" in if (SlicingMacros.is_call_stmt stmt)then Format.fprintf fmt "@[%t@ /* %s */@]" (str_call_sig ff stmt) str_m else Format.fprintf fmt "@[/* %s */@]" str_m in let s = Extlib.the self#current_stmt in try Format.fprintf fmt "@[%a@ %a@]" stmt_info s (fun fmt -> super#stmtkind next fmt) kind with Not_found -> (* some sub statements may be visible *) let sub_stmts = find_sub_stmts s in List.iter (self#stmt fmt) sub_stmts method label fmt l = let label_info = match opt_ff with | None -> "label" | Some ff -> let m = Fct_slice.get_label_mark ff (Extlib.the self#current_stmt) l in SlicingMarks.mark_to_string m in Format.fprintf fmt "@[/* %s */@ %a@]" label_info super#label l end let print_fct_from_pdg fmt ?ff pdg = let kf = PdgTypes.Pdg.get_kf pdg in let fct = Kernel_function.get_definition kf in let loc = Lexing.dummy_pos,Lexing.dummy_pos in let glob = Cil_types.GFun (fct, loc) in (* TODO : make it cleaner *) let printer = new printerClass ff in printer#global fmt glob let print_marked_ff fmt ff = let pdg = SlicingMacros.get_ff_pdg ff in Format.fprintf fmt "@[@[Print slice =@ %a@]@ @ %a@]" Fct_slice.print_ff_sig ff (print_fct_from_pdg ~ff) pdg let print_original_glob fmt glob = let printer = new printerClass None in printer#global fmt glob (*----------------------------------------------------------------------------*) module PrintProject = struct type t = string * SlicingInternals.project type node = | Src of SlicingInternals.fct_info | Slice of SlicingInternals.fct_slice | OptSlicingLevel of SlicingInternals.level_option | OptSliceCallers of bool | Action of (int * SlicingInternals.criterion) module V = struct type t = node end module E = struct type t = (node * node) * Cil_types.stmt option let src (e, _) = fst e let dst (e, _) = snd e end type tfi = Undef | PersistSelect | Other let fi_type fi = match fi.SlicingInternals.fi_def with | Some _f -> if SlicingMacros.fi_has_persistent_selection fi then PersistSelect else Other | None -> Undef let node_slice_callers () = (OptSliceCallers (SlicingParameters.Mode.Callers.get ())) let node_slice_calls () = (OptSlicingLevel (SlicingMacros.get_default_level_option true)) let iter_vertex f (_, proj) = f (node_slice_calls ()); f (node_slice_callers ()); let rec do_act n rq_list = match rq_list with | [] -> () | rq :: rq_list -> f (Action (n, rq)) ; do_act (n+1) rq_list in do_act 1 proj.SlicingInternals.actions; let do_kf kf = let fi = SlicingMacros.get_kf_fi proj kf in let slices = SlicingMacros.fi_slices fi in List.iter (fun ff -> f (Slice ff)) slices; f (Src fi) in Globals.Functions.iter do_kf let iter_edges_slices f proj = let do_edge dest (ff_caller, call) = f ((Slice ff_caller, dest), Some call) in let do_f _f_var fi = List.iter (do_edge (Src fi)) fi.SlicingInternals.f_called_by; let do_ff ff = List.iter (do_edge (Slice ff)) ff.SlicingInternals.ff_called_by in List.iter do_ff (SlicingMacros.fi_slices fi) in Cil_datatype.Varinfo.Hashtbl.iter do_f proj.SlicingInternals.functions let iter_edges_actions f proj = let rec do_act_edge n rq_list = match rq_list with | [] -> () | _ :: [] -> () | rq1 :: rq2 :: rq_list -> f (((Action (n, rq1)), (Action (n+1, rq2))), None); do_act_edge (n+1) (rq2 :: rq_list) in do_act_edge 1 proj.SlicingInternals.actions let iter_edges_src_fun f proj = let do_kf_calls kf = let fi = SlicingMacros.get_kf_fi proj kf in let doit (kf_caller,_) = let fi_caller = SlicingMacros.get_kf_fi proj kf_caller in f ((Src fi_caller, Src fi), None) in List.iter doit (!Db.Value.callers kf) in Globals.Functions.iter do_kf_calls let iter_edges_e f (_, proj) = let _ = match proj.SlicingInternals.actions with [] -> () | rq :: _ -> f ((node_slice_callers (), (Action (1, rq))), None) in let _ = iter_edges_slices f proj in let _ = iter_edges_actions f proj in let _ = iter_edges_src_fun f proj in () let color_soft_green = (0x7FFFD4) let color_medium_green = (0x00E598) let _color_soft_blue = (0x7FAAFF) let color_soft_orange = (0xFFD57F) let color_medium_orange = (0xFFB57F) let _color_green_yellow = (0xAAFF7F) let color_soft_yellow = (0xFFFFC3) let color_medium_yellow = (0xFFFF5D) let _color_pale_orange = (0xFFE1C3) let color_soft_pink = (0xFACDEF) let color_medium_pink = (0xF070D1) let color_soft_purple = (0xE2CDFA) let graph_attributes (name, _) = [`Label name] let default_vertex_attributes _ = [`Style `Filled] let vertex_name v = match v with | Src fi -> SlicingMacros.fi_name fi | Slice ff -> SlicingMacros.ff_name ff | Action (n, _) -> ("rq_"^(string_of_int n)) | OptSlicingLevel _ -> "slicing_level" | OptSliceCallers _ -> "slice_callers" let vertex_attributes v = match v with | Src fi -> let color = match fi_type fi with | Undef -> (`Fillcolor color_soft_yellow) | PersistSelect -> (`Fillcolor color_soft_orange) | Other -> (`Fillcolor color_soft_green) in color::[`Shape `Plaintext] | Slice ff -> let color = match fi_type ff.SlicingInternals.ff_fct with | Undef -> assert false | PersistSelect -> (`Fillcolor color_soft_orange) | Other -> (`Fillcolor color_soft_green) in color ::[`Shape `Ellipse] | Action (_, crit) -> let label = Pretty_utils.sfprintf "%a" SlicingActions.print_crit crit in let attrib = [] in let attrib = (`Label label)::attrib in let attrib = (`Fillcolor color_soft_pink)::attrib in let attrib = (`Shape `Box)::attrib in attrib | OptSlicingLevel mode -> let label = ("SliceCalls = "^(SlicingMacros.str_level_option mode)) in let attrib = [] in let attrib = (`Label label)::attrib in let attrib = (`Fillcolor color_soft_purple)::attrib in let attrib = (`Shape `Ellipse)::attrib in let attrib = (`Fontsize 10)::attrib in attrib | OptSliceCallers b -> let label = ("SliceCallers = "^(if b then "true" else "false")) in let attrib = [] in let attrib = (`Label label)::attrib in let attrib = (`Fillcolor color_soft_purple)::attrib in let attrib = (`Shape `Ellipse)::attrib in let attrib = (`Fontsize 10)::attrib in attrib let default_edge_attributes _ = let attrib = [] in let attrib = (`Fontsize 10)::attrib in attrib let edge_attributes (e, call) = let attrib = match e with | (Src _, Src _) -> [`Style `Invis] | (OptSliceCallers _, _) -> [`Style `Invis] | (_, OptSliceCallers _) -> [`Style `Invis] | _ -> [] in match call with None -> attrib | Some call -> (`Label (string_of_int call.sid)):: attrib let get_subgraph v = let mk_subgraph name attrib = let attrib = (*(`Label name) ::*) (`Style `Filled) :: attrib in Some { Graph.Graphviz.DotAttributes.sg_name= name; Graph.Graphviz.DotAttributes.sg_attributes = attrib } in let f_subgraph fi = let name = SlicingMacros.fi_name fi in let attrib = [`Label ""] in let color = match fi_type fi with | Undef -> (`Fillcolor color_medium_yellow) | PersistSelect -> (`Fillcolor color_medium_orange) | Other -> (`Fillcolor color_medium_green) in let attrib = color :: attrib in mk_subgraph name attrib in let rq_subgraph = let name = "Requests" in let attrib = [] in let attrib = (`Fillcolor color_medium_pink) :: attrib in let attrib = (`Label name) :: attrib in mk_subgraph name attrib in match v with | Src fi -> f_subgraph fi | Slice ff -> f_subgraph ff.SlicingInternals.ff_fct | Action _ -> rq_subgraph | OptSlicingLevel _ | OptSliceCallers _ -> rq_subgraph end module PrintProjGraph = Graph.Graphviz.Dot(PrintProject) let build_dot_project filename title project = let file = open_out filename in PrintProjGraph.output_graph file (title, project); close_out file let print_fct_stmts fmt (_proj, kf) = try let pdg = !Db.Pdg.get kf in print_fct_from_pdg fmt pdg; Format.pp_print_flush fmt () with Not_found -> () (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/slicing/fct_slice.ml0000644000175000017500000017101012155630217020503 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** This module deals with slice computation. * It computes a mapping between the PDG nodes and some marks * (see {!module:Fct_slice.FctMarks}), * and also manage interprocedural propagation ({!module:Fct_slice.CallInfo}). * * Most high level function, named [apply_xxx], * like [apply_change_call], [apply_missing_outputs], ..., * correspond the actions defined in the * {{:../../slicing/index.html}specification report}. * * Many functions are modifying the marks of a slice, * so they can return a list of actions to be applied in order to deal with * the propagation in the calls and callers. * * Moreover, some function (named [get_xxx_mark]) are provided to retreive * the mark of the slice elements. * *) (**/**) open Cil_types (**/**) (** Manage the information related to a function call in a slice. * It is composed of the called function if it has been established yet, * and the call signature. Also deals with the [called_by] information. *) module CallInfo : sig type call_id = SlicingInternals.fct_slice * Cil_types.stmt type t val get_info_call : call_id -> t val fold_calls : (Cil_types.stmt -> t -> 'a -> 'a) -> SlicingInternals.fct_slice -> SlicingInternals.marks_index -> 'a -> 'a val get_call_f_called : call_id -> SlicingInternals.called_fct option val get_call_sig : t -> SlicingMarks.sig_marks val get_f_called : t -> SlicingInternals.called_fct option val something_visible : t -> bool val remove_called_by : SlicingInternals.project -> call_id -> t -> unit val is_call_to_change : t -> SlicingInternals.called_fct option -> bool val change_call : SlicingInternals.project -> SlicingInternals.marks_index -> call_id -> SlicingInternals.called_fct option -> unit end = struct type call_id = SlicingInternals.fct_slice * Cil_types.stmt type t = call_id * SlicingInternals.called_fct option * SlicingMarks.sig_marks let empty = (None, SlicingMarks.empty_sig) let get_f_called (_id,f,_sgn) = f let get_sig (_id,_f,sgn) = sgn (** find call information (ff_called option + signature of a call) *) let get_info_call call_id = let ff, call = call_id in let f, sgn = try let _, marks = ff.SlicingInternals.ff_marks in match PdgIndex.FctIndex.find_call marks call with | None, sgn -> None, sgn | Some (None), sgn -> None, sgn | Some (Some f), sgn -> Some f, sgn with Not_found -> empty in (call_id, f, sgn) let get_call_f_called call_id = get_f_called (get_info_call call_id) let get_call_sig call_info = get_sig call_info let fold_calls f ff ff_marks acc = let do_it call (c_opt,sgn) a = let info = match c_opt with | None | Some (None) -> ((ff, call), None, sgn) | Some (Some f) -> ((ff, call), Some f, sgn) in f call info a in PdgIndex.FctIndex.fold_calls do_it ff_marks acc let something_visible ci = SlicingMarks.something_visible (get_sig ci) let is_call_to_change ci f_to_call = let old_called = get_f_called ci in match old_called, f_to_call with | None, None -> false | None, _ -> true | Some (SlicingInternals.CallSrc _), Some (SlicingInternals.CallSrc _) -> false | Some (SlicingInternals.CallSrc _), _ -> true | Some (SlicingInternals.CallSlice _), Some (SlicingInternals.CallSrc _) -> true | Some (SlicingInternals.CallSlice _), None -> true | Some (SlicingInternals.CallSlice ff_called), Some (SlicingInternals.CallSlice ff_to_call) -> if (SlicingMacros.equal_ff ff_called ff_to_call) then false else true let indirectly_called_src_functions call_id = let _, stmt = call_id in let funcexp = match stmt.skind with | Instr (Call (_,funcexp,_,_)) -> funcexp | _ -> assert false in let _, called_functions = !Db.Value.expr_to_kernel_function ~with_alarms:CilE.warn_none_mode (Kstmt stmt) ~deps:(Some Locations.Zone.bottom) funcexp in Kernel_function.Hptset.elements called_functions (** [call_id] is a call to [g] in [f]. * we don't want [f] to call [g] anymore, so we have to update [g] [called_by] * field. * *) let remove_called_by proj call_id call_info = let rec remove called_by = match called_by with | [] -> [] | e :: called_by -> if (SlicingMacros.same_ff_call call_id e) then called_by else e::(remove called_by) in SlicingParameters.debug ~level:2 "[Fct_Slice.CallInfo.remove_called_by] -> remove old_called"; let old_called = get_f_called call_info in match old_called with | None -> () | Some (SlicingInternals.CallSlice g) -> g.SlicingInternals.ff_called_by <- remove g.SlicingInternals.ff_called_by | Some (SlicingInternals.CallSrc (Some old_fi)) -> old_fi.SlicingInternals.f_called_by <- remove old_fi.SlicingInternals.f_called_by | Some (SlicingInternals.CallSrc (None)) -> let called = indirectly_called_src_functions call_id in let update kf = let old_fi = SlicingMacros.get_kf_fi proj kf in old_fi.SlicingInternals.f_called_by <- remove old_fi.SlicingInternals.f_called_by in List.iter update called (** very low level function to change information of a call : * no checks at all (they must have been done before). * [call] in [ff] is changed in order to call [to_call]. If some function was * previously called, update its [called_by] information. *) let change_call proj ff_marks call_id to_call = SlicingParameters.debug ~level:2 "[Fct_Slice.CallInfo.change_call]"; let call_info = get_info_call call_id in let something_to_do = is_call_to_change call_info to_call in if something_to_do then begin SlicingParameters.debug ~level:2 " -> remove old_called"; let _ = remove_called_by proj call_id call_info in SlicingParameters.debug ~level:2 " -> add new_called"; let _ = match to_call with | None -> () (* nothing to do *) | Some f -> begin match f with | (SlicingInternals.CallSrc None) -> let called = indirectly_called_src_functions call_id in let update kf = let fi = SlicingMacros.get_kf_fi proj kf in fi.SlicingInternals.f_called_by <- call_id :: fi.SlicingInternals.f_called_by in List.iter update called | (SlicingInternals.CallSlice g) -> g.SlicingInternals.ff_called_by <- call_id :: g.SlicingInternals.ff_called_by | (SlicingInternals.CallSrc (Some fi)) -> fi.SlicingInternals.f_called_by <- call_id :: fi.SlicingInternals.f_called_by end in let _ff, call = call_id in let new_call_info = to_call in PdgIndex.FctIndex.add_info_call ff_marks call new_call_info true end end (** [FctMarks] manages the mapping between a function elements and their * marks. See {!module:PdgIndex.FctIndex} to know what an element is. *) module FctMarks : sig type t (* = SlicingInternals.marks_index *) type to_prop val empty_to_prop : to_prop (** build a new, empty, slice for the function *) val new_empty_slice : SlicingInternals.fct_info -> SlicingInternals.fct_slice val new_copied_slice : SlicingInternals.fct_slice -> SlicingInternals.fct_slice val new_empty_fi_marks : SlicingInternals.fct_info -> t val fi_marks : SlicingInternals.fct_info -> t option val get_fi_node_mark : SlicingInternals.fct_info -> PdgIndex.Key.t -> SlicingTypes.sl_mark (** build a new, slice for the function with some initial marks (they will be * copied)*) val new_init_slice : SlicingInternals.fct_info -> SlicingInternals.ff_marks -> SlicingInternals.fct_slice val get_ff_marks : SlicingInternals.fct_slice -> t (** merge the marks and clear all the calls : * they will have to be processed by examine_calls. *) val merge : SlicingInternals.fct_slice -> SlicingInternals.fct_slice -> SlicingInternals.ff_marks val get_node_mark : SlicingInternals.fct_slice -> PdgIndex.Key.t -> SlicingTypes.sl_mark val get_node_marks : SlicingInternals.fct_slice -> PdgIndex.Key.t -> SlicingTypes.sl_mark list val get_sgn : SlicingInternals.fct_slice -> SlicingMarks.sig_marks option val get_new_marks: SlicingInternals.fct_slice -> SlicingTypes.sl_mark PdgMarks.select -> SlicingTypes.sl_mark PdgMarks.select val get_all_input_marks : t -> to_prop val get_matching_input_marks : t -> Locations.Zone.t -> to_prop (** add the given mark to the node, and propagate to its dependencies *) val mark_and_propagate : t -> ?to_prop:to_prop -> SlicingTypes.sl_mark PdgMarks.select -> to_prop (** add a [Spare] mark to all the input nodes of the call and propagate *) val mark_spare_call_nodes : SlicingInternals.fct_slice -> Cil_types.stmt -> to_prop (** Mark the output nodes can be made visible due to marks in their * dependencies. This can occurs if, for instance, * the user asked to select a data at the last point of a function. *) val mark_visible_output : t -> unit (** Some inputs must be visible when a parameter is used as a local variable. * ie. its input value is not used. * TODO : handle the difference between input value/decl in [Signature] *) val mark_visible_inputs : t -> to_prop -> to_prop val marks_for_caller_inputs : PdgTypes.Pdg.t -> t -> Cil_types.stmt -> to_prop -> SlicingInternals.fct_info -> (SlicingTypes.sl_mark PdgMarks.select) * bool val marks_for_call_outputs : to_prop -> (Cil_types.stmt * (PdgIndex.Signature.out_key * SlicingTypes.sl_mark) list) list val get_call_output_marks : ?spare_info:CallInfo.call_id option -> CallInfo.t -> (PdgIndex.Signature.out_key * SlicingTypes.sl_mark) list val persistant_in_marks_to_prop : SlicingInternals.fct_info -> to_prop -> SlicingTypes.sl_mark PdgMarks.pdg_select (** [f] calls [g] and the call marks have been modified in [f]. * Compute the marks that should be propagated in [g]. * * This function is also use to choose the slice of [g] to call : * in that case, the first parameter holds the call output marks * that can be given by [get_call_output_marks]. * *) val check_called_marks : (PdgIndex.Signature.out_key * SlicingTypes.sl_mark) list -> SlicingInternals.fct_slice -> (SlicingTypes.sl_mark PdgMarks.select) * bool val fold_calls : (Cil_types.stmt -> CallInfo.t -> 'a -> 'a) -> SlicingInternals.fct_slice -> 'a -> 'a val change_call : SlicingInternals.project -> SlicingInternals.fct_slice -> Cil_types.stmt -> SlicingInternals.called_fct option -> unit val debug_marked_ff : Format.formatter -> SlicingInternals.fct_slice -> unit end = struct module Marks4Pdg = struct type t = SlicingTypes.sl_mark type call_info = SlicingInternals.call_info let is_bottom = SlicingMarks.is_bottom_mark let merge m1 m2 = SlicingMarks.merge_marks [m1; m2] let combine = SlicingMarks.combine_marks let pretty = SlicingMarks.pretty_mark end module PropMark = PdgMarks.F_Fct (Marks4Pdg) type t = PropMark.t (* = SlicingInternals.ff_marks*) type to_prop = PropMark.mark_info_inter let empty_to_prop = PropMark.empty_to_prop (** @raise SlicingTypes.NoPdg when the function PDG couldn't have been * computed. *) let new_slice fi marks = let ff_num = fi.SlicingInternals.fi_next_ff_num in let pdg = SlicingMacros.get_fi_pdg fi in if (PdgTypes.Pdg.is_top pdg) then raise SlicingTypes.NoPdg; let marks = match marks with None -> PropMark.create pdg | Some (pdg, marks) -> (pdg, PdgIndex.FctIndex.copy marks) in let ff = { SlicingInternals.ff_fct = fi ; SlicingInternals.ff_id = ff_num ; SlicingInternals.ff_marks = marks ; SlicingInternals.ff_called_by = [] } in fi.SlicingInternals.fi_slices <- ff :: fi.SlicingInternals.fi_slices ; fi.SlicingInternals.fi_next_ff_num <- ff_num + 1; ff let new_copied_slice ff = try let fi = ff.SlicingInternals.ff_fct in new_slice fi (Some ff.SlicingInternals.ff_marks) with SlicingTypes.NoPdg -> assert false (** @raise SlicingTypes.NoPdg (see [new_slice]) *) let new_init_slice fi marks = new_slice fi (Some marks) (** @raise SlicingTypes.NoPdg (see [new_slice]) *) let new_empty_slice fi = new_slice fi None let new_empty_fi_marks fi = let marks = PropMark.create (SlicingMacros.get_fi_pdg fi) in fi.SlicingInternals.fi_init_marks <- Some marks ; marks let fi_marks fi = fi.SlicingInternals.fi_init_marks let get_ff_marks ff = ff.SlicingInternals.ff_marks let get_marks (fm:t) = PropMark.get_idx fm let merge ff1 ff2 = let pdg1, fm1 = ff1.SlicingInternals.ff_marks in let pdg2, fm2 = ff2.SlicingInternals.ff_marks in assert (Db.Pdg.from_same_fun pdg1 pdg2) ; let merge_marks m1 m2 = SlicingMarks.merge_marks [m1; m2] in let merge_call_info _c1 _c2 = None in let fm = PdgIndex.FctIndex.merge fm1 fm2 merge_marks merge_call_info in (pdg1, fm) let get_mark fm node_key = try PdgIndex.FctIndex.find_info (get_marks fm) node_key with Not_found -> SlicingMarks.bottom_mark let get_node_mark ff node_key = let fm = ff.SlicingInternals.ff_marks in get_mark fm node_key let get_fi_node_mark fi node_key = match fi_marks fi with None -> SlicingMarks.bottom_mark | Some fm -> get_mark fm node_key let get_node_marks ff node_key = let fm = ff.SlicingInternals.ff_marks in PdgIndex.FctIndex.find_all (get_marks fm) node_key let get_sgn ff = let fm = ff.SlicingInternals.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 = SlicingMarks.get_all_input_marks (PdgIndex.FctIndex.sgn fm) in let out_marks = [] in (in_marks, out_marks) let get_matching_input_marks fm z = let fm = get_marks fm in let in_marks = SlicingMarks.get_matching_input_marks (PdgIndex.FctIndex.sgn fm) z in let out_marks = [] in (in_marks, out_marks) let fold_calls process ff acc = let fm = ff.SlicingInternals.ff_marks in CallInfo.fold_calls process ff (get_marks fm) acc let change_call proj ff call newf = let ff_marks = get_ff_marks ff in let marks = get_marks ff_marks in CallInfo.change_call proj marks (ff, call) newf (** mark the node with the given mark and propagate it to its dependencies *) let mark_and_propagate (fct_marks:t) ?(to_prop=PropMark.empty_to_prop) to_select = PropMark.mark_and_propagate fct_marks ~to_prop to_select (** compute the marks to propagate in [pdg_caller] when the called function * have the [to_prop] marks. * @param fi_to_call is used to compute [more_inputs] only : * a persistent input mark is not considered as a new input. * *) let marks_for_caller_inputs pdg_caller old_marks call (in_info,_ as _to_prop) fi_to_call = assert (not (PdgTypes.Pdg.is_top pdg_caller)); let new_input = ref false in let m2m s m = let key = match s with | PdgMarks.SelIn loc -> PdgIndex.Key.implicit_in_key loc | PdgMarks.SelNode (n,_z) -> !Db.Pdg.node_key n in let old_m = get_mark old_marks key in let add_mark = let kf = fi_to_call.SlicingInternals.fi_kf in let op_inputs = !Db.Operational_inputs.get_internal_precise ~stmt:call kf in let z = op_inputs.Inout_type.over_inputs in match s with | PdgMarks.SelNode (_, None) -> true | PdgMarks.SelIn z' | PdgMarks.SelNode (_,Some z') -> Locations.Zone.intersects z z' in if add_mark then let new_m = SlicingMarks.missing_input_mark ~call:old_m ~called:m in SlicingParameters.debug ~level:2 "[Fct_Slice.FctMarks.marks_for_caller_inputs] for %a : \ old=%a new=%a -> %a" !Db.Pdg.pretty_key key SlicingMarks.pretty_mark old_m SlicingMarks.pretty_mark m SlicingMarks.pretty_mark (match new_m with None -> SlicingMarks.bottom_mark | Some m -> m); let _ = match new_m with | Some _new_m when SlicingMarks.is_bottom_mark old_m -> let init_m = get_fi_node_mark fi_to_call key in if SlicingMarks.is_bottom_mark init_m then new_input := true | _ -> () in new_m else None in let new_input_marks = Pdg.Register.in_marks_to_caller pdg_caller call m2m in_info in new_input_marks, !new_input let marks_for_call_outputs (_, out_info) = out_info let get_call_output_marks ?(spare_info=None) call_info = let sig_call = CallInfo.get_call_sig call_info in let add1 acc (k,m) = (k,m)::acc in let call_out_marks = PdgIndex.Signature.fold_all_outputs add1 [] sig_call in match spare_info with | None -> call_out_marks | Some (ff_call, call) -> let pdg = SlicingMacros.get_ff_pdg ff_call in let spare = SlicingMarks.mk_gen_spare in let rec add2 marks n = match !Db.Pdg.node_key n with | PdgIndex.Key.SigCallKey (_, (PdgIndex.Signature.In _)) -> marks | PdgIndex.Key.SigCallKey (_, (PdgIndex.Signature.Out key)) -> begin match marks with | [] -> [(key, spare)] | (k, m):: marks -> if PdgIndex.Signature.equal_out_key k key then let m = if SlicingMarks.is_bottom_mark m then spare else m in (k, m):: marks else (k, m)::(add2 marks n) end | _ -> assert false in PdgTypes.Pdg.fold_call_nodes add2 call_out_marks pdg call let check_called_marks new_call_marks ff_called = let ff_marks = get_ff_marks ff_called in let ff_pdg, _ = ff_marks in let new_output = ref false in let m2m s m = match s with | PdgMarks.SelIn _ -> (* let nkey = PdgIndex.Key.implicit_in_key l in *) (* As we are looking for some call output node, * even if the data is not entirely defined by the function, * it has already been taken into account in the "from". *) None | PdgMarks.SelNode (n, _z_opt) -> let nkey = !Db.Pdg.node_key n in (* let nkey = match z_opt with None -> nkey | Some z -> match nkey with | PdgIndex.Key.SigCallKey (call_id, (PdgIndex.Signature.Out _)) -> let call = PdgIndex.Key.call_from_id call_id in PdgIndex.Key.call_output_key call z | _ -> nkey in *) let old_m = get_mark ff_marks nkey in let m_opt = SlicingMarks.missing_output_mark ~call:m ~called:old_m in let new_out = match m_opt with | Some _new_m when SlicingMarks.is_bottom_mark old_m -> new_output := true; true | _ -> (); false in SlicingParameters.debug ~level:2 "[Fct_Slice.FctMarks.check_called_marks] for %a : old=%a new=%a -> %a %s" !Db.Pdg.pretty_key nkey SlicingMarks.pretty_mark old_m SlicingMarks.pretty_mark m SlicingMarks.pretty_mark (match m_opt with None -> SlicingMarks.bottom_mark | Some m -> m) (if new_out then "(new out)" else ""); m_opt in let new_called_marks = Pdg.Register.call_out_marks_to_called ff_pdg m2m new_call_marks in new_called_marks, !new_output let persistant_in_marks_to_prop fi to_prop = let in_info, _ = to_prop in SlicingParameters.debug ~level:2 "[Fct_Slice.FctMarks.persistant_in_marks_to_prop] from %s" (SlicingMacros.fi_name fi); let m2m _call _pdg_caller _n m = (* SlicingParameters.debug ~level:2 " in_m2m %a in %s ?@." PdgIndex.Key.pretty (!Db.Pdg.node_key n) (SlicingMacros.pdg_name pdg_caller); *) SlicingMarks.missing_input_mark ~call:SlicingMarks.bottom_mark ~called:m in let pdg = SlicingMacros.get_fi_pdg fi in let pdg_node_marks = Pdg.Register.translate_in_marks pdg ~m2m in_info [] in pdg_node_marks let get_new_marks ff nodes_marks = let fm = get_ff_marks ff in let add_if_new acc (n, m) = let nkey = match n with | PdgMarks.SelNode (n, _z_opt) -> (* TODO : something to do for z_opt ? *) !Db.Pdg.node_key n | PdgMarks.SelIn l -> PdgIndex.Key.implicit_in_key l in let oldm = get_mark fm nkey in let newm = SlicingMarks.minus_marks m oldm in (* Format.printf "get_new_marks for %a : old=%a new=%a -> %a@." !Db.Pdg.pretty_key nkey SlicingMarks.pretty_mark oldm SlicingMarks.pretty_mark m SlicingMarks.pretty_mark newm; *) if not (SlicingMarks.is_bottom_mark newm) then (n, newm)::acc else acc in List.fold_left add_if_new [] nodes_marks (** We know that the 'call' element is visible. * We have to check that all the associated nodes and * the dependencies of these nodes are, at least, marked as 'spare'. *) let mark_spare_nodes ff nodes = let ff_marks = get_ff_marks ff in let m_spare = SlicingMarks.mk_gen_spare in let node_marks = List.map (fun n -> (PdgMarks.mk_select_node n, m_spare)) nodes in let to_prop = mark_and_propagate ff_marks node_marks in to_prop let mark_spare_call_nodes ff call = let pdg = SlicingMacros.get_ff_pdg ff in let nodes = !Db.Pdg.find_simple_stmt_nodes pdg call in mark_spare_nodes ff nodes (** TODO : * this function should disappear when the parameter declarations will * be handled... * See TODO in Pdg.Build.do_param * *) let mark_visible_inputs _ff_marks to_prop = (* let pdg, _ = ff_marks in let kf = SlicingMacros.get_pdg_kf pdg in let param_list = Kernel_function.get_formals kf in let rec check_in_params n params = match params with | [] -> [] | _ :: params -> let node = !Db.Pdg.find_input_node pdg n in let dpds = !Db.Pdg.direct_dpds pdg node in let get_n_mark n = get_mark ff_marks (PdgTypes.Node.elem_key n) in let dpds_marks = List.map get_n_mark dpds in let m = SlicingMarks.inter_marks dpds_marks in let marks = check_in_params (n+1) params in if not (SlicingMarks.is_bottom_mark m) then begin SlicingKernel.debug ~level:2 "[Fct_Slice.FctMarks.mark_visible_inputs] %a -> %a" (!Db.Pdg.pretty_node true) node SlicingMarks.pretty_mark m; PdgMarks.add_node_to_select marks (node, None) m end else marks in let new_marks = check_in_params 1 param_list in mark_and_propagate ff_marks ~to_prop new_marks *) to_prop let mark_visible_output ff_marks = let pdg, _ = ff_marks in try let out_node = !Db.Pdg.find_ret_output_node pdg in let dpds = !Db.Pdg.direct_dpds pdg out_node in let get_n_mark n = get_mark ff_marks (PdgTypes.Node.elem_key n) in let dpds_marks = List.map get_n_mark dpds in let m = SlicingMarks.inter_marks dpds_marks in if not (SlicingMarks.is_bottom_mark m) then begin SlicingParameters.debug ~level:2 "[Fct_Slice.FctMarks.mark_visible_outputs] %a -> %a" (!Db.Pdg.pretty_node true) out_node SlicingMarks.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 Not_found -> () let debug_ff_marks fmt fm = let pdg, fm = fm in let print_node node = let node_key = PdgTypes.Node.elem_key node in let m = try try PdgIndex.FctIndex.find_info fm node_key with PdgIndex.CallStatement -> assert false with Not_found -> SlicingMarks.bottom_mark in Format.fprintf fmt "%a : %a" (!Db.Pdg.pretty_node true) node SlicingMarks.pretty_mark m in !Db.Pdg.iter_nodes print_node pdg let debug_marked_ff fmt ff = Format.fprintf fmt "@[Print slice =@ %s@]" (SlicingMacros.ff_name ff); let ff_marks = ff.SlicingInternals.ff_marks in debug_ff_marks fmt ff_marks end (*-----------------------------------------------------------------------*) (** {2 xxx } *) (** Inform about the called slice or else calls to source functions. *) let get_called_slice ff call = let call_id = (ff, call) in let f_called = CallInfo.get_call_f_called call_id in match f_called with | None -> None, false | Some (SlicingInternals.CallSrc _) -> None, true | Some (SlicingInternals.CallSlice g) -> Some g, false (*-----------------------------------------------------------------------*) (** {2 xxx } *) let _pretty_node_marks fmt marks = let print fmt (n, m) = (!Db.Pdg.pretty_node true) fmt n; SlicingMarks.pretty_mark fmt m in Format.fprintf fmt "%a" (fun fmt x -> List.iter (print fmt) x) marks let check_outputs call_id called_ff add_spare = let (ff_call, call) = call_id in SlicingParameters.debug ~level:2 "[Fct_Slice.check_outputs] %s outputs for call %d in %s" (SlicingMacros.ff_name called_ff) call.sid (SlicingMacros.ff_name ff_call); let call_info = CallInfo.get_info_call call_id in let spare_info = if add_spare then Some call_id else None in let out_call = FctMarks.get_call_output_marks ~spare_info call_info in let new_marks, more = FctMarks.check_called_marks out_call called_ff in SlicingParameters.debug ~level:2 " -> %d more marks. %s more outputs" (List.length new_marks) (if more then "some" else "no"); (new_marks, more) (** [ff] marks have changed : check if the call to [ff_called] is still ok. *) let check_ff_called ff call new_marks_in_call_outputs ff_called = let call_id = (ff, call) in let is_this_call (c, _) = (c.sid = call.sid) in let new_call_marks = try let _, new_call_marks = List.find is_this_call new_marks_in_call_outputs in new_call_marks with Not_found -> (* no new marks for this call *) [] in let missing_outputs = match new_call_marks with | [] -> (* why do we check this if there is no new mark ??? *) check_outputs call_id ff_called false | _ -> FctMarks.check_called_marks new_call_marks ff_called in match missing_outputs with | ([], false) -> None | _ -> let missing_out_act = SlicingActions.mk_crit_missing_outputs ff call missing_outputs in Some missing_out_act (** Examine the call statements after the modification of [ff] marks. * If one node is visible we have to choose which function to call, * or to check if it is ok is something is called already. * * @return a list of actions if needed. *) let examine_calls ff new_marks_in_call_outputs = SlicingParameters.debug ~level:2 "[Fct_Slice.examine_calls]"; let process_this_call call call_info filter_list = if CallInfo.something_visible call_info then begin SlicingParameters.debug ~level:2 " examine visible call %d" call.sid; let f_called = CallInfo.get_f_called call_info in let filter_list = match f_called with | None -> (* have to chose a function to call here *) SlicingParameters.debug ~level:2 " -> add choose_call"; (SlicingActions.mk_crit_choose_call ff call) :: filter_list | Some (SlicingInternals.CallSrc _) -> (* the source function compute every outputs, so nothing to do *) SlicingParameters.debug ~level:2 " -> source called : nothing to do"; filter_list | Some (SlicingInternals.CallSlice ff_called) -> (* call to a sliced function : check if it's still ok, * or create new [missing_output] action *) SlicingParameters.debug ~level:2 " -> slice called -> check"; let new_filter = check_ff_called ff call new_marks_in_call_outputs ff_called in match new_filter with None -> filter_list | Some f -> f :: filter_list in filter_list end else (* the call is not visible : nothing to do *) begin SlicingParameters.debug ~level:2 " invisible call -> OK"; filter_list end in FctMarks.fold_calls process_this_call ff [] (** build a new empty slice in the given [fct_info]. * If the function has some persistent selection, let's copy it in the new slice. * Notice that there can be at most one slice for the application entry point * (main), but we allow to have several slice for a library entry point. * @param build_actions (bool) is useful if the function has some persistent * selection : if the new slice marks will be modified just after that, * it is not useful to do [examine_calls], but if it is finished, * we must generate those actions to choose the calls. @raise SlicingTypes.NoPdg (see [new_slice]) *) let make_new_ff fi build_actions = let new_ff fi = let some_marks, ff = match fi.SlicingInternals.fi_init_marks with | None -> false, FctMarks.new_empty_slice fi | Some marks -> true, FctMarks.new_init_slice fi marks in let new_filters = (if build_actions && some_marks then examine_calls ff [] else []) in SlicingParameters.debug ~level:1 "[Fct_Slice.make_new_ff] = %s@." (SlicingMacros.ff_name ff); (ff, new_filters) in let fname = SlicingMacros.fi_name fi in let kf_entry, _ = Globals.entry_point () in if fname = Kernel_function.get_name kf_entry then match fi.SlicingInternals.fi_slices with | [] -> new_ff fi | ff :: [] -> ff, [] | _ -> assert false (* Entry point shouldn't have several slices *) else new_ff fi let copy_slice ff = let kf_entry, _ = Globals.entry_point () in if (SlicingMacros.ff_src_name ff) = Kernel_function.get_name kf_entry then raise SlicingTypes.OnlyOneEntryPointSlice else FctMarks.new_copied_slice ff (** [ff] marks have just been modified : * check if the [calls] to [ff] compute enough inputs, * and create [MissingInputs] actions if not. *) let add_missing_inputs_actions ff calls to_prop actions = let fi = ff.SlicingInternals.ff_fct in let check_call actions (ff_call, call as call_id) = let call_info = CallInfo.get_info_call call_id in let ff_called = CallInfo.get_f_called call_info in let _ = match ff_called with | Some (SlicingInternals.CallSlice ff_called) -> assert (SlicingMacros.equal_ff ff_called ff) | _ -> assert false in let pdg_caller = SlicingMacros.get_ff_pdg ff_call in assert (not (PdgTypes.Pdg.is_top pdg_caller)); (* we cannot have a top pdg here, because it is a sliced pdg *) let old_marks = FctMarks.get_ff_marks ff_call in let missing_inputs = FctMarks.marks_for_caller_inputs pdg_caller old_marks call to_prop fi in match missing_inputs with | ([], false) -> SlicingParameters.debug ~level:2 "[Fct_Slice.add_missing_inputs_actions] call %a, \ no missing inputs@." Printer.pp_location (Cil_datatype.Stmt.loc call); actions | _ -> SlicingParameters.debug ~level:2 "[Fct_Slice.add_missing_inputs_actions] call %a, \ missing inputs@." Printer.pp_location (Cil_datatype.Stmt.loc call); let new_action = SlicingActions.mk_crit_missing_inputs ff_call call missing_inputs in new_action :: actions in SlicingParameters.debug ~level:2 "[Fct_Slice.add_missing_inputs_actions] Called, calls %a" (Pretty_utils.pp_list (fun fmt (_, s) -> Printer.pp_location fmt (Cil_datatype.Stmt.loc s))) calls; let actions = List.fold_left check_call actions calls in SlicingParameters.debug ~level:2 "[Fct_Slice.add_missing_inputs_actions] %s" (match actions with | [] -> " -> no missing input" | _ -> " -> add missing inputs actions"); actions (** {2 Adding marks} *) (** [ff] marks have been modified : we have to check if the calls and the * callers are ok. Create new actions if there is something to do. * Notice that the action creations are independent from the options. * They will by used during the applications. * *) let after_marks_modifications ff to_prop = SlicingParameters.debug ~level:2 "[Fct_Slice.after_marks_modifications] before: %a" FctMarks.debug_marked_ff ff; let new_filters = [] in let calls = ff.SlicingInternals.ff_called_by in let new_filters = add_missing_inputs_actions ff calls to_prop new_filters in let call_outputs = FctMarks.marks_for_call_outputs to_prop in let new_filters = (SlicingActions.mk_crit_examines_calls ff call_outputs)::new_filters in SlicingParameters.debug ~level:2 "[Fct_Slice.after_marks_modifications] after: %s new filters" (match new_filters with | [] -> "no" | _ -> "some"); new_filters let apply_examine_calls ff call_outputs = examine_calls ff call_outputs (** quite internal function that only computes the marks. * Dont't use it alone because it doesn't take care of the calls and so on. * See [apply_add_marks] or [add_marks_to_fi] for higher level functions. *) let add_marks fct_marks nodes_marks = SlicingParameters.debug ~level:2 "add_marks@."; let to_prop = FctMarks.mark_and_propagate fct_marks nodes_marks in FctMarks.mark_visible_output fct_marks; let to_prop = FctMarks.mark_visible_inputs fct_marks to_prop in to_prop (** main function to build or modify a slice. * @return a list of the filters to add to the worklist. *) let apply_add_marks ff nodes_marks = SlicingParameters.debug ~level:3 "[Fct_Slice.apply_add_marks]@\n-BEFORE:@\n%a" FctMarks.debug_marked_ff ff; (*let pdg = SlicingMacros.get_ff_pdg ff in*) let to_prop = add_marks (FctMarks.get_ff_marks ff) nodes_marks in let new_filters = after_marks_modifications ff to_prop in new_filters (** a function that doesn't modify anything but test if the [nodes_marks] * are already in the slice or not. * @return the [nodes_marks] that are not already in. *) let filter_already_in ff selection = FctMarks.get_new_marks ff selection (** when the user adds persistent marks to a function, * he might want to propagate them to the callers, * but, anyway, we don't want to propagate persistent marks to the calls * for the same reason (if we mark [x = g ();] in [f], we don't necessarily want * all versions of [g] to have a visible [return] for instance). **) let prop_persistant_marks proj fi to_prop actions = let pdg_node_marks = FctMarks.persistant_in_marks_to_prop fi to_prop in let add_act acc (pdg, node_marks) = let kf = SlicingMacros.get_pdg_kf pdg in let fi = SlicingMacros.get_kf_fi proj kf in let a = match node_marks with | PdgMarks.SelList node_marks -> SlicingActions.mk_crit_prop_persit_marks fi node_marks | PdgMarks.SelTopMarks marks -> assert (PdgTypes.Pdg.is_top pdg); let m = SlicingMarks.merge_marks marks in SlicingActions.mk_crit_fct_top fi m in a::acc in List.fold_left add_act actions pdg_node_marks (** add the marks to the persistent marks to be used when new slices will be * created. The actions to add the marks to the existing slices are generated * in slicingProject. * If it is the first persistent selection for this function, * and [propagate=true], also generates the actions to make every calls to this * function visible. *) let add_marks_to_fi proj fi nodes_marks propagate actions = SlicingParameters.debug ~level:2 "[Fct_Slice.add_marks_to_fi] (persistent)"; let marks, are_new_marks = match FctMarks.fi_marks fi with | Some m -> m, false | None -> let init_marks = FctMarks.new_empty_fi_marks fi in init_marks, true in let to_prop = add_marks marks nodes_marks in let actions = if propagate then prop_persistant_marks proj fi to_prop actions else actions in are_new_marks, actions let add_top_mark_to_fi fi m propagate actions = let new_top = match fi.SlicingInternals.fi_top with | None -> fi.SlicingInternals.fi_top <- Some m; true | Some old_m -> fi.SlicingInternals.fi_top <- Some (SlicingMarks.merge_marks [old_m; m]); false in let actions = if propagate && new_top then (SlicingActions.mk_appli_select_calls fi)::actions else actions in actions (** {3 Choosing the function to call} *) (** Build a new action [ChangeCall] (if needed) *) let add_change_call_action ff call call_info f_to_call actions = SlicingParameters.debug ~level:2 "[Fct_Slice.add_change_call_action]:"; let add_change_call = CallInfo.is_call_to_change call_info (Some f_to_call) in if add_change_call then begin let change_call_action = SlicingActions.mk_crit_change_call ff call f_to_call in SlicingParameters.debug ~level:2 " -> %a" SlicingActions.print_crit change_call_action; change_call_action :: actions end else begin SlicingParameters.debug ~level:2 " -> not needed"; actions end (* (** This function doesn't use the PDG call dependencies on purpose ! * See explanations in [add_spare_call_inputs] *) let get_called_needed_input called_kf need_out0 needed_out_zone = let froms = !Db.From.get called_kf in let from_table = froms.Function_Froms.deps_table in let acc_in_zones out (default, from_out) in_zones = if Locations.Zone.valid_intersects needed_out_zone out then let in_zones = Locations.Zone.join in_zones from_out in let in_zones = if default then Locations.Zone.join in_zones out else in_zones in in_zones else in_zones in let in_zones = Lmap_bitwise.From_Model.fold acc_in_zones from_table Locations.Zone.bottom in let in_zones = if need_out0 then let from0 = froms.Function_Froms.deps_return in let z_return = Lmap_bitwise.From_Model.LOffset.collapse from0 in Locations.Zone.join in_zones z_return else in_zones in in_zones let get_call_in_nodes called_kf call_info called_in_zone = let (ff_caller, call_stmt) = CallInfo.get_call_id call_info in let pdg_caller = SlicingMacros.get_ff_pdg ff_caller in let pdg_idx = PdgTypes.InternalPdg.get_index pdg_caller in let _, pdg_sig_call = PdgIndex.FctIndex.find_call pdg_idx call_stmt in (* In the input zones, we have the formal parameters, not the arguments *) let param_list = Kernel_function.get_formals called_kf in let check_param (n, nodes, called_in_zone) param = let param_loc = Locations.loc_of_varinfo param in let param_zone = Locations.enumerate_valid_bits param_loc in let nodes, called_in_zone = if Locations.Zone.valid_intersects param_zone called_in_zone then let node = PdgIndex.Signature.find_input pdg_sig_call n in let called_in_zone = Locations.Zone.diff called_in_zone param_zone in ((node, None)::nodes, called_in_zone) else (nodes, called_in_zone) in (n+1, nodes, called_in_zone) in let _, nodes, in_zone = List.fold_left check_param (1, [], called_in_zone) param_list in let impl_in_nodes, undef = !Db.Pdg.find_location_nodes_at_stmt pdg_caller call_stmt ~before:true in_zone in (nodes @ impl_in_nodes), undef (** This function is used to prevent [choose_precise_slice] from looping * (see #335) because sometimes, when the [-calldeps] option is used, * the dependencies of the call in the PDG are more precise than what we * can get by slicing, and so, when we ask for the most precise slice, * we always reject the result. * So, when [choose_precise_slice] build a new slice for a call, * we first add some spare marks to the inputs of the call that are needed * by the marked outputs according to the froms of the called function. * The computed function won't be rejected then because we will * 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 SlicingKernel.debug ~level:2 "[slicing] add_spare_call_inputs in %s@." (SlicingMacros.ff_name ff_caller); let sig_call = CallInfo.get_call_sig call_info in let out0, marked_out_zone = SlicingMarks.get_marked_out_zone sig_call in let called_in_zone = get_called_needed_input called_kf out0 marked_out_zone in 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 let m_spare = SlicingMarks.mk_gen_spare in let to_select = List.fold_left (fun marks n -> PdgMarks.add_node_to_select marks n m_spare) [] needed_nodes in let to_select = PdgMarks.add_undef_in_to_select to_select undef m_spare in let actions = apply_add_marks ff_caller to_select in actions *) (** choose among the already computed slice if there is a function that computes * just enough outputs (what ever their marks are). If not, create a new one *) let choose_precise_slice fi_to_call call_info = let out_call = FctMarks.get_call_output_marks call_info in let rec find slices = match slices with | [] -> let ff, actions = make_new_ff fi_to_call true in (* let called_kf = SlicingMacros.get_fi_kf fi_to_call in let new_actions = add_spare_call_inputs called_kf call_info in let actions = new_actions @ actions in *) ff, actions | ff :: slices -> let _missing_outputs, more_outputs = FctMarks.check_called_marks out_call ff in if more_outputs then (* not enough outputs in [ff] *) begin SlicingParameters.debug ~level:2 "[Fct_Slice.choose_precise_slice] %s ? not enought outputs" (SlicingMacros.ff_name ff); find slices end else begin (* let ff_marks = FctMarks.get_ff_marks ff in let input_marks = FctMarks.get_all_input_marks ff_marks in let (caller, call) = CallInfo.get_call_id call_info in let pdg_caller = SlicingMacros.get_ff_pdg caller in let caller_marks = FctMarks.get_ff_marks caller in let _ , more_inputs = FctMarks.marks_for_caller_inputs pdg_caller caller_marks call input_marks fi_to_call in if more_inputs then (* [ff] needs too many inputs *) begin SlicingKernel.debug ~level:2 "[Fct_Slice.choose_precise_slice] %s ? too many inputs" (SlicingMacros.ff_name ff); find slices end else *) begin SlicingParameters.debug ~level:2 "[Fct_Slice.choose_precise_slice] %s ? ok" (SlicingMacros.ff_name ff); ff , [] end end in let slices = SlicingMacros.fi_slices fi_to_call in find slices (** choose the function to call according to the slicing level of the function * to call *) let choose_f_to_call fbase_to_call call_info = SlicingParameters.debug ~level:2 "[Fct_Slice.choose_f_to_call]"; let choose_min_slice fi_to_call = SlicingParameters.debug ~level:2 "MinimizeNbSlice -> choose_min_slice"; let slices = SlicingMacros.fi_slices fi_to_call in match slices with | [] -> make_new_ff fi_to_call true | ff :: [] -> ff, [] | _ -> (* TODO : choose a slice *) SlicingParameters.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"; match SlicingMacros.fi_slices fi_to_call with | [] -> make_new_ff fi_to_call true (* the signature is computed in [apply_choose_call] * (missing_outputs) *) | ff :: [] -> ff, [] | _ -> (* TODO : choose a slice *) SlicingParameters.not_yet_implemented "choose_full_slice with several slices" in let to_call, new_filters = match fbase_to_call with | None -> (* if we don't know the called function : either it is a call through a pointer or an external or variadic function => we don't try to slice it, so we keep the source call *) SlicingParameters.debug ~level:1 "unknown called function -> keep src"; SlicingInternals.CallSrc None, [] | Some fi_to_call -> try let slicing_level = fi_to_call.SlicingInternals.fi_level_option in SlicingParameters.debug ~level:1 "choose_call with level %s" (SlicingMacros.str_level_option slicing_level); match slicing_level with | SlicingInternals.DontSlice -> SlicingParameters.debug ~level:2 "DontSliceCalls -> call src"; SlicingInternals.CallSrc fbase_to_call, [] | SlicingInternals.DontSliceButComputeMarks -> let ff_to_call, new_filters = choose_full_slice fi_to_call in (SlicingInternals.CallSlice ff_to_call), new_filters | SlicingInternals.MinNbSlice -> let ff_to_call, new_filters = choose_min_slice fi_to_call in (SlicingInternals.CallSlice ff_to_call), new_filters | SlicingInternals.MaxNbSlice -> let ff_to_call, new_filters = choose_precise_slice fi_to_call call_info in (SlicingInternals.CallSlice ff_to_call), new_filters with SlicingTypes.NoPdg -> SlicingParameters.feedback "unable to compute %s PDG : call source function" (SlicingMacros.fi_name fi_to_call); SlicingInternals.CallSrc None, [] in to_call, new_filters (** we are about to call [ff] for [sig_call] : let's first add some more output * marks in [ff] if needed. *) let check_called_outputs call_id ff actions = let level = SlicingMacros.ff_slicing_level ff in let add_spare = (level = SlicingInternals.DontSliceButComputeMarks) in let missing_outputs, _more_outputs = check_outputs call_id ff add_spare in let actions = match missing_outputs with | [] -> actions | _ -> let add_outputs = SlicingActions.mk_crit_add_output_marks ff missing_outputs in add_outputs :: actions in actions (** Choose the function (slice or source) to call according to the * slicing level of the called function. * Does nothing if there is already a called function : * this is useful because we can sometime generate several [choose_call] * for the same call, and we want to do something only the first time. * Build an action [change_call] to really call it. * If the chosen function doesn't compute enough output, * build an action to add outputs to it. * *) let apply_choose_call proj ff call = SlicingParameters.debug ~level:2 "[Fct_Slice.apply_choose_call] for call-%d" call.sid; let call_id = ff, call in let call_info = CallInfo.get_info_call (ff, call) in if ((CallInfo.get_f_called call_info) = None) then begin if CallInfo.something_visible call_info then let fbase_to_call = SlicingMacros.get_fi_call proj call in let f_to_call, actions = choose_f_to_call fbase_to_call call_info in let actions = add_change_call_action ff call call_info f_to_call actions in let actions = match f_to_call with | SlicingInternals.CallSrc _ -> actions | SlicingInternals.CallSlice ff -> check_called_outputs call_id ff actions in actions else begin SlicingParameters.debug ~level:2 " -> invisible call : nothing to do"; [] end end else begin SlicingParameters.debug ~level:2 " -> already call something : nothing to do"; [] end (** {4 Calls input/output marks} *) (** propagate the [input_marks] in the inputs of [call] in [ff]. *) let modif_call_inputs ff _call input_marks = (* SlicingParameters.debug ~level:1 "modif_call_inputs : %a" pretty_node_marks input_marks; *) add_marks (FctMarks.get_ff_marks ff) input_marks (** [modif_call_inputs] and then, check the calls and the callers *) let apply_modif_call_inputs ff call missing_inputs = SlicingParameters.debug ~level:2 "apply_modif_call_inputs@."; let input_marks, _more_inputs = missing_inputs in let to_prop = modif_call_inputs ff call input_marks in let new_filters = after_marks_modifications ff to_prop in new_filters (** [ff] calls a slice [g] that needs more inputs than those computed by [ff]. * The slicing level of [ff] is used in order to know if we have to modify [ff] * or to call another function. *) let apply_missing_inputs proj ff call missing_inputs = let _input_marks, more_inputs = missing_inputs in SlicingParameters.debug ~level:1 "[Fct_Slice.apply_missing_inputs] (%s)" (if more_inputs then "more" else "marks"); (* let rec visible_top in_marks = match in_marks with | [] -> false | (sel, m)::tl -> assert (not (SlicingMarks.is_bottom_mark m)); match sel with | PdgMarks.SelNode (n, _) when (!Db.Pdg.node_key n = PdgIndex.Key.top_input) -> true | _ -> visible_top tl in let is_top_visible = visible_top input_marks in *) let level = SlicingMacros.ff_slicing_level ff in if more_inputs && level = SlicingInternals.MaxNbSlice then (* if adding marks doesn't change the visibility of the inputs, * let's keep the same called function. If it adds visible inputs, * let's choose another one *) begin FctMarks.change_call proj ff call None; apply_choose_call proj ff call end else apply_modif_call_inputs ff call missing_inputs (** [ff] calls a slice [g] that doesn't compute enough outputs for the [call]. * The missing marks are [output_marks]. * The slicing level has to be used to choose either to modify the called * function [g] or to change it. *) let apply_missing_outputs proj ff call output_marks more_outputs = SlicingParameters.debug ~level:2 "[Fct_Slice.apply_missing_outputs]"; let ff_g = match CallInfo.get_call_f_called (ff, call) with | Some (SlicingInternals.CallSlice g) -> g | _ -> (* we shouldn't be here *) assert false in let g_slicing_level = SlicingMacros.ff_slicing_level ff_g in if more_outputs && g_slicing_level = SlicingInternals.MaxNbSlice then begin (* the easiest way is to ignore the called function and to use * [choose_call] *) FctMarks.change_call proj ff call None; apply_choose_call proj ff call end else apply_add_marks ff_g output_marks (** {3 Changing the function to call} *) (** check if [f_to_call] is ok for this call, and if so, * change the function call and propagate missing marks in the inputs * if needed. * @raise ChangeCallErr if [f_to_call] doesn't compute enought outputs. *) let apply_change_call proj ff call f_to_call = SlicingParameters.debug ~level:1 "[Fct_Slice.apply_change_call]"; let pdg = SlicingMacros.get_ff_pdg ff in let to_call, to_prop = match f_to_call with | SlicingInternals.CallSlice ff_to_call -> (* let to_call_sig = FctMarks.get_sgn ff_to_call in let top = match to_call_sig with None -> false | Some to_call_sig -> SlicingMarks.is_topin_visible to_call_sig in if top then begin Cil.log "[slicing] top input in %s -> call source function" (SlicingMacros.ff_name ff_to_call); let to_prop = FctMarks.mark_spare_call_nodes ff call in SlicingInternals.CallSrc (Some (SlicingMacros.ff_fi ff_to_call)), to_prop end else *) begin let f = match check_outputs (ff, call) ff_to_call false with | ([], false) -> f_to_call | _ -> raise (SlicingTypes.ChangeCallErr "not enough computed output") in (* find [f_to_call] input marks *) let marks = FctMarks.get_ff_marks ff_to_call in let input_marks = try let kf = ff_to_call.SlicingInternals.ff_fct.SlicingInternals.fi_kf in let op_inputs = !Db.Operational_inputs.get_internal_precise ~stmt:call kf in let z = op_inputs.Inout_type.over_inputs in (*Format.printf "##Call at %a,@ kf %a,@ @[Z %a@]@." Cil.d_loc (Cil_datatype.Stmt.loc call) Kernel_function.pretty kf Locations.Zone.pretty z; *) FctMarks.get_matching_input_marks marks z with Not_found -> FctMarks.get_all_input_marks marks in let ff_marks = FctMarks.get_ff_marks ff in let missing_inputs, _more = FctMarks.marks_for_caller_inputs pdg ff_marks call input_marks ff_to_call.SlicingInternals.ff_fct in let to_prop = modif_call_inputs ff call missing_inputs in f, to_prop end | SlicingInternals.CallSrc _ -> let to_prop = FctMarks.mark_spare_call_nodes ff call in f_to_call, to_prop in FctMarks.change_call proj ff call (Some to_call); let new_filters = after_marks_modifications ff to_prop in new_filters (** When the user wants to make a [change_call] to a function that doesn't * compute enough outputs, he can call [check_outputs_before_change_call] in * order to build the action the add those outputs. *) let check_outputs_before_change_call _proj caller call ff_to_call = let call_id = caller, call in let actions = [] in let actions = check_called_outputs call_id ff_to_call actions in actions (*-----------------------------------------------------------------------*) (** {2 Merge, remove, ...} *) (** Build a new slice which marks are a join between [ff1] marks and [ff2] * marks. The result [ff] is not called at the end of this action. * [examine_calls] is called to generate the actions to choose the calls. *) let merge_slices ff1 ff2 = let fi = ff1.SlicingInternals.ff_fct in assert (SlicingMacros.equal_fi fi ff2.SlicingInternals.ff_fct); (* TODO : raise exception *) let ff, _ = try make_new_ff fi false (* [ff] can already have some persistent selection, * but we can safely forget then because they then have to also be in * [ff1] and [ff2]. *) with SlicingTypes.NoPdg -> assert false in ff.SlicingInternals.ff_marks <- FctMarks.merge ff1 ff2; let to_prop = FctMarks.empty_to_prop (* ff is new, so it isn't called, and all its calls are reset to None... *) in let new_filters = after_marks_modifications ff to_prop in ff, new_filters (** [ff] has to be removed. We have to check if it is not called * and to remove the called function in [ff]. * @raise SlicingTypes.CantRemoveCalledFf if the slice is called. * *) let clear_ff proj ff = let clear_call call_stmt call_info _ = CallInfo.remove_called_by proj (ff, call_stmt) call_info in match ff.SlicingInternals.ff_called_by with | [] -> FctMarks.fold_calls clear_call ff () | _ -> raise SlicingTypes.CantRemoveCalledFf (*-----------------------------------------------------------------------*) (** {2 Getting the slice marks} *) let get_node_key_mark ff k = try FctMarks.get_node_mark ff k with Not_found -> SlicingMarks.bottom_mark let get_node_mark ff node = get_node_key_mark ff (PdgTypes.Node.elem_key node) let get_local_var_mark ff var = get_node_key_mark ff (PdgIndex.Key.decl_var_key var) let get_param_mark ff n = try match FctMarks.get_sgn ff with None -> SlicingMarks.bottom_mark | Some sgn -> SlicingMarks.get_input_mark sgn n with Not_found -> SlicingMarks.bottom_mark let get_label_mark ff label_stmt label = let key = PdgIndex.Key.label_key label_stmt label in get_node_key_mark ff key let get_stmt_mark ff stmt = try let stmt_key = PdgIndex.Key.stmt_key stmt in let marks = FctMarks.get_node_marks ff stmt_key in let marks = match stmt_key with | PdgIndex.Key.Stmt _ -> marks | PdgIndex.Key.CallStmt _ -> marks | _ -> assert false in SlicingMarks.merge_marks marks with Not_found -> match stmt.Cil_types.skind with | Cil_types.Block _ | Cil_types.UnspecifiedSequence _ -> (* block are always visible for syntactic reasons *) SlicingMarks.mk_gen_spare | _ -> SlicingMarks.bottom_mark let get_top_input_mark fi = try let key = PdgIndex.Key.top_input in FctMarks.get_fi_node_mark fi key with Not_found -> SlicingMarks.bottom_mark let merge_inputs_m1_mark ff = let ff_sig = match FctMarks.get_sgn ff with Some s -> s | None -> assert false (* "Should have a signature !" *) in SlicingMarks.merge_inputs_m1_mark ff_sig let get_input_loc_under_mark ff loc = let ff_sig = match FctMarks.get_sgn ff with Some s -> s | None -> assert false (* "Should have a signature !" *) in SlicingMarks.get_input_loc_under_mark ff_sig loc (*-----------------------------------------------------------------------*) (** {2 Getting the source function marks} *) exception StopMerging let merge_fun_callers get_list get_value merge is_top acc proj kf = if is_top acc then acc else begin let acc = ref acc in let table = ref Cil_datatype.Varinfo.Set.empty in try let merge m = acc := merge m !acc ; if is_top !acc then raise StopMerging (* acceleration when top is reached *) in let rec merge_fun_callers kf = let merge_fun_caller (kf,_) = merge_fun_callers kf in let vf = Kernel_function.get_vi kf in if not (Cil_datatype.Varinfo.Set.mem vf !table) then begin table := Cil_datatype.Varinfo.Set.add vf !table ; 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. *) in merge_fun_callers kf; !acc with StopMerging -> !acc end (** The mark [m] related to all statements of a source function [kf]. Property : [is_bottom (get_from_func proj kf) = not (Project.is_called proj kf) ] *) let get_mark_from_src_fun proj kf = let kf_entry, _library = Globals.entry_point () in if !Db.Slicing.Project.is_called proj kf_entry then SlicingMarks.mk_user_mark ~data:true ~addr:true ~ctrl:true else let directly_called proj kf = (SlicingMacros.get_kf_fi proj kf).SlicingInternals.f_called_by in let get_call_mark (ff,stmt) = get_stmt_mark ff stmt in let merge m1 m2 = SlicingMarks.merge_marks [m1 ; m2] in let is_top = SlicingMarks.is_top_mark in let bottom = SlicingMarks.bottom_mark in merge_fun_callers directly_called get_call_mark merge is_top bottom proj kf (*-----------------------------------------------------------------------*) (** {2 Printing} (see also {!PrintSlice}) *) let print_ff_sig fmt ff = Format.fprintf fmt "@[%s:@ " (SlicingMacros.ff_name ff); match FctMarks.get_sgn ff with | None -> Format.fprintf fmt "@]" | Some s -> Format.fprintf fmt "%a@]" SlicingMarks.pretty_sig s (*-----------------------------------------------------------------------*) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/slicing/slicingCmds.mli0000644000175000017500000001164212155630217021164 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Db (* TODO: This .mli exists mainly to avoid problems with 'make -j'. This API is too vast and must be simplified. For example, functions should not receive variables as names (ie. strings) but directly as zones, possibly with a hint to the function that does to conversion. Also, most functions are slightly modified in Register, then registered in Db. This module and Register should be fused. *) val topologic_propagation : Slicing.Project.t -> unit val select_pdg_nodes : Slicing.Select.set -> Slicing.Mark.t -> PdgTypes.Node.t list -> kernel_function -> Slicing.Select.set val select_stmt : Slicing.Select.set -> spare:bool -> stmt -> kernel_function -> Slicing.Select.set val select_func_calls_to : Slicing.Select.set -> spare:bool -> Kernel_function.t -> Slicing.Select.set val select_func_calls_into : Slicing.Select.set -> spare:bool -> Kernel_function.t -> Slicing.Select.set val select_func_zone : Slicing.Select.set -> Slicing.Mark.t -> Locations.Zone.t -> kernel_function -> Slicing.Select.set val select_func_return : Slicing.Select.set -> spare:bool -> Kernel_function.t -> Slicing.Select.set val select_stmt_ctrl : Slicing.Select.set -> spare:bool -> stmt -> kernel_function -> Slicing.Select.set val select_stmt_zone : Slicing.Select.set -> Slicing.Mark.t -> Locations.Zone.t -> before:bool -> stmt -> kernel_function -> Slicing.Select.set val select_stmt_lval : Slicing.Select.set -> Slicing.Mark.t -> Datatype.String.Set.t -> before:bool -> stmt -> scope:stmt -> eval:stmt -> kernel_function -> Slicing.Select.set val select_stmt_lval_rw : Slicing.Select.set -> Slicing.Mark.t -> rd:Datatype.String.Set.t -> wr:Datatype.String.Set.t -> stmt -> scope:stmt -> eval:stmt -> Kernel_function.t -> Slicing.Select.set val select_stmt_pred : Slicing.Select.set -> Slicing.Mark.t -> predicate named -> stmt -> kernel_function -> Slicing.Select.set val select_stmt_term : Slicing.Select.set -> Slicing.Mark.t -> term -> stmt -> kernel_function -> Slicing.Select.set val select_stmt_annot : Slicing.Select.set -> Slicing.Mark.t -> spare:bool -> code_annotation -> stmt -> kernel_function -> Slicing.Select.set val select_stmt_annots : Slicing.Select.set -> Slicing.Mark.t -> spare:bool -> threat:bool -> user_assert:bool -> slicing_pragma:bool -> loop_inv:bool -> loop_var:bool -> stmt -> kernel_function -> Slicing.Select.set val select_func_annots : Slicing.Select.set -> Slicing.Mark.t -> spare:bool -> threat:bool -> user_assert:bool -> slicing_pragma:bool -> loop_inv:bool -> loop_var:bool -> kernel_function -> Slicing.Select.set val select_func_lval : Slicing.Select.set -> Slicing.Mark.t -> Datatype.String.Set.t -> Kernel_function.t -> Slicing.Select.set val select_func_lval_rw : Slicing.Select.set -> Slicing.Mark.t -> rd:Datatype.String.Set.t -> wr:Datatype.String.Set.t -> scope:stmt -> eval:stmt -> Kernel_function.t -> Slicing.Select.set val add_selection : Slicing.Project.t -> Slicing.Select.set -> unit val add_persistent_selection : Slicing.Project.t -> Slicing.Select.set -> unit val add_persistent_cmdline : Slicing.Project.t -> unit val apply_all : Slicing.Project.t -> propagate_to_callers:bool -> unit frama-c-Fluorine-20130601/src/slicing/slicingMarks.ml0000644000175000017500000004111612155630217021201 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Everything related with the marks. Mainly quite low level function. *) (**/**) let debug = false (**/**) (** a [Mark] is used to represent some information about the status of * a PDF element in a slice. *) module Mark : sig val bottom : SlicingInternals.mark val spare : SlicingInternals.mark val data : SlicingInternals.mark val ctrl : SlicingInternals.mark val addr : SlicingInternals.mark val mk_adc : bool -> bool -> bool -> SlicingInternals.mark val is_bottom : SlicingInternals.mark -> bool val is_top : SlicingInternals.mark -> bool val is_included : SlicingInternals.mark -> SlicingInternals.mark -> bool (** this operation has to be commutative. It is used to merge two slices into one. *) val merge : SlicingInternals.mark -> SlicingInternals.mark -> SlicingInternals.mark val inter : SlicingInternals.mark -> SlicingInternals.mark -> SlicingInternals.mark (** this operation add a new information to the old value. * @return (new_mark, is_new) where is_new=true if the new_mark is not included in the old one. *) val combine : old:SlicingInternals.mark -> SlicingInternals.mark -> bool * SlicingInternals.mark (** [minus m1 m2] provides the mark [m] that you have to merge with [m2] to * get at least [m1]. So : [m1 <= m U m2] * If [m1 <= m2] then [m = bot]. * *) val minus : SlicingInternals.mark -> SlicingInternals.mark -> SlicingInternals.mark val pretty : Format.formatter -> SlicingInternals.mark -> unit end = struct let spare = SlicingInternals.Spare (* Internal constructor *) let create_adc a d c = SlicingInternals.Cav (PdgTypes.Dpd.make ~a ~d ~c ()) let bottom = SlicingInternals.Cav PdgTypes.Dpd.bottom let top = SlicingInternals.Cav PdgTypes.Dpd.top 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_dc = create_adc false true true let create adc = match adc with | false, false, false -> bottom | true, false, false -> addr | false, true, false -> data | false, false, true -> ctrl | true, true, false -> m_ad | 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 (PdgTypes.Dpd.adc_value dpd) let is_bottom m = (m = bottom) let is_top m = (m = top) let is_included m1 m2 = match m1,m2 with | SlicingInternals.Spare, SlicingInternals.Spare -> true | SlicingInternals.Spare, SlicingInternals.Cav _ -> not (is_bottom m2) | SlicingInternals.Cav _, SlicingInternals.Spare -> is_bottom m1 | SlicingInternals.Cav d1, SlicingInternals.Cav d2 -> PdgTypes.Dpd.is_included d1 d2 let merge m1 m2 = match m1,m2 with | SlicingInternals.Spare, SlicingInternals.Spare -> m1 | SlicingInternals.Spare, SlicingInternals.Cav _ -> if is_bottom m2 then m1 else m2 | SlicingInternals.Cav _, SlicingInternals.Spare -> if is_bottom m1 then m2 else m1 | SlicingInternals.Cav d1, SlicingInternals.Cav d2 -> mk_mark (PdgTypes.Dpd.combine d1 d2) let inter m1 m2 = if is_bottom m1 then m1 else if is_bottom m2 then m2 else (* m1 and m2 are not bottom => the result cannot be bottom *) match m1,m2 with | SlicingInternals.Spare, _ -> m1 | _, SlicingInternals.Spare -> m2 | SlicingInternals.Cav d1, SlicingInternals.Cav d2 -> let m = mk_mark (PdgTypes.Dpd.inter d1 d2) in if is_bottom m then spare else m let combine ~old m = match old, m with | SlicingInternals.Spare, SlicingInternals.Spare -> (false, old) | SlicingInternals.Cav old_d, SlicingInternals.Spare -> if PdgTypes.Dpd.is_bottom old_d then (true, m) else (false, old) | SlicingInternals.Spare, SlicingInternals.Cav new_d -> if PdgTypes.Dpd.is_bottom new_d then (false, old) else (true, m) | SlicingInternals.Cav old_d, SlicingInternals.Cav new_d -> let new_d = PdgTypes.Dpd.combine old_d new_d in if old_d = new_d then (false, old) else (true, mk_mark new_d) let minus m1 m2 = match m1,m2 with | SlicingInternals.Spare, SlicingInternals.Spare -> bottom | SlicingInternals.Spare, SlicingInternals.Cav d2 -> if PdgTypes.Dpd.is_bottom d2 then m1 else bottom | SlicingInternals.Cav _, SlicingInternals.Spare -> m1 (* even if [PdgTypes.Dpd.is_bottom d1] because m1 = bot *) | SlicingInternals.Cav d1, SlicingInternals.Cav d2 -> mk_mark (PdgTypes.Dpd.minus d1 d2) let pretty fmt m = match m with | SlicingInternals.Cav d -> PdgTypes.Dpd.pretty fmt d | SlicingInternals.Spare -> Format.fprintf fmt "[ S ]" end (** a [SlicingInternals.pdg_mark] 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. *) let mk_m1 m1 = { SlicingInternals.m1 = m1 ; m2 = Mark.bottom } let mk_m2 m2 = { SlicingInternals.m1 = Mark.bottom ; m2 = m2} let bottom_mark = { SlicingInternals.m1 = Mark.bottom ; m2 = Mark.bottom } let user_mark m = Mark.merge m.SlicingInternals.m1 m.SlicingInternals.m2 let is_bottom_mark m = (Mark.is_bottom (user_mark m)) module MarkPair = struct let mk_m1_spare = mk_m1 Mark.spare let mk_gen_spare = mk_m2 Mark.spare let is_top m = (Mark.is_top m.SlicingInternals.m1) && (Mark.is_top m.SlicingInternals.m2) let is_ctrl m = (Mark.is_included Mark.ctrl (user_mark m)) 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 = not (is_bottom_mark m) && not (is_ctrl m || is_addr m || is_data m) let compare = SlicingInternals.compare_pdg_mark let _is_included ma mb = Mark.is_included ma.SlicingInternals.m1 mb.SlicingInternals.m1 && Mark.is_included ma.SlicingInternals.m2 mb.SlicingInternals.m2 let pretty fmt m = Format.fprintf fmt "@[<%a,@ %a>@]" Mark.pretty m.SlicingInternals.m1 Mark.pretty m.SlicingInternals.m2 let to_string m = Pretty_utils.sfprintf "%a" pretty m let minus ma mb = { SlicingInternals.m1 = Mark.minus ma.SlicingInternals.m1 mb.SlicingInternals.m1; m2 = Mark.minus ma.SlicingInternals.m2 mb.SlicingInternals.m2 } (** see {! Mark.merge} *) let merge ma mb = let m1 = Mark.merge ma.SlicingInternals.m1 mb.SlicingInternals.m1 in let m2 = Mark.merge ma.SlicingInternals.m2 mb.SlicingInternals.m2 in { SlicingInternals.m1 = m1 ; m2 = m2 } (** merge only ma_1 et mb_1, m_2 is always bottom *) let merge_user_marks ma mb = let m1 = Mark.merge ma.SlicingInternals.m1 mb.SlicingInternals.m1 in { SlicingInternals.m1 = m1 ; m2 = Mark.bottom } let rec merge_all marks = match marks with | [] -> bottom_mark | m :: [] -> m (* to avoid merging with bottom every time ! *) | m :: tl -> merge m (merge_all tl) let inter ma mb = let m1 = Mark.inter ma.SlicingInternals.m1 mb.SlicingInternals.m1 in let m2 = Mark.inter ma.SlicingInternals.m2 mb.SlicingInternals.m2 in { SlicingInternals.m1 = m1 ; m2 = m2 } let rec inter_all marks = match marks with | [] -> bottom_mark | m :: [] -> m | m :: tl -> inter m (inter_all tl) (** [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, * it means that [mb] was included in [ma]. *) let combine ma mb = let combine_m ma mb = let is_new, mr = Mark.combine ma mb in let m_to_prop = if is_new then mr else Mark.bottom in mr, m_to_prop in let new_m1, prop1 = combine_m ma.SlicingInternals.m1 mb.SlicingInternals.m1 in let new_m2, prop2 = combine_m ma.SlicingInternals.m2 mb.SlicingInternals.m2 in { SlicingInternals.m1 = new_m1 ; m2 = new_m2 }, { SlicingInternals.m1 = prop1 ; m2 = 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 * 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 * and check with Patrick if it is ok. * *) let missing_output ~call:m_out_call ~called:m_out_called = if debug then Format.printf "check_out : call=%a called=%a\n" pretty m_out_call pretty m_out_called; let mf1 = m_out_call.SlicingInternals.m1 in let mf2 = m_out_call.SlicingInternals.m2 in let mg1 = m_out_called.SlicingInternals.m1 in let mg2 = m_out_called.SlicingInternals.m2 in let needed_mg2 = (* we need (mf1 + mf2) for this out in the call *) 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 else let m2 = mk_m2 min_mg2 in 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]). * 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 = let mf1 = m_in_call.SlicingInternals.m1 in let mf2 = m_in_call.SlicingInternals.m2 in let mg1 = m_in_called.SlicingInternals.m1 in let mg2 = m_in_called.SlicingInternals.m2 in let new_mf1 = if Mark.is_included mg1 mf1 then Mark.bottom else mg1 in let new_mf2 = if (not (Mark.is_bottom mg2)) && (Mark.is_bottom mf2) then Mark.spare else Mark.bottom in let new_m = { SlicingInternals.m1 = new_mf1 ; m2 = new_mf2 } in if is_bottom_mark new_m then None else Some new_m end (** [SigMarks] works on the marks in function signatures. *) module SigMarks = struct open PdgIndex type t = SlicingInternals.pdg_mark Signature.t let pretty = Signature.pretty MarkPair.pretty let get_input_mark (sgn:t) n = Signature.find_input sgn n let get_in_ctrl_mark (sgn:t) = Signature.find_in_ctrl sgn let get_in_top_mark (sgn:t) = Signature.find_in_top sgn let get_all_input_marks (sgn:t) = Signature.fold_all_inputs (fun acc (k, m) -> (k, m)::acc) [] sgn let get_matching_input_marks (sgn:t) z = Signature.fold_all_inputs (fun acc (k, m) -> match k with | PdgIndex.Signature.InCtrl | PdgIndex.Signature.InNum _ -> (k, m) :: acc | PdgIndex.Signature.InImpl z' -> if Locations.Zone.intersects z z' then (k, m) :: acc else acc ) [] sgn exception Visible let raise_if_visible () (_, m) = if is_bottom_mark m then () else raise Visible let some_visible_out cm = try Signature.fold_all_outputs raise_if_visible () cm ; false with Visible -> true let is_topin_visible cm = try let m = get_in_top_mark cm in not (is_bottom_mark m) with Not_found -> false let ctrl_visible cm = try let ctrl_m = get_in_ctrl_mark cm in not (is_bottom_mark ctrl_m) 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) -> MarkPair.merge_user_marks acc m) bottom_mark 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. * Else, it returns the intersection of the inputs that intersect the location. *) let get_input_loc_under_mark cm loc = if debug then Format.printf "get_input_loc_under_mark of %a" Locations.Zone.pretty loc; assert (not (Locations.Zone.equal Locations.Zone.bottom loc)); let do_in (marked_inputs, marks) (in_loc, m) = if is_bottom_mark m then (marked_inputs, []) 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 let marked_inputs = Locations.Zone.bottom in let marked_inputs, marks = Signature.fold_impl_inputs do_in (marked_inputs, []) cm in let m = if Locations.Zone.is_included loc marked_inputs then MarkPair.inter_all marks else bottom_mark in if debug then Format.printf "get_input_loc_under_mark : m = %a" MarkPair.pretty m; m let something_visible cm = some_visible_out cm || some_visible_in cm || ctrl_visible cm let get_marked_out_zone call_marks = let add (out0, out_zone) (out_key, m_out) = if is_bottom_mark m_out then (out0, out_zone) else match out_key with | PdgIndex.Signature.OutRet -> true, out_zone | PdgIndex.Signature.OutLoc z -> out0, Locations.Zone.join out_zone z in Signature.fold_all_outputs add (false, Locations.Zone.bottom) call_marks end (** 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] *) (** {2 Exported things} *) (** {3 on marks} *) 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 mk_m1 (Mark.mk_adc addr data ctrl) else mk_user_spare let is_top_mark = MarkPair.is_top let is_spare_mark = MarkPair.is_spare let is_ctrl_mark = MarkPair.is_ctrl let is_addr_mark = MarkPair.is_addr let is_data_mark = MarkPair.is_data let merge_marks = MarkPair.merge_all let combine_marks = MarkPair.combine let inter_marks = MarkPair.inter_all let minus_marks = MarkPair.minus let compare_marks = MarkPair.compare let pretty_mark = MarkPair.pretty let mark_to_string = MarkPair.to_string let missing_input_mark = MarkPair.missing_input let missing_output_mark = MarkPair.missing_output (** {3 on signatures} *) type sig_marks = SigMarks.t let empty_sig = PdgIndex.Signature.empty let get_input_mark = SigMarks.get_input_mark let get_all_input_marks = SigMarks.get_all_input_marks let get_matching_input_marks = SigMarks.get_matching_input_marks let merge_inputs_m1_mark = SigMarks.merge_inputs_m1_mark let get_input_loc_under_mark = SigMarks.get_input_loc_under_mark (*let same_output_visibility = SigMarks.same_output_visibility*) let get_in_ctrl_mark = SigMarks.get_in_ctrl_mark let something_visible = SigMarks.something_visible let some_visible_out = SigMarks.some_visible_out let is_topin_visible = SigMarks.is_topin_visible let get_marked_out_zone = SigMarks.get_marked_out_zone let pretty_sig = SigMarks.pretty (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/slicing/register.mli0000644000175000017500000000351612155630217020552 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** * This file should be empty because every API functions of the slicing module * should be registered in {!Db.Slicing}. If you are more interested in the internal point of view of this module, please look at {{:../code_slicing/index.html}here}. *) frama-c-Fluorine-20130601/src/slicing/slicingMacros.ml0000644000175000017500000001653312155630217021355 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Slicing module public macros that should be used to avoid using the type * concrete definition from other modules. *) (**/**) open Cil_types (**/**) (** {2 Options} *) let str_level_option opt = match opt with | SlicingInternals.DontSlice -> "DontSlice" | SlicingInternals.DontSliceButComputeMarks -> "DontSliceButComputeMarks" | SlicingInternals.MinNbSlice -> "MinNbSlice" | SlicingInternals.MaxNbSlice -> "MaxNbSlice" let translate_num_to_slicing_level n = match n with | 0 -> SlicingInternals.DontSlice | 1 -> SlicingInternals.DontSliceButComputeMarks | 2 -> SlicingInternals.MinNbSlice | 3 -> SlicingInternals.MaxNbSlice | _ -> raise SlicingTypes.WrongSlicingLevel let get_default_level_option defined_function = if defined_function || (SlicingParameters.Mode.SliceUndef.get ()) then translate_num_to_slicing_level (SlicingParameters.Mode.Calls.get ()) else SlicingInternals.DontSlice (** {2 Getting [fct_info] and others } *) (** {4 getting [svar]} *) let fi_svar fi = Kernel_function.get_vi fi.SlicingInternals.fi_kf let ff_svar ff = fi_svar (ff.SlicingInternals.ff_fct) (** {4 getting [fct_info]} *) (** Get the fct_info if it exists or build a new fct_info. *) let get_kf_fi proj kf = let fct_var = Kernel_function.get_vi kf in try Cil_datatype.Varinfo.Hashtbl.find proj.SlicingInternals.functions fct_var with Not_found -> let fi_def, is_def = 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 = { SlicingInternals.fi_kf = kf; SlicingInternals.fi_def = fi_def; SlicingInternals.fi_project = proj; SlicingInternals.fi_top = None; SlicingInternals.fi_level_option = get_default_level_option is_def; SlicingInternals.fi_init_marks = None ; SlicingInternals.fi_slices = [] ; SlicingInternals.fi_next_ff_num = 1; SlicingInternals.f_called_by = [] } in Cil_datatype.Varinfo.Hashtbl.add proj.SlicingInternals.functions fct_var new_fi; new_fi let fold_fi f acc proj = Cil_datatype.Varinfo.Hashtbl.fold (fun _v fi acc -> f acc fi) proj.SlicingInternals.functions acc (** {4 getting num id} *) let get_ff_id ff = ff.SlicingInternals.ff_id (** {4 getting names} *) let fi_name fi = let svar = fi_svar fi in svar.Cil_types.vname (** get the name of the function corresponding to that slice. *) let ff_name ff = let fi = ff.SlicingInternals.ff_fct in let ff_id = get_ff_id ff in let fct_name = fi_name fi in (fct_name ^ "_slice_" ^ (string_of_int (ff_id))) let f_name f = match f with | SlicingInternals.FctSrc fct -> fi_name fct | SlicingInternals.FctSliced ff -> ff_name ff let ff_src_name ff = fi_name ff.SlicingInternals.ff_fct (** {4 getting [kernel_function]} *) let get_fi_kf fi = fi.SlicingInternals.fi_kf let get_ff_kf ff = let fi = ff.SlicingInternals.ff_fct in get_fi_kf fi let get_pdg_kf pdg = PdgTypes.Pdg.get_kf pdg (** {4 getting PDG} *) let get_fi_pdg fi = let kf = get_fi_kf fi in !Db.Pdg.get kf let get_ff_pdg ff = get_fi_pdg ff.SlicingInternals.ff_fct (** {4 getting the slicing level} *) let ff_slicing_level ff = ff.SlicingInternals.ff_fct.SlicingInternals.fi_level_option let change_fi_slicing_level fi slicing_level = fi.SlicingInternals.fi_level_option <- slicing_level (** @raise SlicingTypes.WrongSlicingLevel if [n] is not valid. * *) let change_slicing_level proj kf n = let slicing_level = translate_num_to_slicing_level n in let fi = get_kf_fi proj kf in (* build if if it doesn't exist *) change_fi_slicing_level fi slicing_level (** {2 functions and slices} *) let fi_slices fi = fi.SlicingInternals.fi_slices (** {4 Comparisons} *) let equal_fi fi1 fi2 = let v1 = fi_svar fi1 in let v2 = fi_svar fi2 in Cil_datatype.Varinfo.equal v1 v2 let equal_ff ff1 ff2 = (equal_fi ff1.SlicingInternals.ff_fct ff2.SlicingInternals.ff_fct) && ((get_ff_id ff1) = (get_ff_id ff2)) (** {2 Calls} *) let same_call c1 c2 = (c1.sid = c2.sid) let same_ff_call (f1,c1) (f2,c2) = equal_ff f1 f2 && same_call c1 c2 let is_call_stmt stmt = match stmt.skind with Instr (Call _) -> true | _ -> false let get_called_kf call_stmt = match call_stmt.skind with | Instr (Call (_, funcexp,_,_)) -> let _funcexp_dpds, called_functions = !Db.Value.expr_to_kernel_function ~with_alarms:CilE.warn_none_mode ~deps:(Some Locations.Zone.bottom) (Kstmt call_stmt) funcexp in (match Kernel_function.Hptset.contains_single_elt called_functions with | Some kf -> kf | _ -> raise SlicingTypes.PtrCallExpr) | _ -> invalid_arg "Not a call statement !" let is_variadic kf = let varf = Kernel_function.get_vi kf in match varf.vtype with | TFun (_, _, is_variadic, _) -> is_variadic | _ -> assert false (** get the [fct_info] of the called function, if we know it *) let get_fi_call proj call = try let kf = get_called_kf call in if is_variadic kf then None else let fct_info = get_kf_fi proj kf in Some fct_info with SlicingTypes.PtrCallExpr -> None let is_src_fun_called proj kf = let fi = get_kf_fi proj kf in match fi.SlicingInternals.f_called_by with [] -> false | _ -> true let is_src_fun_visible proj kf = let is_fi_top fi = match fi.SlicingInternals.fi_top with None -> false | Some _ -> true in is_src_fun_called proj kf || is_fi_top (get_kf_fi proj kf) let fi_has_persistent_selection fi = (match fi.SlicingInternals.fi_init_marks with None -> false | _ -> true) let has_persistent_selection proj kf = let fi = get_kf_fi proj kf in fi_has_persistent_selection fi (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/printer/0000755000175000017500000000000012155634040016247 5ustar mehdimehdiframa-c-Fluorine-20130601/src/printer/cil_printer.ml0000644000175000017500000025226512155630231021125 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Printer_api open Format module Behavior_extensions = struct let printer_tbl = Hashtbl.create 5 let register name printer = Hashtbl.add printer_tbl name printer let pp (printer:extensible_printer_type) fmt (name, code, preds) = try let pp = Hashtbl.find printer_tbl name in pp printer fmt (code, preds) with Not_found -> (* default pretty-printer *) Format.fprintf fmt "@[%s %a;@]" name (Pretty_utils.pp_list ~sep:",@ " printer#identified_predicate) preds; end let register_behavior_extension = Behavior_extensions.register (* Internal attributes. Won't be pretty-printed *) let reserved_attributes = ref [] let register_shallow_attribute s = reserved_attributes:=s::!reserved_attributes let print_as_source source = Kernel.Debug.get () = 0 && (Kernel.BigIntsHex.is_default () || not (Str.string_match (Str.regexp "^-?[0-9]+$") source 0)) let pretty_C_constant suffix k fmt i = let nb_signed_bits = Integer.pred (Integer.of_int (8 * (Cil.bytesSizeOfInt k))) in let max_strict_signed = Integer.shift_left Integer.one nb_signed_bits in let most_neg = Integer.neg max_strict_signed in if Integer.equal most_neg i then (* sm: quirk here: if you print -2147483648 then this is two tokens in C, and the second one is too large to represent in a signed int.. so we do what's done in limits.h, and print (-2147483467-1); *) (* in gcc this avoids a warning, but it might avoid a real problem on another compiler or a 64-bit architecture *) Format.fprintf fmt "(-%a-1)" Datatype.Big_int.pretty (Integer.pred max_strict_signed) else Format.fprintf fmt "%a%s" Datatype.Big_int.pretty i suffix let pred_body = function | LBpred a -> a | LBnone | LBreads _ | LBinductive _ | LBterm _ -> Kernel.fatal "definition expected in Cil.pred_body" let state = { line_directive_style = Some Line_preprocessor_input; print_cil_input = false; print_cil_as_is = false; line_length = 80; warn_truncate = true } (* Parentheses/precedence level. An expression "a op b" is printed parenthesized if its parentheses level is >= that that of its context. Identifiers have the lowest level and weakly binding operators (e.g. |) have the largest level. The correctness criterion is that a smaller level MUST correspond to a stronger precedence! *) module Precedence = struct let derefStarLevel = 20 let indexLevel = 20 let arrowLevel = 20 let addrOfLevel = 30 let additiveLevel = 60 let comparativeLevel = 70 let bitwiseLevel = 75 let logic_level = 77 let binderLevel = 90 let questionLevel = 100 let upperLevel = 110 let getParenthLevelPred = function | Pfalse | Ptrue | Papp _ | Pallocable _ | Pfreeable _ | Pvalid _ | Pvalid_read _ | Pinitialized _ | Pseparated _ | Pat _ | Pfresh _ -> 0 | Pnot _ -> 30 | Psubtype _ -> 75 | Pand _ | Por _ | Pxor _ -> 85 | Pimplies _ -> 88 | Piff _ -> 89 | Pif _ -> questionLevel | Prel _ -> comparativeLevel | Plet _ | Pforall _ | Pexists _ -> binderLevel let getParenthLevel e = match (Cil.stripInfo e).enode with | Info _ -> assert false | BinOp((LAnd | LOr), _,_,_) -> 80 (* Bit operations. *) | BinOp((BOr|BXor|BAnd),_,_,_) -> bitwiseLevel (* 75 *) (* Comparisons *) | BinOp((Eq|Ne|Gt|Lt|Ge|Le),_,_,_) -> comparativeLevel (* 70 *) (* Additive. Shifts can have higher level than + or - but I want parentheses around them *) | BinOp((MinusA|MinusPP|MinusPI|PlusA| PlusPI|IndexPI|Shiftlt|Shiftrt),_,_,_) -> additiveLevel (* 60 *) (* Multiplicative *) | BinOp((Div|Mod|Mult),_,_,_) -> 40 (* Unary *) | CastE(_,_) -> 30 | AddrOf(_) -> 30 | StartOf(_) -> 30 | UnOp((Neg|BNot|LNot),_,_) -> 30 (* Lvals *) | Lval(Mem _ , _) -> derefStarLevel (* 20 *) | Lval(Var _, (Field _|Index _)) -> indexLevel (* 20 *) | SizeOf _ | SizeOfE _ | SizeOfStr _ -> 20 | AlignOf _ | AlignOfE _ -> 20 | Lval(Var _, NoOffset) -> 0 (* Plain variables *) | Const _ -> 0 (* Constants *) let rec getParenthLevelLogic = function | Tlambda _ | Trange _ | Tlet _ -> binderLevel | TBinOp((LAnd | LOr), _,_) -> 80 (* Bit operations. *) | TBinOp((BOr|BXor|BAnd),_,_) -> bitwiseLevel (* 75 *) (* Comparisons *) | TBinOp((Eq|Ne|Gt|Lt|Ge|Le),_,_) -> comparativeLevel (* 70 *) (* Additive. Shifts can have higher level than + or - but I want parentheses around them *) | TBinOp((MinusA|MinusPP|MinusPI|PlusA| PlusPI|IndexPI|Shiftlt|Shiftrt),_,_) -> additiveLevel (* 60 *) (* Multiplicative *) | TBinOp((Div|Mod|Mult),_,_) -> 40 (* Unary *) | TCastE(_,_) -> 30 | TAddrOf(_) -> addrOfLevel | TStartOf(_) -> 30 | TUnOp((Neg|BNot|LNot),_) -> 30 (* Unary post *) | TCoerce _ | TCoerceE _ -> 25 (* Lvals *) | TLval(TMem _ , _) -> derefStarLevel | TLval(TVar _, (TField _|TIndex _|TModel _)) -> indexLevel | TLval(TResult _,(TField _|TIndex _|TModel _)) -> indexLevel | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ -> 20 | TAlignOf _ | TAlignOfE _ -> 20 (* VP: I'm not sure I understand why sizeof(x) and f(x) should have a separated treatment wrt parentheses. *) (* application and applications-like constructions *) | Tapp (_, _,_)|TDataCons _ | Tblock_length _ | Tbase_addr _ | Toffset _ | Tat (_, _) | Tunion _ | Tinter _ | TUpdate _ | Ttypeof _ | Ttype _ -> 10 | TLval(TVar _, TNoOffset) -> 0 (* Plain variables *) (* Constructions that do not require parentheses *) | TConst _ | Tnull | TLval (TResult _,TNoOffset) | Tcomprehension _ | Tempty_set -> 0 | Tif (_, _, _) -> logic_level | TLogic_coerce(_,e) -> (getParenthLevelLogic e.term_node) + 1 (* Create an expression of the same shape, and use {!getParenthLevel} *) let getParenthLevelAttrParam = function | AInt _ | AStr _ | ACons _ -> 0 | ASizeOf _ | ASizeOfE _ -> 20 | AAlignOf _ | AAlignOfE _ -> 20 | AUnOp (uo, _) -> getParenthLevel (Cil.dummy_exp (UnOp(uo, Cil.zero ~loc:Cil_datatype.Location.unknown, Cil.intType))) | ABinOp (bo, _, _) -> getParenthLevel (Cil.dummy_exp(BinOp(bo, Cil.zero ~loc:Cil_datatype.Location.unknown, Cil.zero ~loc:Cil_datatype.Location.unknown, Cil.intType))) | AAddrOf _ -> 30 | ADot _ | AIndex _ | AStar _ -> 20 | AQuestion _ -> questionLevel end let get_termination_kind_name = function | Normal -> "ensures" | Exits -> "exits" | Breaks -> "breaks" | Continues -> "continue" | Returns -> "returns" class cil_printer () = object (self) val mutable logic_printer_enabled = true method reset () = () method without_annot: 'a. (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit = fun f fmt x -> let tmp = logic_printer_enabled in logic_printer_enabled <- false; let finally () = logic_printer_enabled <- tmp in Extlib.try_finally ~finally (f fmt) x; val mutable force_brace = false method force_brace: 'a. (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit = fun f fmt x -> let tmp = force_brace in force_brace <- true; let finally () = force_brace <- tmp in Extlib.try_finally ~finally f fmt x; val mutable verbose = false val current_stmt = Stack.create () val mutable current_function = None method private current_function = current_function method private in_current_function vi = assert (current_function = None); current_function <- Some vi method private out_current_function = assert (current_function <> None); current_function <- None val mutable current_behavior = None method private current_behavior = current_behavior method private set_current_behavior b = assert (current_behavior = None); current_behavior <- Some b method private reset_current_behavior () = assert (current_behavior <> None); current_behavior <- None val mutable has_annot = false method private has_annot = has_annot && logic_printer_enabled method private push_stmt s = Stack.push s current_stmt method private pop_stmt s = ignore (Stack.pop current_stmt); has_annot <- false; s method private current_stmt = try Some (Stack.top current_stmt) with Stack.Empty -> None method private may_be_skipped s = s.labels = [] val mutable currentFormals : varinfo list = [] method private getLastNamedArgument s = match List.rev currentFormals with | [] -> Kernel.abort "Cannot find the last named argument when printing call to %s" s | f :: _ -> Cil.new_exp ~loc:f.vdecl (Lval (Cil.var f)) method location fmt loc = Cil_datatype.Location.pretty fmt loc (* constant *) method constant fmt = function | CInt64(_, _, Some s) when print_as_source s -> fprintf fmt "%s" s (* Always print the text if there is one, unless we want to print it as hexa *) | CInt64(i, ik, _) -> (*fprintf fmt "/* %Lx */" i;*) (** We must make sure to capture the type of the constant. For some constants this is done with a suffix, for others with a cast prefix.*) let suffix = match ik with | IUInt -> "U" | ILong -> "L" | IULong -> "UL" | ILongLong -> if Cil.theMachine.Cil.msvcMode then "L" else "LL" | IULongLong -> if Cil.theMachine.Cil.msvcMode then "UL" else "ULL" | IInt | IBool | IShort | IUShort | IChar | ISChar | IUChar -> "" in let prefix = if suffix <> "" then "" else if ik = IInt then "" else Pretty_utils.sfprintf "(%a)" self#ikind ik in fprintf fmt "%s%a" prefix (pretty_C_constant suffix ik) i | CStr(s) -> fprintf fmt "\"%s\"" (Escape.escape_string s) | CWStr(s) -> (* text ("L\"" ^ escape_string s ^ "\"") *) fprintf fmt "L"; List.iter (fun elt -> if (elt >= Int64.zero && elt <= (Int64.of_int 255)) then fprintf fmt "%S" (Escape.escape_char (Char.chr (Int64.to_int elt))) else fprintf fmt "\"\\x%LX\"" elt; fprintf fmt "@ ") s; (* we cannot print L"\xabcd" "feedme" as L"\xabcdfeedme" -- * the former has 7 wide characters and the later has 3. *) | CChr(c) -> fprintf fmt "'%s'" (Escape.escape_char c) | CReal(_, _, Some s) -> fprintf fmt "%s" s | CReal(f, fsize, None) -> fprintf fmt "%a%s" Floating_point.pretty f (match fsize with FFloat -> "f" | FDouble -> "" | FLongDouble -> "L") | CEnum {einame = s} -> fprintf fmt "%s" s (*** VARIABLES ***) method varname fmt v = pp_print_string fmt v method private p_varstring v = Pretty_utils.sfprintf "%a" self#varinfo v (* variable use *) method varinfo fmt v = Format.fprintf fmt "%a" self#varname v.vname (* variable declaration *) method vdecl fmt (v:varinfo) = let stom, rest = Cil.separateStorageModifiers v.vattr in let fundecl = if Cil.isFunctionType v.vtype then Some v else None in (* First the storage modifiers *) fprintf fmt "%s%a%a%s%a%a" (if v.vinline then "__inline " else "") self#storage v.vstorage self#attributes stom (if stom = [] then "" else " ") (self#typ ?fundecl (if v.vname = "" then None else Some (fun fmt -> self#varinfo fmt v))) v.vtype self#attributes rest (*** L-VALUES ***) method lval fmt (lv:lval) = (* lval (base is 1st field) *) match lv with Var vi, o -> fprintf fmt "%a%a" self#varinfo vi self#offset o | Mem e, Field(fi, o) -> fprintf fmt "%a->%a%a" (self#exp_prec Precedence.arrowLevel) e self#varname fi.fname self#offset o | Mem e, NoOffset -> fprintf fmt "*%a" (self#exp_prec Precedence.derefStarLevel) e | Mem e, o -> fprintf fmt "(*%a)%a" (self#exp_prec Precedence.derefStarLevel) e self#offset o (** Offsets **) method field fmt fi = self#varname fmt fi.fname method offset fmt = function | NoOffset -> () | Field (fi, o) -> fprintf fmt ".%a%a" self#field fi self#offset o | Index (e, o) -> fprintf fmt "[%a]%a" self#exp e self#offset o method private lval_prec (contextprec: int) fmt lv = if Precedence.getParenthLevel (Cil.dummy_exp(Lval(lv))) >= contextprec then fprintf fmt "(%a)" self#lval lv else self#lval fmt lv (*** EXPRESSIONS ***) method exp fmt (e: exp) = let level = Precedence.getParenthLevel e in match (Cil.stripInfo e).enode with | Info _ -> assert false | Const(c) -> self#constant fmt c | Lval(l) -> self#lval fmt l | UnOp(u,e1,_) -> (match u, e1 with | Neg, {enode = Const (CInt64 (v, _, _))} when Integer.ge v Integer.zero -> fprintf fmt "-%a" (self#exp_prec level) e1 | _ -> fprintf fmt "%a %a" self#unop u (self#exp_prec level) e1) | BinOp(b,e1,e2,_) -> fprintf fmt "@[%a %a %a@]" (self#exp_prec level) e1 self#binop b (self#exp_prec level) e2 | CastE(t,e) -> fprintf fmt "(%a)%a" (self#typ None) t (self#exp_prec level) e | SizeOf t -> fprintf fmt "sizeof(%a)" (self#typ None) t | SizeOfE e -> fprintf fmt "sizeof(%a)" self#exp e | SizeOfStr s -> fprintf fmt "sizeof(%a)" self#constant (CStr s) | AlignOf t -> fprintf fmt "__alignof__(%a)" (self#typ None) t | AlignOfE e -> fprintf fmt "__alignof__(%a)" self#exp e | AddrOf lv -> fprintf fmt "& %a" (self#lval_prec Precedence.addrOfLevel) lv | StartOf(lv) -> if state.print_cil_as_is then fprintf fmt "&(%a[0])" self#lval lv else self#lval fmt lv method unop fmt u = fprintf fmt "%s" (match u with | Neg -> "-" | BNot -> "~" | LNot -> "!") method binop fmt b = fprintf fmt "%s" (match b with | PlusA | PlusPI | IndexPI -> "+" | MinusA | MinusPP | MinusPI -> "-" | Mult -> "*" | Div -> "/" | Mod -> "%" | Shiftlt -> "<<" | Shiftrt -> ">>" | Lt -> "<" | Gt -> ">" | Le -> "<=" | Ge -> ">=" | Eq -> "==" | Ne -> "!=" | BAnd -> "&" | BXor -> "^" | BOr -> "|" | LAnd -> "&&" | LOr -> "||") (* Print an expression, given the precedence of the context in which it * appears. *) method private exp_prec (contextprec: int) fmt (e: exp) = let thisLevel = Precedence.getParenthLevel e in let needParens = if thisLevel >= contextprec then true else if contextprec == Precedence.bitwiseLevel then (* quiet down some GCC warnings *) thisLevel == Precedence.additiveLevel || thisLevel == Precedence.comparativeLevel else false in if needParens then fprintf fmt "(%a)" self#exp e else self#exp fmt e method init fmt = function | SingleInit e -> self#exp fmt e | CompoundInit (t, initl) -> (* We do not print the type of the Compound *) (* let dinit e = d_init () e in dprintf "{@[%a@]}" (docList ~sep:(chr ',' ++ break) dinit) initl *) let printDesignator = if not Cil.theMachine.Cil.msvcMode then begin (* Print only for union when we do not initialize the first field *) match Cil.unrollType t, initl with | TComp(ci, _, _), [(Field(f, NoOffset), _)] -> not (ci.cstruct) && ci.cfields != [] && (List.hd ci.cfields) != f | _ -> false end else false in let d_oneInit fmt = function | Field(f, NoOffset), i -> if printDesignator then fprintf fmt ".%a = " self#varname f.fname; self#init fmt i | Index(e, NoOffset), i -> if printDesignator then fprintf fmt "[%a] = " self#exp e; self#init fmt i | _ -> Kernel.fatal "Trying to print malformed initializer" in fprintf fmt "{@[%a@]}" (Pretty_utils.pp_list ~sep:",@ " d_oneInit) initl (** What terminator to print after an instruction. sometimes we want to print sequences of instructions separated by comma *) val mutable instr_terminator = ";" method private set_instr_terminator (term : string) = instr_terminator <- term method private get_instr_terminator () = instr_terminator (*** INSTRUCTIONS ****) method instr fmt (i:instr) = (* imperative instruction *) fprintf fmt "%a" (self#line_directive ~forcefile:false) (Cil_datatype.Instr.loc i); match i with | Skip _ -> fprintf fmt ";" | Set(lv,e,_) -> begin (* Be nice to some special cases *) match e.enode with BinOp((PlusA|PlusPI|IndexPI), {enode = Lval(lv')}, {enode=Const(CInt64(one,_,_))},_) when Cil.compareLval lv lv' && Integer.equal one Integer.one && not state.print_cil_as_is -> fprintf fmt "%a ++%s" (self#lval_prec Precedence.indexLevel) lv instr_terminator | BinOp((MinusA|MinusPI), {enode = Lval(lv')}, {enode=Const(CInt64(one,_,_))}, _) when Cil.compareLval lv lv' && Integer.equal one Integer.one && not state.print_cil_as_is -> fprintf fmt "%a --%s" (self#lval_prec Precedence.indexLevel) lv instr_terminator | BinOp((PlusA|PlusPI|IndexPI), {enode = Lval(lv')}, {enode = Const(CInt64(mone,_,_))},_) when Cil.compareLval lv lv' && Integer.equal mone Integer.minus_one && not state.print_cil_as_is -> fprintf fmt "%a --%s" (self#lval_prec Precedence.indexLevel) lv instr_terminator | BinOp((PlusA|PlusPI|IndexPI|MinusA|MinusPP|MinusPI|BAnd|BOr|BXor| Mult|Div|Mod|Shiftlt|Shiftrt) as bop, {enode = Lval(lv')},e,_) when Cil.compareLval lv lv' -> fprintf fmt "%a %a= %a%s" self#lval lv self#binop bop self#exp e instr_terminator | _ -> fprintf fmt "%a = %a%s" self#lval lv self#exp e instr_terminator end (* In cabs2cil we have turned the call to builtin_va_arg into a three-argument call: the last argument is the address of the destination *) | Call(None, {enode = Lval(Var vi, NoOffset)}, [dest; {enode = SizeOf t}; adest], (l,_)) when vi.vname = "__builtin_va_arg" && not state.print_cil_as_is -> let destlv = match (Cil.stripCasts adest).enode with AddrOf destlv -> destlv (* If this fails, it's likely that an extension interfered with the AddrOf *) | _ -> Kernel.fatal ~source:l "Encountered unexpected call to %s with dest %a" vi.vname self#exp adest in fprintf fmt "%a = __builtin_va_arg (@[%a,@ %a@])%s" self#lval destlv (* Now the arguments *) self#exp dest (self#typ None) t instr_terminator (* In cabs2cil we have dropped the last argument in the call to __builtin_va_start and __builtin_stdarg_start. *) | Call(None, {enode = Lval(Var vi, NoOffset)}, [marker], l) when ((vi.vname = "__builtin_stdarg_start" || vi.vname = "__builtin_va_start") && not state.print_cil_as_is) -> let last = self#getLastNamedArgument vi.vname in self#instr fmt (Call(None, Cil.dummy_exp(Lval(Var vi,NoOffset)), [marker; last],l)) (* In cabs2cil we have dropped the last argument in the call to __builtin_next_arg. *) | Call(res, {enode = Lval(Var vi, NoOffset)}, [ ], l) when vi.vname = "__builtin_next_arg" && not state.print_cil_as_is -> let last = self#getLastNamedArgument vi.vname in self#instr fmt (Call(res,Cil.dummy_exp(Lval(Var vi,NoOffset)),[last],l)) (* In cparser we have turned the call to __builtin_types_compatible_p(t1, t2) into __builtin_types_compatible_p(sizeof t1, sizeof t2), so that we can represent the types as expressions. Remove the sizeofs when printing. *) | Call(dest, {enode = Lval(Var vi, NoOffset)}, [{enode = SizeOf t1}; {enode = SizeOf t2}], _) when vi.vname = "__builtin_types_compatible_p" && not state.print_cil_as_is -> (* Print the destination *) (match dest with None -> () | Some lv -> fprintf fmt "%a = " self#lval lv ); (* Now the call itself *) fprintf fmt "%a(%a, %a)%s" self#varname vi.vname (self#typ None) t1 (self#typ None) t2 instr_terminator | Call(_, {enode = Lval(Var vi, NoOffset)}, _, (l,_)) when vi.vname = "__builtin_types_compatible_p" && not state.print_cil_as_is -> Kernel.fatal ~source:l "__builtin_types_compatible_p: cabs2cil should have added sizeof to \ the arguments." | Call(dest,e,args,_) -> (match dest with | None -> () | Some lv -> fprintf fmt "%a = " self#lval lv; (* Maybe we need to print a cast *) (let destt = Cil.typeOfLval lv in match Cil.unrollType (Cil.typeOf e) with | TFun(rt, _, _, _) when (Cil.need_cast rt destt) -> fprintf fmt "(%a)" (self#typ None) destt | _ -> ())); (* Now the function name *) (match e.enode with | Lval(Var _, _) -> self#exp fmt e | _ -> fprintf fmt "(%a)" self#exp e); (* Now the arguments *) Pretty_utils.pp_flowlist ~left:"(" ~sep:"," ~right:")" self#exp fmt args; (* Now the terminator *) fprintf fmt "%s" instr_terminator | Asm(attrs, tmpls, outs, ins, clobs, l) -> self#line_directive fmt l; if Cil.theMachine.Cil.msvcMode then fprintf fmt "__asm {@[%a@]}%s" (Pretty_utils.pp_list ~sep:"@\n" (fun fmt s -> fprintf fmt "%s" s)) tmpls instr_terminator else begin fprintf fmt "__asm__%a (@[%a" self#attributes attrs (Pretty_utils.pp_list ~sep:"@\n" (fun fmt x -> (* [JS 2011/03/11] isn't equivalent to [fprintf fmt "%S" x]? *) fprintf fmt "\"%s\"" (Escape.escape_string x))) tmpls; if outs = [] && ins = [] && clobs = [] then fprintf fmt ":" else fprintf fmt ": %a" (Pretty_utils.pp_list ~sep:",@ " (fun fmt (idopt, c, lv) -> fprintf fmt "%s\"%s\" (%a)" (match idopt with None -> "" | Some id -> "[" ^ id ^ "] " ) (Escape.escape_string c) self#lval lv )) outs; if ins <> [] || clobs <> [] then fprintf fmt ": %a" (Pretty_utils.pp_list ~sep:",@ " (fun fmt (idopt, c, e) -> fprintf fmt "%s\"%s\"(%a)" (match idopt with None -> "" | Some id -> "[" ^ id ^ "] " ) (Escape.escape_string c) self#exp e)) ins; if clobs <> [] then fprintf fmt ": %a" (Pretty_utils.pp_list ~sep:",@ " (fun fmt c -> fprintf fmt "\"%s\"" (Escape.escape_string c))) clobs; fprintf fmt "@])%s" instr_terminator end | Code_annot (annot, l) -> has_annot <- true; if logic_printer_enabled then begin self#line_directive ~forcefile:false fmt l; Pretty_utils.pp_open_block fmt "/*@@ "; self#code_annotation fmt annot ; Pretty_utils.pp_close_block fmt "*/"; end (**** STATEMENTS ****) method stmt fmt (s:stmt) = (* control-flow statement *) self#push_stmt s; self#pop_stmt (self#next_stmt Cil.invalidStmt fmt s) method next_stmt (next: stmt) fmt (s: stmt) = self#push_stmt s; self#pop_stmt (self#annotated_stmt next fmt s) method stmt_labels fmt (s:stmt) = if s.labels <> [] then Pretty_utils.pp_list ~sep:"@ " ~suf:"@]@ " self#label fmt s.labels method label fmt = function | Label (s, _, true) -> fprintf fmt "@[%s:@]" s | Label (s, _, false) -> fprintf fmt "@[%s: /* internal */@]" s | Case (e, _) -> fprintf fmt "@[case %a:@]" self#exp e | Default _ -> fprintf fmt "@[default:@]" val ghost_stack = Stack.create () method annotated_stmt (next: stmt) fmt (s: stmt) = pp_open_hvbox fmt 2; self#stmt_labels fmt s; pp_open_hvbox fmt 0; (* print the statement. *) if Cil.is_skip s.skind && not s.ghost then begin if verbose || s.labels <> [] then fprintf fmt ";" end else begin if s.ghost && not (Stack.top ghost_stack) then Pretty_utils.pp_open_block fmt "@[/*@@ ghost "; Stack.push s.ghost ghost_stack; self#stmtkind next fmt s.skind ; ignore (Stack.pop ghost_stack); if s.ghost && not (Stack.top ghost_stack) then Pretty_utils.pp_close_block fmt "*/@]" ; end; pp_close_box fmt (); pp_close_box fmt () method private require_braces ?(has_annot=self#has_annot) blk = force_brace || match blk.bstmts, blk.battrs, blk.blocals with | _ :: _ :: _, _, _ | _, _, _ :: _ | _, _ :: _, _ -> true | [ { skind = Block b } ], _, _ -> has_annot || self#require_braces b | _, _, _ -> has_annot method private inline_block ?has_annot blk = match blk.bstmts with | [] | [ { skind = (Instr _ | Return _ | Goto _ | Break _ | Continue _ ) } ] -> not (self#require_braces ?has_annot blk) | [ { skind = Block blk } ] -> self#inline_block blk | _ -> false method private block_is_function blk = match blk.bstmts with | [ { skind = Instr (Call _) } ] -> true | [ { skind = Block blk } ] -> self#block_is_function blk | _ -> false method private block_has_dangling_else blk = match blk.bstmts with | [ { skind = If(_, { bstmts=[]; battrs=[] }, _, _) | If(_, {bstmts=[{skind=Goto _; labels=[]}]; battrs=[]}, _, _) | If(_, _, { bstmts=[]; battrs=[] }, _) | If(_, _, {bstmts=[{skind=Goto _; labels=[]}]; battrs=[]}, _) } ] -> true | [ { skind = Block blk | If(_, _, blk, _) } ] -> self#block_has_dangling_else blk | _ -> false method private vdecl_complete fmt v = let in_ghost_code = try Stack.top ghost_stack with Stack.Empty -> false in Format.fprintf fmt "@[%t%a;%t@]" (if v.vghost && not in_ghost_code then fun fmt -> Format.fprintf fmt "/*@@ ghost@ " else ignore) self#vdecl v (if v.vghost && not in_ghost_code then fun fmt -> Format.fprintf fmt "@ */" else ignore) (* no box around the block *) method private unboxed_block ?(cut=true) ?braces ?has_annot fmt blk = let braces = match braces with | None -> self#require_braces ?has_annot blk | Some b -> b in let inline = not braces && self#inline_block ?has_annot blk in if braces then pp_print_char fmt '{'; if braces && not inline then pp_print_space fmt (); if Kernel.debug_atleast 1 then fprintf fmt "@[/* %a */@]@ " (Pretty_utils.pp_list ~sep:",@ " self#varinfo) blk.blocals; if blk.battrs <> [] then (* [JS 2012/12/07] could directly call self#attributesGen whenever we are sure than it puts its printing material inside a box *) fprintf fmt "@[%a@]" (self#attributesGen true) blk.battrs; if blk.blocals <> [] then Pretty_utils.pp_list ~pre:"@[" ~sep:"@;" ~suf:"@]@ " self#vdecl_complete fmt blk.blocals; let rec iterblock ~cut fmt = function | [] -> () | [ s ] -> fprintf fmt ""; if cut && not inline && not braces then pp_print_cut fmt (); self#next_stmt Cil.invalidStmt fmt s | s_cur :: (s_next :: _ as tail) -> Format.fprintf fmt "%a@ %a" (self#next_stmt s_next) s_cur (iterblock ~cut:false) tail in let stmts = blk.bstmts in if stmts = [] && not braces then fprintf fmt ";" else fprintf fmt "%a" (iterblock ~cut) stmts; if braces then Format.fprintf fmt "@;<1 -2>}" (* no box around the block *) method block ?braces fmt (blk: block) = let braces = match braces with None -> self#require_braces blk | Some b -> b in let open_box = if self#inline_block blk then pp_open_hvbox else pp_open_vbox in open_box fmt (if braces then 2 else 0); if verbose then Pretty_utils.pp_open_block fmt "/*block:begin*/@ "; self#unboxed_block ~cut:false ~braces fmt blk; if verbose then Pretty_utils.pp_close_block fmt "/*block:end*/"; pp_close_box fmt () (* Store here the name of the last file printed in a line number. This is private to the object *) val mutable lastFileName = "" val mutable lastLineNumber = -1 (* Make sure that you only call self#line_directive on an empty line *) method line_directive ?(forcefile=false) fmt l = Cil.CurrentLoc.set l; match state.line_directive_style with | None -> () | Some _ when (fst l).Lexing.pos_lnum <= 0 -> () (* Do not print lineComment if the same line as above *) | Some Line_comment_sparse when (fst l).Lexing.pos_lnum = lastLineNumber -> () | Some style -> let directive = match style with | Line_comment | Line_comment_sparse -> "//#line " | Line_preprocessor_output when not Cil.theMachine.Cil.msvcMode -> "#" | Line_preprocessor_output | Line_preprocessor_input -> "#line" in lastLineNumber <- (fst l).Lexing.pos_lnum; let filename = if forcefile || (fst l).Lexing.pos_fname <> lastFileName then begin lastFileName <- (fst l).Lexing.pos_fname; " \"" ^ (fst l).Lexing.pos_fname ^ "\"" end else "" in fprintf fmt "@[@<0>\n@<0>%s@<0> @<0>%d@<0> @<0>%s@]@\n" directive (fst l).Lexing.pos_lnum filename method stmtkind (next: stmt) fmt = function | UnspecifiedSequence seq -> let print_stmt pstmt fmt (stmt, modifies, writes, reads,_) = pstmt fmt stmt; if verbose then Format.fprintf fmt "@ /*effects: @[(%a)%a@ <-@ %a@]*/" (Pretty_utils.pp_list ~sep:",@ " self#lval) modifies (Pretty_utils.pp_list ~sep:",@ " self#lval) writes (Pretty_utils.pp_list ~sep:",@ " self#lval) reads in let rec iterblock fmt = function | [] -> () | [ srw ] -> fprintf fmt "@ " ; print_stmt (self#next_stmt Cil.invalidStmt) fmt srw | srw_first :: ((s_next,_,_,_,_) :: _ as tail) -> fprintf fmt "@ " ; print_stmt (self#next_stmt s_next) fmt srw_first ; iterblock fmt tail in fprintf fmt "@[{@ @[/*undefined sequence*/@]%a@;<1 -2>}@]" iterblock seq; | Return(None, l) -> fprintf fmt "@[%areturn;@]" (fun fmt -> self#line_directive fmt) l | Return(Some e, l) -> fprintf fmt "@[%a@[return@ %a;@]@]" (fun fmt -> self#line_directive fmt) l self#exp e | Goto (sref, l) -> begin (* Grab one of the labels *) let rec pickLabel = function [] -> None | Label (lbl, _, _) :: _ -> Some lbl | _ :: rest -> pickLabel rest in match pickLabel !sref.labels with | Some lbl -> fprintf fmt "@[%agoto %s;@]" (fun fmt -> self#line_directive fmt) l lbl | None -> Kernel.error "Cannot find label for target of goto: %a" (self#without_annot self#stmt) !sref; fprintf fmt "@[goto@ __invalid_label;@]" end | Break l -> fprintf fmt "@[%a%s@]" (fun fmt -> self#line_directive fmt) l "break;" | Continue l -> fprintf fmt "@[%a%s@]" (fun fmt -> self#line_directive fmt) l "continue;" | Instr i -> self#instr fmt i | If(be,t,{bstmts=[];battrs=[]},l) when not state.print_cil_as_is -> fprintf fmt "@[%a@[if (%a) %a@]@]" (fun fmt -> self#line_directive ~forcefile:false fmt) l self#exp be (fun fmt -> self#unboxed_block ~has_annot:false fmt) t | If(be,t,{bstmts=[{skind=Goto(gref,_);labels=[]}]; battrs=[]},l) when !gref == next && not state.print_cil_as_is -> fprintf fmt "@[%a@[if (%a) %a@]@]" (fun fmt -> self#line_directive ~forcefile:false fmt) l self#exp be (fun fmt -> self#unboxed_block ~has_annot:false fmt) t | If(be,{bstmts=[];battrs=[]},e,l) when not state.print_cil_as_is -> fprintf fmt "@[%a@[if (%a) %a@]@]" (fun fmt -> self#line_directive ~forcefile:false fmt) l self#exp (Cil.dummy_exp(UnOp(LNot,be,Cil.intType))) (fun fmt -> self#unboxed_block ~has_annot:false fmt) e | If(be,{bstmts=[{skind=Goto(gref,_);labels=[]}]; battrs=[]},e,l) when !gref == next && not state.print_cil_as_is -> fprintf fmt "@[%a@[if (%a) %a@]@]" (fun fmt -> self#line_directive ~forcefile:false fmt) l self#exp (Cil.dummy_exp(UnOp(LNot,be,Cil.intType))) (fun fmt -> self#unboxed_block ~has_annot:false fmt) e; | If(be,t,e,l) -> pp_open_hvbox fmt 0; self#line_directive fmt l; let braces_then = self#require_braces ~has_annot:false t || self#block_has_dangling_else t in let else_at_newline = braces_then || not (self#inline_block ~has_annot:false t) || not (self#inline_block ~has_annot:false e) || (* call to a function in both branches (for GUI' status bullets) *) (force_brace && self#block_is_function t && self#block_is_function e) in fprintf fmt "@[if (%a) %a@]" self#exp be (fun fmt -> self#unboxed_block ~has_annot:false ~braces:braces_then fmt) t; if else_at_newline then fprintf fmt "@\n" else fprintf fmt "@ "; fprintf fmt "@[else %a@]" (fun fmt -> self#unboxed_block ~has_annot:false fmt) e; pp_close_box fmt () | Switch(e,b,_,l) -> fprintf fmt "@[%a@[switch (%a) %a@]@]" (fun fmt -> self#line_directive ~forcefile:false fmt) l self#exp e (fun fmt -> self#unboxed_block ~has_annot:false fmt) b | Loop(a, b, l, _, _) -> Format.pp_open_hvbox fmt 0; if logic_printer_enabled && a <> [] then begin Pretty_utils.pp_open_block fmt "/*@@ " ; Pretty_utils.pp_list ~sep:"@\n" self#code_annotation fmt a; Pretty_utils.pp_close_block fmt "@ */@\n" ; end; ((* Maybe the first thing is a conditional. Turn it into a WHILE *) try let rec skipEmpty = function | [] -> [] | {skind=Instr (Skip _);labels=[]} as h :: rest when self#may_be_skipped h-> skipEmpty rest | x -> x in let term, bodystmts = (* Bill McCloskey: Do not remove the If if it has labels *) match skipEmpty b.bstmts with | { skind = If(e,tb,fb,_) } as to_skip :: rest when not state.print_cil_as_is && self#may_be_skipped to_skip -> (match skipEmpty tb.bstmts, skipEmpty fb.bstmts with | [], { skind = Break _; labels = [] } :: _ -> e, rest | { skind = Break _; labels = [] }:: _, [] -> Cil.dummy_exp (UnOp(LNot, e, Cil.intType)), rest | _ -> raise Not_found) | _ -> raise Not_found in let b = match skipEmpty bodystmts with [{ skind=Block b} as s ] when self#may_be_skipped s -> b | _ -> { b with bstmts = bodystmts } in Format.fprintf fmt "%a@[while (%a) %a@]" (fun fmt -> self#line_directive fmt) l self#exp term (fun fmt -> self#unboxed_block ~has_annot:false fmt) b; with Not_found -> Format.fprintf fmt "%a@[while (1) %a@]" (fun fmt -> self#line_directive fmt) l (fun fmt -> self#unboxed_block ~has_annot:false fmt) b); Format.pp_close_box fmt () | Block b -> (* We do not want to put extra braces in presence of blocks included in another block (that's often the case). So the following line specifically limits the number of braces in that case. But that assumes that the required braces have already be put before by the callers *) let braces = b.blocals <> [] || b.battrs <> [] || (self#has_annot && logic_printer_enabled && (* at least two statements inside *) match b.bstmts with [] | [ _ ] -> false | _ -> true) in self#block fmt ~braces b | TryFinally (b, h, l) -> fprintf fmt "@[%a@[__try@ %a@]@ @[__finally@ %a@]@]" (fun fmt -> self#line_directive fmt) l (fun fmt -> self#block fmt) b (fun fmt -> self#block fmt) h | TryExcept (b, (il, e), h, l) -> fprintf fmt "@[%a@[__try@ %a@]@ @[__except(@\n@[" (fun fmt -> self#line_directive fmt) l (fun fmt -> self#block fmt) b; (* Print the instructions but with a comma at the end, instead of * semicolon *) instr_terminator <- ","; Pretty_utils.pp_list ~sep:"@\n" self#instr fmt il; instr_terminator <- ";"; fprintf fmt "%a) @]@ %a@]" self#exp e (fun fmt -> self#block fmt) h (*** GLOBALS ***) method global fmt (g:global) = match g with | GFun (fundec, l) -> if not (Cil.is_unused_builtin fundec.svar) || Kernel.verbose_atleast 4 then begin self#in_current_function fundec.svar; (* If the function has attributes then print a prototype because * GCC cannot accept function attributes in a definition *) let oldattr = fundec.svar.vattr in (* Always pring the file name before function declarations *) (* Prototype first *) if oldattr <> [] then (self#line_directive fmt l; fprintf fmt "%a;@\n" self#vdecl_complete fundec.svar); (* Temporarily remove the function attributes *) fundec.svar.vattr <- []; (* Body now *) self#line_directive ~forcefile:true fmt l; self#fundecl fmt fundec; fundec.svar.vattr <- oldattr; fprintf fmt "@\n"; self#out_current_function end | GType (typ, l) -> self#line_directive ~forcefile:true fmt l; fprintf fmt "typedef %a;@\n" (self#typ (Some (fun fmt -> fprintf fmt "%s" typ.tname))) typ.ttype | GEnumTag (enum, l) -> self#line_directive fmt l; if verbose then fprintf fmt "/* Following enum is equivalent to %a */@\n" (self#typ None) (TInt(enum.ekind,[])); fprintf fmt "enum@[ %a {@\n%a@]@\n}%a;@\n" self#varname enum.ename (Pretty_utils.pp_list ~sep:",@\n" (fun fmt item -> fprintf fmt "%s = %a" item.einame self#exp item.eival)) enum.eitems self#attributes enum.eattr | GEnumTagDecl (enum, l) -> (* This is a declaration of a tag *) self#line_directive fmt l; fprintf fmt "enum %a;@\n" self#varname enum.ename | GCompTag (comp, l) -> (* This is a definition of a tag *) let n = comp.cname in let su = if comp.cstruct then "struct" else "union" in let sto_mod, rest_attr = Cil.separateStorageModifiers comp.cattr in self#line_directive ~forcefile:true fmt l; fprintf fmt "@[<3>%s%a %a {@\n%a@]@\n}%a;@\n" su self#attributes sto_mod self#varname n (Pretty_utils.pp_list ~sep:"@\n" self#fieldinfo) comp.cfields self#attributes rest_attr | GCompTagDecl (comp, l) -> (* This is a declaration of a tag *) self#line_directive fmt l; fprintf fmt "%s;@\n" (Cil.compFullName comp) | GVar (vi, io, l) -> if not (Cil.is_unused_builtin vi) || Kernel.verbose_atleast 4 then begin self#line_directive ~forcefile:true fmt l; if vi.vghost then Format.fprintf fmt "/*@@ ghost@ "; self#vdecl fmt vi; (match io.init with None -> () | Some i -> fprintf fmt " = "; let islong = match i with CompoundInit (_, il) when List.length il >= 8 -> true | _ -> false in if islong then begin self#line_directive fmt l; fprintf fmt " @[@\n" end; self#init fmt i; if islong then fprintf fmt "@]"); fprintf fmt ";%t@\n" (if vi.vghost then fun fmt -> Format.fprintf fmt "@ */" else ignore) end (* print global variable 'extern' declarations, and function prototypes *) | GVarDecl (funspec, vi, l) -> if not (Cil.is_unused_builtin vi) || Kernel.verbose_atleast 4 then begin if Cil.isFunctionType vi.vtype then self#in_current_function vi; self#opt_funspec fmt funspec; if not state.print_cil_as_is && Cil.Builtin_functions.mem vi.vname then begin (* Compiler builtins need no prototypes. Just print them in comments. *) fprintf fmt "/* compiler builtin: @\n %a; */@\n" self#vdecl vi end else begin self#line_directive fmt l; fprintf fmt "%a@\n@\n" self#vdecl_complete vi end; if Cil.isFunctionType vi.vtype then self#out_current_function end | GAsm (s, l) -> self#line_directive fmt l; fprintf fmt "__asm__(\"%s\");@\n" (Escape.escape_string s) | GPragma (Attr(an, args), l) -> (* sm: suppress printing pragmas that gcc does not understand *) (* assume anything starting with "ccured" is ours *) (* also don't print the 'combiner' pragma *) (* nor 'cilnoremove' *) let suppress = not state.print_cil_input && not Cil.theMachine.Cil.msvcMode && (Cil.startsWith "box" an || Cil.startsWith "ccured" an || an = "merger" || an = "cilnoremove") in self#line_directive fmt l; if suppress then fprintf fmt "/* "; fprintf fmt "#pragma "; begin match an, args with | _, [] -> fprintf fmt "%s" an | "weak", [ACons (varinfo, [])] -> fprintf fmt "weak %s" varinfo | "",_ -> fprintf fmt "%a" (Pretty_utils.pp_list ~sep:" " self#attrparam) args | _ -> fprintf fmt "%s(%a)" an (Pretty_utils.pp_list ~sep:"," self#attrparam) args end; if suppress then fprintf fmt " */@\n" else fprintf fmt "@\n" | GPragma (AttrAnnot _, _) -> assert false (* self#line_directive fmt l; fprintf fmt "/* #pragma %s */@\n" a*) | GAnnot (decl,l) -> self#line_directive fmt l; fprintf fmt "/*@@@ %a@ */@\n" self#global_annotation decl | GText s -> if s <> "//" then fprintf fmt "%s@\n" s method fieldinfo fmt fi = fprintf fmt "%a %s%a;" (self#typ (Some (fun fmt -> if fi.fname <> Cil.missingFieldName then fprintf fmt "%s" fi.fname))) fi.ftype (match fi.fbitfield with | None -> "" | Some i -> ": " ^ string_of_int i ^ " ") self#attributes fi.fattr method private opt_funspec fmt funspec = if logic_printer_enabled && not (Cil.is_empty_funspec funspec) then fprintf fmt "@[/*@@ %a@ */@]@\n" self#funspec funspec method private fundecl fmt f = (* declaration. *) fprintf fmt "@[%t%a@\n@[" (if f.svar.vghost then fun fmt -> Format.fprintf fmt "/*@@ ghost@ " else ignore) self#vdecl f.svar; (* We take care of locals in blocks. *) (*List.iter (fprintf fmt "@\n%a;" self#vdecl) f.slocals ;*) (* body. *) currentFormals <- f.sformals ; Stack.push f.svar.vghost ghost_stack; self#unboxed_block ~has_annot:false ~braces:true fmt f.sbody; ignore (Stack.pop ghost_stack); currentFormals <- []; fprintf fmt "@]%t@]@." (if f.svar.vghost then fun fmt -> Format.fprintf fmt "@ */" else ignore) (***** PRINTING DECLARATIONS and TYPES ****) method storage fmt c = fprintf fmt "%s" (match c with | NoStorage -> "" | Static -> "static " | Extern -> "extern " | Register -> "register ") method fkind fmt = function | FFloat -> fprintf fmt "float" | FDouble -> fprintf fmt "double" | FLongDouble -> fprintf fmt "long double" method ikind fmt c = fprintf fmt "%s" (match c with | IChar -> "char" | IBool -> "_Bool" | ISChar -> "signed char" | IUChar -> "unsigned char" | IInt -> "int" | IUInt -> "unsigned int" | IShort -> "short" | IUShort -> "unsigned short" | ILong -> "long" | IULong -> "unsigned long" | ILongLong -> if Cil.theMachine.Cil.msvcMode then "__int64" else "long long" | IULongLong -> if Cil.theMachine.Cil.msvcMode then "unsigned __int64" else "unsigned long long") method typ ?fundecl nameOpt fmt (t:typ) = let pname fmt space = match nameOpt with | None -> () | Some d -> Format.fprintf fmt "%s%t" (if space then " " else "") d in let printAttributes fmt (a: attributes) = match nameOpt with | None when not state.print_cil_input && not Cil.theMachine.Cil.msvcMode -> () (* Cannot print the attributes in this case because gcc does not like them here, except if we are printing for CIL, or for MSVC. In fact, for MSVC we MUST print attributes such as __stdcall *) (* if pa = nil then nil else text "/*" ++ pa ++ text "*/"*) | _ -> self#attributes fmt a in match t with | TVoid a -> fprintf fmt "void%a%a" self#attributes a pname true | TInt (ikind,a) -> fprintf fmt "%a%a%a" self#ikind ikind self#attributes a pname true | TFloat(fkind, a) -> fprintf fmt "%a%a%a" self#fkind fkind self#attributes a pname true | TComp (comp, _, a) -> (* A reference to a struct *) fprintf fmt "%s %a%a%a" (if comp.cstruct then "struct" else "union") self#varname comp.cname self#attributes a pname true | TEnum (enum, a) -> fprintf fmt "enum %a%a%a" self#varname enum.ename self#attributes a pname true | TPtr (bt, a) -> (* Parenthesize the ( * attr name) if a pointer to a function or an * array. However, on MSVC the __stdcall modifier must appear right * before the pointer constructor "(__stdcall *f)". We push them into * the parenthesis. *) let (paren: (formatter -> unit) option), (bt': typ) = match bt with TFun(rt, args, isva, fa) when Cil.theMachine.Cil.msvcMode -> let an, af', at = Cil.partitionAttributes ~default:Cil.AttrType fa in (* We take the af' and we put them into the parentheses *) Some (fun fmt -> fprintf fmt "(%a" printAttributes af'), TFun(rt, args, isva, Cil.addAttributes an at) | TFun _ | TArray _ -> (Some (fun fmt -> fprintf fmt "(")), bt | _ -> None, bt in let name' = fun fmt -> fprintf fmt "*%a%a" printAttributes a pname (a <> []) in let name'' = fun fmt -> (* Put the parenthesis *) match paren with Some p -> fprintf fmt "%t%t)" p name' | _ -> fprintf fmt "%t" name' in self#typ (Some name'') fmt bt' | TArray (elemt, lo, _, a) -> (* qualifiers attributes are not supposed to be on the TArray, but on the base type. (Besides, GCC and Clang do not parse the result if the qualifier is misplaced. *) let atts_elem, a = Cil.splitArrayAttributes a in if atts_elem != [] then Kernel.failure ~current:true "Found some incorrect attributes for array (%a). Please report." self#attributes atts_elem; let name' fmt = if a = [] then pname fmt false else if nameOpt = None then printAttributes fmt a else fprintf fmt "(%a%a)" printAttributes a pname true in self#typ (Some (fun fmt -> fprintf fmt "%t[%t]" name' (fun fmt -> match lo with | None -> () | Some e -> self#exp fmt e) )) fmt elemt | TFun (restyp, args, isvararg, a) -> let name' fmt = if a = [] then pname fmt false else if nameOpt = None then printAttributes fmt a else fprintf fmt "(%a%a)" printAttributes a pname (a <> []) in let module Args(A:sig type t val args: t list option val pp_args: Format.formatter -> t -> unit end)= struct let pp_prms fmt = fprintf fmt "%t(@[%t@])" name' (fun fmt -> match A.args with | None -> () | Some [] when isvararg -> fprintf fmt "..." | Some [] -> fprintf fmt "void" | Some args -> Pretty_utils.pp_list ~sep:",@ " A.pp_args fmt args ; if isvararg then fprintf fmt "@ , ..."; ) end in let pp_prms = match fundecl with | None -> let module Args = Args(struct type t = (string * typ * attributes) let args = args let pp_args fmt (aname,atype,aattr) = let stom, rest = Cil.separateStorageModifiers aattr in (* First the storage modifiers *) fprintf fmt "%a%a%a" self#attributes stom (self#typ (Some (fun fmt -> fprintf fmt "%s" aname))) atype self#attributes rest end) in Args.pp_prms | Some fundecl -> let module Args = Args(struct type t = varinfo let args = (try Some (Cil.getFormalsDecl fundecl) with Not_found -> None) let pp_args = self#vdecl end) in Args.pp_prms in self#typ (Some pp_prms) fmt restyp | TNamed (t, a) -> fprintf fmt "%a%a%a" self#varname t.tname self#attributes a pname true | TBuiltin_va_list a -> fprintf fmt "__builtin_va_list%a%a" self#attributes a pname true (**** PRINTING ATTRIBUTES *********) method attributes fmt a = self#attributesGen false fmt a (* Print one attribute. Return also an indication whether this attribute should be printed inside the __attribute__ list *) method attribute fmt = function | Attr(an, args) -> (* Recognize and take care of some known cases *) (match an, args with | "const", [] -> fprintf fmt "const"; false (* Put the aconst inside the attribute list *) | "aconst", [] when not Cil.theMachine.Cil.msvcMode -> fprintf fmt "__const__"; true | "thread", [] when not Cil.theMachine.Cil.msvcMode -> fprintf fmt "__thread"; false (* | "used", [] when not !msvcMode -> text "__attribute_used__", false *) | "volatile", [] -> fprintf fmt "volatile"; false | "restrict", [] -> fprintf fmt "__restrict"; false | "missingproto", [] -> fprintf fmt "/* missing proto */"; false | "cdecl", [] when Cil.theMachine.Cil.msvcMode -> fprintf fmt "__cdecl"; false | "stdcall", [] when Cil.theMachine.Cil.msvcMode -> fprintf fmt "__stdcall"; false | "fastcall", [] when Cil.theMachine.Cil.msvcMode -> fprintf fmt "__fastcall"; false | "declspec", args when Cil.theMachine.Cil.msvcMode -> fprintf fmt "__declspec(%a)" (Pretty_utils.pp_list ~sep:"" self#attrparam) args; false | "w64", [] when Cil.theMachine.Cil.msvcMode -> fprintf fmt "__w64"; false | "asm", args -> fprintf fmt "__asm__(%a)" (Pretty_utils.pp_list ~sep:"" self#attrparam) args; false (* we suppress printing mode(__si__) because it triggers an internal compiler error in all current gcc versions sm: I've now encountered a problem with mode(__hi__)... I don't know what's going on, but let's try disabling all "mode". *) | "mode", [ACons(tag,[])] -> fprintf fmt "/* mode(%s) */" tag; false (* sm: also suppress "format" because we seem to print it in a way gcc does not like *) | "format", _ -> fprintf fmt "/* format attribute */"; false | "hidden", _ -> (* hidden attribute list *) fprintf fmt ""; false (* sm: here's another one I don't want to see gcc warnings about.. *) | "mayPointToStack", _ when not state.print_cil_input -> (* [matth: may be inside another comment.] -> text "/*mayPointToStack*/", false *) fprintf fmt ""; false | "arraylen", [a] -> fprintf fmt "/*[%a]*/" self#attrparam a; false | "static",_ -> fprintf fmt "/* static */"; false | "", _ -> fprintf fmt "%a " (Pretty_utils.pp_list ~sep:" " self#attrparam) args; true | s, _ when s = Cil.bitfield_attribute_name && not Cil.miscState.Cil.printCilAsIs -> false | _ -> (* This is the dafault case *) (* Add underscores to the name *) let an' = if Cil.theMachine.Cil.msvcMode then "__" ^ an else "__" ^ an ^ "__" in if args = [] then (fprintf fmt "%s" an'; true) else (fprintf fmt "%s(%a)" an' (Pretty_utils.pp_list ~sep:"," self#attrparam) args; true)) | AttrAnnot s -> fprintf fmt "%s" (Cil.mkAttrAnnot s); false method private attribute_prec (contextprec: int) fmt (a: attrparam) = let thisLevel = Precedence.getParenthLevelAttrParam a in let needParens = if thisLevel >= contextprec then true else if contextprec == Precedence.bitwiseLevel then (* quiet down some GCC warnings *) thisLevel == Precedence.additiveLevel || thisLevel == Precedence.comparativeLevel else false in if needParens then fprintf fmt "(%a)" self#attrparam a else self#attrparam fmt a method attrparam fmt a = let level = Precedence.getParenthLevelAttrParam a in match a with | AInt n -> fprintf fmt "%a" Datatype.Big_int.pretty n | AStr s -> fprintf fmt "\"%s\"" (Escape.escape_string s) | ACons(s, []) -> fprintf fmt "%s" s | ACons(s,al) -> fprintf fmt "%s(%a)" s (Pretty_utils.pp_list ~sep:"" self#attrparam) al | ASizeOfE a -> fprintf fmt "sizeof(%a)" self#attrparam a | ASizeOf t -> fprintf fmt "sizeof(%a)" (self#typ None) t | AAlignOfE a -> fprintf fmt "__alignof__(%a)" self#attrparam a | AAlignOf t -> fprintf fmt "__alignof__(%a)" (self#typ None) t | AUnOp(u,a1) -> fprintf fmt "%a %a" self#unop u (self#attribute_prec level) a1 | ABinOp(b,a1,a2) -> fprintf fmt "@[(%a)%a@ (%a) @]" (self#attribute_prec level) a1 self#binop b (self#attribute_prec level) a2 | ADot (ap, s) -> fprintf fmt "%a.%s" self#attrparam ap s | AStar a1 -> fprintf fmt "(*%a)" (self#attribute_prec Precedence.derefStarLevel) a1 | AAddrOf a1 -> fprintf fmt "& %a" (self#attribute_prec Precedence.addrOfLevel) a1 | AIndex (a1, a2) -> fprintf fmt "%a[%a]" self#attrparam a1 self#attrparam a2 | AQuestion (a1, a2, a3) -> fprintf fmt "%a ? %a : %a" self#attrparam a1 self#attrparam a2 self#attrparam a3 (* A general way of printing lists of attributes *) method private attributesGen (block: bool) fmt (a: attributes) = (* Scan all the attributes and separate those that must be printed inside the __attribute__ list *) let rec loop (in__attr__: string list) = function | [] -> if in__attr__ <> [] then begin (* sm: added 'forgcc' calls to not comment things out * if CIL is the consumer; this is to address a case * Daniel ran into where blockattribute(nobox) was being * dropped by the merger *) (if block then fprintf fmt " %s __blockattribute__(" (Cil.forgcc "/*") else fprintf fmt " __attribute__(("); Pretty_utils.pp_list ~sep:",@ " Format.pp_print_string fmt in__attr__; fprintf fmt ")%s" (if block then Cil.forgcc "*/" else ")") end | x :: rest -> let buff = Buffer.create 17 in let local_fmt = formatter_of_buffer buff in let ina = self#attribute local_fmt x in pp_print_flush local_fmt (); let dx = Buffer.contents buff in if ina then loop (dx :: in__attr__) rest else begin if dx <> "" then fprintf fmt " %s" dx; loop in__attr__ rest end in let keep_attr = function | Attr (s,_) -> not (List.mem s !reserved_attributes) | AttrAnnot _ -> true in loop [] (List.filter keep_attr a); (* ******************************************************************* *) (* Logic annotations printer *) (* ******************************************************************* *) method logic_constant fmt = function | Integer(_, Some s) when print_as_source s -> fprintf fmt "%s" s (* Always print the text if there is one, unless we want to print it as hexa *) | Integer(i, _) -> Datatype.Big_int.pretty fmt i | LStr(s) -> fprintf fmt "\"%s\"" (Escape.escape_string s) | LWStr(s) -> (* text ("L\"" ^ escape_string s ^ "\"") *) fprintf fmt "L"; List.iter (fun elt -> if (elt >= Int64.zero && elt <= (Int64.of_int 255)) then fprintf fmt "%S" (Escape.escape_char (Char.chr (Int64.to_int elt))) else fprintf fmt "\"\\x%LX\"" elt; fprintf fmt "@ ") s; (* we cannot print L"\xabcd" "feedme" as L"\xabcdfeedme" -- the former has 7 wide characters and the later has 3. *) | LChr(c) -> fprintf fmt "'%s'" (Escape.escape_char c) | LReal(r) -> fprintf fmt "%s" r.r_literal | LEnum {einame = s} -> fprintf fmt "%s" s method logic_type name fmt = let pname = match name with | Some d -> (fun fmt -> Format.fprintf fmt "@ %t" d) | None -> fun _ -> () in function | Ctype typ -> self#typ name fmt typ | Linteger -> let res = if Kernel.Unicode.get () then Utf8_logic.integer else "integer" in Format.fprintf fmt "%s%t" res pname | Lreal -> let res = if Kernel.Unicode.get () then Utf8_logic.real else "real" in Format.fprintf fmt "%s%t" res pname | Ltype ({ lt_name = name},[]) when name = Utf8_logic.boolean-> let res = if Kernel.Unicode.get () then Utf8_logic.boolean else "boolean" in Format.fprintf fmt "%s%t" res pname | Ltype (s,l) -> fprintf fmt "%a%a%t" self#varname s.lt_name ((* the space avoids the issue of list> where the double > would be read as a shift. It could be optimized away in most of the cases. *) Pretty_utils.pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@]>@ " (self#logic_type None)) l pname | Larrow (args,rt) -> fprintf fmt "@[@[<2>{@ %a@]}@]%a%t" (Pretty_utils.pp_list ~sep:",@ " (self#logic_type None)) args (self#logic_type None) rt pname | Lvar s -> fprintf fmt "%a%t" self#varname s pname method private term_prec contextprec fmt e = let thisLevel = Precedence.getParenthLevelLogic e.term_node in let needParens = if thisLevel >= contextprec then true else if contextprec == Precedence.bitwiseLevel then (* quiet down some GCC warnings *) thisLevel == Precedence.additiveLevel || thisLevel == Precedence.comparativeLevel else false in if needParens then fprintf fmt "@[(%a)@]" self#term e else self#term fmt e val mutable is_debug_type_mode = false initializer is_debug_type_mode <- false method identified_term fmt t = self#term fmt t.it_content method term fmt t = if (Kernel.debug_atleast 5) && (not is_debug_type_mode) then begin is_debug_type_mode <- true ; fprintf fmt "/*type:%a*/" (self#logic_type None) t.term_type; is_debug_type_mode <- false ; end; match t.term_name with | [] -> self#term_node fmt t | _ :: _ -> fprintf fmt "(@[%a:@ %a@])" (Pretty_utils.pp_list ~sep:":@ " pp_print_string) t.term_name self#term_node t (* This instance variable is true the pretty-printed term is not inside an \at. Hence one may not pretty-print useless Here labels. *) val mutable current_label = Logic_const.here_label method term_binop fmt b = fprintf fmt "%s" (match b with | PlusA | PlusPI | IndexPI -> "+" | MinusA | MinusPP | MinusPI -> "-" | Mult -> "*" | Div -> "/" | Mod -> "%" | Shiftlt -> "<<" | Shiftrt -> ">>" | Lt -> "<" | Gt -> ">" | Le -> if Kernel.Unicode.get () then Utf8_logic.le else "<=" | Ge -> if Kernel.Unicode.get () then Utf8_logic.ge else ">=" | Eq -> if Kernel.Unicode.get () then Utf8_logic.eq else "==" | Ne -> if Kernel.Unicode.get () then Utf8_logic.neq else "!=" | BAnd -> "&" | BXor -> "^" | BOr -> "|" | LAnd -> if Kernel.Unicode.get () then Utf8_logic.conj else "&&" | LOr -> if Kernel.Unicode.get () then Utf8_logic.disj else "||") method relation fmt b = fprintf fmt "%s" (match b with | Rlt -> "<" | Rgt -> ">" | Rle -> if Kernel.Unicode.get () then Utf8_logic.le else "<=" | Rge -> if Kernel.Unicode.get () then Utf8_logic.ge else ">=" | Req -> if Kernel.Unicode.get () then Utf8_logic.eq else "==" | Rneq -> if Kernel.Unicode.get () then Utf8_logic.neq else "!=") method term_node fmt t = let current_level = Precedence.getParenthLevelLogic t.term_node in match t.term_node with | TConst s -> fprintf fmt "%a" self#logic_constant s | TDataCons(ci,args) -> fprintf fmt "%a%a" self#varname ci.ctor_name (Pretty_utils.pp_list ~pre:"(@[" ~suf:"@])" ~sep:",@ " self#term) args | TLval lv -> fprintf fmt "%a" (self#term_lval_prec current_level) lv | TSizeOf t -> fprintf fmt "sizeof(%a)" (self#typ None) t | TSizeOfE e -> fprintf fmt "sizeof(%a)" self#term e | TSizeOfStr s -> fprintf fmt "sizeof(%S)" s | TAlignOf e -> fprintf fmt "alignof(%a)" (self#typ None) e | TAlignOfE e -> fprintf fmt "alignof(%a)" self#term e | TUnOp (op,e) -> fprintf fmt "%a%a" self#unop op (self#term_prec current_level) e | TBinOp (op,l,r) -> fprintf fmt "%a%a%a" (self#term_prec current_level) l self#term_binop op (self#term_prec current_level) r | TCastE (ty,e) -> fprintf fmt "(%a)%a" (self#typ None) ty (self#term_prec current_level) e | TAddrOf lv -> fprintf fmt "&%a" (self#term_lval_prec Precedence.addrOfLevel) lv | TStartOf lv -> fprintf fmt "(%a)%a" (self#logic_type None) t.term_type (self#term_lval_prec current_level) lv | Tapp (f, labels, tl) -> fprintf fmt "%a%a%a" self#logic_info f self#labels (List.map snd labels) (Pretty_utils.pp_list ~pre:"@[(" ~suf:")@]" ~sep:",@ " self#term) tl | Tif (cond,th,el) -> fprintf fmt "@[<2>%a?@;%a:@;%a@]" (self#term_prec current_level) cond (self#term_prec current_level) th (self#term_prec current_level) el | Tat (t,StmtLabel sref) -> let rec pickLabel = function | [] -> None | Label (l, _, _) :: _ -> Some l | _ :: rest -> pickLabel rest in let l = match pickLabel !sref.labels with Some l -> l | None -> Kernel.fatal "Cannot find label for \\at@."; in fprintf fmt "@[\\at(@[@[%a@],@,@[%s@]@])@]" self#term t l | Tat (t,(LogicLabel (_, l) as lab)) -> let old_label = current_label in current_label <- lab; begin if lab = Logic_const.old_label then fprintf fmt "@[\\old(@[%a@])@]" self#term t else fprintf fmt "@[\\at(@[@[%a@],@,@[%s@]@])@]" self#term t l end; current_label <- old_label | Toffset (l,t) -> fprintf fmt "\\offset%a(%a)" self#labels [l] self#term t | Tbase_addr (l,t) -> fprintf fmt "\\base_addr%a(%a)" self#labels [l] self#term t | Tblock_length (l,t) -> fprintf fmt "\\block_length%a(%a)" self#labels [l] self#term t | Tnull -> fprintf fmt "\\null" | TCoerce (e,ty) -> fprintf fmt "%a@ :>@ %a" (self#term_prec current_level) e (self#typ None) ty | TCoerceE (e,ce) -> fprintf fmt "%a :> %a" (self#term_prec current_level) e (self#term_prec current_level) ce | TUpdate (t,toff,v) -> fprintf fmt "{%a \\with %a = %a}" self#term t self#term_offset toff self#term v | Tlambda(prms,expr) -> fprintf fmt "@[<2>\\lambda@ %a;@ %a@]" self#quantifiers prms (self#term_prec current_level) expr | Ttypeof t -> fprintf fmt "\\typeof(%a)" self#term t | Ttype ty -> fprintf fmt "\\type(%a)" (self#typ None) ty | Tunion locs -> fprintf fmt "@[\\union(@,%a)@]" (Pretty_utils.pp_list ~sep:",@ " self#term) locs | Tinter locs -> fprintf fmt "@[\\inter(@,%a)@]" (Pretty_utils.pp_list ~sep:",@ " self#term) locs | Tempty_set -> pp_print_string fmt "\\empty" | Tcomprehension(lv,quant,pred) -> fprintf fmt "{@[%a@ |@ %a%a@]}" self#term lv self#quantifiers quant (Pretty_utils.pp_opt (fun fmt p -> fprintf fmt ";@ %a" self#identified_pred p)) pred | Trange(low,high) -> fprintf fmt "@[%a..@,%a@]" (Pretty_utils.pp_opt (self#term_prec current_level)) low (Pretty_utils.pp_opt (self#term_prec current_level)) high | Tlet(def,body) -> assert (Kernel.verify (def.l_labels = []) "invalid logic construction: local definition with label"); assert (Kernel.verify (def.l_tparams = []) "invalid logic construction: polymorphic local definition"); let v = def.l_var_info in let args = def.l_profile in let pp_defn = match def.l_body with | LBterm t -> fun fmt -> self#term fmt t | LBpred p -> fun fmt -> self#predicate_named fmt p | LBnone | LBreads _ | LBinductive _ -> Kernel.fatal "invalid logic local definition" in fprintf fmt "@[\\let@ %a@ =@ %t%t;@ %a@]" self#logic_var v (fun fmt -> if args <> [] then fprintf fmt "@[<2>\\lambda@ %a;@]@ " self#quantifiers args) pp_defn (self#term_prec current_level) body | TLogic_coerce(ty,t) -> if Kernel.debug_atleast 1 then fprintf fmt "/*coercion to:@[%a@]*/" (self#logic_type None) ty; self#term_prec current_level fmt t method private term_lval_prec contextprec fmt lv = if Precedence.getParenthLevelLogic (TLval lv) > contextprec then fprintf fmt "(%a)" self#term_lval lv else fprintf fmt "%a" self#term_lval lv method term_lval fmt lv = match lv with | TVar vi, o -> fprintf fmt "%a%a" self#logic_var vi self#term_offset o | TResult _, o -> fprintf fmt "\\result%a" self#term_offset o | TMem e, TField(fi,o) -> fprintf fmt "%a->%a%a" (self#term_prec Precedence.arrowLevel) e self#varname fi.fname self#term_offset o | TMem e, TNoOffset -> fprintf fmt "*%a" (self#term_prec Precedence.derefStarLevel) e | TMem e, o -> fprintf fmt "(*%a)%a" (self#term_prec Precedence.derefStarLevel) e self#term_offset o method model_field fmt mi = self#varname fmt mi.mi_name method term_offset fmt o = match o with | TNoOffset -> () | TField (fi,o) -> fprintf fmt ".%a%a" self#field fi self#term_offset o | TModel (mi,o) -> fprintf fmt ".%a%a" self#model_field mi self#term_offset o | TIndex(e,o) -> fprintf fmt "[%a]%a" self#term e self#term_offset o method logic_info fmt li = self#logic_var fmt li.l_var_info method logic_var fmt v = self#varname fmt v.lv_name method quantifiers fmt l = Pretty_utils.pp_list ~sep:",@ " (fun fmt lv -> let pvar fmt = self#logic_var fmt lv in self#logic_type (Some pvar) fmt lv.lv_type) fmt l method private pred_prec fmt (contextprec,p) = let thisLevel = Precedence.getParenthLevelPred p in let needParens = thisLevel >= contextprec in if needParens then fprintf fmt "@[(%a)@]" self#predicate p else self#predicate fmt p method private named_pred fmt (parenth, names, content) = match names with | [] -> self#pred_prec fmt (parenth,content) | _ :: _ -> if parenth = Precedence.upperLevel then fprintf fmt "@[%a:@ %a@]" (Pretty_utils.pp_list ~sep:":@ " pp_print_string) names self#pred_prec (Precedence.upperLevel, content) else fprintf fmt "(@[%a:@ %a@])" (Pretty_utils.pp_list ~sep:":@ " pp_print_string) names self#pred_prec (Precedence.upperLevel, content) method private identified_pred fmt p = self#named_pred fmt (Precedence.upperLevel, p.name, p.content) method private pred_prec_named fmt (parenth,p) = self#named_pred fmt (parenth,p.name,p.content) method predicate_named fmt p = self#named_pred fmt (Precedence.upperLevel, p.name, p.content) method identified_predicate fmt p = (*fprintf fmt "@[IP_LOC:%a@\n@]" Extlib.pretty_position (fst p.ip_loc);*) if verbose then fprintf fmt "@[//id:%d@ %a@]" p.ip_id self#predicate_named (Logic_const.pred_of_id_pred p) else self#predicate_named fmt (Logic_const.pred_of_id_pred p) method private preds kw fmt l = Pretty_utils.pp_list ~suf:"@]@\n" ~sep:"@\n" (fun fmt p -> fprintf fmt "@[%s %a;@]" kw self#identified_predicate p) fmt l method predicate fmt p = let current_level = Precedence.getParenthLevelPred p in let term = self#term_prec current_level in match p with | Pfalse -> pp_print_string fmt "\\false" | Ptrue -> pp_print_string fmt "\\true" | Papp (p,labels,l) -> fprintf fmt "@[%a%a%a@]" self#logic_info p self#labels (List.map snd labels) (Pretty_utils.pp_list ~pre:"@[(" ~suf:")@]" ~sep:",@ " self#term) l | Prel (rel,l,r) -> fprintf fmt "@[%a@ %a@ %a@]" term l self#relation rel term r | Pand (p1, p2) -> fprintf fmt "@[%a@ %a@ %a@]" self#pred_prec_named (current_level,p1) self#term_binop LAnd self#pred_prec_named (current_level,p2) | Por (p1, p2) -> fprintf fmt "@[%a@ %a@ %a@]" self#pred_prec_named (current_level,p1) self#term_binop LOr self#pred_prec_named (current_level,p2) | Pxor (p1, p2) -> fprintf fmt "@[%a@ %s@ %a@]" self#pred_prec_named (current_level,p1) (if Kernel.Unicode.get () then Utf8_logic.x_or else "^^") self#pred_prec_named (current_level,p2) | Pimplies (p1,p2) -> fprintf fmt "@[%a@ %s@ %a@]" self#pred_prec_named (current_level,p1) (if Kernel.Unicode.get () then Utf8_logic.implies else "==>") self#pred_prec_named (current_level,p2) | Piff (p1,p2) -> fprintf fmt "@[%a@ %s@ %a@]" self#pred_prec_named (current_level,p1) (if Kernel.Unicode.get () then Utf8_logic.iff else "<==>") self#pred_prec_named (current_level,p2) | Pnot a -> fprintf fmt "@[%s%a@]" (if Kernel.Unicode.get () then Utf8_logic.neg else "!") self#pred_prec_named (current_level,a) | Pif (e, p1, p2) -> fprintf fmt "@[%a?@ %a:@ %a@]" term e self#pred_prec_named (current_level, p1) self#pred_prec_named (current_level, p2) | Plet (def, p) -> assert (Kernel.verify (def.l_labels = []) "invalid logic construction: local definition with label"); assert (Kernel.verify (def.l_tparams = []) "invalid logic construction: polymorphic local definition"); let v = def.l_var_info in let args = def.l_profile in let pp_defn = match def.l_body with | LBterm t -> fun fmt -> self#term fmt t | LBpred p -> fun fmt -> self#pred_prec_named fmt (current_level,p) | LBnone | LBreads _ | LBinductive _ -> Kernel.fatal "invalid logic local definition" in fprintf fmt "@[\\let@ %a@ =@ %t%t;@ %a@]" self#logic_var v (fun fmt -> if args <> [] then fprintf fmt "@[\\lambda@ %a;@]@ " self#quantifiers args) pp_defn self#pred_prec_named (current_level,p) | Pforall (quant,pred) -> fprintf fmt "@[@[%s %a;@]@ %a@]" (if Kernel.Unicode.get () then Utf8_logic.forall else "\\forall") self#quantifiers quant self#pred_prec_named (current_level,pred) | Pexists (quant,pred) -> fprintf fmt "@[@[%s %a;@]@ %a@]" (if Kernel.Unicode.get () then Utf8_logic.exists else "\\exists") self#quantifiers quant self#pred_prec_named (current_level,pred) | Pfreeable (l,p) -> fprintf fmt "@[\\freeable%a(@[%a@])@]" self#labels [l] self#term p | Pallocable (l,p) -> fprintf fmt "@[\\allocable%a(@[%a@])@]" self#labels [l] self#term p | Pvalid (l,p) -> fprintf fmt "@[\\valid%a(@[%a@])@]" self#labels [l] self#term p | Pvalid_read (l,p) -> fprintf fmt "@[\\valid_read%a(@[%a@])@]" self#labels [l] self#term p | Pinitialized (l,p) -> fprintf fmt "@[\\initialized%a(@[%a@])@]" self#labels [l] self#term p | Pfresh (l1,l2,e1,e2) -> fprintf fmt "@[\\fresh%a(@[%a@],@[%a@])@]" self#labels [l1;l2] self#term e1 self#term e2 | Pseparated seps -> fprintf fmt "@[\\separated(@,%a@,)@]" (Pretty_utils.pp_list ~sep:",@ " self#term) seps | Pat (p,StmtLabel sref) -> let rec pickLabel = function | [] -> Kernel.fatal "Cannot find label for \\at@." | Label (l, _, _) :: _ -> l | _ :: rest -> pickLabel rest in let l = pickLabel !sref.labels in fprintf fmt "@[\\at(@[@[%a@],@,@[%s@]@])@]" self#pred_prec_named (Precedence.upperLevel, p) l | Pat(p,(LogicLabel (_, s) as lab)) -> if lab = Logic_const.old_label then fprintf fmt "@[\\old(@[%a@])@]" self#pred_prec_named (Precedence.upperLevel,p) else fprintf fmt "@[\\at(@[@[%a@],@,%s@])@]" self#pred_prec_named (Precedence.upperLevel,p) s | Psubtype (e,ce) -> fprintf fmt "@[%a@ <:@ %a@]" term e term ce method private decrement kw fmt (t, rel) = match rel with | None -> fprintf fmt "@[<2>%s@ %a;@]" kw self#term t | Some str -> (*TODO: replace this string with an interpreted variable*) fprintf fmt "@[<2>%s@ %a@ for@ %s;@]" kw self#term t str method decreases fmt v = self#decrement "decreases" fmt v method variant fmt v = self#decrement "loop variant" fmt v method assumes fmt p = fprintf fmt "@[assumes@ %a;@]" self#identified_predicate p method requires fmt p = fprintf fmt "@[requires@ %a;@]" self#identified_predicate p method post_cond fmt (k,p) = let kw = get_termination_kind_name k in fprintf fmt "@[%s@ %a;@]" kw self#identified_predicate p method terminates fmt p = fprintf fmt "@[terminates@ %a;@]" self#identified_predicate p method private cd_behaviors fmt kind p = fprintf fmt "@[%s behaviors %a;@]" kind (Pretty_utils.pp_list ~pre:"@[" ~sep:",@ " pp_print_string) p method complete_behaviors fmt p = self#cd_behaviors fmt "complete" p method disjoint_behaviors fmt p = self#cd_behaviors fmt "disjoint" p method allocation ~isloop fmt = function | FreeAllocAny -> () | FreeAlloc([],[]) -> fprintf fmt "@[%sallocates@ \\nothing;@]" (if isloop then "loop " else "") | FreeAlloc(f,a) -> let pFreeAlloc kw fmt = function | [] -> () | _ :: _ as af -> fprintf fmt "@[%s%s@ %a;@]" (if isloop then "loop " else "") kw (Pretty_utils.pp_list ~sep:",@ " self#identified_term) af in fprintf fmt "@[%a%(%)%a@]" (pFreeAlloc "frees") f (if f != [] && a != [] then format_of_string "@ " else "") (pFreeAlloc "allocates") a method assigns kw fmt = function | WritesAny -> () | Writes [] -> fprintf fmt "@[%s \\nothing;@]" kw | Writes l -> let without_result = List.filter (function (a,_) -> not (Logic_const.is_result a.it_content || Logic_const.is_exit_status a.it_content)) l in fprintf fmt "@[%s%a@]" (if without_result == [] then "" else kw ^ " ") (Pretty_utils.pp_list ~sep:",@ " ~suf:";@]" (fun fmt (t, _) -> self#identified_term fmt t)) without_result method private assigns_deps kw fmt = function | WritesAny -> () | Writes [] as a -> self#assigns kw fmt a | Writes [ b,_ as a ] when Logic_const.is_result b.it_content -> self#from kw fmt a | Writes l as a -> fprintf fmt "@[%a%a@]" (self#assigns kw) a (Pretty_utils.pp_list ~pre:"@ @[" ~sep:"@\n" (self#from kw)) (List.filter (fun (_, f) -> f <> FromAny) l); method from kw fmt (base,deps) = match deps with | FromAny -> () | From [] -> fprintf fmt "@[@[%s@ %a@]@ @[\\from \\nothing@];@]" kw self#identified_term base | From l -> fprintf fmt "@[@[%s@ %a@]@ @[\\from %a@];@]" kw self#identified_term base (Pretty_utils.pp_list ~sep:",@ " self#identified_term) l (* not enclosed in a box *) method private terminates_decreases ~extra_nl nl fmt (terminates, variant) = let nl_terminates = nl || variant != None in let pp_opt nl fmt = let suf = if nl then format_of_string "@]@\n" else "@]" in Pretty_utils.pp_opt ~suf fmt in fprintf fmt "%a%a%(%)" (pp_opt nl_terminates self#terminates) terminates (pp_opt nl self#decreases) variant (format_of_string (if extra_nl && nl && (variant != None || terminates != None) then format_of_string "@\n" else "")) (* not enclosed in a box *) method private behavior_contents ~extra_nl nl ?terminates ?variant fmt b = self#set_current_behavior b; let nl_assigns = nl || b.b_allocation != FreeAllocAny in let nl_ensures = nl_assigns || b.b_assigns != WritesAny in let nl_extended = nl_ensures || b.b_extended != [] in let nl_decreases = nl_extended || b.b_post_cond != [] in let nl_requires = nl_decreases || variant != None || terminates != None in let nl_assumes = nl_requires || b.b_requires != [] in let pp_list nl fmt = let suf = if nl then format_of_string "@]@\n" else "@]" in Pretty_utils.pp_list ~pre:"@[" ~sep:"@\n" ~suf fmt in fprintf fmt "%a%a%a%a%a%a%(%)%a%(%)%(%)" (pp_list nl_assumes self#assumes) b.b_assumes (pp_list nl_requires self#requires) b.b_requires (self#terminates_decreases ~extra_nl:false nl_decreases) (terminates, variant) (pp_list nl_ensures self#post_cond) b.b_post_cond (pp_list nl_extended (Behavior_extensions.pp (self:>extensible_printer_type))) b.b_extended (self#assigns_deps "assigns") b.b_assigns (format_of_string (if nl_assigns && b.b_assigns != WritesAny then format_of_string "@\n" else "")) (self#allocation ~isloop:false) b.b_allocation (format_of_string (if nl && b.b_allocation != FreeAllocAny then format_of_string "@\n" else "")) (format_of_string (if extra_nl && (nl_assumes || b.b_assumes != []) then format_of_string "@\n" else "")); self#reset_current_behavior () method behavior fmt b = fprintf fmt "@[behavior %s:@;<1 2>@[%a@]@]" b.b_name (self#behavior_contents ~extra_nl:false false ?terminates:None ?variant:None) b method funspec fmt ({ spec_behavior = behaviors; spec_variant = variant; spec_terminates = terminates; spec_complete_behaviors = complete; spec_disjoint_behaviors = disjoint } as spec) = let pp_list ?(extra_nl=false) nl fmt = let suf = if nl then if extra_nl then format_of_string "@]@\n@\n" else "@]@\n" else "@]" in let sep = if extra_nl then format_of_string "@\n@\n" else "@\n" in Pretty_utils.pp_list ~pre:"@[" ~sep ~suf fmt in fprintf fmt "@["; let default_bhv = Cil.find_default_behavior spec in let other_bhvs = List.filter (fun b -> not (Cil.is_default_behavior b)) behaviors in let nl_complete = disjoint != [] in let nl_other_bhvs = nl_complete || complete != [] in let nl_default = nl_other_bhvs || other_bhvs != [] in (match default_bhv with | None -> self#terminates_decreases ~extra_nl:nl_default nl_default fmt (terminates, variant) | Some b when b.b_assumes == [] && b.b_requires == [] && b.b_post_cond == [] && b.b_extended == [] && b.b_allocation == FreeAllocAny && b.b_assigns == WritesAny -> self#terminates_decreases ~extra_nl:nl_default nl_default fmt (terminates, variant) | Some b -> self#behavior_contents ~extra_nl:nl_default nl_default ?terminates ?variant fmt b); fprintf fmt "%a%a%a@]" (pp_list ~extra_nl:true nl_other_bhvs self#behavior) other_bhvs (pp_list nl_complete self#complete_behaviors) complete (pp_list false self#disjoint_behaviors) disjoint method private loop_pragma fmt = function | Widen_hints terms -> fprintf fmt "WIDEN_HINTS @[%a@]" (Pretty_utils.pp_list ~sep:",@ " self#term) terms | Widen_variables terms -> fprintf fmt "WIDEN_VARIABLES @[%a@]" (Pretty_utils.pp_list ~sep:",@ " self#term) terms | Unroll_specs terms -> fprintf fmt "UNROLL @[%a@]" (Pretty_utils.pp_list ~sep:",@ " self#term) terms method private slice_pragma fmt = function |SPexpr t -> fprintf fmt "expr @[%a@]" self#term t | SPctrl -> pp_print_string fmt "ctrl" | SPstmt -> pp_print_string fmt "stmt" method private impact_pragma fmt = function | IPexpr t -> fprintf fmt "expr @[%a@]" self#term t | IPstmt -> pp_print_string fmt "stmt" (* TODO: add the annot ID in debug mode?*) method code_annotation fmt ca = let pp_for_behavs fmt l = Pretty_utils.pp_list ~pre:"for @[" ~suf:"@]:@ " ~sep:",@ " pp_print_string fmt l in match ca.annot_content with | AAssert (behav,p) -> fprintf fmt "@[%aassert@ %a;@]" pp_for_behavs behav self#identified_pred p | APragma (Slice_pragma sp) -> fprintf fmt "@[slice pragma@ %a;@]" self#slice_pragma sp | APragma (Impact_pragma sp) -> fprintf fmt "@[impact pragma@ %a;@]" self#impact_pragma sp | APragma (Loop_pragma lp) -> fprintf fmt "@[loop pragma@ %a;@]" self#loop_pragma lp | AStmtSpec(for_bhv, spec) -> fprintf fmt "@[%a%a@]" pp_for_behavs for_bhv self#funspec spec | AAssigns(behav,a) -> fprintf fmt "@[<2>%a%a@]" pp_for_behavs behav (self#assigns_deps "loop assigns") a | AAllocation(behav,af) -> fprintf fmt "@[<2>%a%a@]" pp_for_behavs behav (self#allocation ~isloop:true) af | AInvariant(behav,true, i) -> fprintf fmt "@[<2>%aloop invariant@ %a;@]" pp_for_behavs behav self#identified_pred i | AInvariant(behav,false,i) -> fprintf fmt "@[<2>%ainvariant@ %a;@]" pp_for_behavs behav self#identified_pred i | AVariant v -> self#variant fmt v method private loopInv fmt p = fprintf fmt "@[<2>loop invariant@ %a;@]" self#identified_pred p method private logicPrms fmt arg = let pvar fmt = self#logic_var fmt arg in self#logic_type (Some pvar) fmt arg.lv_type method private typeKernel fmt tvars = Pretty_utils.pp_list ~pre:"<@[" ~suf:"@]>" ~sep:",@ " pp_print_string fmt tvars method logic_label fmt lab = let s = match lab with | LogicLabel (_, s) -> s | StmtLabel sref -> let rec pickLabel = function | [] -> None | Label (l, _, _) :: _ -> Some l | _ :: rest -> pickLabel rest in match pickLabel !sref.labels with | Some l -> l | None -> "__invalid_label" in pp_print_string fmt s method private labels fmt labels = match labels with | [ l ] when current_label = l -> () | _ -> Pretty_utils.pp_list ~pre:"{@[" ~suf:"@]}" ~sep:",@ " self#logic_label fmt labels method model_info fmt mfi = let print_decl fmt = self#model_field fmt mfi in fprintf fmt "@[model %a@ @[<2>{@ %a@ };@]" (self#typ None) mfi.mi_base_type (self#logic_type (Some print_decl)) mfi.mi_field_type method global_annotation fmt = function | Dtype_annot (a,_) -> fprintf fmt "@[type invariant @[%a%a=@ %a@,;@]@]@\n" self#logic_var a.l_var_info (Pretty_utils.pp_list ~pre:"@[(" ~suf:")@]@ " ~sep:",@ " self#logicPrms) a.l_profile self#identified_pred (pred_body a.l_body) | Dmodel_annot (mfi,_) -> self#model_info fmt mfi | Dcustom_annot(_c, n ,_) -> fprintf fmt "@[custom %s: <...>@]@\n" n | Dinvariant (pred,_) -> fprintf fmt "@[global@ invariant %a:@[@ %a;@]@]@\n" self#logic_var pred.l_var_info self#identified_pred (pred_body pred.l_body) | Dlemma(name, is_axiom, labels, tvars, pred,_) -> fprintf fmt "@[%s@ %a%a%a:@[@ %a;@]@]@\n" (if is_axiom then "axiom" else "lemma") self#varname name self#labels labels self#typeKernel tvars self#identified_pred pred | Dtype (ti,_) -> fprintf fmt "@[type@ %a%a%a;@]@\n" self#varname ti.lt_name self#typeKernel ti.lt_params (Pretty_utils.pp_opt (fun fmt d -> fprintf fmt "@ =@ @[%a@]" self#logic_type_def d)) ti.lt_def | Dfun_or_pred (li,_) -> (match li.l_type with | Some rt -> fprintf fmt "@[logic %a" (self#logic_type None) rt | None -> (match li.l_body with | LBinductive _ -> fprintf fmt "@[inductive" | _ -> fprintf fmt "@[predicate")); fprintf fmt " %a%a%a%a" self#logic_var li.l_var_info self#labels li.l_labels self#typeKernel li.l_tparams (Pretty_utils.pp_list ~pre:"@[(" ~suf:")@]@ " ~sep:",@ " self#logicPrms) li.l_profile; (match li.l_body with | LBnone -> fprintf fmt ";" | LBreads reads -> (match reads with | [] -> fprintf fmt "@\n@[reads \\nothing;@]" | _ -> fprintf fmt "%a;" (Pretty_utils.pp_list ~pre:"@\n@[reads@ " ~sep:",@ " (fun fmt x -> self#term fmt x.it_content)) reads) | LBpred def -> fprintf fmt "=@ %a;" self#identified_pred def | LBinductive indcases -> fprintf fmt "{@ %a}" (Pretty_utils.pp_list ~pre:"@[" ~suf:"@]@\n" ~sep:"@\n" (fun fmt (id,labels,tvars,p) -> Format.fprintf fmt "case %s%a%a: @[%a@];" id self#labels labels self#typeKernel tvars self#identified_pred p)) indcases | LBterm def -> fprintf fmt "=@ %a;" self#term def); fprintf fmt "@]@\n" | Dvolatile(tsets,rvi_opt,wvi_opt,_) -> let pp_vol txt fmt = function | None -> () ; | Some vi -> fprintf fmt "@ %s %a" txt self#varinfo vi in fprintf fmt "@[volatile@ %a%a%a;@]" (Pretty_utils.pp_list ~sep:",@ " (fun fmt x -> self#term fmt x.it_content)) tsets (pp_vol "reads") rvi_opt (pp_vol "writes") wvi_opt ; | Daxiomatic(id,decls,_) -> (* Format.eprintf "cil.annotation on axiomatic %s@." id; *) fprintf fmt "@[axiomatic@ %s {@\n%a}@]@\n" id (Pretty_utils.pp_list ~pre:"@[" ~suf:"@]@\n" ~sep:"@\n" self#global_annotation) decls method logic_type_def fmt = function | LTsum l -> Pretty_utils.pp_list ~sep:"@ |@ " (fun fmt info -> fprintf fmt "%s@[%a@]" info.ctor_name (Pretty_utils.pp_list ~pre:"@[(" ~suf:")@]" ~sep:",@ " (self#logic_type None)) info.ctor_params) fmt l | LTsyn typ -> self#logic_type None fmt typ method file fmt file = fprintf fmt "@[/* Generated by Frama-C */@\n" ; Cil.iterGlobals file (fun g -> self#global fmt g); fprintf fmt "@]@." end (* class cil_printer *) include Printer_builder.Make(struct class printer = cil_printer end) (* initializing Cil's forward references *) let () = Cil.pp_typ_ref := pp_typ let () = Cil.pp_global_ref := pp_global let () = Cil.pp_exp_ref := pp_exp let () = Cil.pp_lval_ref := pp_lval let () = Cil.pp_ikind_ref := pp_ikind let () = Cil.pp_attribute_ref := pp_attribute let () = Cil.pp_attributes_ref := pp_attributes (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/printer/cil_descriptive_printer.mli0000644000175000017500000000410112155630231023657 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Internal printer for Cabs2cil. Like the standard [Cil_printer], but instead of temporary variable names it prints the description that was provided when the temp was created. This is usually better for messages that are printed for end users, although you may want the temporary names for debugging. *) open Cil_types val pp_exp: Format.formatter -> exp -> unit val pp_lval: Format.formatter -> lval -> unit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/printer/cil_printer.mli0000644000175000017500000000457612155630231021276 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Internal Cil printer. Must not be used by plug-in developers: use module {!Printer} instead. In particular, this pretty-printer is incorrect regarding annotations. It should only be used by modules linked before {!Annotations}. @since Fluorine-20130401 *) include Printer_api.S val get_termination_kind_name: Cil_types.termination_kind -> string val register_shallow_attribute: string -> unit (** Register an attribute that will never be pretty printed. *) val register_behavior_extension: string -> (Printer_api.extensible_printer_type -> Format.formatter -> int * Cil_types.identified_predicate list -> unit) -> unit (** Register a pretty-printer used for behavior extensione. *) val state: Printer_api.state (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/printer/printer.mli0000644000175000017500000000355312155630231020441 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** AST's pretty-printer. @modify Fluorine-20130401 fully change this API *) include Printer_api.S (**/**) val cabsbranches_pp_comment: (Format.formatter -> Cil_types.stmt -> unit) ref (** Internal use only. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/printer/printer.ml0000644000175000017500000002600712155630231020267 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 let cabsbranches_pp_comment = Extlib.mk_fun "Printer.debug_cabs" let compare_annotations la1 la2 = let total_order = Datatype.Int.compare la1.annot_id la2.annot_id in match la1.annot_content,la2.annot_content with | AAssert _, AAssert _ -> total_order | AAssert _,_ -> -1 | AStmtSpec _, AStmtSpec _ -> total_order | AStmtSpec _, AAssert _ -> 1 | AStmtSpec _,_ -> -1 | AInvariant _, AAssert _ -> 1 | AInvariant _, AStmtSpec _ -> 1 | AInvariant ([],_,_), AInvariant ([],_,_) -> total_order | AInvariant ([],_,_), AAssigns ([],_) -> total_order | AInvariant ([],_,_), AAllocation ([],_) -> total_order | AInvariant ([],_,_),_ -> -1 | AInvariant _, AInvariant([],_,_) -> 1 | AInvariant _, AAssigns([],_) -> 1 | AInvariant _, AAllocation([],_) -> 1 | AInvariant _, AInvariant _ -> total_order | AInvariant _, AAssigns _ -> total_order | AInvariant _, AAllocation _ -> total_order | AInvariant _, _ -> -1 | AAssigns _, AAssert _ -> 1 | AAssigns _, AStmtSpec _ -> 1 | AAssigns([],_), AInvariant ([],_,_) -> total_order | AAssigns([],_), AAssigns ([],_) -> total_order | AAssigns([],_), AAllocation ([],_) -> total_order | AAssigns ([],_), _ -> -1 | AAssigns _, AInvariant([],_,_) -> 1 | AAssigns _, AAssigns([],_) -> 1 | AAssigns _, AAllocation([],_) -> 1 | AAssigns _, AInvariant _ -> total_order | AAssigns _, AAssigns _ -> total_order | AAssigns _, AAllocation _ -> total_order | AAssigns _, _ -> -1 | AAllocation _, AAssert _ -> 1 | AAllocation _, AStmtSpec _ -> 1 | AAllocation([],_), AInvariant ([],_,_) -> total_order | AAllocation([],_), AAssigns ([],_) -> total_order | AAllocation([],_), AAllocation ([],_) -> total_order | AAllocation ([],_), _ -> -1 | AAllocation _, AInvariant([],_,_) -> 1 | AAllocation _, AAssigns([],_) -> 1 | AAllocation _, AAllocation([],_) -> 1 | AAllocation _, AInvariant _ -> total_order | AAllocation _, AAssigns _ -> total_order | AAllocation _, AAllocation _ -> total_order | AAllocation _, _ -> -1 | AVariant _, APragma _ -> -1 | AVariant _, AVariant _ -> total_order | AVariant _, _ -> 1 | APragma _, APragma _ -> total_order | APragma _, _ -> 1 (* All annotations are extracted from module [Annotations]. Generated global annotations are inserted before the very first function definition. User-defined global annotations are pretty-printed at their own place in the code. *) class printer_with_annot () = object (self) inherit Cil_printer.extensible_printer () as super val mutable declared_globs = Cil_datatype.Varinfo.Set.empty val mutable print_spec = false method reset () = super#reset (); verbose <- Kernel.debug_atleast 1; declared_globs <- Cil_datatype.Varinfo.Set.empty; print_spec <- false (* Are we printing ghost code? If yes, specifications are introduced by /@ and closed by @/. Not really tested currently, as this is not parseable yet.*) val mutable is_ghost = false method private current_kf = match self#current_function with | None -> assert false | Some vi -> Globals.Functions.get vi method private current_kinstr = match self#current_stmt with | None -> Kglobal | Some st -> Kstmt st method private current_sid = match self#current_stmt with | None -> assert false | Some st -> st.sid method private may_be_skipped s = super#may_be_skipped s && not (Annotations.has_code_annot s) method private pretty_funspec fmt kf = let spec = Annotations.funspec ~populate:false kf in if logic_printer_enabled && not (Cil.is_empty_funspec spec) then Format.fprintf fmt "@[/*@@ %a@ */@]@\n" self#funspec spec; method private has_annot = super#has_annot || match self#current_stmt with | None -> false | Some s -> Annotations.has_code_annot s method private inline_block ?has_annot blk = super#inline_block ?has_annot blk && (match blk.bstmts with | [] -> true | [ s ] -> not (Annotations.has_code_annot s && logic_printer_enabled) && (match s.skind with | Block blk -> self#inline_block blk | _ -> true) | _ :: _ -> false) method varinfo fmt v = super#varinfo fmt v; if Kernel.debug_atleast 4 then begin Format.fprintf fmt "/*vid:%d*/" v.vid; (match v.vlogic_var_assoc with None -> () | Some v -> Format.fprintf fmt "/*lvid:%d*/" v.lv_id); end method logic_var fmt v = super#logic_var fmt v; if Kernel.debug_atleast 4 then begin (match v.lv_origin with None -> () | Some v -> Format.fprintf fmt "/*vid:%d*/" v.vid); Format.fprintf fmt "/*lv_id:%d*/" v.lv_id end method vdecl fmt vi = Format.open_vbox 0; (try let kf = Globals.Functions.get vi in if not (Cil_datatype.Varinfo.Set.mem vi declared_globs) && print_spec then begin declared_globs <- Cil_datatype.Varinfo.Set.add vi declared_globs; (* pretty prints the spec, but not for built-ins*) if not (Cil.Builtin_functions.mem vi.vname) then self#pretty_funspec fmt kf end with Not_found -> ()); print_spec <- false; super#vdecl fmt vi; Format.close_box () method global fmt glob = if Kernel.PrintComments.get () then begin let comments = Globals.get_comments_global glob in Pretty_utils.pp_list ~sep:"@\n" ~suf:"@\n" (fun fmt s -> Format.fprintf fmt "/* %s */" s) fmt comments end; (* Out of tree global annotations are pretty printed before the first variable declaration of the first function definition. *) (match glob with | GVarDecl _ | GFun _ -> print_spec <- Ast.is_last_decl glob; | _ -> ()); super#global fmt glob method private begin_annotation fmt = if is_ghost then Format.fprintf fmt "/@@" else Format.fprintf fmt "/*@@" method private end_annotation fmt = if is_ghost then Format.fprintf fmt "@@/" else Format.fprintf fmt "*/" method private loop_annotations fmt annots = if annots <> [] then let annots = List.sort compare_annotations annots in Pretty_utils.pp_open_block fmt "%t " self#begin_annotation; Pretty_utils.pp_list ~sep:"@\n" self#code_annotation fmt annots; Pretty_utils.pp_close_block fmt "%t@\n" self#end_annotation; method private annotations fmt annots = let annots = List.sort compare_annotations annots in Pretty_utils.pp_list ~sep:"@\n" ~suf:"@]@\n" (fun fmt annot -> Pretty_utils.pp_open_block fmt "%t " self#begin_annotation; self#code_annotation fmt annot; Pretty_utils.pp_close_block fmt "%t" self#end_annotation) fmt annots method annotated_stmt next fmt s = (* To debug location setting: (let loc = fst (Cil_datatype.Stmt.loc s.skind) in Format.fprintf fmt "/*Loc=%s:%d*/" loc.Lexing.pos_fname loc.Lexing.pos_lnum); *) Format.pp_open_hvbox fmt 2; (* print the labels *) self#stmt_labels fmt s; Format.pp_open_hvbox fmt 0; (* print the Cabscond, if any *) Cabscond.pp_comment fmt s; (* JS TODO: should not depend on [Cabsbranches] *) !cabsbranches_pp_comment fmt s; if Kernel.PrintComments.get () then begin let comments = Globals.get_comments_stmt s in if comments <> [] then Pretty_utils.pp_list ~sep:"@\n" ~suf:"@]@\n" (fun fmt s -> Format.fprintf fmt "@[/* %s */@]" s) fmt comments end; if verbose then Format.fprintf fmt "@[/*sid:%d*/@]@ " s.sid ; (* print the annotations *) if logic_printer_enabled then begin let all_annot = List.sort Cil_datatype.Code_annotation.compare (Annotations.code_annot s) in let pGhost fmt s = let was_ghost = is_ghost in if not was_ghost && s.ghost then begin Pretty_utils.pp_open_block fmt "@[/*@@ ghost " ; is_ghost <- true end; self#stmtkind next fmt s.skind; if not was_ghost && s.ghost then begin Pretty_utils.pp_close_block fmt "@,*/@]"; is_ghost <- false; end in (match all_annot with | [] -> pGhost fmt s | [ a ] when Cil.is_skip s.skind && not s.ghost -> Format.fprintf fmt "@[@[/*@@@ %a@;<1 1>*/@]@ %a@]" self#code_annotation a (self#stmtkind next) s.skind; | _ -> let loop_annot, stmt_annot = List.partition Logic_utils.is_loop_annot all_annot in self#annotations fmt stmt_annot; self#loop_annotations fmt loop_annot; pGhost fmt s) end else self#stmtkind next fmt s.skind; Format.pp_close_box fmt (); Format.pp_close_box fmt () end (* class printer_with_annot *) include Printer_builder.Make(struct class printer = printer_with_annot end) (* initializing Cil_datatype's pretty printers *) let () = Cil_datatype.Constant.pretty_ref := pp_constant let () = Cil_datatype.Exp.pretty_ref := pp_exp let () = Cil_datatype.Varinfo.pretty_ref := pp_varinfo let () = Cil_datatype.Lval.pretty_ref := pp_lval let () = Cil_datatype.Offset.pretty_ref := pp_offset let () = Cil_datatype.pretty_typ_ref := pp_typ let () = Cil_datatype.Attribute.pretty_ref := pp_attribute let () = Cil_datatype.Stmt.pretty_ref := pp_stmt let () = Cil_datatype.Block.pretty_ref := pp_block let () = Cil_datatype.Instr.pretty_ref := pp_instr let () = Cil_datatype.Logic_var.pretty_ref := pp_logic_var let () = Cil_datatype.Model_info.pretty_ref := pp_model_info let () = Cil_datatype.pretty_logic_type_ref := pp_logic_type let () = Cil_datatype.Term.pretty_ref := pp_term let () = Cil_datatype.Code_annotation.pretty_ref := pp_code_annotation (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/printer/cil_descriptive_printer.ml0000644000175000017500000000643512155630231023522 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (** Like standard Cil printer, but instead of temporary variable names it prints the description that was provided when the temp was created. This is usually better for messages that are printed for end users, although you may want the temporary names for debugging. *) class descriptive_printer = object (self) inherit Cil_printer.extensible_printer () as super val mutable temps: (varinfo * string * string option) list = [] val mutable useTemps: bool = false method private pVarDescriptive fmt (vi: varinfo) = match vi.vdescr with | Some vd -> if vi.vdescrpure || not useTemps then Format.fprintf fmt "%s" vd else begin try let _, name, _ = List.find (fun (vi', _, _) -> vi == vi') temps in Format.fprintf fmt "%s" name with Not_found -> let name = "tmp" ^ string_of_int (List.length temps) in temps <- (vi, name, vi.vdescr) :: temps; Format.fprintf fmt "%s" name end | None -> super#varinfo fmt vi (* Only substitute temp vars that appear in expressions. (Other occurrences of lvalues are the left-hand sides of assignments, but we shouldn't substitute there since "foo(a,b) = foo(a,b)" would make no sense to the user.) *) method exp fmt e = match e.enode with | Lval (Var vi, o) | StartOf (Var vi, o) -> Format.fprintf fmt "%a%a" self#pVarDescriptive vi self#offset o | AddrOf (Var vi, o) -> (* No parens needed, since offsets have higher precedence than & *) Format.fprintf fmt "& %a%a" self#pVarDescriptive vi self#offset o | _ -> super#exp fmt e end include Printer_builder.Make(struct class printer () = descriptive_printer end) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/printer/printer_api.mli0000644000175000017500000004651612155630231021300 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Type of AST's extensible printers. @since Fluorine-20130401 *) open Cil_types (* ********************************************************************* *) (** {2 Class type for extensible printer} *) (* ********************************************************************* *) (** The class type that a printer must implement. *) class type extensible_printer_type = object (* ******************************************************************* *) (** {3 Useful functions for building pretty-printers} *) (* ******************************************************************* *) val mutable logic_printer_enabled : bool (** Local logical annotation (function specifications and code annotations are printed only if [logic_printer_enabled] is set to [true]. *) val mutable force_brace: bool (** If set to [true] (default is [false], some additional braces are printed. *) val mutable verbose: bool (** more info is displayed when on verbose mode. *) method reset: unit -> unit method private current_function: varinfo option (** @return the [varinfo] corresponding to the function being printed *) method private current_behavior: funbehavior option (** @return the [funbehavior] being pretty-printed. *) method private has_annot: bool (** [true] if [current_stmt] has some annotations attached to it. *) method private current_stmt: stmt option (** @return the [stmt] being printed *) method private may_be_skipped: stmt -> bool (** This is called to check that a given statement may be compacted with another one. For example this is called whenever a [while(1)] followed by a conditional [if (cond) break;] may be compacted into [while (cond)]. *) method private require_braces: ?has_annot:bool -> block -> bool (** @return [true] if the given block must be enclosed in a block. [has_annot] indicates if the stmt corresponding to the block may have annotations (default is [true]). @modify Fluorine-20130401 optional arguments has been modified. *) method private inline_block: ?has_annot:bool -> block -> bool (** @return [true] if the given block may be inlined in a single line. [has_annot] indicates if the stmt corresponding to the block may have annotations (default is [true]). @modify Fluorine-20130401 optional arguments has been modified. *) method private get_instr_terminator: unit -> string (** What terminator to print after an instruction. sometimes we want to print sequences of instructions separated by comma *) method private set_instr_terminator: string -> unit (* ******************************************************************* *) (** {3 Pretty-printing of C code} *) (* ******************************************************************* *) method location: Format.formatter -> location -> unit method constant: Format.formatter -> constant -> unit method varname: Format.formatter -> string -> unit (** Invoked each time an identifier name is to be printed. Allows for various manipulation of the name, such as unmangling. *) method vdecl: Format.formatter -> varinfo -> unit (** Invoked for each variable declaration. Note that variable declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo] in formals of function types, and the formals and locals for function definitions. *) method varinfo: Format.formatter -> varinfo -> unit (** Invoked on each variable use. *) method lval: Format.formatter -> lval -> unit (** Invoked on each lvalue occurence *) method field: Format.formatter -> fieldinfo -> unit method offset: Format.formatter -> offset -> unit (** Invoked on each offset occurence. The second argument is the base. *) method global: Format.formatter -> global -> unit (** Global (vars, types, etc.). This can be slow. *) method fieldinfo: Format.formatter -> fieldinfo -> unit (** A field declaration *) method storage: Format.formatter -> storage -> unit method ikind: Format.formatter -> ikind -> unit method fkind: Format.formatter -> fkind -> unit method typ: ?fundecl:varinfo -> (Format.formatter -> unit) option -> Format.formatter -> typ -> unit (** Use of some type in some declaration. [fundecl] is the name of the function which is declared with the corresponding type. The second argument is used to print the declared element, or is None if we are just printing a type with no name being declared. If [fundecl] is not None, second argument must also have a value. *) method attrparam: Format.formatter -> attrparam -> unit (** Attribute paramter *) method attribute: Format.formatter -> attribute -> bool (** Attribute. Also return an indication whether this attribute must be printed inside the __attribute__ list or not. *) method attributes: Format.formatter -> attributes -> unit (** Attribute lists *) method label: Format.formatter -> label -> unit (** Label *) method line_directive: ?forcefile:bool -> Format.formatter -> location -> unit (** Print a line-number. This is assumed to come always on an empty line. If the forcefile argument is present and is true then the file name will be printed always. Otherwise the file name is printed only if it is different from the last time time this function is called. The last file name is stored in a private field inside the cilPrinter object. *) method stmt_labels: Format.formatter -> stmt -> unit (** Print only the labels of the statement. Used by [annotated_stmt]. *) method annotated_stmt: stmt -> Format.formatter -> stmt -> unit (** Print an annotated statement. The code to be printed is given in the last {!Cil_types.stmt} argument. The initial {!Cil_types.stmt} argument records the statement which follows the one being printed. *) method stmtkind: stmt -> Format.formatter -> stmtkind -> unit (** Print a statement kind. The code to be printed is given in the {!Cil_types.stmtkind} argument. The initial {!Cil_types.stmt} argument records the statement which follows the one being printed; {!defaultCilPrinterClass} uses this information to prettify statement printing in certain special cases. The boolean flag indicated whether the statement has labels (which have already been printed) *) method instr: Format.formatter -> instr -> unit (** Invoked on each instruction occurrence. *) method stmt: Format.formatter -> stmt -> unit (** Control-flow statement. [annot] is [true] iff the printer prints the annotations of the stmt. *) method next_stmt : stmt -> Format.formatter -> stmt -> unit method block: ?braces: bool -> Format.formatter -> block -> unit (** Prints a block. Enclose the block braces '\{' and '\}' according to the optional argument. If it is not set, braces are put only when required. @modify Fluorine-20130401 optional arguments has been modified. *) method exp: Format.formatter -> exp -> unit (** Print expressions *) method unop: Format.formatter -> unop -> unit method binop: Format.formatter -> binop -> unit method init: Format.formatter -> init -> unit (** Print initializers. This can be slow. *) method file: Format.formatter -> file -> unit (* ******************************************************************* *) (** {3 Pretty-printing of annotations} *) (* ******************************************************************* *) method logic_constant: Format.formatter -> logic_constant -> unit method logic_type: (Format.formatter -> unit) option -> Format.formatter -> logic_type -> unit method logic_type_def: Format.formatter -> logic_type_def -> unit method model_info: Format.formatter -> model_info -> unit method term_binop: Format.formatter -> binop -> unit method relation: Format.formatter -> relation -> unit method identified_term: Format.formatter -> identified_term -> unit method term: Format.formatter -> term -> unit method term_node: Format.formatter -> term -> unit method term_lval: Format.formatter -> term_lval -> unit method model_field: Format.formatter -> model_info -> unit method term_offset: Format.formatter -> term_offset -> unit method logic_label: Format.formatter -> logic_label -> unit method logic_info: Format.formatter -> logic_info -> unit method logic_var: Format.formatter -> logic_var -> unit method quantifiers: Format.formatter -> quantifiers -> unit method predicate: Format.formatter -> predicate -> unit method predicate_named: Format.formatter -> predicate named -> unit method identified_predicate: Format.formatter -> identified_predicate -> unit method behavior: Format.formatter -> funbehavior -> unit method requires: Format.formatter -> identified_predicate -> unit method complete_behaviors: Format.formatter -> string list -> unit method disjoint_behaviors: Format.formatter -> string list -> unit method terminates: Format.formatter -> identified_predicate -> unit method post_cond: Format.formatter -> (termination_kind * identified_predicate) -> unit (** pretty prints a post condition according to the exit kind it represents @modify Boron-20100401 replaces [pEnsures] *) method assumes: Format.formatter -> identified_predicate -> unit method funspec: Format.formatter -> funspec -> unit method assigns: string -> Format.formatter -> identified_term assigns -> unit (** first parameter is the introducing keyword (e.g. loop_assigns or assigns). *) method allocation: isloop:bool -> Format.formatter -> identified_term allocation -> unit (** first parameter is the introducing keyword (e.g. loop_allocates, loop_frees, allocates or free) @since Oxygen-20120901. *) method from: string -> Format.formatter -> identified_term from -> unit (** prints an assignment with its dependencies. *) method code_annotation: Format.formatter -> code_annotation -> unit method global_annotation: Format.formatter -> global_annotation -> unit method decreases: Format.formatter -> term variant -> unit method variant: Format.formatter -> term variant -> unit (* ******************************************************************* *) (** {3 Modifying pretty-printer behavior} *) (* ******************************************************************* *) method without_annot: 'a. (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit (** [self#without_annot printer fmt x] pretty prints [x] by using [printer], without pretty-printing its function contracts and code annotations. *) method force_brace: 'a. (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit (** [self#force_brace printer fmt x] pretty prints [x] by using [printer], but add some extra braces '\{' and '\}' which are hidden by default. *) end (* ********************************************************************* *) (** {2 Types for customizing pretty printers} *) (* ********************************************************************* *) (** Styles of printing line directives *) type line_directive_style = | Line_comment (** Before every element, print the line number in comments. This is ignored by processing tools (thus errors are reproted in the CIL output), but useful for visual inspection *) | Line_comment_sparse (** Like LineComment but only print a line directive for a new source line *) | Line_preprocessor_input (** Use #line directives *) | Line_preprocessor_output (** Use # nnn directives (in gcc mode) *) type state = { (** How to print line directives *) mutable line_directive_style: line_directive_style option; (** Whether we print something that will only be used as input to Cil's parser. In that case we are a bit more liberal in what we print. *) mutable print_cil_input: bool; (** Whether to print the CIL as they are, without trying to be smart and print nicer code. Normally this is false, in which case the pretty printer will turn the while(1) loops of CIL into nicer loops, will not print empty "else" blocks, etc. These is one case howewer in which if you turn this on you will get code that does not compile: if you use varargs the __builtin_va_arg function will be printed in its internal form. *) mutable print_cil_as_is: bool; (** The length used when wrapping output lines. Setting this variable to a large integer will prevent wrapping and make #line directives more accurate. *) mutable line_length: int; (** Emit warnings when truncating integer constants (default true) *) mutable warn_truncate: bool } (* ********************************************************************* *) (** {2 Functions for pretty printing} *) (* ********************************************************************* *) module type S = sig (* ********************************************************************* *) (** {3 Printer for C constructs} *) (* ********************************************************************* *) val pp_location: Format.formatter -> location -> unit val pp_constant: Format.formatter -> constant -> unit val pp_storage: Format.formatter -> storage -> unit val pp_ikind: Format.formatter -> ikind -> unit val pp_fkind: Format.formatter -> fkind -> unit val pp_typ: Format.formatter -> typ -> unit val pp_exp: Format.formatter -> exp -> unit (** @plugin development guide *) val pp_varinfo: Format.formatter -> varinfo -> unit (** @plugin development guide *) val pp_lval: Format.formatter -> lval -> unit val pp_field: Format.formatter -> fieldinfo -> unit val pp_offset: Format.formatter -> offset -> unit val pp_init: Format.formatter -> init -> unit val pp_binop: Format.formatter -> binop -> unit val pp_unop: Format.formatter -> unop -> unit val pp_attribute: Format.formatter -> attribute -> unit val pp_attrparam: Format.formatter -> attrparam -> unit val pp_attributes: Format.formatter -> attributes -> unit val pp_instr: Format.formatter -> instr -> unit (** @plugin development guide *) val pp_label: Format.formatter -> label -> unit val pp_stmt: Format.formatter -> stmt -> unit (** @plugin development guide *) val pp_block: Format.formatter -> block -> unit val pp_global: Format.formatter -> global -> unit val pp_file: Format.formatter -> file -> unit (* ********************************************************************* *) (** {3 Printer for ACSL constructs} *) (* ********************************************************************* *) val pp_relation: Format.formatter -> relation -> unit val pp_model_info: Format.formatter -> model_info -> unit (** @since Oxygen-20120901 *) val pp_term_lval: Format.formatter -> term_lval -> unit val pp_logic_var: Format.formatter -> logic_var -> unit val pp_logic_type: Format.formatter -> logic_type -> unit val pp_identified_term: Format.formatter -> identified_term -> unit val pp_term: Format.formatter -> term -> unit val pp_model_field: Format.formatter -> model_info -> unit val pp_term_offset: Format.formatter -> term_offset -> unit val pp_logic_label: Format.formatter -> logic_label -> unit val pp_predicate: Format.formatter -> predicate -> unit val pp_predicate_named: Format.formatter -> predicate named -> unit val pp_identified_predicate: Format.formatter -> identified_predicate -> unit val pp_code_annotation: Format.formatter -> code_annotation -> unit val pp_funspec: Format.formatter -> funspec -> unit val pp_behavior: Format.formatter -> funbehavior -> unit val pp_global_annotation: Format.formatter -> global_annotation -> unit val pp_decreases: Format.formatter -> term variant -> unit val pp_variant: Format.formatter -> term variant -> unit val pp_from: Format.formatter -> identified_term from -> unit val pp_assigns: Format.formatter -> identified_term assigns -> unit val pp_allocation: Format.formatter -> identified_term allocation -> unit (** @since Oxygen-20120901 *) val pp_loop_from: Format.formatter -> identified_term from -> unit val pp_loop_assigns: Format.formatter -> identified_term assigns -> unit val pp_loop_allocation: Format.formatter -> identified_term allocation -> unit (** @since Oxygen-20120901 *) val pp_post_cond: Format.formatter -> (termination_kind * identified_predicate) -> unit (* ********************************************************************* *) (** {3 General form of printers} *) (* ********************************************************************* *) val pp_full_assigns: string -> Format.formatter -> identified_term assigns -> unit (** first parameter is the introducing keyword (e.g. loop_assigns or assigns). *) val without_annot: (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit (** [without_annot printer fmt x] pretty prints [x] by using [printer], without pretty-printing its function contracts and code annotations. *) val force_brace: (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit (** [self#force_brace printer fmt x] pretty prints [x] by using [printer], but add some extra braces '\{' and '\}' which are hidden by default. *) (* ********************************************************************* *) (** {3 Extensible printer} *) (* ********************************************************************* *) class extensible_printer: unit -> extensible_printer_type (** Extend this class if you want to modify the default behavior of the printer. *) val change_printer: (unit -> extensible_printer) -> unit (** [change_printer extension] let the pp_* function use [extension] as printer *) end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/printer/printer_builder.ml0000644000175000017500000001206212155630231021771 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module Make (P: sig class printer: unit -> Printer_api.extensible_printer_type end) = struct class extensible_printer = P.printer let mk_printer = ref (new extensible_printer) let printer_ref = ref None let printer () = match !printer_ref with | None -> let p = !mk_printer () in printer_ref := Some p; p | Some p -> p#reset (); p let change_printer new_printer = mk_printer := new_printer; printer_ref := None let without_annot f fmt x = (printer ())#without_annot f fmt x let force_brace f fmt x = (printer ())#force_brace f fmt x (* eta-expansion required for applying side-effect of [printer ()] at the right time *) let pp_location fmt x = (printer ())#location fmt x let pp_constant fmt x = (printer ())#constant fmt x let pp_ikind fmt x = (printer ())#ikind fmt x let pp_fkind fmt x = (printer ())#fkind fmt x let pp_storage fmt x = (printer ())#storage fmt x let pp_typ fmt x = (printer ())#typ None fmt x let pp_exp fmt x = (printer ())#exp fmt x let pp_varinfo fmt x = (printer ())#varinfo fmt x let pp_lval fmt x = (printer ())#lval fmt x let pp_field fmt x = (printer())#field fmt x let pp_offset fmt x = (printer ())#offset fmt x let pp_init fmt x = (printer ())#init fmt x let pp_binop fmt x = (printer ())#binop fmt x let pp_unop fmt x = (printer ())#unop fmt x let pp_attribute fmt x = ignore ((printer ())#attribute fmt x) let pp_attrparam fmt x = (printer ())#attrparam fmt x let pp_attributes fmt x = (printer ())#attributes fmt x let pp_instr fmt x = (printer ())#instr fmt x let pp_label fmt x = (printer ())#label fmt x let pp_logic_label fmt x = (printer ())#logic_label fmt x let pp_stmt fmt x = (printer ())#stmt fmt x let pp_block fmt x = (printer ())#block fmt x let pp_global fmt x = (printer ())#global fmt x let pp_file fmt x = (printer ())#file fmt x let pp_relation fmt x = (printer ())#relation fmt x let pp_model_info fmt x = (printer ())#model_info fmt x let pp_term_lval fmt x = (printer ())#term_lval fmt x let pp_logic_var fmt x = (printer ())#logic_var fmt x let pp_logic_type fmt x = (printer ())#logic_type None fmt x let pp_identified_term fmt x = (printer ())#identified_term fmt x let pp_term fmt x = (printer ())#term fmt x let pp_model_field fmt x = (printer())#model_field fmt x let pp_term_offset fmt x = (printer ())#term_offset fmt x let pp_predicate fmt x = (printer ())#predicate fmt x let pp_predicate_named fmt x = (printer ())#predicate_named fmt x let pp_identified_predicate fmt x = (printer ())#identified_predicate fmt x let pp_code_annotation fmt x = (printer ())#code_annotation fmt x let pp_funspec fmt x = (printer ())#funspec fmt x let pp_behavior fmt x = (printer ())#behavior fmt x let pp_global_annotation fmt x = (printer ())#global_annotation fmt x let pp_decreases fmt x = (printer ())#decreases fmt x let pp_variant fmt x = (printer ())#variant fmt x let pp_from fmt x = (printer ())#from "assigns" fmt x let pp_full_assigns fmt x = (printer ())#assigns fmt x let pp_assigns = pp_full_assigns "assigns" let pp_allocation fmt x = (printer ())#allocation ~isloop:false fmt x let pp_loop_from fmt x = (printer ())#from "loop assigns" fmt x let pp_loop_assigns fmt x = (printer ())#assigns "loop assigns" fmt x let pp_loop_allocation fmt x = (printer ())#allocation ~isloop:true fmt x let pp_post_cond fmt x = (printer ())#post_cond fmt x end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/printer/printer_builder.mli0000644000175000017500000000352712155630231022150 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Build a full pretty-printer from a pretty-printing class. @since Fluorine-20130401 *) module Make (P: sig class printer: unit -> Printer_api.extensible_printer_type end): Printer_api.S (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/misc/0000755000175000017500000000000012155634040015517 5ustar mehdimehdiframa-c-Fluorine-20130601/src/misc/bit_utils.ml0000644000175000017500000004131212155630235020052 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* $id$ *) (** Some utilities *) open Cil_types open Cil open Abstract_interp (** [sizeof(char)] in bits *) let sizeofchar () = Int.of_int (bitsSizeOf charType) (** [sizeof(char* )] in bits *) let sizeofpointer () = bitsSizeOf theMachine.upointType let max_bit_size () = Int.mul (sizeofchar()) (Int.shift_left Int.one (Int.of_int (sizeofpointer()))) let max_bit_address () = Int.pred (max_bit_size()) let warn_if_zero ty r = if r = 0 then Kernel.abort "size of '%a' is zero. Check target code or Frama-C -machdep option." Printer.pp_typ 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 _ -> Kernel.warning ~current:true ~once:true "using size of 'void'" | _ -> ()) ; try Int_Base.inject (Int.of_int (bitsSizeOf ty)) with SizeOfError _ -> Int_Base.top (** [osizeof ty] is the size of [ty] in bytes. This function may return [Int_Base.top]. *) let osizeof ty = (match ty with | 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)) with SizeOfError _ -> Int_Base.top exception Neither_Int_Nor_Enum_Nor_Pointer (** May raise [Neither_Int_Nor_Enum_Nor_Pointer] if the sign of the type is not meaningful. [true] means that the type is signed. *) let is_signed_int_enum_pointer ty = match unrollType ty with | TInt (k,_) | TEnum ({ekind=k},_) -> Cil.isSigned k | TPtr _ -> false | TFloat _ | TFun _ | TBuiltin_va_list _ | TVoid _ | TArray _ | TComp _ | TNamed _ -> raise Neither_Int_Nor_Enum_Nor_Pointer (** Returns the sign of type of the [lval]. [true] means that the type is signed. *) let signof_typeof_lval lv = let typ = Cil.typeOfLval lv in is_signed_int_enum_pointer typ (** Returns the size of a the type of the variable in bits. *) let sizeof_vid v = sizeof v.vtype (** Returns the size of a the type of the variable in bits. *) let sizeof_lval lv = let typ = Cil.typeOfLval lv in let typ = unrollType typ in if isIntegralType typ then (* We might be a bitfield *) let rec get_size off = match off with | NoOffset | Index (_,NoOffset) -> sizeof typ | Field (f,NoOffset) -> (match f.fbitfield with | None -> sizeof typ | Some i -> Int_Base.inject (Int.of_int i)) | Field (_,f) | Index(_,f) -> get_size f in get_size (snd lv) else sizeof typ (** Returns the size of the type pointed by a pointer type in bits. Never call it on a non pointer type. *) let sizeof_pointed typ = match unrollType typ with | TPtr (typ,_) -> sizeof typ | TArray(typ,_,_,_) -> sizeof typ | _ -> Kernel.abort "TYPE IS: %a (unrolled as %a)" Printer.pp_typ typ Printer.pp_typ (unrollType typ) (** Returns the size of the type pointed by a pointer type in bytes. Never call it on a non pointer type. *) let osizeof_pointed typ = match unrollType typ with | TPtr (typ,_) -> osizeof typ | TArray(typ,_,_,_) -> osizeof typ | _ -> assert false (* Format.printf "TYPE IS: %a\n" Printer.pp_typ typ; Int_Base.top*) (** Returns the size of the type pointed by a pointer type of the [lval] in bits. Never call it on a non pointer type [lval]. *) let sizeof_pointed_lval lv = sizeof_pointed (Cil.typeOfLval lv) (** Set of integers *) module IntSet = Set.Make(Int) (* -------------------------------------------------------------------------- *) (* --- Pretty Printing --- *) (* -------------------------------------------------------------------------- *) type types = | NoneYet | SomeType of typ | Mixed let update_types types t = match types with | NoneYet -> SomeType t | Mixed -> Mixed | SomeType t' -> if Cil_datatype.Typ.equal t t' then types else Mixed type ppenv = { fmt : Format.formatter ; use_align : bool ; rh_size : Int.t ; mutable misaligned : bool ; mutable types: types ; } type bfinfo = Other | Bitfield of int64 type fieldpart = | NamedField of string * bfinfo * typ * Int.t * Int.t * Int.t (* name, parameters to pretty_bits_internal for the field *) | RawField of char * Int.t * Int.t (* parameters for raw_bits of the raw field *) type arraypart = | ArrayPart of Int.t * Int.t * typ * Int.t * Int.t * Int.t (* start index, stop index, typ of element , align , start, stop *) let rec pretty_bits_internal env bfinfo typ ~align ~start ~stop = assert ( Int.le Int.zero align && Int.lt align env.rh_size); assert (if (Int.lt start Int.zero || Int.lt stop Int.zero) then (Format.printf "start: %a stop: %a@\n" Int.pretty start Int.pretty stop; false) else true); let update_types typ = env.types <- update_types env.types typ in let req_size = Int.length start stop in (* Format.printf "align:%Ld size: %Ld start:%Ld stop:%Ld req_size:%Ld@\n" align size start stop req_size;*) 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))) in Format.fprintf env.fmt "[%s%t]%s" (if Kernel.debug_atleast 1 then String.make 1 c else "") (fun fmt -> if Int.equal stop (max_bit_address ()) then if Int.equal start Int.zero then Format.pp_print_string fmt "..." else Format.fprintf fmt "bits %a to ..." Int.pretty start else Format.fprintf fmt "bits %a to %a" Int.pretty start Int.pretty stop ) (if cond then (env.misaligned <- true ; "#") else "") in assert (if (Int.le req_size Int.zero || Int.lt start Int.zero || Int.lt stop Int.zero) then (Format.printf "req_s: %a start: %a stop: %a@\n" Int.pretty req_size Int.pretty start Int.pretty stop; false) else true); match (unrollType typ) with | TInt (_ , _) | TPtr (_, _) | TEnum (_, _) | TFloat (_, _) | TVoid _ | TBuiltin_va_list _ | TNamed _ | TFun (_, _, _, _) as typ -> let size = match bfinfo with | Other -> Int.of_int (bitsSizeOf typ) | Bitfield i -> Int.of_int64 i in (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 update_types typ else (env.types <- Mixed; env.misaligned <- true ; Format.pp_print_char env.fmt '#')) else ( env.types <- Mixed; raw_bits 'b' start stop) ) | TComp (compinfo, _, _) as typ -> begin let size = Int.of_int (try bitsSizeOf typ with SizeOfError _ -> 0) in if (not env.use_align) && Int.compare req_size size = 0 then update_types typ (* do not print sub-fields if the size is exactly the right one and the alignement is not important *) else let full_fields_to_print = List.fold_left (fun acc field -> let current_offset = Field (field,NoOffset) in let start_o,width_o = bitsOffset typ current_offset in let start_o,width_o = Int.of_int start_o, Int.of_int width_o in let new_start = if compinfo.cstruct then Int.max Int.zero (Int.sub start start_o) else start in let new_stop = if compinfo.cstruct then Int.min (Int.sub stop start_o) (Int.pred width_o) else stop in let new_bfinfo = match field.fbitfield with | 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 if Int.le new_start new_stop then let name = Pretty_utils.sfprintf "%a" Printer.pp_field field in NamedField( name , new_bfinfo , field.ftype , new_align , new_start , new_stop ) :: acc else acc) [] compinfo.cfields in (** find non covered intervals in structs *) let non_covered,succ_last = if compinfo.cstruct then List.fold_left (fun ((s,last_field_offset) as acc) field -> let current_offset = Field (field,NoOffset) in let start_o,width_o = bitsOffset typ current_offset in let start_o,width_o = Int.of_int start_o, Int.of_int width_o in let succ_stop_o = Int.add start_o width_o in if Int.gt start_o stop then acc 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, succ_stop_o) else (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 else non_covered in let pretty_one_field = function | NamedField(name,bf,ftyp,align,start,stop) -> Format.fprintf env.fmt ".%s" name ; pretty_bits_internal env bf ftyp ~align ~start ~stop | RawField(c,start,stop) -> env.types <- Mixed; Format.pp_print_char env.fmt '.' ; raw_bits c start stop in let rec pretty_all_fields = function | [] -> () | [f] -> pretty_one_field f | f::fs -> pretty_all_fields fs ; Format.pp_print_string env.fmt "; "; pretty_one_field f ; 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, _, _, _) -> let size = try Int.of_int (bitsSizeOf typ) with Cil.SizeOfError _ -> Int.zero in if Int.is_zero size then raw_bits 'z' start stop else let start_case = Int.pos_div start size in let stop_case = Int.pos_div stop size in let rem_start_size = Int.pos_rem start size in let rem_stop_size = Int.pos_rem stop size in if Int.equal start_case stop_case then (** part of one element *) let new_align = Int.pos_rem (Int.sub align (Int.mul start_case size)) env.rh_size in Format.fprintf env.fmt "[%a]" Int.pretty start_case ; pretty_bits_internal env Other typ ~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 let pred_size = Int.pred size in let start_full_case = if Int.is_zero rem_start_size then start_case else Int.succ start_case in let stop_full_case = if Int.equal rem_stop_size pred_size then stop_case else Int.pred stop_case in let first_part = if Int.is_zero rem_start_size then [] else [ArrayPart(start_case,start_case, 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)] in let last_part = if Int.equal rem_stop_size pred_size then [] else [ArrayPart(stop_case,stop_case, 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] -> do_part p | 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 '}' ; else (env.types <- Mixed; raw_bits 'a' start stop) let pretty_bits typ ~use_align ~align ~rh_size ~start ~stop fmt = (* It is simpler to perform all computation using an absolute offset: Cil easily gives offset information in terms of offset since the start, but not easily the offset between two fields (with padding) *) let align = Int.pos_rem (Rel.add_abs start align) rh_size in assert (Int.le Int.zero align && Int.lt align rh_size); if Int.lt start Int.zero then (Format.fprintf fmt "[%sbits %a to %a]#(negative offsets)" (if Kernel.debug_atleast 1 then "?" else "") Int.pretty start Int.pretty stop ; true, None) else let env = { fmt = fmt ; rh_size = rh_size ; use_align = use_align ; misaligned = false ; types = NoneYet ; } in pretty_bits_internal env Other typ ~align ~start ~stop ; env.misaligned, (match env.types with | Mixed | NoneYet -> None | SomeType t -> Some t) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/misc/service_graph.mli0000644000175000017500000000767312155630235021062 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Compute services from a callgraph. *) val frama_c_display: bool -> unit (** must be set to [false] before output the graph in dot format and must be set to [true] in order to display the graph in the Frama-C GUI. @since Oxygen-20120901 *) (** Generic functor implementing the services algorithm according to a graph implementation. *) module Make (G: sig type t module V: sig (** @modify Oxygen-20120901 require [compare] *) include Graph.Sig.COMPARABLE val id: t -> int (** 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 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 val iter_pred : (V.t -> unit) -> t -> V.t -> unit val fold_pred : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a val datatype_name: string end) : sig type vertex = private { node: G.V.t; mutable is_root: bool; mutable root: vertex } type edge = private Inter_services | Inter_functions | Both module CallG: sig include Graph.Sig.G with type V.t = vertex and type E.label = edge module Datatype: Datatype.S with type t = t end 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 option (** [compute] must be called before @since Carbon-20101201 @modify Nitrogen-20111001 return an option type *) module TP: Graph.Graphviz.GraphWithDotAttrs with type t = CallG.t and type V.t = vertex and type E.t = CallG.E.t (** @since Beryllium-20090902 *) (* (** Graph of services *) module SS: Set.S with type elt = G.V.t type service_vertex = private { service: int; mutable root: G.V.t; mutable nodes: SS.t } (** @since Beryllium-20090901 *) (** @since Beryllium-20090901 *) module SG : sig include Graph.Sig.G with type V.t = service_vertex type tt = t module Datatype: Project.Datatype.S with type t = tt end val compute_services: CallG.t -> SG.t (** @since Beryllium-20090901 *) val output_services: out_channel -> SG.t -> unit (** @since Beryllium-20090901 *) *) end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/misc/filter.mli0000644000175000017500000001412612155630235017515 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (** [Filter] helps to build a new [cilfile] from an old one by removing some of * its elements. One can even build several functions from a source function * by specifying different names for each of them. * *) (** Signature of a module that decides which element of a function * have to be visible or not *) module type RemoveInfo = sig (** exception that fun_assign_visible should raise to indicate that the corresponding assigns clause should be erased entirely *) exception EraseAssigns (** exception that fun_frees_visible or fun_allocates_visible should raise to indicate that the corresponding allocation clause should be erased entirely *) exception EraseAllocation (** some type for the whole project information *) type proj (** some type for a function information *) type fct (** 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 : proj -> kernel_function -> 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]. * It is the responsibility of the user to given different names to different * function. *) val fct_name : varinfo -> fct -> string (** tells if the n-th formal parameter is visible. *) val param_visible : fct -> int -> bool (** tells if the body of a function definition is visible. * True is most cases, but can be defined to be false when we want to export * only the declaration of a function instead of its definition *) val body_visible : fct -> bool (** tells if the local variable is visible. *) val loc_var_visible : fct -> varinfo -> bool (** tells if the statement is visible. *) val inst_visible : fct -> stmt -> bool (** tells if the label is visible. *) val label_visible : fct -> stmt -> label -> bool (** tells if the annotation, attached to the given statement is visible. *) val annotation_visible: fct -> stmt -> code_annotation -> bool val fun_precond_visible : fct -> predicate -> bool val fun_postcond_visible : fct -> predicate -> bool val fun_variant_visible : fct -> term -> bool val fun_frees_visible : fct -> identified_term -> bool val fun_allocates_visible : fct -> identified_term -> bool val fun_assign_visible : fct -> identified_term from -> bool (** 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 *) val fun_deps_visible : fct -> identified_term -> bool (** true if the corresponding functional dependency is visible. *) (** [called_info] will be called only if the call statement is visible. * If it returns [None], the source call will be visible, * else it will use the returned [fct] to know if the return value and the * arguments are visible. * The input [fct] parameter is the one of the caller function. * *) val called_info : proj * fct -> stmt -> (kernel_function * fct) option (** tells if the lvalue of the call has to be visible *) val res_call_visible : fct -> stmt -> bool (** tells if the function returns something or if the result is [void]. * Notice that if this function returns [true] the function will have the same * return type than the original function. So, if it was already [void], it * makes no difference if this function returns true or false. * * - For a defined function, this should give the same result than * [inst_visible fct_info (Kernel_function.find_return kf)]. * - [res_call_visible] must return [false] * if [result_visible] returns false on the called function. *) val result_visible : kernel_function -> fct -> bool (** [cond_edge_visible f s] emplies that [s] is an 'if' in [f]. The first returned boolean indicates that the 'then' edge is useful, the second one the 'else' is. Setting one or both to true will lead to the simplification in the 'if'. *) val cond_edge_visible: fct -> stmt -> bool * bool end (** Given a module that match the module type described above, * [F.build_cil_file] initializes a new project containing the slices *) module F (Info : RemoveInfo) : sig val build_cil_file : string -> Info.proj -> Project.t end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/misc/service_graph.ml0000644000175000017500000002503612155630235020702 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let inter_services_ref = ref false let frama_c_display b = inter_services_ref := b module Make (G: sig type t module V: sig include Graph.Sig.COMPARABLE val id: t -> int val name: t -> string val attributes: t -> Graph.Graphviz.DotAttributes.vertex list 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 val iter_pred : (V.t -> unit) -> t -> V.t -> unit val fold_pred : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a val datatype_name: string end) = struct type vertex = { node: G.V.t; mutable is_root: bool; mutable root: vertex } type edge = Inter_services | Inter_functions | Both module Vertex = struct type t = vertex let id v = (G.V.id v.node) let compare v1 v2 = Datatype.Int.compare (id v1) (id v2) let equal v1 v2 = (id v1) = (id v2) let hash = id end module Edge = struct type t = edge let default = Inter_functions let compare : t -> t -> _ = Extlib.compare_basic end module CallG = struct module M = Graph.Imperative.Digraph.ConcreteLabeled(Vertex)(Edge) 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) 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) end else add_edge_e g (E.create src l dst) end type incomming_service = | Fresh_if_unchanged | Unknown_cycle | To_be_confirmed of vertex | Final of vertex type service = Maybe_fresh of vertex | In_service of vertex module Vertices = struct module H = Hashtbl.Make(G.V) let vertices : (vertex * service) H.t = H.create 7 let find = H.find vertices let add = H.add vertices let replace = H.replace vertices let clear () = H.clear vertices end let edge_invariant src dst = function | Inter_functions -> if not (Vertex.equal src.root dst.root || dst.is_root) then Kernel.failure "Correctness bug when computing services.\n\ PLEASE REPORT AS MAJOR BUG on http://bts.frama-c.com with the following info.\n\ 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 | Inter_services | Both -> if not (src.is_root && dst.is_root) then Kernel.failure "Correctness bug when computing services.\n\ PLEASE REPORT AS MAJOR BUG on http://bts.frama-c.com with the following info.\n\ Src root:%s in %s (is_root:%b) Dst:%s in %s (is_root:%b) [2d case]" (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 let check_invariant callg = CallG.iter_edges_e (fun e -> edge_invariant (CallG.E.src e) (CallG.E.dst e) (CallG.E.label e)) callg let mem initial_roots node = Datatype.String.Set.mem (G.V.name node) initial_roots (* [merge_service] is not symmetric *) exception Cannot_merge let merge_service s1 s2 = match s1, s2 with | Fresh_if_unchanged, In_service v2 -> Final v2 | Unknown_cycle, In_service v2 -> To_be_confirmed v2 | (Fresh_if_unchanged | Unknown_cycle), Maybe_fresh v2 -> To_be_confirmed v2 | (To_be_confirmed v1 | Final v1), In_service v2 when Vertex.equal v1 v2 -> s1 | (To_be_confirmed v1 | Final v1), Maybe_fresh 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 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 | Unknown_cycle -> 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 (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 | Unknown_cycle | Final _ -> In_service v.root | To_be_confirmed root -> Maybe_fresh root in Vertices.add node (v, s); CallG.add_vertex callg v in if mem initial_roots node then 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 -> (* cycle *) match acc with | Fresh_if_unchanged | Unknown_cycle -> Unknown_cycle | To_be_confirmed v | Final v -> To_be_confirmed v) 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 let update_vertex g node = try let v, s = Vertices.find node in 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; Vertices.replace node (v, In_service v); with Not_found -> assert false let add_edges g callg = let find node = try fst (Vertices.find node) with Not_found -> assert false 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) g let compute g initial_roots = entry_point_ref := None; let module Go = Graph.Topological.Make(G) in let callg = CallG.create () in Go.iter (make_vertex g callg initial_roots) g; Go.iter (update_vertex g) g; add_edges g callg; check_invariant callg; Vertices.clear (); callg let entry_point () = !entry_point_ref (* *********************************************************************** *) (* Pretty-print *) (* *********************************************************************** *) module TP = struct include CallG let root_id v = G.V.id v.root.node let graph_attributes _ = [ `Ratio (`Float 0.5) ] let vertex_name s = Format.sprintf "\"UV %s (%d)\"" (G.V.name s.node) (G.V.id s.node) let vertex_attributes s = let attr = `Label (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 let default_vertex_attributes _ = [] let edge_attributes e = let color e = let sr = root_id (CallG.E.src e) in [ `Color (Extlib.number_to_color sr) ] in if !inter_services_ref then color e else match CallG.E.label e with | Inter_services -> [ `Style `Invis ] | Inter_functions | Both -> color e let default_edge_attributes _ = [] let get_subgraph v = let id = root_id v in let cs = string_of_int id in Some { Graph.Graphviz.DotAttributes.sg_name = cs; sg_attributes = [ `Label ("S " ^ cs); `Color (Extlib.number_to_color id); `Style `Bold ] } end include Graph.Graphviz.Dot(TP) end (* functor Service *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/misc/bit_utils.mli0000644000175000017500000000733612155630235020233 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Some bit manipulations. *) open Cil_types val sizeofchar: unit -> Integer.t (** [sizeof(char)] in bits *) val sizeofpointer: unit -> int (** [sizeof(char* )] in bits *) val sizeof: typ -> Int_Base.t (** [sizeof ty] is the size of [ty] in bits. This function may return [Int_Base.top]. *) 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. @raise Neither_Int_Nor_Enum_Nor_Pointer if the sign of the type is not meaningful. *) val signof_typeof_lval: lval -> bool (** @return the sign of type of the [lval]. [true] means that the type is signed. *) val sizeof_vid: varinfo -> Int_Base.t (** @return the size of the type of the variable in bits. *) val sizeof_lval: lval -> Int_Base.t (** @return the size of the type of the left value in bits. *) val sizeof_pointed: typ -> Int_Base.t (** @return the size of the type pointed by a pointer or array type in bits. Never call it on a non pointer or non array type . *) val osizeof_pointed: typ -> Int_Base.t (** @return the size of the type pointed by a pointer or array type in bytes. Never call it on a non pointer or array type. *) val sizeof_pointed_lval: lval -> Int_Base.t (** @return the size of the type pointed by a pointer type of the [lval] in bits. Never call it on a non pointer type [lval]. *) val max_bit_address : unit -> Abstract_interp.Int.t (** @return the maximal possible offset in bits of a memory base. *) val max_bit_size : unit -> Abstract_interp.Int.t (** @return the maximal possible size in bits of a memory base. *) (** {2 Pretty printing} *) val pretty_bits: typ -> use_align:bool -> align:Abstract_interp.Rel.t -> rh_size:Integer.t -> start:Integer.t -> stop:Integer.t -> Format.formatter -> bool * typ option (** Pretty prints a range of bits in a type for the user. Tries to find field names and array indexes, whenever possible. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/misc/subst.mli0000644000175000017500000000466712155630235017401 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Substitution of varinfos by exps. @deprecated Carbon-20101201 *) open Cil_types type t (** Type of the substitution. *) val empty: t (** The empty substitution. *) val add: varinfo -> exp -> t -> t (** Add a new couple to the substitution. *) val remove: varinfo -> t -> t (** Do not substitute the varinfo anymore. *) 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 is &b by default and &y if trans is false. The returned boolean flag is true is a substitution occured. *) val lval: ?trans:bool -> lval -> t -> exp * bool (** Apply the substitution to a lvalue. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/misc/subst.ml0000644000175000017500000000462512155630235017222 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 module M = Cil_datatype.Varinfo.Map type t = exp M.t let empty = M.empty let add = M.add let remove = M.remove let expr ?(trans=true) e subst = let modified = ref false in let rec expr e = let visitor = object 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) | _ -> DoChildren end in visitCilExpr visitor e in let e = expr e in e, !modified let lval ?trans x = expr ?trans (new_exp ~loc:Cil_datatype.Location.unknown (Lval x)) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/misc/filter.ml0000644000175000017500000010665112155630235017351 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Cil_types module FC_file = File (* overwritten by Cil_datatype *) open Cil_datatype open Extlib let dkey = Kernel.register_category "filter" let debug1 fmt = Kernel.debug ~current:true ~dkey fmt let debug2 fmt = Kernel.debug ~current:true ~dkey ~level:2 fmt module type RemoveInfo = sig type proj type fct exception EraseAssigns exception EraseAllocation val fct_info : proj -> kernel_function -> fct list val fct_name : varinfo -> fct -> string val param_visible : fct -> int -> bool val body_visible : fct -> bool val loc_var_visible : fct -> varinfo -> bool val inst_visible : fct -> stmt -> bool val label_visible : fct -> stmt -> label -> bool val annotation_visible: fct -> stmt -> code_annotation -> bool val fun_precond_visible : fct -> predicate -> bool val fun_postcond_visible : fct -> predicate -> bool val fun_variant_visible : fct -> term -> bool val fun_frees_visible : fct -> identified_term -> bool val fun_allocates_visible : fct -> identified_term -> bool val fun_assign_visible : fct -> identified_term from -> bool val fun_deps_visible : fct -> identified_term -> bool val called_info : (proj * fct) -> stmt -> (kernel_function * fct) option val res_call_visible : fct -> stmt -> bool val result_visible : kernel_function -> fct -> bool val cond_edge_visible: fct -> stmt -> bool * bool end module F (Info : RemoveInfo) : sig val build_cil_file : string -> Info.proj -> Project.t end = struct type t = (string, Cil_types.varinfo) Hashtbl.t let mk_new_stmt s kind = s.skind <- kind 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 _) -> 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) | Block b -> is_empty_block keep_stmts b | UnspecifiedSequence seq -> is_empty_unspecified_sequence keep_stmts seq | _ -> false and is_empty_block keep_stmts block = List.for_all (can_skip keep_stmts) block.bstmts 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 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 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) | { 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 blk) (* same as above, but for unspecified sequences. *) and mk_new_unspecified_sequence keep_stmts s seq 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 seq with | [] -> mk_new_stmt s (mk_skip loc) | _ when is_empty_unspecified_sequence keep_stmts seq -> mk_new_stmt s (mk_skip loc) | [stmt,_,_,_,_] -> (* one statement only *) 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 | _ -> mk_new_stmt s stmt.skind end | _ -> mk_new_stmt s (UnspecifiedSequence seq) 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 Printer.pp_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@]@." Printer.pp_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, * and the param types. * Notice that this is just a filtering of the list. * It doesn't do any transformation of any kind on the element, * so at the end they are shared with the original list. * *) let filter_params finfo params = let do_param (n, new_params) var = let new_params = if not (Info.param_visible finfo n) then new_params else new_params @ [var] in (n+1, new_params) in let _, new_params = List.fold_left do_param (1, []) params in new_params let ff_var (fun_vars: t) kf finfo = let fct_var = Kernel_function.get_vi kf in let name = Info.fct_name fct_var finfo in try let ff_var = Hashtbl.find fun_vars name in 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 if not (Info.result_visible kf finfo) then 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. *) 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 fct 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 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 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 = Info.cond_edge_visible fct 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 inherit Visitor.frama_c_inplace method vvrbl v = if not v.vglob then ignore (Varinfo.Hashtbl.find vars_visible v); SkipChildren end in try ignore (Cil.visitCilLval (visitor :> Cil.cilVisitor) lval); true with Not_found -> false let filter_list is_visible visit l = let build e acc = if is_visible e then (visit e)::acc else acc in List.fold_right build l [] (** This visitor is to be used to filter a function. * It does a deep copy of the source function without the invisible elements. * It also change the function declaration and filter the function calls. * * Many ideas come from [Cil.copyFunctionVisitor] but we were not able to * directly inherit from it since some processing would not have worked in our * context (like the [sid] computation for instance). * *) class filter_visitor pinfo prj = object(self) inherit Visitor.generic_frama_c_visitor (Cil.copy_visit prj) val mutable keep_stmts = Stmt.Set.empty val mutable fi = None val fi_table = Varinfo.Hashtbl.create 7 val spec_table = Varinfo.Hashtbl.create 7 val fun_vars: t = 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 method private add_stmt_keep stmt = keep_stmts <- Stmt.Set.add stmt keep_stmts (** Applied on each variable use : * must replace references to formal/local variables * and source function calls *) method vvrbl (v: varinfo) = if v.vglob then try let v' = (Hashtbl.find fun_vars v.vname) in Cil.ChangeTo v' with Not_found -> Cil.SkipChildren else Cil.SkipChildren (*copy has already been done by default visitor*) (*method vvdec _ = SkipChildren (* everything is done elsewhere *)*) method private add_formals_bindings v formals = Varinfo.Hashtbl.add formals_table v formals method private get_formals_bindings v = Varinfo.Hashtbl.find formals_table v method private filter_formals formals = let formals = filter_params (self#get_finfo ()) formals in List.map (fun v -> Varinfo.Hashtbl.add local_visible v (); let v' = Cil.copyVarinfo v v.vname in Cil.set_varinfo self#behavior v v'; Cil.set_orig_varinfo self#behavior v' v; (match v.vlogic_var_assoc, v'.vlogic_var_assoc with None, None -> () | Some lv, Some lv' -> Cil.set_logic_var self#behavior lv lv'; Cil.set_orig_logic_var self#behavior lv' lv | _ -> assert false (* copy should be faithful *)); v') formals method private filter_locals locals = let rec filter locals = match locals with | [] -> [] | var :: locals -> let visible = Info.loc_var_visible (self#get_finfo ()) var in debug2 "[local] %s -> %s@." var.vname (if visible then "keep" else "remove"); if visible then begin Varinfo.Hashtbl.add local_visible var (); let var' = Cil.copyVarinfo var var.vname in Cil.set_varinfo self#behavior var var'; Cil.set_orig_varinfo self#behavior var' var; (match var.vlogic_var_assoc, var'.vlogic_var_assoc with None, None -> () | Some lv, Some lv' -> Cil.set_logic_var self#behavior lv lv'; Cil.set_orig_logic_var self#behavior lv' lv | _ -> assert false (* copy should be faithful *)); var' :: (filter locals) end else filter locals in let new_locals = filter locals in new_locals method vcode_annot v = let stmt = Cil.get_original_stmt self#behavior (Extlib.the self#current_stmt) in debug1 "[annotation] stmt %d : %a @." stmt.sid Printer.pp_code_annotation v; if 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 debug1 "\t-> ignoring annotation: %a@." Printer.pp_code_annotation v; ChangeTo (Logic_const.new_code_annotation (AAssert ([], { name = []; loc = Lexing.dummy_pos,Lexing.dummy_pos; content = Ptrue}))) end method private process_call call_stmt call = let finfo = self#get_finfo () in let info = (pinfo, finfo) in let lval, _funcexp, args, loc = call in let called_info = Info.called_info info call_stmt in match called_info with | None -> call_stmt.skind | Some (called_kf, called_finfo) -> let var_slice = ff_var fun_vars called_kf called_finfo in let new_funcexp = new_exp ~loc (Lval (Var var_slice, NoOffset)) in let new_args = filter_params called_finfo args in 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 debug1 "[process_call] call %s@." var_slice.vname; Instr (new_call) method vblock (b: block) = let optim b' = (* This optim must be performed after the sliced annotations have been put in the new table. Hence, we must put the action into the queue. *) Queue.add (fun () -> b'.bstmts <- List.filter (fun st -> not (Cil.is_skip st.skind) || st.labels <> [] || Annotations.has_code_annot st (*|| ((*Format.eprintf "Skipping %d@.@." st.sid;*) false)*) ) b'.bstmts) self#get_filling_actions; b' in (* b.blocals still contains original varinfos at this stage. The remaining ones will be copied later in the visit. *) b.blocals <- List.filter (Info.loc_var_visible (self#get_finfo ())) b.blocals; Cil.ChangeDoChildrenPost (b, optim) method private change_sid s = let orig = Cil.get_original_stmt self#behavior s in assert (Cil.get_stmt self#behavior orig == s); let old = s.sid in let keep = Stmt.Set.mem s keep_stmts in keep_stmts <- Stmt.Set.remove s keep_stmts; s.sid <- Cil.Sid.next (); Cil.set_stmt self#behavior orig s; Cil.set_orig_stmt self#behavior s orig; if keep then self#add_stmt_keep s; debug2 "@[finalize sid:%d->sid:%d@]@\n@." old s.sid method private process_invisible_stmt s = 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 = self#change_sid s; s.skind <- oldskind; (match s.skind with | If (_,bthen,belse,loc) -> let bthen = Cil.visitCilBlock (self:>Cil.cilVisitor) bthen in let belse = Cil.visitCilBlock (self:>Cil.cilVisitor) belse in let s_orig = Cil.get_original_stmt self#behavior s in optim_if finfo 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, _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 | 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 "@[[process_invisible_stmt] gives sid:%d@ @[%a@]@]@." s.sid Printer.pp_stmt s; s in s.skind <- mk_stmt_skip s; ChangeDoChildrenPost(s, do_after) method private process_visible_stmt s = debug2 "[process_visible_stmt] does sid:%d@." s.sid; let finfo = self#get_finfo () in (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 *) ); let do_after s' = self#change_sid s'; (match s'.skind with | If (cond,bthen,belse,loc) -> let s_orig = Cil.get_original_stmt self#behavior s' in optim_if finfo 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) | Block b -> let loc = Stmt.loc s' in (* must be performed after the optimisation of the block itself (see comment in vblock) *) Queue.add (fun () -> if b.bstmts = [] && b.battrs = [] then s'.skind <- (Instr (Skip loc))) self#get_filling_actions | UnspecifiedSequence _ -> let loc = Stmt.loc s' in let visible_stmt = let info = self#get_finfo () in (fun s -> Info.inst_visible info !s) in Queue.add (fun () -> match s'.skind with | UnspecifiedSequence l -> let res = List.filter (fun (s,_,_,_,_) -> not (is_skip s.skind)) l in let res = List.map (fun (s,m,w,r,c) -> (s, List.filter (visible_lval local_visible) m, List.filter (visible_lval local_visible) w, List.filter (visible_lval local_visible) r, List.filter visible_stmt c ) ) res in (match res with [] -> s'.skind <- (Instr (Skip loc)) | _ -> s'.skind <- UnspecifiedSequence res) | _ -> ()) self#get_filling_actions | _ -> ()); debug2 "@[[process_visible_stmt] gives sid:%d@ @[%a@]@]@." s'.sid Printer.pp_stmt s'; s' in Cil.ChangeDoChildrenPost (s, do_after) method vstmt_aux s = let finfo = self#get_finfo () 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") Printer.pp_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 method vfunc f = debug1 "@[[vfunc] -> %s@\n@]@." f.svar.vname; fi <- Some (Varinfo.Hashtbl.find fi_table f.svar); (* parameters *) let new_formals = try self#get_formals_bindings f.svar (* if there was a declaration, use the already computed formals list *) with Not_found -> self#filter_formals f.sformals in (* local declarations *) let new_locals = self#filter_locals f.slocals in let new_body = Cil.visitCilBlock (self:>Cil.cilVisitor) f.sbody in f.slocals <- new_locals; f.sbody <- new_body; Queue.add (fun () -> Cil.setFormals f new_formals) self#get_filling_actions; (* clean up the environment if we have more than one copy of the function in the sliced code. *) Cil.reset_behavior_stmt self#behavior; keep_stmts <- Stmt.Set.empty; Varinfo.Hashtbl.clear local_visible; Varinfo.Hashtbl.add spec_table f.svar (visitCilFunspec (self:>Cil.cilVisitor) (Annotations.funspec ~populate:false (Extlib.the self#current_kf))); SkipChildren method private visit_pred p = Logic_const.new_predicate { name = p.ip_name; loc = p.ip_loc; content = visitCilPredicate (self:>Cil.cilVisitor) p.ip_content } method private visit_identified_term t = let t' = visitCilTerm (self:>Cil.cilVisitor) t.it_content in Logic_const.new_identified_term t' method vfrom (b,f) = let finfo = self#get_finfo () in let from_visible t = Info.fun_deps_visible finfo t in let b = self#visit_identified_term b in let res = match f with FromAny -> b,FromAny | From l -> b, From (filter_list from_visible self#visit_identified_term l) in ChangeTo res method vbehavior b = let finfo = self#get_finfo () in let pre_visible p = Info.fun_precond_visible finfo p.ip_content in b.b_assumes <- filter_list pre_visible self#visit_pred b.b_assumes; b.b_requires <- filter_list pre_visible self#visit_pred b.b_requires; 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; let allocates_visible a = Info.fun_allocates_visible finfo a in let frees_visible a = Info.fun_frees_visible finfo a in (match b.b_allocation with FreeAllocAny -> () | FreeAlloc(f,a) -> try let frees = filter_list frees_visible self#visit_identified_term f in let allocates = filter_list allocates_visible self#visit_identified_term a in b.b_allocation <- FreeAlloc (frees, allocates) with Info.EraseAllocation -> b.b_allocation <- FreeAllocAny ); let from_visible a = Info.fun_assign_visible finfo a in let from_visit a = visitCilFrom (self:>Cil.cilVisitor) a in (match b.b_assigns with WritesAny -> () | Writes l -> try let assigns = filter_list from_visible from_visit l in b.b_assigns <- Writes assigns with Info.EraseAssigns -> b.b_assigns <- WritesAny ); SkipChildren (* see the warning on [SkipChildren] in [vspec] ! *) method vspec spec = 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 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 then Some (self#visit_pred p) else None in spec.spec_terminates <- new_term ; spec.spec_complete_behaviors <- [] (* TODO ! *) ; spec.spec_disjoint_behaviors <- [] (* TODO ! *) ; SkipChildren (* Be very careful that we can use [SkipChildren] here only if everything that is in the new spec has been visited above. we need to put links to the appropriate copies of variables (both pure C and logical ones) *) method private build_proto finfo loc = let kf = Extlib.the self#current_kf in fi <- Some finfo; let new_var = ff_var fun_vars kf finfo in (* we're building a prototype. *) new_var.vdefined <- false; let new_kf = make_new_kf my_kf kf new_var in Varinfo.Hashtbl.add fi_table new_var finfo; debug1 "@[[build_cil_proto] -> %s@\n@]@." new_var.vname; let action = let (rt,args,va,attrs) = Cil.splitFunctionType new_var.vtype in (match args with | None -> () | Some args -> let old_formals = Kernel_function.get_formals kf in let old_formals = filter_params finfo old_formals in let args = filter_params finfo args in let mytype = TFun(rt,Some args,va,attrs) in let new_formals = List.map makeFormalsVarDecl args in self#add_formals_bindings new_var new_formals; new_var.vtype <- mytype; List.iter2 (fun x y -> Cil.set_varinfo self#behavior x y; Cil.set_orig_varinfo self#behavior y x; match x.vlogic_var_assoc with None -> (); | Some lv -> let lv' = Cil.cvar_to_lvar y in Cil.set_logic_var self#behavior lv lv'; Cil.set_orig_logic_var self#behavior lv' lv) old_formals new_formals; (* adds the new parameters to the formals decl table *) Queue.add (fun () -> Cil.unsafeSetFormalsDecl new_var new_formals) self#get_filling_actions); let res = Cil.visitCilFunspec (self :> Cil.cilVisitor) (Annotations.funspec ~populate:false kf) 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 formals... *) Queue.add (fun () -> new_kf.spec <- res; Annotations.register_funspec ~force:true new_kf) self#get_filling_actions in action in let orig_var = Ast_info.Function.get_vi kf.fundec in (* The first copy is also the default one for varinfo that are not handled 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; (* 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 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 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 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 self#build_proto finfo loc else begin let kf = Extlib.the self#current_kf in let new_fct_var = ff_var fun_vars kf finfo in new_fct_var.vdefined <- true; 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; debug1 "@[[build_cil_fct] -> %s@\n@]@." (Info.fct_name (Kernel_function.get_vi (Extlib.the self#current_kf)) finfo); let action () = Queue.add (fun () -> new_kf.spec <- Varinfo.Hashtbl.find spec_table new_fct_var; Annotations.register_funspec ~force:true new_kf) self#get_filling_actions in let f = Kernel_function.get_definition new_kf 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); (* if this ever changes, we must do some work. *) GFun (f,loc), action end in List.map do_f finfo_list method vglob_aux g = let post action g = List.iter (fun x -> x()) action; fi <- None; debug1 "[post action] done.@."; g in match g with | GFun (f, loc) -> let (new_functions,actions) = List.split (self#compute_fct_definitions f loc) in Cil.ChangeToPost (new_functions, post actions) | GVarDecl (_, v, loc) -> begin match Cil.unrollType v.vtype with | TFun _ -> 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) | _ -> debug1 "[vglob_aux] GVarDecl %s (other)@." v.vname; Cil.DoChildren end | _ -> Cil.DoChildren end let build_cil_file new_proj_name pinfo = 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 debug1 "[build_cil_file] done.@."; prj end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/inout/0000755000175000017500000000000012155634040015722 5ustar mehdimehdiframa-c-Fluorine-20130601/src/inout/outputs.mli0000644000175000017500000000335012155630223020150 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 pretty_external: Format.formatter -> Cil_types.kernel_function -> unit val pretty_internal: Format.formatter -> Cil_types.kernel_function -> unit frama-c-Fluorine-20130601/src/inout/cumulative_analysis.ml0000644000175000017500000001455512155630223022346 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Db open Visitor let specialize_state_on_call ?stmt kf = match stmt with | Some ({ skind = Instr (Call (_, _, l, _)) } as stmt) -> let at_stmt = Db.Value.get_stmt_state stmt in if Cvalue.Model.is_top at_stmt then Cvalue.Model.top (* can occur with -no-results-function option *) else !Db.Value.add_formals_to_state at_stmt kf l | _ -> Value.get_initial_state kf class virtual ['a] cumulative_visitor = object inherit frama_c_inplace as self method specialize_state_on_call kf = specialize_state_on_call ?stmt:self#current_stmt kf method virtual compute_kf: kernel_function -> 'a end class type virtual ['a] cumulative_class = object inherit ['a] cumulative_visitor method bottom: 'a method result: 'a method join: 'a -> unit method compute_funspec : kernel_function -> 'a method clean_kf_result: kernel_function -> 'a -> 'a end module Make (X: sig val analysis_name: string type t module T: Datatype.S with type t = t class virtual do_it: [t] cumulative_class end) = struct module Memo = Kernel_function.Make_Table(X.T) (struct let name = "Memo " ^ X.analysis_name let dependencies = [ Value.self ] let size = 97 end) class do_it_cached call_stack = object(self) inherit X.do_it (* The cycle variable holds the list of functions that are involved in a cycle. As long as it is not empty, we known that the results we are computing are not complete, and we do not memorize them *) val mutable cycle = Kernel_function.Hptset.empty method private add_cycle s = cycle <- Kernel_function.Hptset.union s cycle method cycle = cycle (* Computation using the body of a kernel function. The result is automatically cached by the function if possible *) method private compute_kf_with_def kf = let f = Kernel_function.get_definition kf in if List.exists (Kernel_function.equal kf) call_stack then ( if Db.Value.ignored_recursive_call kf then Inout_parameters.warning ~current:true "During %s analysis of %a: ignoring probable recursive call." X.analysis_name Kernel_function.pretty kf; self#add_cycle (Kernel_function.Hptset.singleton kf); self#bottom ) else let computer = new do_it_cached (kf :: call_stack) in ignore (visitFramacFunction (computer:>frama_c_visitor) f); (* Results on all the statements of the function *) let v = computer#result in let v = computer#clean_kf_result kf v in (* recursive calls detected during analysis of the statements*) let cycle_aux = Kernel_function.Hptset.remove kf computer#cycle in self#add_cycle cycle_aux; if Kernel_function.Hptset.is_empty cycle then ( (* No recursive calls, our results are correct *) Inout_parameters.debug "Caching %s result for %a" X.analysis_name Kernel_function.pretty kf; Memo.add kf v; ) else Inout_parameters.debug "Not caching %s result for %a because of cycle" X.analysis_name Kernel_function.pretty kf; v (* Computation and caching for a kernel function, using its spec *) method private compute_kf_with_spec_generic kf = try Memo.find kf with Not_found -> let r_glob = self#compute_funspec kf in let r_glob = self#clean_kf_result kf r_glob in Memo.add kf r_glob; r_glob method compute_kf kf = if !Db.Value.use_spec_instead_of_definition kf then (* If only a declaration is available, or we are instructed to use the spec, do so. If a current stmt is available (most of the times), do not cache the results. Maybe [compute_funspec] will be able to deliver a more precise result on this given statement *) match self#current_stmt with | None -> self#compute_kf_with_spec_generic kf | Some _stmt -> self#compute_funspec kf else try Memo.find kf with Not_found -> self#compute_kf_with_def kf end let statement stmt = let computer = new do_it_cached [] in ignore (visitFramacStmt (computer:>frama_c_visitor) stmt); assert (Kernel_function.Hptset.is_empty computer#cycle); computer#result let expr stmt e = let computer = new do_it_cached [] in computer#push_stmt stmt; ignore (visitFramacExpr (computer:>frama_c_visitor) e); assert (Kernel_function.Hptset.is_empty computer#cycle); computer#result let kernel_function kf = let computer = new do_it_cached [] in computer#join (computer#compute_kf kf); assert (Kernel_function.Hptset.is_empty computer#cycle); computer#result end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/inout/inout_parameters.mli0000644000175000017500000000401512155630223022005 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.S module ForceAccessPath: Plugin.Bool module ForceOut: Plugin.Bool module ForceExternalOut: Plugin.Bool module ForceInput: Plugin.Bool module ForceInputWithFormals: Plugin.Bool module ForceInout: Plugin.Bool module ForceCallwiseInout: Plugin.Bool module ForceInoutExternalWithFormals: Plugin.Bool module ForceDeref: Plugin.Bool module Output: Plugin.Bool (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/inout/Inout.mli0000644000175000017500000000367612155630223017536 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* $Id: Inout.mli,v 1.5 2008-04-01 09:25:20 uid568 Exp $ *) (** Inputs-outputs computations. *) (** No function is directly exported: they are registered in: - {!Db.Inputs} for computations of non functionnal inputs; - {!Db.Outputs} for computations of outputs; - {!Db.Operational_inputs} for computation of inout context; and - {!Db.Derefs}. *) frama-c-Fluorine-20130601/src/inout/inputs.mli0000644000175000017500000000335412155630223017753 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 pretty_external: Format.formatter -> Cil_types.kernel_function -> unit val pretty_with_formals: Format.formatter -> Cil_types.kernel_function -> unit frama-c-Fluorine-20130601/src/inout/derefs.mli0000644000175000017500000000332612155630223017700 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 pretty_external: Format.formatter -> Cil_types.kernel_function -> unit val compute_external: Cil_types.kernel_function -> unit frama-c-Fluorine-20130601/src/inout/inputs.ml0000644000175000017500000001413212155630223017576 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Db open Locations open Visitor class virtual do_it_ = object(self) inherit [Zone.t] Cumulative_analysis.cumulative_visitor as super val mutable inputs = Zone.bottom method bottom = Zone.bottom method result = inputs method join new_ = inputs <- Zone.join new_ inputs; method vstmt_aux s = match s.skind with | UnspecifiedSequence seq -> List.iter (fun (stmt,_,_,_,_) -> ignore (visitFramacStmt (self:>frama_c_visitor) stmt)) seq; Cil.SkipChildren (* do not visit the additional lvals *) | _ -> super#vstmt_aux s method vlval lv = let deps,loc = !Value.lval_to_loc_with_deps ~with_alarms:CilE.warn_none_mode ~deps:Zone.bottom self#current_kinstr lv in let bits_loc = enumerate_valid_bits ~for_writing:false loc in self#join deps; self#join bits_loc; Cil.SkipChildren method private do_assign lv = let deps,_loc = !Value.lval_to_loc_with_deps ~with_alarms:CilE.warn_none_mode ~deps:Zone.bottom self#current_kinstr lv in (* Format.printf "do_assign deps:%a@." Zone.pretty deps; *) self#join deps; method vinst i = if Value.is_reachable (Value.get_state self#current_kinstr) then begin match i with | Set (lv,exp,_) -> self#do_assign lv; ignore (visitFramacExpr (self:>frama_c_visitor) exp); Cil.SkipChildren | Call (lv_opt,exp,args,_) -> (match lv_opt with None -> () | Some lv -> self#do_assign lv); let deps_callees, callees = !Value.expr_to_kernel_function ~with_alarms:CilE.warn_none_mode ~deps:(Some Zone.bottom) self#current_kinstr exp in self#join deps_callees; Kernel_function.Hptset.iter (fun kf -> self#join (self#compute_kf kf)) callees; List.iter (fun exp -> ignore (visitFramacExpr (self:>frama_c_visitor) exp)) args; Cil.SkipChildren | _ -> Cil.DoChildren end else Cil.SkipChildren method vexpr exp = match exp.enode with | AddrOf lv | StartOf lv -> let deps,_loc = !Value.lval_to_loc_with_deps ~with_alarms:CilE.warn_none_mode ~deps:Zone.bottom self#current_kinstr lv in self#join deps; Cil.SkipChildren | _ -> Cil.DoChildren method compute_funspec kf = let state = self#specialize_state_on_call kf in let behaviors = !Value.valid_behaviors kf state in let assigns = Ast_info.merge_assigns behaviors in !Value.assigns_inputs_to_zone state assigns method clean_kf_result (_ : kernel_function) (r: Locations.Zone.t) = r end module Analysis = Cumulative_analysis.Make( struct let analysis_name ="inputs" type t = Locations.Zone.t module T = Locations.Zone class virtual do_it = do_it_ end) let get_internal = Analysis.kernel_function module Externals = Kernel_function.Make_Table(Locations.Zone) (struct let name = "External inputs" let dependencies = [ Analysis.Memo.self ] let size = 17 end) let get_external = Externals.memo (fun kf -> Zone.filter_base (!Db.Semantic_Callgraph.accept_base ~with_formals:false ~with_locals:false kf) (get_internal kf)) let get_with_formals kf = Zone.filter_base (!Db.Semantic_Callgraph.accept_base ~with_formals:true ~with_locals:false kf) (get_internal kf) let compute_external kf = ignore (get_external kf) let pretty_external fmt kf = Format.fprintf fmt "@[Inputs for function %a:@\n@[ %a@]@]@\n" Kernel_function.pretty kf Zone.pretty (get_external kf) let pretty_with_formals fmt kf = Format.fprintf fmt "@[Inputs (with formals) for function %a:@\n@[ %a@]@]@\n" Kernel_function.pretty kf Zone.pretty (get_with_formals kf) let () = Db.Inputs.self_internal := Analysis.Memo.self; Db.Inputs.self_external := Externals.self; Db.Inputs.self_with_formals := Analysis.Memo.self; Db.Inputs.get_internal := get_internal; Db.Inputs.get_external := get_external; Db.Inputs.get_with_formals := get_with_formals; Db.Inputs.compute := compute_external; Db.Inputs.display := pretty_external; Db.Inputs.display_with_formals := pretty_with_formals; Db.Inputs.statement := Analysis.statement; Db.Inputs.expr := Analysis.expr (* Local Variables: compile-command: "LC_ALL=C make -C ../.. -j" End: *) frama-c-Fluorine-20130601/src/inout/operational_inputs.ml0000644000175000017500000006421512155630223022202 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Db open Locations (* Computation of over-approximed operational inputs: An acurate computation of these inputs needs the computation of under-approximed outputs. *) type tt = Inout_type.tt = { over_inputs: Locations.Zone.t; over_inputs_if_termination: Locations.Zone.t; under_outputs_if_termination: Locations.Zone.t; over_outputs: Locations.Zone.t; over_outputs_if_termination: Locations.Zone.t; } let top = { over_inputs = Zone.top; over_inputs_if_termination = Zone.top; under_outputs_if_termination = Zone.bottom; over_outputs = Zone.top; over_outputs_if_termination = Zone.top; } (* [_if_termination] fields of the type above, which are the one propagated by the dataflow analysis of this module. It is meaningless to store the other ones, as they come from branches that are by construction not propagated until the end by the dataflow. *) type compute_t = { over_inputs_d : Zone.t ; under_outputs_d : Zone.t; over_outputs_d: Zone.t; } (* Initial value for the computation *) let empty = { over_inputs_d = Zone.bottom; under_outputs_d = Zone.bottom; over_outputs_d = Zone.bottom; } let bottom = { over_inputs_d = Zone.bottom; under_outputs_d = Zone.top; over_outputs_d = Zone.bottom; } let equal ct1 ct2 = Zone.equal ct1.over_inputs_d ct2.over_inputs_d && Zone.equal ct1.under_outputs_d ct2.under_outputs_d && Zone.equal ct1.over_outputs_d ct2.over_outputs_d let join c1 c2 = { over_inputs_d = Zone.join c1.over_inputs_d c2.over_inputs_d; under_outputs_d = Zone.meet c1.under_outputs_d c2.under_outputs_d; over_outputs_d = Zone.join c1.over_outputs_d c2.over_outputs_d; } let is_included c1 c2 = Zone.is_included c1.over_inputs_d c2.over_inputs_d && Zone.is_included c2.under_outputs_d c1.under_outputs_d && Zone.is_included c1.over_outputs_d c2.over_outputs_d let catenate c1 c2 = { over_inputs_d = Zone.join c1.over_inputs_d (Zone.diff c2.over_inputs_d c1.under_outputs_d); under_outputs_d = Zone.link c1.under_outputs_d c2.under_outputs_d; over_outputs_d = Zone.join c1.over_outputs_d c2.over_outputs_d; } let externalize_zone ~with_formals kf = Zone.filter_base (!Db.Semantic_Callgraph.accept_base ~with_formals ~with_locals:false kf) (* This code evaluates an assigns, computing in particular a sound approximation of sure outputs. For an assigns [locs_out \from locs_from], the process is the following: - evaluate locs_out to locations; discard those that are not exact, as we cannot guarantee that they are always assigned - evaluate locs_from, as a zone (no need for locations) - compute the difference between the out and the froms, ie remove the zones that are such that [z \from z] holds (Note: large parts of this code are inspired/redundant with [assigns_to_zone_foobar_state] in Value/register.ml) *) let eval_assigns kf state assigns = let treat_one_zone acc (out, froms as asgn) = (* treat a single assign *) (* Return a list of independent output zones, plus a zone indicating that the zone has been overwritten in a sure way *) let clean_deps = Locations.Zone.filter_base (function | Base.Var (v, _) | Base.Initialized_Var (v, _) -> not (Kernel_function.is_formal v kf) | Base.Null | Base.String _ -> true) in let outputs, deps = try if Logic_utils.is_result out.it_content then [], Zone.bottom else let locs_out, deps = !Db.Properties.Interp.loc_to_locs ~result:None state out.it_content in let conv loc = let z = enumerate_valid_bits ~for_writing:true loc in let sure = Locations.cardinal_zero_or_one loc in z, sure in List.map conv locs_out, clean_deps deps with Invalid_argument _ -> Inout_parameters.warning ~current:true ~once:true "Failed to interpret assigns clause '%a'" Printer.pp_term out.it_content; [Locations.Zone.top, false], Locations.Zone.top in (* Compute all inputs as a zone *) let inputs = try match froms with | FromAny -> Zone.top | From l -> let aux acc { it_content = from } = let locs, deps = !Db.Properties.Interp.loc_to_locs None state from in let acc = Zone.join (clean_deps deps) acc in List.fold_left (fun acc loc -> let z = enumerate_valid_bits ~for_writing:false loc in Zone.join z acc ) acc locs in List.fold_left aux deps l with Invalid_argument _ -> Inout_parameters.warning ~current:true ~once:true "Failed to interpret inputs in assigns clause '%a'" Printer.pp_from asgn; Zone.top in (* Fuse all outputs. An output is sure if it was certainly overwritten, and if it is not amongst its from *) let extract_sure (sure_out, all_out) (out, exact) = let all_out' = Zone.join out all_out in if exact then let sure = Locations.Zone.diff out inputs in Zone.join sure sure_out, all_out' else sure_out, all_out' in let sure_out, all_out = List.fold_left extract_sure (Zone.bottom, Zone.bottom) outputs in (* Join all three kinds of locations. The use a join (not a meet) for under_outputs is correct here (and in fact required for precision) *) { under_outputs_d = Zone.join acc.under_outputs_d sure_out; over_inputs_d = Zone.join acc.over_inputs_d inputs; over_outputs_d = Zone.join acc.over_outputs_d all_out; } in match assigns with | WritesAny -> top | Writes l -> let init = { bottom with under_outputs_d = Zone.bottom } in let r = List.fold_left treat_one_zone init l in { over_inputs = r.over_inputs_d; over_inputs_if_termination = r.over_inputs_d; under_outputs_if_termination = r.under_outputs_d; over_outputs = r.over_outputs_d; over_outputs_if_termination = r.over_outputs_d; } let compute_using_prototype_state state kf = let behaviors = !Value.valid_behaviors kf state in let assigns = Ast_info.merge_assigns behaviors in eval_assigns kf state assigns let compute_using_prototype ?stmt kf = let state = Cumulative_analysis.specialize_state_on_call ?stmt kf in compute_using_prototype_state state kf (* Results of this module, consolidated by functions. Formals and locals are stored *) module Internals = Kernel_function.Make_Table(Inout_type) (struct let name = "Internal inouts full" let dependencies = [ Value.self ] let size = 17 end) module CallsiteHash = Value_types.Callsite.Hashtbl (* Results of an an entire call, represented by a pair (stmt, kernel_function]). This table is filled by the [-inout-callwise] option, or for functions for which only the specification is used. *) module CallwiseResults = State_builder.Hashtbl (CallsiteHash) (Inout_type) (struct let size = 17 let dependencies = [Internals.self; Inout_parameters.ForceCallwiseInout.self] let name = "Operational_inputs.CallwiseResults" end) module Computer (X:sig val version: string (* Callwise or functionwise *) val kf: kernel_function (* Function being analyzed *) val stmt_state: stmt -> Db.Value.state (* Memory state at the given stmt *) val at_call: stmt -> kernel_function -> Inout_type.t (* Results of the analysis for the given call. Must not contain locals or formals *) end) = struct let name = "InOut context " ^ X.version let debug = ref false let stmt_can_reach = Stmts_graph.stmt_can_reach X.kf let non_terminating_callees_inputs = ref Zone.bottom let non_terminating_callees_outputs = ref Zone.bottom type t = compute_t let pretty fmt x = Format.fprintf fmt "@[Over-approximated operational inputs: %a@]@\n\ @[Under-approximated operational outputs: %a@]" Zone.pretty x.over_inputs_d Zone.pretty x.under_outputs_d module StmtStartData = Dataflow.StartData(struct type t = compute_t let size = 107 end) let copy (d: t) = d let computeFirstPredecessor (s: stmt) data = match s.skind with | Switch (exp,_,_,_) | If (exp,_,_,_) | Return (Some exp, _) -> let state = X.stmt_state s in let inputs = !From.find_deps_no_transitivity_state state exp in let new_inputs = Zone.diff inputs data.under_outputs_d in {data with over_inputs_d = Zone.join data.over_inputs_d new_inputs} | _ -> data let combinePredecessors (s: stmt) ~old new_ = let new_c = computeFirstPredecessor s new_ in let result = join new_c old in if is_included result old then None else Some result let doInstr stmt (i: instr) (_d: t) = let state = X.stmt_state stmt in let add_out lv deps data = let deps, loclv = !Value.lval_to_loc_with_deps_state ~deps state lv in let new_inputs = Zone.diff deps data.under_outputs_d in let new_outs = Locations.enumerate_valid_bits ~for_writing:true loclv in let new_sure_outs = if Locations.valid_cardinal_zero_or_one ~for_writing:true loclv then (* There is only one modified zone. So, this is an exact output. Add it into the under-approximed outputs. *) Zone.link data.under_outputs_d new_outs else data.under_outputs_d in { under_outputs_d = new_sure_outs; over_inputs_d = Zone.join data.over_inputs_d new_inputs; over_outputs_d = Zone.join data.over_outputs_d new_outs } in match i with | Set (lv, exp, _) -> Dataflow.Post (fun data -> let state = X.stmt_state stmt in let e_inputs = !From.find_deps_no_transitivity_state state exp in add_out lv e_inputs data) | Call (lvaloption,funcexp,argl,_) -> let state = X.stmt_state stmt in Dataflow.Post (fun data -> let funcexp_inputs, called = !Db.Value.expr_to_kernel_function_state ~deps:(Some Zone.bottom) state funcexp in let acc_funcexp_arg_inputs = (* add the inputs of [argl] to the inputs of the function expression *) List.fold_right (fun arg inputs -> let arg_inputs = !From.find_deps_no_transitivity_state state arg in Zone.join inputs arg_inputs) argl funcexp_inputs in let data = catenate data { over_inputs_d = acc_funcexp_arg_inputs ; under_outputs_d = Zone.bottom; over_outputs_d = Zone.bottom; } in let for_functions = Kernel_function.Hptset.fold (fun kf acc -> let res = X.at_call stmt kf in non_terminating_callees_inputs := Zone.join !non_terminating_callees_inputs (Zone.diff res.Inout_type.over_inputs data.under_outputs_d); non_terminating_callees_outputs := Zone.join !non_terminating_callees_outputs res.over_outputs; let for_function = { over_inputs_d = res.over_inputs_if_termination; under_outputs_d = res.under_outputs_if_termination; over_outputs_d = res.over_outputs_if_termination; } in join for_function acc) called bottom in let result = catenate data for_functions in let result = (* Treatment for the possible assignment of the call result *) (match lvaloption with | None -> result | Some lv -> add_out lv Zone.bottom result) in result ) | _ -> Dataflow.Default let doStmt s d = if Db.Value.is_reachable (X.stmt_state s) && not (equal bottom d) then Dataflow.SDefault else Dataflow.SDone let filterStmt stmt = let state = X.stmt_state stmt in Value.is_reachable state let doGuard stmt e _t = let state = X.stmt_state stmt in let v_e = !Db.Value.eval_expr ~with_alarms:CilE.warn_none_mode state e in let t1 = Cil.unrollType (Cil.typeOf e) in let do_then, do_else = if Cil.isIntegralType t1 || Cil.isPointerType t1 then Cvalue.V.contains_non_zero v_e, Cvalue.V.contains_zero v_e else true, true (* TODO: a float condition is true iff != 0.0 *) in (if do_then then Dataflow.GDefault else Dataflow.GUnreachable), (if do_else then Dataflow.GDefault else Dataflow.GUnreachable) let doEdge _ _ d = d let init_dataflow () = (* TODO. Less ugly way? *) let start = List.hd (Kernel_function.get_definition X.kf).sbody.bstmts in StmtStartData.add start (computeFirstPredecessor start empty); start let end_dataflow () = let res_if_termination = try StmtStartData.find (Kernel_function.find_return X.kf) with Not_found -> bottom in StmtStartData.iter (fun _ data -> non_terminating_callees_inputs := Zone.join data.over_inputs_d !non_terminating_callees_inputs; non_terminating_callees_outputs := Zone.join data.over_outputs_d !non_terminating_callees_outputs; ); { over_inputs_if_termination = res_if_termination.over_inputs_d; under_outputs_if_termination = res_if_termination.under_outputs_d ; over_inputs = !non_terminating_callees_inputs; over_outputs_if_termination = res_if_termination.over_outputs_d; over_outputs = !non_terminating_callees_outputs; } end let externalize ~with_formals kf v = let filter = externalize_zone ~with_formals kf in Inout_type.map filter v let compute_externals_using_prototype ?stmt kf = let internals = compute_using_prototype ?stmt kf in externalize ~with_formals:false kf internals let get_internal_aux ?stmt kf = match stmt with | None -> !Db.Operational_inputs.get_internal kf | Some stmt -> try CallwiseResults.find (kf, Kstmt stmt) with Not_found -> if !Db.Value.use_spec_instead_of_definition kf then compute_using_prototype ~stmt kf else !Db.Operational_inputs.get_internal kf let get_external_aux ?stmt kf = match stmt with | None -> !Db.Operational_inputs.get_external kf | Some stmt -> try let internals = CallwiseResults.find (kf, Kstmt stmt) in externalize ~with_formals:false kf internals with Not_found -> if !Db.Value.use_spec_instead_of_definition kf then let r = compute_externals_using_prototype ~stmt kf in CallwiseResults.add (kf, Kstmt stmt) r; r else !Db.Operational_inputs.get_external kf module Callwise = struct let compute_callwise () = Inout_parameters.ForceCallwiseInout.get () || Dynamic.Parameter.Bool.get "-memexec-all" () let merge_call_in_local_table call local_table v = let prev = try CallsiteHash.find local_table call with Not_found -> Inout_type.bottom in let joined = Inout_type.join v prev in CallsiteHash.replace local_table call joined let merge_call_in_global_tables (kf, _ as call) v = (* Global callwise table *) let prev = try CallwiseResults.find call with Not_found -> Inout_type.bottom in CallwiseResults.replace call (Inout_type.join v prev); (* Global, kf-indexed, table *) let prev = try Internals.find kf with Not_found -> Inout_type.bottom in Internals.replace kf (Inout_type.join v prev); ;; let merge_local_table_in_global_ones = CallsiteHash.iter merge_call_in_global_tables ;; let call_inout_stack = ref [] let call_for_callwise_inout (state, call_stack) = if compute_callwise () then begin let (current_function, ki as call_site) = List.hd call_stack in if not (!Db.Value.use_spec_instead_of_definition current_function) then let table_current_function = CallsiteHash.create 7 in call_inout_stack := (current_function, table_current_function) :: !call_inout_stack else try let _above_function, table = List.hd !call_inout_stack in let inout = compute_using_prototype_state state current_function in if ki = Kglobal then merge_call_in_global_tables call_site inout else merge_call_in_local_table call_site table inout; with Failure "hd" -> Inout_parameters.fatal "inout: empty stack" Kernel_function.pretty current_function end module MemExec = State_builder.Hashtbl (Datatype.Int.Hashtbl) (Inout_type) (struct let size = 17 let dependencies = [Internals.self] let name = "Operational_inputs.MemExec" end) let end_record call_stack inout = merge_local_table_in_global_ones (snd (List.hd !call_inout_stack)); let (current_function, _ as call_site) = List.hd call_stack in (* pop + record in top of stack the inout of function that just finished*) match !call_inout_stack with | (current_function2, _) :: (((_caller, table) :: _) as tail) -> if current_function2 != current_function then Inout_parameters.fatal "callwise inout %a != %a@." Kernel_function.pretty current_function (* g *) Kernel_function.pretty current_function2 (* f *); call_inout_stack := tail; merge_call_in_local_table call_site table inout; | _ -> (* the entry point, probably *) merge_call_in_global_tables call_site inout; call_inout_stack := []; CallwiseResults.mark_as_computed () let compute_call_from_value_states kf states = let module Computer = Computer( struct let version = "callwise" let kf = kf let stmt_state stmt = try Cil_datatype.Stmt.Hashtbl.find states stmt with Not_found -> Cvalue.Model.bottom let at_call stmt kf = let _cur_kf, table = List.hd !call_inout_stack in try let with_internals = CallsiteHash.find table (kf, Kstmt stmt) in match kf.fundec with | Definition (fundec, _) -> let filter = Zone.filter_base (fun b -> not (Base.is_formal_or_local b fundec)) in Inout_type.map filter with_internals | _ -> with_internals with Not_found -> Inout_type.bottom end) in let module Compute = Dataflow.Forwards(Computer) in let start_stmt = Computer.init_dataflow () in Compute.compute [start_stmt]; Computer.end_dataflow () let record_for_callwise_inout ((call_stack: Db.Value.callstack), value_res) = if compute_callwise () then let inout = match value_res with | Value_types.Normal states | Value_types.NormalStore (states, _) -> let kf = fst (List.hd call_stack) in let inout = if !Db.Value.no_results (Kernel_function.get_definition kf) then top else compute_call_from_value_states kf (Lazy.force states) in Db.Operational_inputs.Record_Inout_Callbacks.apply (call_stack, inout); (match value_res with | Value_types.NormalStore (_, memexec_counter) -> MemExec.replace memexec_counter inout | _ -> ()); inout | Value_types.Reuse counter -> MemExec.find counter in end_record call_stack inout (* Register our callbacks inside the value analysis *) let add_hooks () = Db.Value.Record_Value_Callbacks_New.extend_once record_for_callwise_inout; Db.Value.Call_Value_Callbacks.extend_once call_for_callwise_inout let () = Inout_parameters.ForceCallwiseInout.add_update_hook (fun _bold bnew -> if bnew then add_hooks ()) let () = Inout_parameters.ForceCallwiseInout.add_set_hook (fun bold bnew -> if bold = false && bnew then Project.clear ~selection:(State_selection.with_dependencies Db.Value.self) (); ) end (* Functionwise version of the computations. *) module FunctionWise = struct (* Stack of function being processed *) let call_stack : kernel_function Stack.t = Stack.create () let compute_internal_using_cfg kf = try let module Computer = Computer (struct let version = "functionwise" let kf = kf let stmt_state = Db.Value.get_stmt_state let at_call stmt kf = get_external_aux ~stmt kf end) in let module Compute = Dataflow.Forwards(Computer) in Stack.iter (fun g -> if kf == g then begin if Db.Value.ignored_recursive_call kf then Inout_parameters.warning ~current:true "During inout context analysis of %a:@ \ ignoring probable recursive call." Kernel_function.pretty kf; raise Exit end) call_stack; Stack.push kf call_stack; let start_stmt = Computer.init_dataflow () in Compute.compute [start_stmt]; let r = Computer.end_dataflow () in ignore (Stack.pop call_stack); r with Exit -> Inout_type.bottom (*TODO*) (*{ Inout_type.over_inputs_if_termination = empty.over_inputs_d ; under_outputs_if_termination = empty.under_outputs_d; over_inputs = empty.over_inputs_d; over_outputs = empty.over_outputs_d; over_outputs_if_termination = empty.over_outputs_d; }*) let compute_internal_using_cfg kf = Inout_parameters.feedback ~level:2 "computing for function %a%s" Kernel_function.pretty kf (let s = ref "" in Stack.iter (fun kf -> s := !s^" <-"^ (Pretty_utils.sfprintf "%a" Kernel_function.pretty kf)) call_stack; !s); let r = compute_internal_using_cfg kf in Inout_parameters.feedback ~level:2 "done for function %a" Kernel_function.pretty kf; r end let get_internal = Internals.memo (fun kf -> !Value.compute (); try Internals.find kf (* If [-inout-callwise] is set, the results may have been computed by the call to Value.compute *) with | Not_found -> if!Db.Value.use_spec_instead_of_definition kf then compute_using_prototype kf else FunctionWise.compute_internal_using_cfg kf ) let raw_externals ~with_formals kf = let filter = externalize ~with_formals kf in filter (get_internal kf) module Externals = Kernel_function.Make_Table(Inout_type) (struct let name = "External inouts full" let dependencies = [ Internals.self ] let size = 17 end) let get_external = Externals.memo (raw_externals ~with_formals:false) let compute_external kf = ignore (get_external kf) module Externals_With_Formals = Kernel_function.Make_Table(Inout_type) (struct let name = "External inouts with formals full" let dependencies = [ Internals.self ] let size = 17 end) let get_external_with_formals = Externals_With_Formals.memo (raw_externals ~with_formals:true) let compute_external_with_formals kf = ignore (get_external_with_formals kf) let pretty_operational_inputs_internal fmt kf = Format.fprintf fmt "@[InOut (internal) for function %a:@\n%a@]@\n" Kernel_function.pretty kf Inout_type.pretty_operational_inputs (get_internal kf) let pretty_operational_inputs_external fmt kf = Format.fprintf fmt "@[InOut for function %a:@\n%a@]@\n" Kernel_function.pretty kf Inout_type.pretty_operational_inputs (get_external kf) let pretty_operational_inputs_external_with_formals fmt kf = Format.fprintf fmt "@[InOut (with formals) for function %a:@\n%a@]@\n" Kernel_function.pretty kf Inout_type.pretty_operational_inputs (get_external_with_formals kf) let () = Db.Operational_inputs.self_internal := Internals.self; Db.Operational_inputs.self_external := Externals.self; Db.Operational_inputs.get_internal := get_internal; Db.Operational_inputs.get_external := get_external; Db.Operational_inputs.get_internal_precise := get_internal_aux; Db.Operational_inputs.compute := compute_external; Db.Operational_inputs.display := pretty_operational_inputs_internal (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/inout/derefs.ml0000644000175000017500000001024412155630223017524 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Db open Locations class virtual do_it_ = object(self) inherit [Zone.t] Cumulative_analysis.cumulative_visitor val mutable derefs = Zone.bottom method bottom = Zone.bottom method result = derefs method join new_ = derefs <- Zone.join new_ derefs; method vlval (base,_ as lv) = begin match base with | Var _ -> () | Mem e -> let state = Value.get_state (Kstmt (Extlib.the self#current_stmt)) in let r = !Value.eval_expr ~with_alarms:CilE.warn_none_mode state e in let loc = loc_bytes_to_loc_bits r in let size = Bit_utils.sizeof_lval lv in self#join (enumerate_valid_bits ~for_writing:false (make_loc loc size)) end; DoChildren method compute_funspec (_: kernel_function) = Zone.bottom method clean_kf_result (_ : kernel_function) (r: Locations.Zone.t) = r end module Analysis = Cumulative_analysis.Make( struct let analysis_name ="derefs" type t = Locations.Zone.t module T = Locations.Zone class virtual do_it = do_it_ end) let get_internal = Analysis.kernel_function let externalize _return fundec x = Zone.filter_base (fun v -> not (Base.is_formal_or_local v fundec)) x module Externals = Kernel_function.Make_Table(Locations.Zone) (struct let name = "External derefs" let dependencies = [ Analysis.Memo.self ] let size = 17 end) let get_external = Externals.memo (fun kf -> !Value.compute (); if Kernel_function.is_definition kf then try externalize (Kernel_function.find_return kf) (Kernel_function.get_definition kf) (get_internal kf) with Kernel_function.No_Statement -> assert false else (* assume there is no deref for leaf functions *) Zone.bottom) let compute_external kf = ignore (get_external kf) let _pretty_internal fmt kf = Format.fprintf fmt "@[Derefs (internal) for function %a:@\n@[ %a@]@]@\n" Kernel_function.pretty kf Zone.pretty (get_internal kf) let pretty_external fmt kf = Format.fprintf fmt "@[Derefs for function %a:@\n@[ %a@]@]@\n" Kernel_function.pretty kf Zone.pretty (get_external kf) let () = Db.Derefs.self_internal := Analysis.Memo.self; Db.Derefs.self_external := Externals.self; Db.Derefs.get_internal := get_internal; Db.Derefs.get_external := get_external; Db.Derefs.compute := compute_external; Db.Derefs.display := pretty_external; Db.Derefs.statement := Analysis.statement frama-c-Fluorine-20130601/src/inout/inout_parameters.ml0000644000175000017500000000743612155630223021646 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.Register (struct let name = "inout" let shortname = "inout" let help = "operational, imperative and all kinds of inputs/outputs" end) module ForceDeref = False (struct let option_name = "-deref" let help = "force deref computation (undocumented)" end) module ForceAccessPath = False (struct let option_name = "-access-path" let help = "force the access path information to be computed" end) module ForceOut = False (struct let option_name = "-out" let help = "Compute internal out. Those are an over-approximation of the set of written locations" end) module ForceExternalOut = False (struct let option_name = "-out-external" let help = "Compute external out. Those are an over-approximation of the set of written locations, excluding locals" end) module ForceInput = False (struct let option_name = "-input" let help = "Compute imperative inputs. Locals and function parameters are not displayed" end) module ForceInputWithFormals = False (struct let option_name = "-input-with-formals" let help = "Compute imperative inputs. Function parameters are displayed, locals are not" end) module ForceInout = False (struct let option_name = "-inout" let help = "Compute operational inputs, an over-approximation of the set of locations whose initial value is used; and the sure outputs, an under-approximation of the set of the certainly written locations" end) module ForceCallwiseInout = False (struct let option_name = "-inout-callwise" let help = "Compute callsite-wide operational inputs; this results in more precise results for -inout and -out options" end) module ForceInoutExternalWithFormals = False (struct let option_name = "-inout-with-formals" let help = "same as -inout but without local variables and with function parameters" end) let () = Plugin.set_group messages module Output = True(struct let option_name = "-inout-print" let help = "print the results of all the analyzes" end) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/inout/outputs.ml0000644000175000017500000001313212155630223017776 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* Hidden by open Db *) let get_external_aux = Operational_inputs.get_external_aux open Cil_types open Visitor open Db open Locations class virtual do_it_ = object(self) inherit [Zone.t] Cumulative_analysis.cumulative_visitor as super val mutable outs = Zone.bottom method bottom = Zone.bottom method result = outs method vstmt_aux s = match s.skind with | UnspecifiedSequence seq -> List.iter (fun (stmt,_,_,_,_) -> ignore(visitFramacStmt (self:>frama_c_visitor) stmt)) seq; Cil.SkipChildren (* do not visit the additional lvals *) | _ -> super#vstmt_aux s method join new_ = outs <- Zone.join new_ outs; method private do_assign lv = let loc = !Value.lval_to_loc ~with_alarms:CilE.warn_none_mode self#current_kinstr lv in if not (Location_Bits.equal loc.loc Location_Bits.bottom) then begin if Location_Bits.equal loc.loc Location_Bits.top then Inout_parameters.debug ~current:true "Problem with %a@\nValue at this point:@\n%a" Printer.pp_lval lv Value.pretty_state (Value.get_state self#current_kinstr) ; let bits_loc = enumerate_valid_bits ~for_writing:true loc in self#join bits_loc end method vinst i = if Value.is_reachable (Value.noassert_get_state self#current_kinstr) then (* noassert needed for Eval.memoize. Not really satisfactory *) begin match i with | Set (lv,_,_) -> self#do_assign lv | Call (lv_opt,exp,_,_) -> (match lv_opt with None -> () | Some lv -> self#do_assign lv); let _, callees = !Value.expr_to_kernel_function ~with_alarms:CilE.warn_none_mode ~deps:None self#current_kinstr exp in Kernel_function.Hptset.iter (fun kf -> let { Inout_type.over_outputs = z } = get_external_aux ?stmt:self#current_stmt kf in self#join z ) callees | _ -> () end; Cil.SkipChildren method clean_kf_result kf r = Zone.filter_base (!Db.Semantic_Callgraph.accept_base ~with_formals:true ~with_locals:true kf) r method compute_funspec kf = let state = self#specialize_state_on_call kf in let behaviors = !Value.valid_behaviors kf state in let assigns = Ast_info.merge_assigns behaviors in !Db.Value.assigns_outputs_to_zone state ~result:None assigns end module Analysis = Cumulative_analysis.Make( struct let analysis_name ="outputs" type t = Locations.Zone.t module T = Locations.Zone class virtual do_it = do_it_ end) let get_internal = Analysis.kernel_function let externalize kf x = Zone.filter_base (!Db.Semantic_Callgraph.accept_base ~with_formals:false ~with_locals:false kf) x module Externals = Kernel_function.Make_Table(Locations.Zone) (struct let name = "External outs" let dependencies = [ Analysis.Memo.self ] let size = 17 end) let get_external = Externals.memo (fun kf -> externalize kf (get_internal kf)) let pretty_internal fmt kf = try Format.fprintf fmt "@[Out (internal) for function %a:@\n@[ %a@]@]@\n" Kernel_function.pretty kf Zone.pretty (get_internal kf) with Not_found -> () let pretty_external fmt kf = try Format.fprintf fmt "@[Out (external) for function %a:@\n@[ %a@]@]@\n" Kernel_function.pretty kf Zone.pretty (get_external kf) with Not_found -> () let () = Db.Outputs.self_internal := Analysis.Memo.self; Db.Outputs.self_external := Externals.self; Db.Outputs.get_internal := get_internal; Db.Outputs.get_external := get_external; Db.Outputs.compute := (fun kf -> ignore (get_internal kf)); Db.Outputs.display := pretty_internal; Db.Outputs.display_external := pretty_external; Db.Outputs.statement := Analysis.statement (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/inout/register.ml0000644000175000017500000000771112155630223020105 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* This code duplicates more or less Plugin.WithOutput. Since Inout prints the results of all its options interleaved, it is difficult to proceed otherwise *) module ShouldOutput = State_builder.True_ref (struct let dependencies = [Db.Value.self] (* To be completed if some computations use some other results than value *) let name = "Inout.Register.ShouldOuput" end) let () = Inout_parameters.Output.add_set_hook (fun _ v -> if v then ShouldOutput.set true) let main () = let forceout = Inout_parameters.ForceOut.get () in let forceexternalout = Inout_parameters.ForceExternalOut.get () in let forceinput = Inout_parameters.ForceInput.get () in let forceinout = Inout_parameters.ForceInout.get () in let forceinoutwithformals = Inout_parameters.ForceInoutExternalWithFormals.get () in let forcederef = Inout_parameters.ForceDeref.get () in let forceinputwithformals = Inout_parameters.ForceInputWithFormals.get () in if (forceout || forceexternalout || forceinput || forceinputwithformals || forcederef || forceinout || forceinoutwithformals) && Inout_parameters.Output.get () && ShouldOutput.get () then begin ShouldOutput.set false; !Db.Semantic_Callgraph.topologically_iter_on_functions (fun kf -> if Kernel_function.is_definition kf then begin if forceout then Inout_parameters.result "%a" Outputs.pretty_internal kf ; if forceexternalout then Inout_parameters.result "%a" Outputs.pretty_external kf ; if forceinput then Inout_parameters.result "%a" Inputs.pretty_external kf; if forcederef then begin Derefs.compute_external kf; Inout_parameters.result "%a" Derefs.pretty_external kf; end; if forceinout then Inout_parameters.result "%a" Operational_inputs.pretty_operational_inputs_internal kf; if forceinoutwithformals then Inout_parameters.result "%a" Operational_inputs.pretty_operational_inputs_external_with_formals kf; if forceinputwithformals then Inout_parameters.result "%a" Inputs.pretty_with_formals kf ; end) end let () = Db.Main.extend main (* Local Variables: compile-command: "make -C ../.. -j" End: *) frama-c-Fluorine-20130601/src/inout/cumulative_analysis.mli0000644000175000017500000001275512155630223022517 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (** Implementation of a simple meta-analysis on top of the results of the value analysis. This implementation correctly handles memoization and apparent recursive calls during the value analysis. The underlying analysis is supposed to be cumulative at the level of a kernel_function (its results are derived from the results on all its statements), and mostly non-contextual (all the informations can be gathered using a Cil visitor). *) val specialize_state_on_call: ?stmt:stmt -> kernel_function -> Db.Value.state (** If the given statement is a call to the given function, enrich the superposed memory state at this statement with the formal arguments of this function. This is usually more precise than the superposition of all initial states of the function *) (** Frama-C visitor for cumulative analyses: we add a few useful methods. The method [compute_kf] must be used to add the effects of a call to the given kernel function to the pool of results *) class virtual ['a] cumulative_visitor : object inherit Visitor.frama_c_inplace method specialize_state_on_call: kernel_function -> Db.Value.state (** If the current statement is a call to the given function, enrich the superposed memory state at this statement with the formal arguments of this function. Useful to do an analysis with a limited amount of context *) method virtual compute_kf: kernel_function -> 'a (** Virtual function to use when one needs to compute the effect of a function call. This function carries implictly a context: thus calling [self#compute_kf k1; self#compute_kf k2] is different from calling one within the other *) end class type virtual ['a] cumulative_class = object inherit ['a] cumulative_visitor method bottom: 'a (** Result of the analysis *) method result: 'a (** Adding partial results to the current ones *) method join: 'a -> unit (** Function that computes and returns the partial results on a funspec. May consult [self#current_stmt] to specialize itself, and return partially contextual results *) method compute_funspec : kernel_function -> 'a (** Assuming [v] are the results of the analysis for [f] (ie. the union of the results on all the statements of [f], or [compute_funspec f] if [f] has no body), [clean_kf_result k v] cleans those results before storing them. Use for example to remove out-of-scope locals *) method clean_kf_result: kernel_function -> 'a -> 'a end module Make (X: sig val analysis_name: string (** Type of the results *) type t module T: Datatype.S with type t = t (** Class that implements the analysis. Must not deal with memoization, as this is automatically done by the functor *) class virtual do_it: [t] cumulative_class end) : sig (** Module that contains the memoized results *) module Memo: sig val self: State.t end (** Class that implements a cached version of the above analysis. Recursion in the dynamic call graphs are handled, provided the value analysis terminated without detecting a real recursion *) class do_it_cached: Kernel_function.t list -> object inherit X.do_it (** Internal methods that gives the functions for which a cycle has been detected in the dynamic call-graph. Results cannot be safely memoized if this set is not empty *) method cycle: Kernel_function.Hptset.t (** Memoized version of the analysis of a kernel-function *) method compute_kf: kernel_function -> X.t end (** Effects of the given kernel_function, using memoization *) val kernel_function: kernel_function -> X.t (** Effects of a statement, using memoization if it contains a function call*) val statement: stmt -> X.t (** Effects of the given expression (wich is supposed to be at the given statement *) val expr: stmt -> exp -> X.t end frama-c-Fluorine-20130601/src/inout/access_path.ml0000644000175000017500000001370312155630223020534 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Locations open Abstract_interp open Lattice_Interval_Set open Cvalue let pretty = let module M = Base.Map.Make(struct open Locations include Datatype.Pair(Zone)(Location_Bits) let pretty fmt (z, loc) = Format.fprintf fmt "@[[Zone:%a@ Loc_bits:%a]@]" Zone.pretty z Location_Bits.pretty loc end) in fun fmt m -> Format.fprintf fmt "Access_path:@\n%a@\n=============@\n" M.pretty m (** [reciprocal_image b m] is the set of bits in the offsetmap [m] that may lead to Top([b]) and the set of offsets in [m] where one can read an address [b]+_ *) let reciprocal_image_offsm base m = let treat_binding (bi,ei as itv) (v, modu, r) (acc1,acc2) = let r = Integer.c_rem (Rel.add_abs bi r) modu in let v = Cvalue.V_Or_Uninitialized.get_v v in let acc1 = if Locations.Location_Bytes.may_reach base v then Int_Intervals.join acc1 (Int_Intervals.inject [itv]) else acc1 in let acc2 = if (Locations.Location_Bytes.intersects (Locations.Location_Bytes.inject base Ival.top) v) && Int.compare modu (Integer.of_int (Bit_utils.sizeofpointer ())) = 0 then let first = Int.round_up_to_r ~min:bi ~r ~modu in let last = Integer.mul (Integer.pred (Integer.div (Integer.succ (Integer.sub ei first)) modu)) modu in if Integer.lt last Integer.zero then acc2 else Ival.join acc2 (Ival.inject_top (Some first) (Some (Integer.add first last)) r modu) else acc2 in acc1,acc2 in Cvalue.V_Offsetmap.fold treat_binding m (Int_Intervals.bottom, Ival.bottom) (** [reciprocal_image m b] is the set of bits in the map [m] that may lead to Top([b]) and the location in [m] where one may read an address [b]+_ *) let reciprocal_image base m : Zone.t*Location_Bits.t = if Base.is_null base then Zone.top,Location_Bits.top else Model.fold_base_offsetmap (fun b offsm (acc1,acc2) -> let interv_set,ival = reciprocal_image_offsm base offsm in let acc1 = Zone.join acc1 (Zone.inject b interv_set) in let acc2 = Location_Bits.join acc2 (Location_Bits.inject b ival) in acc1,acc2 ) m (Zone.bottom,Location_Bits.bottom) let compute state base_set = let q = Queue.create () in let result = ref Base.Map.empty in Base.Set.iter (fun elt -> Queue.add elt q) base_set; while not (Queue.is_empty q) do let current_base = Queue.take q in let recip = reciprocal_image current_base state in result := Base.Map.add current_base recip !result ; try Zone.fold_bases (fun base () -> try ignore (Base.Map.find base !result) with Not_found -> Queue.add base q) (fst recip) () with Zone.Error_Top -> () done; Inout_parameters.result "%a" pretty !result; !result let filter m inputs = Base.Map.map (fun (zone,loc) -> Zone.narrow zone inputs, (Locations.filter_loc (Locations.make_loc loc (Int_Base.inject (Int.of_int (Bit_utils.sizeofpointer ())))) inputs).Locations.loc) m let main () = if Inout_parameters.ForceAccessPath.get () then !Db.Semantic_Callgraph.topologically_iter_on_functions (fun kf -> if Kernel_function.is_definition kf && !Db.Value.is_called kf then let state = Db.Value.get_state (Cil_types.Kstmt (Kernel_function.find_first_stmt kf)) in let inputs = !Db.Operational_inputs.get_internal kf in let s = !Db.Access_path.compute state (Cvalue.Model.fold_base (fun base acc -> Base.Set.add base acc) state Base.Set.empty) in Inout_parameters.result "Filtered access_path for %a :@ %a@." Kernel_function.pretty kf !Db.Access_path.pretty (!Db.Access_path.filter s (Locations.Zone.filter_base (fun b -> not (Base.is_local b (Kernel_function.get_definition kf))) inputs.Inout_type.over_inputs))) let () = Db.Main.extend main let () = Db.Access_path.compute := compute; Db.Access_path.filter := filter; Db.Access_path.pretty := pretty (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/inout/access_path.mli0000644000175000017500000000321712155630223020704 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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: *) frama-c-Fluorine-20130601/src/syntactic_callgraph/0000755000175000017500000000000012155634040020602 5ustar mehdimehdiframa-c-Fluorine-20130601/src/syntactic_callgraph/cg_viewer.ml0000644000175000017500000001251312155630240023106 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Register open Dgraph let ($) f x = f x type service_id = int module View = DGraphContainer.Make(Service.TP) class ['v, 'e, 'c] services_view view = object (self) val services: (service_id, bool ref * Service.CallG.V.t DGraphViewItem.view_item list ref) Hashtbl.t = Hashtbl.create 10 method is_root (n:'v DGraphViewItem.view_item) = n#item.Service.is_root method is_deployed id = try !(fst (Hashtbl.find services id)) with Not_found -> assert false method edge_kind (e: 'e DGraphViewItem.view_item) = Service.CallG.E.label e#item method deploy node = assert (self#is_root node); let service = self#service node in let deployed, nodes = Hashtbl.find services service in assert (not !deployed); deployed := true; (* 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) !nodes method undeploy node = assert (self#is_root node); let service = self#service node in let deployed, nodes = Hashtbl.find services service in assert !deployed; deployed := false; (* 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) !nodes method service n = n#item.Service.root.Service.node.Callgraph.cnid initializer let add_in_service n s = try let _, nodes = Hashtbl.find services s in nodes := n :: !nodes with Not_found -> Hashtbl.add services s (ref false, ref [ n ]) in 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 | _ -> false in n#connect_event ~callback in view#iter_nodes (fun n -> add_in_service n (self#service n); if self#is_root n then connect_trigger_to_node n else n#hide ()); view#iter_edges_e (fun e -> match self#edge_kind e with | Service.Inter_services | Service.Both -> e#show () | Service.Inter_functions -> e#hide ()) end (* Constructor copied from dGraphView *) let services_view model = let delay_node v = not v.Service.is_root in let delay_edge e = match Service.CallG.E.label e with | Service.Inter_services | Service.Both -> false | Service.Inter_functions -> true in let view = View.GView.view ~aa:true ~delay_node ~delay_edge model in view#set_zoom_padding 0.025; (* not very nice *) ignore (new services_view view); view#connect_highlighting_event (); ignore $ view#set_center_scroll_region true; view let make_graph_view ~packing () = let _, view = View.from_graph_with_commands ~packing ?root:(Service.entry_point ()) ~mk_global_view:services_view (Register.get ()) in view let main (window: Design.main_window_extension_points) = ignore ((window#menu_manager ())#add_plugin [ Menu_manager.menubar "Show callgraph" (Menu_manager.Unit_callback (fun () -> Service_graph.frama_c_display true; Gtk_helper.graph_window ~parent:window#main_window ~title:"Syntactic Callgraph" make_graph_view)) ]) let () = Design.register_extension main (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/syntactic_callgraph/options.ml0000644000175000017500000000504712155630240022633 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let name = "syntactic callgraph" include Plugin.Register (struct let name = name let shortname = "cg" let help = "syntactic stratified callgraph" end) module Filename = EmptyString (struct let option_name = "-cg" let arg_name = "filename" let help = "dump the syntactic stratified callgraph to the file \ in dot format" end) module InitFunc = StringSet (struct 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)" end) module ServicesOnly = False (struct let option_name = "-cg-services-only" let help = "only computes the graph of services" end) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/syntactic_callgraph/options.mli0000644000175000017500000000350312155630240022777 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.S val name: string module Filename: Plugin.String module InitFunc: Plugin.String_set module ServicesOnly: Plugin.Bool (** @since Beryllium-20090901 *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/syntactic_callgraph/register.ml0000644000175000017500000001224412155630240022761 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Callgraph open Options let entry_point_ref = ref None module Service = Service_graph.Make (struct let datatype_name = name type t = Callgraph.callgraph module V = struct type t = callnode let id v = v.cnid let name v = nodeName v.cnInfo let attributes v = [ match v.cnInfo with | NIVar (_,b) when not !b -> `Style `Dotted | _ -> `Style `Bold ] let equal v1 v2 = id v1 = id v2 let compare v1 v2 = let i1 = id v1 in let i2 = id v2 in if i1 < i2 then -1 else if i1 > i2 then 1 else 0 let hash = id let entry_point () = !entry_point_ref end let iter_vertex f = Hashtbl.iter (fun _ -> f) let iter_succ f _g v = Datatype.Int.Hashtbl.iter (fun _ -> f) v.cnCallees let iter_pred f _g v = Datatype.Int.Hashtbl.iter (fun _ -> f) v.cnCallers let fold_pred f _g v = Datatype.Int.Hashtbl.fold (fun _ -> f) v.cnCallers end) module CG = State_builder.Option_ref (Service.CallG.Datatype) (struct let name = name let dependencies = [ Ast.self ] end) 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 Datatype.Int.Hashtbl.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 let cg = computeGraph p 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"; cg let get () = CG.memo compute (* module SG = State_builder.OptionRef (Service.SG.Datatype) (struct let name = name ^ " (service only)" let dependencies = [ CG.self; ServicesOnly.self ] end) let get_services () = SG.memo (fun () -> Service.compute_services (get ())) *) let dump () = let output = (* if ServicesOnly.get () then let sg = get_services () in fun o -> Service.output_services o sg else *) let cg = get () in fun o -> Service_graph.frama_c_display false; Service.output_graph o cg in let file = Filename.get () in feedback ~level:2 "dumping the graph into file %s" file; try let o = open_out file in output o; close_out o with e -> error "error while dumping the syntactic callgraph: %s" (Printexc.to_string e) let () = Db.register_guarded_compute "Syntactic_Callgraph.dump" (fun () -> Filename.get () = "" || CG.is_computed ()) Db.Syntactic_Callgraph.dump dump let () = (* Do not directly use [dump]: function in [Db] is guarded and apply only if required. *) Db.Main.extend (fun _fmt -> !Db.Syntactic_Callgraph.dump ()) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/syntactic_callgraph/Syntactic_callgraph.mli0000644000175000017500000000355212155630240025266 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* $Id: Syntactic_callgraph.mli,v 1.2 2008-11-04 10:05:05 uid568 Exp $ *) (** Syntactic callgraph plugin. *) (** No function is directly exported: they are registered in {!Db.Syntactic_callgraph}. *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.. -j" End: *) frama-c-Fluorine-20130601/src/pdg_types/0000755000175000017500000000000012155634040016562 5ustar mehdimehdiframa-c-Fluorine-20130601/src/pdg_types/pdgTypes.mli0000644000175000017500000001610012155630235021064 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** This module defines the types that are used to store the PDG of a function. @plugin development guide *) (** [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, * - address dependency, * - data dependency. * An edge can carry one or several kinds. * A bottom edge means that there are no relation. *) module Dpd : sig type t type td = Ctrl | Addr | Data val make : ?a:bool -> ?d:bool -> ?c:bool -> unit -> t val top : t val bottom : t val is_addr : t -> bool val is_ctrl : t -> bool val is_data : t -> bool val adc_value : t -> bool * bool * bool val is_dpd : td -> t -> bool val is_bottom : t -> bool val is_included : t -> t -> bool val compare : t -> t -> int val equal : t -> t -> bool val combine : t -> t -> t val add : t -> td -> t val inter : t -> t -> t val intersect : t -> t -> bool val minus : t -> t -> t val pretty_td : Format.formatter -> td -> unit val pretty : Format.formatter -> t -> unit end (** A node of the PDG : includes some information to know where it comes from. *) module Node : sig include Datatype.S_with_collections val 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 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 : 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. Only a few functions are exported, to build the graph in [pdg/build.ml]. Iterating over the PDG should be done using the functions in module [Pdg] below *) module G : sig type t 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 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 val defaultall : Base.t -> t end module LocInfo : Lmap_bitwise.Location_map_bitwise with type y = NodeSetLattice.t (** a [data_state] object is associated with a program point and provides a mapping between a location and some nodes in the PDG that are used to compute the location value at that point. *) type data_state = { loc_info : LocInfo.t ; under_outputs : Locations.Zone.t } module Pdg : sig exception Top (** can be raised by most of the functions when called with a Top PDG. Top means that we were not abled to compute the PDG for this function. *) exception Bottom (** exception raised when requiring the PDG of a function that is never called. *) include Datatype.S (** @param name of the function associated with that PDG *) val top : Kernel_function.t -> t val bottom : Kernel_function.t -> t val is_top : t -> bool val is_bottom : t -> bool val get_kf : t -> Kernel_function.t val iter_nodes : (Node.t -> unit) -> t -> unit val fold_call_nodes : ('a -> Node.t -> 'a) -> 'a -> t -> Cil_types.stmt -> 'a val iter_direct_dpds : t -> (Node.t -> unit) -> Node.t -> unit val iter_direct_codpds : t -> (Node.t -> unit) -> Node.t -> unit (** 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 val get_x_direct_dpds : Dpd.td -> t -> Node.t -> dpd_info list 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 fold_direct_dpds : t -> ('a -> Dpd.t * Locations.Zone.t option -> Node.t -> 'a) -> 'a -> Node.t -> 'a val fold_direct_codpds : t -> ('a -> Dpd.t * Locations.Zone.t option -> Node.t -> 'a) -> 'a -> Node.t -> 'a val pretty_bw : ?bw:bool -> Format.formatter -> t -> unit val pretty_graph : ?bw:bool -> Format.formatter -> G.t -> unit type fi = (Node.t, unit) PdgIndex.FctIndex.t val get_index : t -> fi (** [make fundec graph states index] *) val make : Kernel_function.t -> G.t -> data_state Cil_datatype.Stmt.Hashtbl.t -> fi -> t val get_states : t -> data_state Cil_datatype.Stmt.Hashtbl.t (** build the PDG .dot file and put it in [filename]. *) val build_dot: string -> t -> unit module Printer : sig val iter_vertex : (Node.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 : Node.t -> string val vertex_attributes : Node.t -> Graph.Graphviz.DotAttributes.vertex list val get_subgraph : Node.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: *) frama-c-Fluorine-20130601/src/pdg_types/pdgTypes.ml0000644000175000017500000005773712155630235020740 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (** Node.t is the type of the PDG vertex. *) module Node : sig include Datatype.S_with_collections val 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 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 val make: PdgIndex.Key.t -> t end = struct type tt = { id : int; key : PdgIndex.Key.t } module Counter = State_builder.Counter(struct let name = "PdgTypes.Node.Counter" end) let make key = {id = Counter.next (); key = key} let print_id fmt e = Format.fprintf fmt "%d" e.id let id n = n.id let elem_key n = n.key 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 @[%a@])" Locations.Zone.pretty z let pretty_node fmt n = Format.fprintf fmt "[Elem] %d : %a" (id n) PdgIndex.Key.pretty (elem_key n) end module NodeSet = Hptset.Make(Node) (struct let v = [ [ ] ] end) (struct let l = [ Ast.self ] end) (* Clear the (non-project compliant) internal caches each time the ast is updated, which includes every time we switch project. *) let () = Ast.add_hook_on_update NodeSet.clear_caches let () = Ast.add_monotonic_state NodeSet.self (** set of nodes of the graph *) module NodeSetLattice = struct include Abstract_interp.Make_Lattice_Set(Node) let default _v _a _b : t = empty let defaultall _v : t = empty end module LocInfo = Lmap_bitwise.Make_bitwise (NodeSetLattice) let () = Ast.add_hook_on_update LocInfo.clear_caches (* See comment on previous call to Ast.add_hook_on_update *) (** Edges label for the Program Dependence Graph. *) module Dpd : sig include Datatype.S (** used to speak about the different kinds of dependencies *) type td = Ctrl | Addr | Data val make : ?a:bool -> ?d:bool -> ?c:bool -> unit -> t val make_simple : td -> t val bottom : t val top : t val adc_value : t -> bool * bool * bool val is_addr : t -> bool val is_ctrl : t -> bool val is_data : t -> bool val is_dpd : td -> t -> bool val is_bottom : t -> bool val is_included : t -> t -> bool val combine : t -> t -> t val add : t -> td -> t val inter : t -> t -> t val intersect : t -> t -> bool (** 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 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 let make ?(a=false) ?(d=false) ?(c=false) _ = match a,d,c with | 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 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 -> is_addr d | Ctrl -> is_ctrl d | Data -> is_data d let is_bottom = (=) bottom let adc_value d = (is_addr d, is_data d, is_ctrl d) 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 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 = adc1 land (lnot adc2) let pretty fmt d = Format.fprintf fmt "[%c%c%c]" (if is_addr d then 'a' else '-') (if is_ctrl d then 'c' else '-') (if is_data d then 'd' else '-') end module DpdZone : sig 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 val pretty : Format.formatter -> t -> unit end = struct include Datatype.Pair(Dpd)(Datatype.Option(Locations.Zone)) (* None == Locations.Zone.Top *) let dpd_kind dpd = fst dpd let dpd_zone dpd = snd dpd let kind_and_zone dpd = dpd let make k z = (Dpd.make_simple k), z let is_dpd k dpd = Dpd.is_dpd k (dpd_kind dpd) 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 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 | Locations.Zone.Top(_p, _o) -> None | _ -> (* To share values as much as possible *) if (zz == zz1) then z1 else if (zz == zz2) then z else Some zz in if (d == d1) && (z == z1) then dpd else d, z let pretty fmt dpd = Dpd.pretty fmt (dpd_kind dpd); match (dpd_zone dpd) with None -> () | Some z -> Format.fprintf fmt "@[(%a)@]" Locations.Zone.pretty z end (** The graph itself. *) module G = struct (* 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 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(Node)(DpdZone)(Hptmap.Comp_unused) (struct let v = [[]] end)(struct let l = [Ast.self] end) let () = Ast.add_hook_on_update (fun _ -> To.clear_caches ()) (* See comment on previous call to Ast.add_hook_on_update *) let () = Ast.add_monotonic_state To.self 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 -> if rev then f v' lbl v else f v lbl v') 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 -> if rev then f v' lbl v acc else f v lbl v' 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_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 create () = { d_graph = Node.Hashtbl.create 17; co_graph = Node.Hashtbl.create 17; } let find_dpd g v1 v2 = let lbl = find_edge g v1 v2 in ((v1, lbl, v2), lbl) let add_elem g key = let elem = Node.make key in add_vertex g elem; elem let simple_add_dpd g v1 dpd v2 = add_edge g v1 dpd v2 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 = try let edge, old_dpd = find_dpd graph v1 v2 in let new_dpd = DpdZone.add old_dpd dpd_kind opt_zone in if not (DpdZone.equal old_dpd new_dpd) then replace_dpd graph edge new_dpd with Not_found -> let new_dpd = DpdZone.make dpd_kind opt_zone in simple_add_dpd graph v1 new_dpd v2 let edge_dpd (_, lbl, _) = DpdZone.kind_and_zone lbl let pretty_edge_label = DpdZone.pretty end (** 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 was last defined. Managed in src/pdg/state.ml *) type data_state = { loc_info : LocInfo.t ; under_outputs : Locations.Zone.t } module Data_state = Datatype.Make (struct include Datatype.Serializable_undefined type 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 let rehash = Datatype.identity let structural_descr = Structural_descr.t_record [| LocInfo.packed_descr; Locations.Zone.packed_descr |] let mem_project = Datatype.never_any_project end) (** PDG for a function *) module Pdg = struct exception Top exception Bottom type fi = (Node.t, unit) PdgIndex.FctIndex.t (** The nodes associated to each element. There is only one node for simple statements, but there are several for a call for instance. *) let fi_descr = PdgIndex.FctIndex.t_descr ~ni:(Descr.str Node.descr) ~ci:Structural_descr.t_unit type def = { graph : G.t ; states : data_state Cil_datatype.Stmt.Hashtbl.t ; index : fi ; } type body = PdgDef of def | PdgTop | PdgBottom module Body_datatype = Datatype.Make (struct include Datatype.Undefined(*Serializable_undefined*) type 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.Stmt.Hashtbl.Make(Data_state) in H.packed_descr); pack fi_descr; |]) |] |]) let name = "body" let mem_project = Datatype.never_any_project end) let () = Type.set_ml_name Body_datatype.ty None include Datatype.Pair(Kernel_function)(Body_datatype) let make kf graph states index = let body = { graph = graph; states = states; index = index ; } in (kf, PdgDef body) let top kf = (kf, PdgTop) let bottom kf = (kf, PdgBottom) let is_top pdg = match snd pdg with PdgTop -> true | _ -> false let is_bottom pdg = match snd pdg with PdgBottom -> true | _ -> false let get_pdg_body pdg = match snd pdg with | PdgDef pdg -> pdg | PdgTop -> raise Top | PdgBottom -> raise Bottom let get_kf pdg = fst pdg let get_graph pdg = let pdg = get_pdg_body pdg in pdg.graph let get_states pdg = let pdg = get_pdg_body pdg in pdg.states let get_index pdg = let pdg = get_pdg_body pdg in pdg.index let iter_nodes f pdg = G.iter_vertex f (get_graph pdg) let iter_direct_dpds pdg f node = let pdg = get_pdg_body pdg in G.fold_one_dir (fun n () -> f n) pdg.graph.G.d_graph node () let iter_direct_codpds pdg f node = let pdg = get_pdg_body pdg in G.fold_one_dir (fun n () -> f n) pdg.graph.G.co_graph node () let fold_call_nodes f acc pdg call = let _, call_pdg = PdgIndex.FctIndex.find_call (get_index pdg) call in let do_it acc (_k, n) = f acc n in PdgIndex.Signature.fold do_it acc call_pdg 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 if [dpd_type] is not [None]. The dependency kind is dropped *) let get_x_direct_edges ~co ?dpd_type pdg node : dpd_info list = let pdg = get_pdg_body pdg in let is_dpd_ok dpd = match dpd_type with None -> true | Some k -> DpdZone.is_dpd k dpd in let filter n dpd n' nodes = if is_dpd_ok dpd then let n = if co then n else n' in let z = DpdZone.dpd_zone dpd in (n, z) :: nodes else nodes in let fold = if co then G.fold_pred_e else G.fold_succ_e in fold filter pdg.graph node [] let get_x_direct ~co dpd_type pdg node = get_x_direct_edges ~co ~dpd_type pdg node let get_x_direct_dpds k = get_x_direct ~co:false k let get_x_direct_codpds k = get_x_direct ~co:true k let get_all_direct ~co pdg node = get_x_direct_edges ~co pdg node let get_all_direct_dpds pdg node = get_all_direct ~co:false pdg node let get_all_direct_codpds pdg node = get_all_direct ~co:true pdg node let fold_direct ~co (pdg:t) f acc node = let do_e n1 dpd n2 acc = let n = if co then n1 else n2 in f acc (DpdZone.kind_and_zone dpd) n in let fold = if co then G.fold_pred_e else G.fold_succ_e in fold do_e (get_graph pdg) node acc let fold_direct_dpds pdg f acc node = fold_direct ~co:false pdg f acc node let fold_direct_codpds pdg f acc node = fold_direct ~co:true pdg f acc node 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@." Node.pretty_node n in let print_dpd src dpd_kind dst = if bw then Format.fprintf fmt " <-%a- %d@." G.pretty_edge_label dpd_kind (Node.id src) else Format.fprintf fmt " -%a-> %d@." G.pretty_edge_label dpd_kind (Node.id dst) in let print_node_and_dpds n = print_node n; iter print_dpd graph n in List.iter print_node_and_dpds all let pretty_bw ?(bw=false) fmt pdg = try let graph = get_graph pdg in pretty_graph ~bw fmt graph; with | Top -> Format.fprintf fmt "Top PDG@." | Bottom -> Format.fprintf fmt "Bottom PDG@." (*-----------------------------------------------------------------------*) module Printer = struct open PdgIndex type parent_t = t type t = parent_t module V = Node module E = struct type t = G.E.t * bool (** boolean to say that the edge is dynamic *) let src (e, _d) = G.E.dst e (* We reverse the direction of edges *) let dst (e, _d) = G.E.src e (* to get graphs with a correct orientation*) end (* Skip InCtrl nodes, that hinder readability *) let print_node n = match Node.elem_key n with | Key.SigKey (Signature.In Signature.InCtrl) | Key.SigCallKey (_, Signature.In Signature.InCtrl) -> false | _ -> true let iter_vertex f pdg = try let graph = get_graph pdg in let f n = if print_node n then f n 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 n1 lbl n2 = if print_node n1 && print_node n2 then f ((n1, lbl, n2), false) in G.iter_edges_e f_static graph; with Top | Bottom -> () let graph_attributes _ = [`Rankdir `TopToBottom ] let default_vertex_attributes _ = [`Style `Filled] let vertex_name v = string_of_int (Node.id v) let vertex_attributes v = let color_in = (`Fillcolor 0x6495ED) in let color_out = (`Fillcolor 0x90EE90) in let color_decl = (`Fillcolor 0xFFEFD5) in let color_stmt = (`Fillcolor 0xCCCCCC) in (* let color_annot = (`Fillcolor 0x999999) in *) let color_call = (`Fillcolor 0xFF8A0F) in let color_elem_call = (`Fillcolor 0xFFCA6E) in let sh_box = (`Shape `Box) in let key = Node.elem_key v in let sh, col, txt = match key with | Key.VarDecl v -> let txt = Pretty_utils.sfprintf "@[Decl %s@]" v.vname in `Shape `Box, color_decl, txt | Key.SigKey k -> let txt = Pretty_utils.sfprintf "%a" Signature.pretty_key k in let color = match k with | Signature.Out _ -> color_out | _ -> color_in in `Shape `Box, color, txt | Key.Stmt s -> let sh, txt = match s.skind with | Switch (exp,_,_,_) | If (exp,_,_,_) -> let txt = Pretty_utils.to_string Printer.pp_exp exp in `Shape `Diamond, txt | Loop _ -> `Shape `Doublecircle, "while" | Block _ | UnspecifiedSequence _ -> `Shape `Doublecircle, "{}" | Goto _ | Break _ | Continue _ -> let txt = Pretty_utils.to_string (Printer.without_annot Printer.pp_stmt) s in (`Shape `Doublecircle), txt | Return _ | Instr _ -> let txt = Pretty_utils.to_string (Printer.without_annot Printer.pp_stmt) s in sh_box, txt | _ -> sh_box, "???" in sh, color_stmt, txt | Key.CallStmt call -> let call_stmt = Key.call_from_id call in let txt = Pretty_utils.to_string (Printer.without_annot Printer.pp_stmt) call_stmt in sh_box, color_call, txt | Key.SigCallKey (_call, sgn) -> let txt = Pretty_utils.to_string Signature.pretty_key sgn in sh_box, color_elem_call, txt | Key.Label _ -> let txt = Pretty_utils.to_string Key.pretty key in sh_box, color_stmt, txt in sh :: col :: [`Label ( String.escaped txt)] let default_edge_attributes _ = [`Dir `Back] let edge_attributes (e, dynamic) = let d, z = G.edge_dpd e in let attrib = [] in let attrib = match z with | None -> attrib | Some z -> let txt = Pretty_utils.sfprintf "@[%a@]" Locations.Zone.pretty z in (`Label (String.escaped txt)) :: attrib in let attrib = 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 let attrib = if Dpd.is_ctrl d then (`Arrowtail `Odot)::attrib else attrib in let 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 Some { Graph.Graphviz.DotAttributes.sg_name= name; Graph.Graphviz.DotAttributes.sg_attributes = attrib } in match Node.elem_key v with | Key.CallStmt call | Key.SigCallKey (call, _) -> let call_stmt = Key.call_from_id call in let name = "Call"^(string_of_int call_stmt.sid) in let call_txt = Pretty_utils.sfprintf "%a" Printer.pp_stmt call_stmt in let call_txt = String.escaped call_txt in let attrib = [(`Label (name^" : "^call_txt))] in let attrib = (`Fillcolor 0xB38B4D) :: attrib in mk_subgraph name attrib | Key.SigKey k -> let pack_inputs_outputs = false in if pack_inputs_outputs then begin let is_in = match k with Signature.In _ -> true | _ -> false in let name = if is_in then "Inputs" else "Outputs" in let color = if is_in then 0x90EE90 else 0x6495ED in let attrib = [] in let attrib = (`Fillcolor color) :: attrib in mk_subgraph name attrib end else None | _ -> None end (** @see * Graph.Graphviz *) module PrintG = Graph.Graphviz.Dot(Printer) (*-----------------------------------------------------------------------*) let build_dot filename pdg = let file = open_out filename in PrintG.output_graph file pdg; close_out file end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/pdg_types/pdgMarks.mli0000644000175000017500000001466212155630235021050 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** This module provides elements to mapped information (here called 'marks') * to PDG elements and propagate it along the dependencies. * * Some more functions are defined in the PDG pluggin itself * (in [pdg/marks]): * the signatures of these public functions can be found in file [Pdg.mli] *) (** Signature of the module to use in order to instanciate the computation *) module type Mark = sig (** type of the information mapped to the nodes *) type t (** type of the information mapped to the function calls. * This can be [unit] if there is nothing to store for the calls. * (see {!PdgIndex.FctIndex} for more information) * *) type call_info (** used to test [combine] result (see below) *) val is_bottom : t -> bool (** merge two pieces of information *) val merge : t -> t -> t (** [combine] is used during propagation. It should return * [(new_mark, mark_to_prop) = combine old_mak new_mark] * where [new_mark] is the mark to associate with the node, * and [mark_to_prop] the mark to propagate to its dependencies. * If [is_bottom mark_to_prop], the propagation is stopped. * *) val combine : t -> t -> t * t val pretty : Format.formatter -> t -> unit end (** When selecting or propagating marks in a function, * the marks are most of the time associated to pdg nodes, * but we also need to associate marks to input locations * in order to propage information to the callers about undefined data. * *) type select_elem = private | SelNode of PdgTypes.Node.t * Locations.Zone.t option | SelIn of Locations.Zone.t val mk_select_node : ?z_opt:Locations.Zone.t option -> PdgTypes.Node.t -> select_elem val mk_select_undef_zone : Locations.Zone.t -> select_elem type 'tm select = (select_elem * 'tm) list val add_to_select : 'tm select -> select_elem -> 'tm -> 'tm select val add_node_to_select : 'tm select -> (PdgTypes.Node.t * Locations.Zone.t option) -> 'tm -> 'tm select val add_undef_in_to_select : 'tm select -> Locations.Zone.t option -> 'tm -> 'tm select (** we sometime need a list of [t_select] associated with its pdg when dealing with several functions at one time. *) type 'tm pdg_select_info = SelList of 'tm select | SelTopMarks of 'tm list type 'tm pdg_select = (PdgTypes.Pdg.t * 'tm pdg_select_info) list (** Represent the information to propagate from a function inputs to its calls. Notice that the input keys don't necessarily correspond to nodes especially when one want to select a data that is not defined in the function. **) type 'tm info_caller_inputs = (PdgIndex.Signature.in_key * 'tm) list (** Represent the information to propagate from a call outputs to the called function. The [stmt] are the calls to consider. *) type 'tm info_called_outputs = (Cil_types.stmt * (PdgIndex.Signature.out_key * 'tm) list) list (** when some marks have been propagated in a function, there is some information to propagate in the callers and called functions to have an interprocedural processing. *) type 'tm info_inter = 'tm info_caller_inputs * 'tm info_called_outputs module type Fct = sig type mark type call_info type fi = (mark, call_info) PdgIndex.FctIndex.t type t = PdgTypes.Pdg.t * fi val create : PdgTypes.Pdg.t -> t val get_idx : t -> fi type mark_info_inter = mark info_inter val empty_to_prop : mark_info_inter val mark_and_propagate : t -> ?to_prop:mark_info_inter -> mark select -> mark_info_inter end module F_Fct(M : Mark) : Fct with type mark = M.t and type call_info = M.call_info type 't_mark m2m = select_elem -> 't_mark -> 't_mark option type 't_mark call_m2m = Cil_types.stmt option -> PdgTypes.Pdg.t -> 't_mark m2m (** this is the type of the functor dedicated to interprocedural propagation. It is defined in PDG pluggin *) module type Proj = sig type t type mark type call_info type fct = (mark, call_info) PdgIndex.FctIndex.t val empty: unit -> t val find_marks: t -> Cil_types.varinfo -> fct option val mark_and_propagate: t -> PdgTypes.Pdg.t -> mark select -> unit end module type Config = sig module M : Mark (** define how to translate an input mark of a function into a mark * to propagate in the callers. * The statement specify to which call we are about to propagate, * and the pdg is the one of the caller in which the call is. * If it returns [None], the propagation is stopped. * A simple propagation can be done by returning [Some m]. * The [call] parameter can be [None] when the caller has a Top PDG. * *) val mark_to_prop_to_caller_input : M.t call_m2m (** define how to translate a mark of a call output into a mark * to propagate in the called function. * The statement specify from which call we are about to propagate, * and the pdg is the one of the called function. * *) val mark_to_prop_to_called_output : M.t call_m2m end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/pdg_types/pdgMarks.ml0000644000175000017500000002513712155630235020676 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** This file provides useful things to help to associate an information * (called mark) to PDG elements and to propagate it across the * dependencies. *) open PdgTypes open PdgIndex type select_elem = | SelNode of PdgTypes.Node.t * Locations.Zone.t option (** zone is [Some z] only for nodes that * represent call output in case we want to * select less than the whole OutCall *) | SelIn of Locations.Zone.t type 'tm select = (select_elem * 'tm) list type 'tm pdg_select_info = SelList of 'tm select | SelTopMarks of 'tm list type 'tm pdg_select = (PdgTypes.Pdg.t * 'tm pdg_select_info) list type 'tm info_caller_inputs = (Signature.in_key * 'tm) list type 'tm info_called_outputs = (Cil_types.stmt * (Signature.out_key * 'tm) list) list type 'tm info_inter = 'tm info_caller_inputs * 'tm info_called_outputs let mk_select_node ?(z_opt=None) node = SelNode (node, z_opt) let mk_select_undef_zone zone = SelIn zone let add_to_select select sel m = (sel, m)::select let add_node_to_select select (node,z_opt) m = add_to_select select (mk_select_node ~z_opt node) m let add_undef_in_to_select select undef m = match undef with | None -> select | Some loc -> if (Locations.Zone.equal Locations.Zone.bottom loc) then select else add_to_select select (mk_select_undef_zone loc) m (** Type of the module that the user has to provide to describe the marks. *) module type Mark = sig type t type call_info val is_bottom : t -> bool val merge : t -> t -> t val combine : t -> t -> (t * t) val pretty : Format.formatter -> t -> unit end module type Fct = sig type mark type call_info type fi = (mark, call_info) PdgIndex.FctIndex.t type t = PdgTypes.Pdg.t * fi val create : PdgTypes.Pdg.t -> t val get_idx : t -> fi type mark_info_inter = mark info_inter val empty_to_prop : mark_info_inter val mark_and_propagate : t -> ?to_prop:mark_info_inter -> mark select -> mark_info_inter end (** If the marks provided by the user respect some constraints (see [Mark]), * we have that, after the marks propagation, * the mark of a node are always smaller than the sum of the marks of its * dependencies. It means that the mark of the statement [x = a + b;] * have to be smaller that the mark of [a] plus the mark of [b] at this point. * * If the marks are used for visibility for instance, * it means that if this statement is visible, * so must be the computation of [a] and [b], but [a] and/or [b] can be * visible while [x] is not. *) module F_Fct (M : Mark) : Fct with type mark = M.t and type call_info = M.call_info = struct type mark = M.t type call_info = M.call_info type fi = (mark, call_info) PdgIndex.FctIndex.t type t = Pdg.t * fi type mark_info_inter = mark info_inter let empty_to_prop = ([], []) let create pdg = let idx = (PdgIndex.FctIndex.create 17) (* TODO Pdg.get_index_size pdg *) in (pdg, idx) let get_idx (_pdg, idx) = idx (** add the given mark to the node. @return [Some m] if [m] has to be propagated in the node dependencies, [None] otherwise. *) let add_mark _pdg fm node_key mark = Kernel.debug ~level:2 "[pdgMark] add_mark %a -> %a @\n" PdgIndex.Key.pretty node_key M.pretty mark ; let mark_to_prop = try begin (* simple node *) let new_mark, mark_to_prop = try 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 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 in mark_to_prop let add_in_to_to_prop to_prop in_key mark = let rec add marks = match marks with | [] -> [(in_key, mark)] | (k, m)::tl -> let cmp = try Signature.cmp_in_key in_key k with PdgIndex.Not_equal -> (* k and in_key are 2 different InImpl : look for in_key in tl *) (* TODO : we could try to group several InImpl... *) 1 in if cmp = 0 then (in_key, M.merge m mark)::tl else if cmp < 0 then (in_key, mark) :: marks else (k, m)::(add tl) in let in_marks, out_marks = to_prop in let new_in_marks = add in_marks in new_in_marks, out_marks (** the new marks [to_prop] are composed of two lists : * - one [(in_key, mark) list] means that the mark has been added in the input, * - one [call, (out_key, m) list] that means that [m] has been added * to the [out_key] output of the call. * * This function [add_to_to_prop] groups similar information, * and keep the list sorted. *) let add_to_to_prop to_prop key mark = let rec add_out_key l key = match l with | [] -> [(key, mark)] | (k, m) :: tl -> let cmp = match key, k with | Signature.OutLoc z, Signature.OutLoc zone -> if Locations.Zone.equal z zone then 0 else 1 | _ -> Signature.cmp_out_key key k in if cmp = 0 then (key, M.merge m mark)::tl else if cmp < 0 then (key, mark) :: l else (k, m)::(add_out_key tl key) in let rec add_out out_marks call out_key = match out_marks with | [] -> [ (call, [(out_key, mark)]) ] | (c, l)::tl -> if call.Cil_types.sid = c.Cil_types.sid 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 (** mark the nodes and their dependencies with the given mark. * Stop when reach a node which is already marked with this mark. * @return the modified marks of the function inputs, * and of the call outputs for interprocedural propagation. * *) 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 | Some z -> match node_key with | Key.SigCallKey (call, Signature.Out (Signature.OutLoc out_z)) -> let z = Locations.Zone.narrow z out_z in Key.call_output_key (Key.call_from_id call) z | _ -> node_key in let mark_to_prop = add_mark pdg fm node_key mark in if (M.is_bottom mark_to_prop) then begin Kernel.debug ~level:2 "[pdgMark] mark_and_propagate = stop propagation !@\n"; to_prop end else begin Kernel.debug ~level:2 "[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 let node_marks = List.map (fun (n, z) -> (n, z, mark_to_prop)) dpds_info in add_node_mark_rec pdg fm node_marks to_prop end in List.fold_left mark_node_and_dpds to_prop node_marks let mark_and_propagate fm ?(to_prop=empty_to_prop) select = let pdg, idx = fm in 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" 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" 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 else add_to_to_prop to_prop in_key mark_to_prop in List.fold_left process to_prop select end module type Proj = sig type t type mark type call_info type fct = (mark, call_info) PdgIndex.FctIndex.t val empty : unit -> t val find_marks : t -> Cil_types.varinfo -> fct option val mark_and_propagate : t -> PdgTypes.Pdg.t -> mark select -> unit end type 'mark m2m = select_elem -> 'mark -> 'mark option type 'mark call_m2m = Cil_types.stmt option -> PdgTypes.Pdg.t -> 'mark m2m module type Config = sig module M : Mark val mark_to_prop_to_caller_input : M.t call_m2m val mark_to_prop_to_called_output : M.t call_m2m end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/pdg_types/pdgIndex.mli0000644000175000017500000002174712155630235021044 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** This module can be useful to store some information about different * elements of a function. * * {!module:PdgIndex.Signature} is used to store information * about function inputs/outputs either for the function itself or for its * calls. {!module:PdgIndex.Key} provides keys to identify the different * elements we want to speak about. {!module:PdgIndex.FctIndex} is the main * object that manages the stored information. * * This module is used for instance to store the relation between a function * elements and the nodes of its PDG, but it can also be used to store many * other things.*) (** try to add in information while there is already something stored. * Should have used replace function *) exception AddError (** Some functions do not apply to call statements because the stored * information has a different type. *) exception CallStatement (** When we compare two things with different locations (no order) *) exception Not_equal (** What we call a [Signature] a mapping between keys that represent either a * function input or output, and some information. *) module Signature : sig (** type of a signature where ['a] is the type of the information that we * want to store for each input/output. *) type 'a t (** key for input elements *) type in_key = private | InCtrl (** input control point *) | InNum of int (** parameters numbered from 1 *) | InImpl of Locations.Zone.t (** key for implicit inputs. Used in function signatures only *) type out_key = private | OutRet (** key for the output corresponding to the [return] *) | OutLoc of Locations.Zone.t (** key for output locations. used in call signatures only *) (** a key represents either an input or an output of a function. *) type key = private In of in_key | Out of out_key val empty : 'a t (** build a new, empty signature *) val mk_undef_in_key : Locations.Zone.t -> in_key val cmp_in_key : in_key -> in_key -> int val cmp_out_key : out_key -> out_key -> int val equal_out_key : out_key -> out_key -> bool val find_info : 'a t -> key -> 'a val find_input : 'a t -> int -> 'a val find_in_ctrl : 'info t -> 'info val find_in_top : 'info t -> 'info val find_in_info : 'info t -> in_key -> 'info val find_out_ret : 'a t -> 'a val find_out_info : 'info t -> out_key -> 'info val fold : ('a -> key * 'b -> 'a) -> 'a -> 'b t -> 'a val fold_num_inputs : ('a -> int * 'b -> 'a) -> 'a -> 'b t -> 'a val fold_impl_inputs : ('a -> Locations.Zone.t * 'b -> 'a) -> 'a -> 'b t -> 'a val fold_matching_impl_inputs : Locations.Zone.t -> ('a -> Locations.Zone.t * 'b -> 'a) -> 'a -> 'b t -> 'a val fold_all_inputs : ('a -> in_key * 'b -> 'a) -> 'a -> 'b t -> 'a val fold_all_outputs : ('a -> out_key * 'b -> 'a) -> 'a -> 'b t -> 'a val pretty : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit val pretty_key : Format.formatter -> key -> unit val pretty_in_key : Format.formatter -> in_key -> unit val pretty_out_key : Format.formatter -> out_key -> unit end (** The keys can be used to identify an element of a function. Have a look at the type [t] to know which kind of elements can be identified.*) module Key : sig type key = private | SigKey of Signature.key (** key for an element of the function signature *) | VarDecl of Cil_types.varinfo (** variable declaration *) | Stmt of Cil_types.stmt (** any statement, except a call *) | CallStmt of Cil_types.stmt (** call statement *) | Label of Cil_types.stmt * Cil_types.label (** program label *) | SigCallKey of Cil_types.stmt * Signature.key (** key for an element of a call signature *) include Datatype.S with type t = key val param_key : int -> t val implicit_in_key : Locations.Zone.t -> t val entry_point : t val top_input : t val output_key : t val out_from_key : Locations.Zone.t -> t val decl_var_key : Cil_types.varinfo -> t val label_key : Cil_types.stmt -> Cil_types.label -> t val stmt_key : Cil_types.stmt -> t val call_key : Cil_types.stmt -> t val call_input_key : Cil_types.stmt -> int -> t val call_output_key : Cil_types.stmt -> Locations.Zone.t -> t val call_outret_key : Cil_types.stmt -> t val call_ctrl_key : Cil_types.stmt -> t val call_topin_key : Cil_types.stmt -> t val stmt : t -> Cil_types.stmt option val call_from_id : Cil_types.stmt -> Cil_types.stmt 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. *) module FctIndex : sig (** this type is used to build indexes between program objects and some information such as the PDG nodes or the slicing marks. - ['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 -> ('ni, 'ci) t val length : ('ni, 'ci) t -> int (** just copy the mapping *) 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 : ('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 : ('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 : ('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 : ('ni, 'ci) t -> Key.t-> 'ni list (** Similar to [find_info] for a label *) val find_label: ('ni, 'ci) t -> Cil_types.label -> 'ni (** find the information stored for the call and its signature *) 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 : ('ni, 'ci) t -> Cil_types.stmt -> 'ci val find_info_call_key : ('ni, 'ci) t -> Key.t -> 'ci val fold_calls : (Cil_types.stmt -> 'ci option * 'ni Signature.t -> 'c -> 'c) -> ('ni, 'ci) 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 : ('ni, 'ci) t -> Key.t-> 'ni -> unit (** store the information for the key. Replace the previously stored information if any. *) val add_or_replace : ('ni, 'ci) t -> Key.t-> 'ni -> unit val add_info_call : ('ni, 'ci) t -> Cil_types.stmt -> 'ci -> replace:bool -> unit val add_info_call_key : ('ni, 'ci) t -> Key.t -> 'ci -> replace:bool -> unit (** Structural destructor for unmarshaling *) val t_descr: ni:Structural_descr.t -> ci:Structural_descr.t -> Structural_descr.t end frama-c-Fluorine-20130601/src/pdg_types/pdgIndex.ml0000644000175000017500000005365512155630235020676 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 exception AddError exception CallStatement exception Not_equal let is_call_stmt stmt = match stmt.skind with Instr (Call _) -> true | _ -> false module Signature = struct type in_key = InCtrl | InNum of int | InImpl of Locations.Zone.t type out_key = OutRet | OutLoc of Locations.Zone.t type key = In of in_key | Out of out_key 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... :-? *) in_implicits : (Locations.Zone.t * 'info) list ; out_ret : 'info option ; outputs : (Locations.Zone.t * 'info) list } module Str_descr = struct open Structural_descr let in_key = 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 ; in_params = [] ; in_implicits = [] ; out_ret = None; outputs = [] } let in_key n = In (InNum n) let in_impl_key loc = In (InImpl loc) let in_top_key = in_impl_key (Locations.Zone.top) let in_ctrl_key = In InCtrl let out_ret_key = Out OutRet let out_key out = Out (OutLoc out) let mk_undef_in_key loc = InImpl loc let copy sgn = sgn (** InCtrl < InNum < InImpl *) let cmp_in_key k1 k2 = match k1, k2 with | (InImpl z1), (InImpl z2) when Locations.Zone.equal z1 z2 -> 0 | (InImpl _), (InImpl _) -> raise Not_equal | (InImpl _), _ -> 1 | _, (InImpl _) -> -1 | InNum n1, InNum n2 -> n1 - n2 | (InNum _), _ -> 1 | _, (InNum _) -> -1 | InCtrl, InCtrl -> 0 (** OutRet < OutLoc *) let cmp_out_key k1 k2 = match k1, k2 with | OutRet, OutRet -> 0 | OutRet, (OutLoc _) -> -1 | (OutLoc _), OutRet -> 1 | OutLoc l1, OutLoc l2 when Locations.Zone.equal l1 l2 -> 0 | OutLoc _, OutLoc _ -> raise Not_equal let equal_out_key k1 k2 = try (0 = cmp_out_key k1 k2) with Not_equal -> false (** add a mapping between [num] and [info] in [lst]. * if we already have something for [num], use function [merge] *) let add_in_list lst num info merge = let new_e = (num, info) in let rec add_to_l l = match l with [] -> [new_e] | (ne, old_e) as e :: tl -> if ne = num then let e = merge old_e info in (num, e)::tl else if ne < num then e :: (add_to_l tl) else new_e :: l in add_to_l lst let add_loc l_loc loc info merge = let rec add lst = match lst with | [] -> [(loc, info)] | (l, e)::tl -> if Locations.Zone.equal l loc then let new_e = merge e info in (loc, new_e)::tl else begin (* if (Locations.Zone.intersects l loc) then begin Format.printf "[pdg] implicit inputs intersect : %a and %a\n" Locations.Zone.pretty l Locations.Zone.pretty loc; assert false end; *) (l, e)::(add tl) end in add l_loc let add_replace replace _old_e new_e = if replace then new_e else raise AddError let add_input sgn n info ~replace = { sgn with in_params = add_in_list sgn.in_params n info (add_replace replace) } let add_impl_input sgn loc info ~replace = { sgn with in_implicits = add_loc sgn.in_implicits loc info (add_replace replace) } let add_output sgn loc info ~replace = { sgn with outputs = add_loc sgn.outputs loc info (add_replace replace) } let add_in_ctrl sgn info ~replace = let new_info = match sgn.in_ctrl with None -> info | Some old -> add_replace replace old info in { sgn with in_ctrl = Some new_info } let add_out_ret sgn info ~replace = let new_info = match sgn.out_ret with None -> info | Some old -> add_replace replace old info in { sgn with out_ret = Some new_info } let add_info sgn key info ~replace = match key with | In InCtrl -> add_in_ctrl sgn info replace | In (InNum n) -> add_input sgn n info replace | In (InImpl loc) -> add_impl_input sgn loc info replace | Out OutRet -> add_out_ret sgn info replace | Out (OutLoc k) -> add_output sgn k info replace let find_input sgn n = try assert (n <> 0); (* no input 0 : use find_in_ctrl *) List.assoc n sgn.in_params with Not_found -> raise Not_found let find_output sgn out_key = let rec find l = match l with | [] -> raise Not_found | (loc, e)::tl -> if Locations.Zone.equal out_key loc then e else find tl in find sgn.outputs let find_out_ret sgn = match sgn.out_ret with | Some i -> i | None -> raise Not_found let find_in_ctrl sgn = match sgn.in_ctrl with | Some i -> i | 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 Not_found | (in_loc, e)::tl -> if Locations.Zone.equal in_loc loc then e else find tl in find sgn.in_implicits let find_in_top sgn = find_implicit_input sgn Locations.Zone.top let find_in_info sgn in_key = match in_key with | InCtrl -> find_in_ctrl sgn | (InNum n) -> find_input sgn n | (InImpl loc) -> find_implicit_input sgn loc let find_out_info sgn out_key = match out_key with | OutRet -> find_out_ret sgn | (OutLoc k) -> find_output sgn k let find_info sgn key = match key with | In in_key -> find_in_info sgn in_key | Out out_key -> find_out_info sgn out_key let fold_outputs f acc sgn = List.fold_left f acc sgn.outputs let fold_all_outputs f acc sgn = let acc = match sgn.out_ret with | None -> acc | Some info -> f acc (OutRet, info) in List.fold_left (fun acc (k, i) -> f acc ((OutLoc k), i)) acc sgn.outputs let fold_num_inputs f acc sgn = List.fold_left f acc sgn.in_params let fold_impl_inputs f acc sgn = List.fold_left f acc sgn.in_implicits let fold_matching_impl_inputs loc f acc sgn = let test acc (in_loc, info) = if (Locations.Zone.intersects in_loc loc) then f acc (in_loc, info) else acc in List.fold_left test acc sgn.in_implicits let fold_all_inputs f acc sgn = let acc = match sgn.in_ctrl with | None -> acc | Some info -> f acc (InCtrl, info) in let acc = fold_num_inputs (fun acc (n, info) -> f acc ((InNum n), info)) acc sgn in fold_impl_inputs (fun acc (l, info) -> f acc ((InImpl l), info)) acc sgn let fold f acc sgn = let acc = fold_all_inputs (fun acc (n, info) -> f acc (In n, info)) acc sgn in fold_all_outputs (fun acc (n, info) -> f acc (Out n, info)) acc sgn let merge sgn1 sgn2 merge_info = let merge_elem lst (k, info) = add_in_list lst k info merge_info in let inputs = fold_num_inputs merge_elem sgn1.in_params sgn2 in let outputs = fold_outputs merge_elem sgn1.outputs sgn2 in let in_ctrl = match sgn1.in_ctrl, sgn2.in_ctrl with | None, _ -> sgn2.in_ctrl | _, None -> sgn1.in_ctrl | Some i1, Some i2 -> Some (merge_info i1 i2) in assert (sgn1.in_implicits = [] && sgn2.in_implicits = []); let out_ret = match sgn1.out_ret, sgn2.out_ret with | None, _ -> sgn2.out_ret | _, None -> sgn1.out_ret | Some i1, Some i2 -> Some (merge_info i1 i2) in { in_ctrl = in_ctrl; in_params = inputs ; in_implicits = [] ; out_ret = out_ret ; outputs = outputs } let pretty_in_key fmt key = match key with | (InNum n) -> Format.fprintf fmt "In%d" n | InCtrl -> Format.fprintf fmt "InCtrl" | InImpl loc -> Format.fprintf fmt "@[In(%a)@]" Locations.Zone.pretty loc let pretty_out_key fmt key = match key with | OutRet -> Format.fprintf fmt "OutRet" | OutLoc loc -> Format.fprintf fmt "@[Out(%a)@]" Locations.Zone.pretty loc let pretty_key fmt key = match key with | In in_key -> pretty_in_key fmt in_key | Out key -> pretty_out_key fmt key let pretty pp fmt sgn = let print _ (k,i) = Format.fprintf fmt "@[(%a:@ %a)@]" pretty_key k pp i in fold print () sgn end module Key = struct type key = | SigKey of Signature.key (** input/output nodes of the function *) | VarDecl of Cil_types.varinfo (** local, parameter or global variable definition *) | Stmt of Cil_types.stmt (** simple statement (not call) excluding its label (stmt.id) *) | CallStmt of Cil_types.stmt (** call statement *) | Label of stmt * Cil_types.label (** Labels are considered as function elements by themselves. *) | SigCallKey of Cil_types.stmt * Signature.key (** Key for an element of a call (input or output). * The call is identified by the statement. *) let entry_point = SigKey (Signature.in_ctrl_key) let top_input = SigKey (Signature.in_top_key) 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) (** this is for the nodes inside undefined functions *) let out_from_key loc = SigKey (Signature.out_key loc) let decl_var_key var = VarDecl var let label_key label_stmt label = Label (label_stmt,label) let call_key call = CallStmt call let stmt_key stmt = if is_call_stmt stmt then call_key stmt else Stmt stmt let call_input_key call n = SigCallKey (call, (Signature.in_key n)) let call_outret_key call = SigCallKey (call, (Signature.out_ret_key)) let call_output_key call loc = SigCallKey (call, (Signature.out_key loc)) let call_ctrl_key call = SigCallKey (call, (Signature.in_ctrl_key)) let call_topin_key call = SigCallKey (call, (Signature.in_top_key)) let call_from_id call_id = call_id let stmt key = match key with | SigCallKey (call, _) -> Some call | CallStmt call -> Some call | Stmt stmt -> Some stmt | Label (stmt, _) -> Some stmt | _ -> None (* see PrintPdg.pretty_key : can't be here because it uses Db... *) let pretty_node fmt k = let print_stmt fmt s = let str = match s.skind with | Switch (exp,_,_,_) | If (exp,_,_,_) -> Pretty_utils.to_string Printer.pp_exp exp | Loop _ -> "while(1)" | Block _ -> "block" | Goto _ | Break _ | Continue _ | Return _ | Instr _ -> Pretty_utils.sfprintf "@[%a@]" (Printer.without_annot Printer.pp_stmt) s | UnspecifiedSequence _ -> "unspecified sequence" | TryExcept _ | TryFinally _ -> "ERROR" in Format.fprintf fmt "%s" str in match k with | 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) -> Printer.pp_label fmt l | VarDecl v -> Format.fprintf fmt "VarDecl : %a" Printer.pp_varinfo v | SigKey k -> Signature.pretty_key fmt 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 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) 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 |]; [| Cil_datatype.Stmt.packed_descr |]; [| Cil_datatype.Stmt.packed_descr; Label.packed_descr |]; [| Cil_datatype.Stmt.packed_descr; p_key |]; |]) let rehash = Datatype.identity let pretty = pretty_node let mem_project = Datatype.never_any_project end) end (* [Key] restricted to [Stmt], [VarDecl] and [Label] constructors. Hash tables are built upon this type, and we currently have no full hash/equality function for [Key.t]. *) module RKey = struct include Key let hash = function | Key.VarDecl v -> 17 * Cil_datatype.Varinfo.hash v | Key.Stmt s -> 29 * Cil_datatype.Stmt.hash s | Key.Label (s, _l) -> (* Intentionnaly buggy: ignore the label and consider only the statement. There seems to be bug in the pdg, only one 'case :' per statement is present. This avoids removing the other 'case' clauses (see tests/slicing/switch.c *) 53 * Cil_datatype.Stmt.hash s (* 7 * Cil_datatype.Label.hash l *) | _ -> assert false let equal k1 k2 = match k1, k2 with | Key.VarDecl v1, Key.VarDecl v2 -> Cil_datatype.Varinfo.equal v1 v2 | Key.Stmt s1, Key.Stmt s2 -> Cil_datatype.Stmt.equal s1 s2 | Key.Label (s1, _l1), Key.Label (s2, _l2) -> (* See [hash] above *) Cil_datatype.Stmt.equal s1 s2 (* && Cil_datatype.Label.equal l1 l2 *) | _ -> false end module H = struct include Hashtbl.Make(RKey) let structural_descr = Structural_descr.t_hashtbl_unchanged_hashs (Descr.str RKey.descr) end module FctIndex = struct type ('node_info, 'call_info) t = { (** inputs and ouputs of the function *) mutable sgn : 'node_info Signature.t ; (** calls signatures *) mutable calls : (Cil_types.stmt * ('call_info option * 'node_info Signature.t)) list ; (** everything else *) other : 'node_info H.t } 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 [| Cil_datatype.Stmt.packed_descr; pack (t_tuple [| pack (t_option d_cinfo); pack (Signature.Str_descr.t d_ninfo); |]) |])); pack (H.structural_descr d_ninfo); |] let sgn idx = idx.sgn let create nb = { sgn = Signature.empty; calls = []; other = H.create nb } let copy idx = { sgn = Signature.copy idx.sgn; calls = idx.calls; other = H.copy idx.other } let merge_info_calls calls1 calls2 merge_a merge_b = let merge_info (b1, sgn1) (b2, sgn2) = let b = match b1, b2 with None, _ -> b2 | _, None -> b1 | Some b1, Some b2 -> Some (merge_b b1 b2) in let sgn = Signature.merge sgn1 sgn2 merge_a in (b, sgn) in let rec merge l1 l2 = match l1, l2 with | [], _ -> l2 | _, [] -> l1 | ((call1, info1) as c1) :: tl1, ((call2, info2) as c2) :: tl2 -> let id1 = call1.sid in let id2 = call2.sid in if id1 = id2 then let info = merge_info info1 info2 in (call1, info) :: (merge tl1 tl2) else if id1 < id2 then c1 :: (merge tl1 l2) else c2 :: (merge l1 tl2) in merge calls1 calls2 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 let add k a2 = let a = try let a1 = H.find table k in merge_a a1 a2 with Not_found -> a2 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 {sgn = sgn; calls = calls; other = table} let add_info_call idx call e ~replace = let sid = call.sid in let rec add l = match l with | [] -> [(call, (Some e, Signature.empty))] | ((call1, (_e1, sgn1)) as c1) :: tl -> let sid1 = call1.sid in if sid = sid1 then (if replace then (call, (Some e, sgn1)) :: tl else raise AddError) else if sid < sid1 then (call, (Some e, Signature.empty)) :: l else c1 :: (add tl) in idx.calls <- add idx.calls let add_info_call_key idx key = match key with | Key.CallStmt call -> add_info_call idx call | _ -> assert false let add_info_sig_call calls call k e replace = let new_sgn old = Signature.add_info old k e replace in let rec add l = match l with | [] -> [(call, (None, new_sgn Signature.empty))] | ((call1, (e1, sgn1)) as c1) :: tl -> let sid = call.sid in let sid1 = call1.sid in if sid = sid1 then (call, (e1, new_sgn sgn1)) :: tl else if sid < sid1 then (call, (None, new_sgn Signature.empty)) :: l else (c1 :: (add tl)) in add calls let find_call idx call = let rec find l = match l with | [] -> 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 Not_found else find tl in find idx.calls let find_call_key idx key = match key with | Key.CallStmt call -> find_call idx call | _ -> assert false let find_info_call idx call = let (e1, _sgn1) = find_call idx call in match e1 with Some e -> e | None -> raise Not_found let find_info_call_key idx key = match key with | Key.CallStmt call -> find_info_call idx call | _ -> assert false let find_info_sig_call idx call k = let (_e1, sgn1) = find_call idx call in Signature.find_info sgn1 k let find_all_info_sig_call idx call = let (_e1, sgn1) = find_call idx call in Signature.fold (fun l (_k,i) -> i::l) [] sgn1 let add_replace idx key e replace = let hfct = if replace then H.replace else H.add in match key with | Key.SigKey k -> idx.sgn <- Signature.add_info idx.sgn k e replace | Key.CallStmt _ -> raise CallStatement (* see add_info_call *) | 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 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 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 key with Not_found -> raise Not_found) let find_all idx key = match key with | Key.CallStmt call -> find_all_info_sig_call idx call | _ -> let info = find_info idx key in [info] let find_label idx lab = let collect k info res = match k with | Key.Label (_,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 Not_found | _ -> assert false let fold_calls f idx acc = let process acc (call, (_i, _sgn as i_sgn)) = f call i_sgn acc in List.fold_left process acc idx.calls 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 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 (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/ai/0000755000175000017500000000000012155634040015155 5ustar mehdimehdiframa-c-Fluorine-20130601/src/ai/base.ml0000644000175000017500000003243712155630234016433 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp type validity = | Known of Int.t * Int.t | Unknown of Int.t * Int.t option * Int.t (* begining, known end, unknown end *) | Periodic of Int.t * Int.t * Int.t | Invalid let pretty_validity fmt v = match v with | Unknown (b,k,e) -> Format.fprintf fmt "Unknown %a/%a/%a" Int.pretty b (Pretty_utils.pp_opt Int.pretty) k Int.pretty e | Known (b,e) -> Format.fprintf fmt "Known %a-%a" Int.pretty b Int.pretty e | Invalid -> Format.fprintf fmt "Invalid" | Periodic (b,e,p) -> Format.fprintf fmt "Periodic %a-%a (%a)" Int.pretty b Int.pretty e Int.pretty p module Validity = Datatype.Make (struct type t = validity let name = "Base.validity" let structural_descr = Structural_descr.Abstract let reprs = [ Known (Int.zero, Int.one) ] let equal = Datatype.undefined let compare = Datatype.undefined let hash = Datatype.undefined let pretty = pretty_validity let mem_project = Datatype.never_any_project let internal_pretty_code = Datatype.pp_fail let rehash = Datatype.identity let copy (x:t) = x let varname _ = "v" end) type string_id = Cil_types.exp type base = | Var of varinfo * validity | Initialized_Var of varinfo * validity (** base that is implicitly initialized. *) | Null (** base for addresses like [(int* )0x123] *) | String of int * string_id (** String constants *) let id = function | Var (vi,_) | Initialized_Var (vi,_) -> vi.vid | Null -> 0 | String (id,_) -> id let hash = id let null = Null let is_null x = match x with Null -> true | _ -> false let is_hidden_variable v = match v with Var (s,_) when s.vlogic -> true | _ -> false type cstring = CSString of string | CSWstring of Escape.wstring let get_string exp = match exp.enode with Const (CStr s) -> CSString s | Const (CWStr w) -> CSWstring w | _ -> assert false let pretty fmt t = match t with | String (_,{enode=Const (CStr s)}) -> Format.fprintf fmt "%S" s | String (_,{enode=Const (CWStr s)}) -> Format.fprintf fmt "L\"%s\"" (Escape.escape_wstring s) | String _ -> assert false | Var (t,_) | Initialized_Var (t,_) -> Printer.pp_varinfo fmt t | Null -> Format.pp_print_string fmt "NULL" let pretty_addr fmt t = ( match t with Var _ | Initialized_Var _ -> Format.fprintf fmt "&" | String _ | Null -> ()); pretty fmt t let compare v1 v2 = Datatype.Int.compare (id v1) (id v2) let typeof v = match v with | String (_,_) -> Some charConstPtrType | Null -> None | Var (v,_) | Initialized_Var (v,_) -> Some (unrollType v.vtype) let cstring_bitlength e = let u, l = match e with {enode=Const (CStr s)} -> 8 (* FIXME: CHAR_BIT *), (String.length s) | {enode=Const (CWStr s)} -> bitsSizeOf theMachine.wcharType, (List.length s) | _ -> assert false in Int.of_int (u*(succ l)) let bits_sizeof v = match v with | String (_,e) -> Int_Base.inject (cstring_bitlength e) | Null -> Int_Base.top | Var (v,_) | Initialized_Var (v,_) -> Bit_utils.sizeof_vid v let dep_absolute = [Kernel.AbsoluteValidRange.self] module MinValidAbsoluteAddress = State_builder.Ref (Abstract_interp.Int) (struct let name = "MinValidAbsoluteAddress" let dependencies = dep_absolute let default () = Abstract_interp.Int.zero end) module MaxValidAbsoluteAddress = State_builder.Ref (Abstract_interp.Int) (struct let name = "MaxValidAbsoluteAddress" let dependencies = dep_absolute let default () = Abstract_interp.Int.minus_one end) let () = Kernel.AbsoluteValidRange.add_set_hook (fun _ x -> try Scanf.sscanf x "%Li-%Li" (fun min max -> let mul8 = Int64.mul 8L in MinValidAbsoluteAddress.set (Abstract_interp.Int.of_int64 (mul8 min)); MaxValidAbsoluteAddress.set (Abstract_interp.Int.of_int64 (Int64.pred (mul8 (Int64.succ max))))) with End_of_file | Scanf.Scan_failure _ | Failure _ as e -> Kernel.abort "Invalid -absolute-valid-range integer-integer: each integer may be in decimal, hexadecimal (0x, 0X), octal (0o) or binary (0b) notation and has to hold in 64 bits. A correct example is -absolute-valid-range 1-0xFFFFFF0.@\nError was %S@." (Printexc.to_string e)) let min_valid_absolute_address = MinValidAbsoluteAddress.get let max_valid_absolute_address = MaxValidAbsoluteAddress.get let validity v = match v with | Null -> let mn = min_valid_absolute_address ()in let mx = max_valid_absolute_address () in if Integer.gt mx mn then Known (mn, mx) else Invalid | Var (_,v) | Initialized_Var (_,v) -> v | String _ -> let max_valid = bits_sizeof v in match max_valid with | Int_Base.Value size -> (* all start to be valid at offset 0 *) Known (Int.zero,Int.pred size) | Int_Base.Top -> Unknown (Int.zero, None, Bit_utils.max_bit_address ()) exception Not_valid_offset let is_read_only base = match base with String _ -> true | _ -> false (* TODO: completely const types *) let is_valid_offset ~for_writing size base offset = if for_writing && (is_read_only base) then raise Not_valid_offset; match validity base with | Invalid -> raise Not_valid_offset | Known (min_valid,max_valid) | Periodic (min_valid, max_valid, _) | Unknown (min_valid, Some max_valid, _) -> let min = Ival.min_int offset in begin match min with | None -> raise Not_valid_offset | Some min -> (* Format.printf "111 %a %a@." Int.pretty min_valid Int.pretty min; *) if Int.lt min min_valid then raise Not_valid_offset end; let max = Ival.max_int offset in begin match max with | None -> raise Not_valid_offset | Some max -> (*Format.printf "222 %a: mb %a, m %a, size %a@." pretty base Int.pretty max_valid Int.pretty max Int.pretty size;*) if Int.gt (Int.pred (Int.add max size)) max_valid then raise Not_valid_offset end | Unknown (_, None, _) -> raise Not_valid_offset let is_function base = match base with String _ | Null | Initialized_Var _ -> false | Var(v,_) -> isFunctionType v.vtype let equal v w = (id v) = (id w) let is_aligned_by b alignment = if Int.is_zero alignment then false else match b with Var (v,_) | Initialized_Var (v,_) -> Int.is_zero (Int.rem (Int.of_int (Cil.bytesAlignOf v.vtype)) alignment) | Null -> true | String _ -> Int.is_one alignment let is_any_formal_or_local v = match v with | Var (v,_) | Initialized_Var (v,_) -> not v.vlogic && not v.vglob | Null | String _ -> false let is_any_local v = match v with | Var (v,_) | Initialized_Var (v,_) -> not v.vlogic && not v.vglob && not v.vformal | Null | String _ -> false let is_global v = match v with | Var (v,_) | Initialized_Var (v,_) -> v.vglob | Null | String _ -> true let is_formal_or_local v fundec = match v with | Var (v,_) | Initialized_Var (v,_) -> Ast_info.Function.is_formal_or_local v fundec | Null | String _ -> false let is_formal_of_prototype v vi = match v with | Var (v,_) | Initialized_Var (v,_) -> Ast_info.Function.is_formal_of_prototype v vi | Null | String _ -> false let is_local v fundec = match v with | Var (v,_) | Initialized_Var (v,_) -> Ast_info.Function.is_local v fundec | Null | String _ -> false let is_formal v fundec = match v with | Var (v,_) | Initialized_Var (v,_) -> Ast_info.Function.is_formal v fundec | Null | String _ -> false let is_block_local v block = match v with | Var (v,_) | Initialized_Var (v,_) -> Ast_info.is_block_local v block | Null | String _ -> false let validity_from_type v = if isFunctionType v.vtype then Invalid else let max_valid = Bit_utils.sizeof_vid v in match max_valid with | Int_Base.Top -> Unknown (Int.zero, None, Bit_utils.max_bit_address ()) | Int_Base.Value size when Int.gt size Int.zero -> (*Format.printf "Got %a for %s@\n" Int.pretty size v.vname;*) Known (Int.zero,Int.pred size) | Int_Base.Value size -> assert (Int.equal size Int.zero); Unknown (Int.zero, None, Bit_utils.max_bit_address ()) exception Not_a_variable module BaseDatatype = struct include Datatype.Make_with_collections (struct type t = base let name = "Base" let structural_descr = Structural_descr.Abstract (* TODO better *) let reprs = [ Null ] let equal = equal let compare = compare let pretty = pretty let hash = hash let mem_project = Datatype.never_any_project let internal_pretty_code = Datatype.pp_fail let rehash = Datatype.identity let copy = Datatype.undefined let varname = Datatype.undefined end) let id = id end include BaseDatatype module Hptset = Hptset.Make (BaseDatatype) (struct let v = [ [ ] ] end) (struct let l = [ Ast.self ] end) let () = Ast.add_monotonic_state Hptset.self let () = Ast.add_hook_on_update Hptset.clear_caches module VarinfoLogic = Cil_state_builder.Varinfo_hashtbl (BaseDatatype) (struct let name = "Base.VarinfoLogic" let dependencies = [ Ast.self ] let size = 89 end) let () = Ast.add_monotonic_state VarinfoLogic.self let get_varinfo t = match t with | Var (t,_) | Initialized_Var (t,_) -> t | _ -> raise Not_a_variable let regexp = Str.regexp "Frama_C_periodic[^0-9]*\\([0-9]+\\)" let create_varinfo varinfo = assert (not varinfo.vlogic); let validity = validity_from_type varinfo in let name = varinfo.vname in let periodic period = Kernel.feedback ~current:true ~once:true "Periodic variable %s of period %d@." name period; match validity with | Known(mn, mx) -> assert (Int.is_zero mn); Periodic(mn, mx, Int.of_int period) | _ -> assert false in let validity = if Str.string_match regexp name 0 then let period = Str.matched_group 1 name in let period = int_of_string period in periodic period else match Cil.unrollType varinfo.vtype with | TArray (typ, _, _, attrs) when Cil.hasAttribute "Frama_C_periodic" varinfo.vattr || Cil.hasAttribute "Frama_C_periodic" attrs -> (try let size = Cil.bitsSizeOf typ in periodic size with Cil.SizeOfError _ -> validity) | _ -> validity in Var (varinfo, validity) module Validities = Cil_state_builder.Varinfo_hashtbl (BaseDatatype) (struct let name = "Base.Validities" let dependencies = [ Ast.self ] (* No dependency on Kernel.AbsoluteValidRange.self needed: the null base is not present in this table (not a varinfo) *) let size = 117 end) let () = Ast.add_monotonic_state Validities.self let create_varinfo = Validities.memo create_varinfo let create_logic varinfo validity = assert (varinfo.vlogic && not (VarinfoLogic.mem varinfo)); let base = Var (varinfo,validity) in VarinfoLogic.add varinfo base; base let create_initialized varinfo validity = assert varinfo.vlogic; let base = Initialized_Var (varinfo,validity) in VarinfoLogic.add varinfo base; base let find varinfo = if varinfo.vlogic then VarinfoLogic.find varinfo else create_varinfo varinfo module LiteralStrings = State_builder.Hashtbl (Datatype.Int.Hashtbl) (BaseDatatype) (struct let name = "litteral strings" let dependencies = [ Ast.self ] let size = 17 end) let () = Ast.add_monotonic_state LiteralStrings.self let create_string e = LiteralStrings.memo (fun _ -> String (Cil_const.new_raw_id (), e)) e.eid module SetLattice = Make_Hashconsed_Lattice_Set(BaseDatatype)(Hptset) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/ai/int_Base.mli0000644000175000017500000000404412155630234017407 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Big integers with an additional top element. *) type i = Top | Value of Integer.t include Datatype.S with type t = i val zero: t val one: t val minus_one: t val top: t val neg: t -> t val is_zero: t -> bool val is_top: t -> bool exception Error_Top val inject: Integer.t -> t val project: t -> Integer.t (** @raise Error_Top if the argument is {!Top}. *) val cardinal_zero_or_one: t -> bool (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/ai/abstract_interp.mli0000644000175000017500000001422512155630234021051 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Signatures for generic lattices, with functors providing generic implementations. *) exception Not_less_than (** Raised by {!Lattice.cardinal_less_than}. *) exception Is_not_included (** Generic lattice. @plugin development guide *) module type Lattice = sig exception Error_Top exception Error_Bottom include Datatype.S (** datatype of element of the lattice *) type widen_hint (** hints for the widening *) val join: t -> t -> t (** over-approximation of union *) val link: t -> t -> t (** under-approximation of union *) val meet: t -> t -> t (** under-approximation of intersection *) val narrow: t -> t -> t (** over-approximation of intersection *) val bottom: t (** the smallest *) val top: t (** the largest *) val is_included: t -> t -> bool val is_included_exn: t -> t -> unit val intersects: t -> t -> bool val widen: widen_hint -> t -> t -> t (** [widen h t1 t2] is an over-approximation of [join t1 t2]. Assumes [is_included t1 t2] *) val cardinal_zero_or_one: t -> bool val cardinal_less_than: t -> int -> int (** @raise Not_less_than whenever the cardinal of the given lattice is higher than the given integer. *) end module type Lattice_With_Diff = sig include Lattice val diff : t -> t -> t (** [diff t1 t2] is an over-approximation of [t1-t2]. *) val diff_if_one : t -> t -> t (** [diff t1 t2] is an over-approximation of [t1-t2]. @return t1 if [t2] is not a singleton. *) val fold_enum : split_non_enumerable:int -> (t -> 'a -> 'a) -> t -> 'a -> 'a val splitting_cardinal_less_than: split_non_enumerable:int -> t -> int -> int val pretty_debug : Format.formatter -> t -> unit end module type Lattice_Product = sig type t1 type t2 type tt = private Product of t1*t2 | Bottom include Lattice with type t = tt val inject : t1 -> t2 -> t val fst : t -> t1 val snd : t -> t2 end module type Lattice_Sum = sig type t1 type t2 type sum = private Top | Bottom | T1 of t1 | T2 of t2 include Lattice with type t = sum val inject_t1 : t1 -> t val inject_t2 : t2 -> t end module type Lattice_Base = sig type l type tt = private Top | Bottom | Value of l include Lattice with type t = tt val project : t -> l val inject: l -> t val transform: (l -> l -> l) -> tt -> tt -> tt end module type Lattice_Set = sig module O: Datatype.Set type tt = private Set of O.t | Top include Lattice with type t = tt and type widen_hint = O.t val inject_singleton: O.elt -> t val inject: O.t -> t val empty: t val apply2: (O.elt -> O.elt -> O.elt) -> (t -> t -> t) val apply1: (O.elt -> O.elt) -> (t -> t) val fold: ( O.elt -> 'a -> 'a) -> t -> 'a -> 'a val iter: ( O.elt -> unit) -> t -> unit val exists: (O.elt -> bool) -> t -> bool val for_all: (O.elt -> bool) -> t -> bool val project : t -> O.t val mem : O.elt -> t -> bool end module type LatValue = Datatype.S_with_collections module Int : sig include module type of Integer with type t = Integer.t include LatValue with type t := Integer.t val pretty : Format.formatter -> t -> unit val fold : (t -> 'a -> 'a) -> inf:t -> sup:t -> step:t -> 'a -> 'a end (** "Relative" integers. They are subtraction between two absolute integers *) module Rel : sig type t val pretty: t Pretty_utils.formatter val equal: t -> t -> bool val compare: t -> t -> int val hash: t -> int val zero: t val is_zero: t -> bool val sub : t -> t -> t val add_abs : Int.t -> t -> Int.t val sub_abs : Int.t -> Int.t -> t val pos_rem: t -> Int.t -> t val check: rem:t -> modu:Int.t -> bool end module Make_Lattice_Base (V : LatValue) : Lattice_Base with type l = V.t module Make_Lattice_Set (V : LatValue) : Lattice_Set with type O.elt=V.t module Make_Hashconsed_Lattice_Set (V : Hptset.Id_Datatype) (O: Hptset.S with type elt = V.t) : Lattice_Set with module O = O (** See e.g. base.ml and locations.ml to see how this functor should be applied. The [O] module passed as argument is the same as [O] in the result. It is passed here to avoid having multiple modules calling [Hptset.Make] on the same argument (which is not forbidden by the datatype library *) module type Collapse = sig val collapse : bool end (** If [C.collapse] then [L1.bottom,_] = [_,L2.bottom] = [bottom] *) (* Untested *) module Make_Lattice_Product (L1:Lattice) (L2:Lattice) (C:Collapse): Lattice_Product with type t1 = L1.t and type t2 = L2.t (* Untested *) module Make_Lattice_Sum (L1:Lattice) (L2:Lattice): (Lattice_Sum with type t1 = L1.t and type t2 = L2.t) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/ai/map_Lattice.ml0000644000175000017500000004512012155630234017734 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Maps from abstract keys to abstract values, that are equipped with the natural lattice interpretation. Keys must be mappable to integers in an unique way. *) open Abstract_interp module type Key = sig include Datatype.S val is_null : t -> bool val null : t val id : t -> int end module Make (K : Key) (Top_Param : Lattice_Set with type O.elt=K.t) (V : Lattice_With_Diff) (L: sig val v : (K.t * V.t) list list end) (Null_Behavior: sig val zone: bool end) = struct module M = Hptmap.Make (K) (V) (Hptmap.Comp_unused) (struct let v = [] :: [K.null,V.top]::L.v end) (struct let l = [ Ast.self ] end) (* TODO: this should be an argument of the functor *) let () = Ast.add_monotonic_state M.self module Top_Param = Top_Param type map_t = M.t type tt = Top of Top_Param.t * Origin.t | Map of map_t (* Invariant : [Top (s,_)] ok if [Top_Param.null] is not in [s] [Top (emptyset,_)] is injected to [Map (Null,Top)] *) type widen_hint = Top_Param.widen_hint * (K.t -> V.widen_hint) let top = Top(Top_Param.top, Origin.top) let hash v = match v with Map m -> (* let f k v acc = (V.hash v) + 11 * acc + 54971 * K.hash k in M.fold f m 3647 *) M.tag m | Top (bases, orig) -> Origin.hash orig + (299 * (Top_Param.hash bases)) let add_or_bottom k v m = if V.equal v V.bottom then M.remove k m else M.add k v m let bottom = Map M.empty let inject k v = Map (add_or_bottom k v M.empty) let top_int = inject K.null V.top let inject_top_origin origin t = if Null_Behavior.zone then Top (Top_Param.inject t, origin) else let s = Top_Param.O.remove K.null t in if Top_Param.O.is_empty s then top_int else Top (Top_Param.inject s, origin) let is_in_set ~set elt = (K.is_null elt && not Null_Behavior.zone) || Top_Param.O.mem elt set let pretty fmt m = match m with | Top (t, a) -> Format.fprintf fmt "@[{{ mix of %a.@ Origin: %a}}@]" Top_Param.pretty t Origin.pretty a | Map m -> Pretty_utils.pp_iter ~pre:"@[{{ " ~suf:" }}@]" ~sep:";@ " (fun pp map -> M.iter (fun k v -> pp (k, v)) map) (fun fmt (k, v) -> Format.fprintf fmt "%a -> %a" K.pretty k V.pretty v) fmt m let find_or_bottom k m = try M.find k m with Not_found -> V.bottom let split k m = match m with | Top (t,_) -> if Top_Param.is_included (Top_Param.inject_singleton k) t then V.top, m else V.bottom, m | Map m -> find_or_bottom k m, Map (M.remove k m) let inject_map m = Map m let get_bases map = (M.fold (fun k _ acc -> Top_Param.O.add k acc) map Top_Param.O.empty) exception Error_Bottom exception Error_Top let decide_none _k v = v let decide_some v1 v2 = V.join v1 v2 let equal m1 m2 = m1 == m2 || match m1, m2 with | Top (s, a), Top (s', a') -> Top_Param.equal s s' && Origin.equal a a' | Map m1, Map m2 -> M.equal m1 m2 | _ -> false let compare = if M.compare == Datatype.undefined || Top_Param.compare == Datatype.undefined || Origin.compare == Datatype.undefined then (Kernel.debug "%s map_lattice, missing comparison function: %b %b %b" M.name (M.compare == Datatype.undefined) (Top_Param.compare == Datatype.undefined) (Origin.compare == Datatype.undefined); Datatype.undefined) else fun m1 m2 -> if m1 == m2 then 0 else match m1, m2 with | Top _, Map _ -> -1 | Map _, Top _ -> 1 | Map m1, Map m2 -> M.compare m1 m2 | Top (s, a), Top (s', a') -> let r = Top_Param.compare s s' in if r = 0 then Origin.compare a a' else r let is_bottom b = equal b bottom let check_join_assert = ref 0 let join = let symetric_merge = M.symetric_merge ~cache:("map_Lattice",8192) ~decide_none ~decide_some in fun m1 m2 -> if m1 == m2 then m1 else let result = match m1, m2 with | Top(x1,a1), Top(x2,a2) -> Top(Top_Param.join x1 x2, Origin.join a1 a2) | Top (Top_Param.Top,_) as x, Map _ | Map _, (Top (Top_Param.Top,_) as x) -> x | Top (Top_Param.Set t,a), Map m | Map m, Top (Top_Param.Set t,a) -> inject_top_origin a (M.fold (fun k _ acc -> Top_Param.O.add k acc) m t) | Map mm1, Map mm2 -> let result = Map (symetric_merge mm1 mm2) in assert ( let n = succ !check_join_assert in check_join_assert := n; n land 63 <> 0 || (let merge_key k v acc = M.add k (V.join v (find_or_bottom k mm2)) acc in let r2 = Map (M.fold merge_key mm1 mm2) in if equal result r2 then true else begin Format.printf "Map_Lattice.join incorrect %a (%d;%x) %a (%d;%x) -> %a (%d;%x) %a (%d;%x)@." pretty m1 (hash m1) (Extlib.address_of_value m1) pretty m2 (hash m2) (Extlib.address_of_value m2) pretty result (hash result) (Extlib.address_of_value result) pretty r2 (hash r2) (Extlib.address_of_value r2); false; end)); result in (*Format.printf "Map_Lattice_join@\nm1=%a@\nm2=%a@\nm1Um2=%a@\n" pretty m1 pretty m2 pretty result;*) result let cached_fold ~cache ~temporary ~f ~projection ~joiner ~empty = let folded_f = M.cached_fold ~cache ~temporary ~f ~joiner ~empty in function m -> match m with Top (Top_Param.Top, _) -> raise Error_Top | Top (Top_Param.Set s, _) -> let f_base base acc = let total_itvs = projection base in joiner (f base total_itvs) acc in Top_Param.O.fold f_base s empty | Map mm -> folded_f mm let map_offsets f m = match m with | Top _ -> raise Error_Top | Map m -> Map (M.map f m) (** Over-approximation of the filter (in the case [Top Top])*) let filter_base f m = match m with | Top (t, a) -> (try inject_top_origin a (Top_Param.fold (fun v acc -> if f v then Top_Param.O.add v acc else acc) t Top_Param.O.empty) with Top_Param.Error_Top -> top) | Map m -> Map (M.fold (fun k _ acc -> if f k then acc else M.remove k acc) m m) let meet m1 m2 = if m1 == m2 then m1 else match m1, m2 with | Top (x1, a1), Top (x2, a2) -> let meet_topparam = Top_Param.meet x1 x2 in Top (meet_topparam, Origin.meet a1 a2) | Top (Top_Param.Top, _), (Map _ as x) | (Map _ as x),Top (Top_Param.Top, _) -> x | Top (Top_Param.Set set, _), (Map _ as x) | (Map _ as x), Top (Top_Param.Set set, _) -> filter_base (fun v -> is_in_set ~set v) x | Map m1, Map m2 -> let merge_key k v acc = add_or_bottom k (V.meet v (find_or_bottom k m2)) acc in Map (M.fold merge_key m1 M.empty) let narrow m1 m2 = let compute_origin_narrow x1 a1 x2 a2 = if Top_Param.equal x1 x2 then Origin.narrow a1 a2 (* equals a1 currently*) else if Top_Param.is_included x1 x2 then a1 else if Top_Param.is_included x2 x1 then a2 else Origin.top in let r = if m1 == m2 then m1 else match m1, m2 with | Top (x1, a1), Top (x2, a2) -> Top (Top_Param.narrow x1 x2, compute_origin_narrow x1 a1 x2 a2) | Top (Top_Param.Top, _), (Map _ as x) | (Map _ as x),Top (Top_Param.Top, _) -> x | Top (Top_Param.Set set, _), (Map _ as x) | (Map _ as x), Top (Top_Param.Set set, _) -> filter_base (fun v -> is_in_set ~set v) x | Map m1, Map m2 -> let merge_key k v acc = add_or_bottom k (V.narrow v (find_or_bottom k m2)) acc in Map (M.fold merge_key m1 M.empty) in (* Format.printf "Map_Lattice.narrow %a and %a ===> %a@\n" pretty x pretty y pretty r; *) r let widen wh = let (_, wh_k_v) = wh in let widen_map = let decide k v1 v2 = let v1 = match v1 with None -> V.bottom | Some v1 -> v1 in let v2 = match v2 with None -> V.bottom | Some v2 -> v2 in V.widen (wh_k_v k) v1 v2 in M.generic_merge ~cache:("map_Lattice.widen",0) ~decide in fun m1 m2 -> match m1, m2 with | _ , Top _ -> m2 | Top _, _ -> assert false (* m2 should be larger than m1 *) | Map m1, Map m2 -> Map (widen_map m1 m2) let equal m1 m2 = m1 == m2 || match m1, m2 with | Top (s, a), Top (s', a') -> Top_Param.equal s s' && Origin.equal a a' | Map m1, Map m2 -> M.equal m1 m2 | _ -> false let decide_fst _k _v = raise Is_not_included let decide_snd _k _v = () let decide_both = V.is_included_exn let is_included_exn = let map_is_included = M.generic_is_included Abstract_interp.Is_not_included ~cache:("map_Lattice",2048) ~decide_fst ~decide_snd ~decide_both in fun m1 m2 -> if (m1 != m2) then (* Format.printf "begin is_included_exn map_lattice@."; *) (match m1,m2 with | Top (s,a), Top (s',a') -> Top_Param.is_included_exn s s' ; Origin.is_included_exn a a' | Map _, Top (Top_Param.Top, _) -> () | Map m, Top (Top_Param.Set set, _) -> M.iter (fun k _ -> if not (is_in_set ~set k) then raise Is_not_included) m | Top _, Map _ -> raise Is_not_included | Map m1, Map m2 -> map_is_included m1 m2) let check_is_included_assert = ref 0 let is_included m1 m2 = let new_ = try is_included_exn m1 m2; true with Is_not_included -> false in assert (let n = succ !check_is_included_assert in check_is_included_assert := n; n land 63 <> 0 || (let mee = meet m1 m2 in let eq = equal mee m1 in if (eq <> new_) then begin Format.printf "Map_Lattice.is_included is wrong. Args: %a(h=%d) %a(h=%d) resultnew = %b meet = %a(h=%d)@." pretty m1 (match m1 with Map m -> M.hash_debug m | _ -> 0) pretty m2 (match m2 with Map m -> M.hash_debug m | _ -> 0) new_ pretty mee (match mee with Map m -> M.hash_debug m | _ -> 0); false end else true)); new_ (* under-approximation of union *) let link m1 m2 = if is_included m1 m2 then m2 (* exact *) else if is_included m2 m1 then m1 (* exact *) else match m1, m2 with | Top _, Map _ -> m1 (* may be approximated *) | Map _, Top _ -> m2 (* may be approximated *) | Top (s,_), Top (s',_) -> if Top_Param.is_included s s' then m2 (* may be approximated *) else if Top_Param.is_included s' s then m1 (* may be approximated *) else m1 (* very approximated *) | Map mm1, Map mm2 -> let map = M.fold (fun k v1 acc -> let v2 = find_or_bottom k mm2 in let link_v = V.link v1 v2 in M.add k link_v acc) mm1 mm2 in Map map let intersects = let map_intersects = M.generic_symetric_existential_predicate Hptmap.Found_inter M.do_it_intersect ~decide_one:(fun _ _ -> ()) ~decide_both:(fun x y -> if V.intersects x y then raise Hptmap.Found_inter) in fun mm1 mm2 -> match mm1, mm2 with | Top (_,_), Top (_,_) -> true | Top _, (Map _ as m) | (Map _ as m), Top _ -> not (equal m bottom) | Map m1, Map m2 -> try map_intersects m1 m2; false with Hptmap.Found_inter -> true (** if there is only one key [k] in map [m], then returns the pair [k,v] where [v] is the value associated to [k]. @raise Not_found otherwise. *) let find_lonely_key m = match m with | Top _ -> raise Not_found | Map m -> let elt = ref None in let check_one k v already_seen = if already_seen then raise Not_found else begin elt := Some (k,v); true end in ignore (M.fold check_one m false); match !elt with | None -> raise Not_found | Some v -> v (** if there is only one binding [k -> v] in map [m] (that is, only one key [k] and [cardinal_zero_or_one v]), returns the pair [k,v]. @raise Not_found otherwise *) let find_lonely_binding m = let _,v as pair = find_lonely_key m in if not (V.cardinal_zero_or_one v) then raise Not_found else pair let cardinal_zero_or_one m = equal m bottom || try let _,_ = find_lonely_binding m in true with Not_found -> false (** the cardinal of a map [m] is the sum of the cardinals of the values bound to a key in [m] *) let cardinal_less_than m n = match m with | Top _ -> raise Not_less_than | Map m -> M.fold (fun _base v card -> card + V.cardinal_less_than v (n-card)) m 0 let splitting_cardinal_less_than ~split_non_enumerable m n = match m with | Top _ -> raise Not_less_than | Map m -> M.fold (fun _base v card -> card + (V.splitting_cardinal_less_than ~split_non_enumerable v (n-card) )) m 0 let diff_if_one m1 m2 = match m1 with | Top _ -> m1 | Map mm1 -> try let k2,v2 = find_lonely_binding m2 in let v1 = find_or_bottom k2 mm1 in let v = V.diff_if_one v1 v2 in Map (add_or_bottom k2 v mm1) with Not_found -> m1 let diff m1 m2 = match m1, m2 with | Top _, _ | _, Top _ -> m1 | Map mm1, Map mm2 -> let result = M.fold (fun k v1 acc -> let dif = try let v2 = M.find k mm2 in (V.diff v1 v2) with Not_found -> v1 in add_or_bottom k dif acc) mm1 M.empty in Map result let map_i f m = match m with | Top _ -> top | Map m -> M.fold (fun k vl acc -> join acc (f k vl)) m bottom let fold_bases f m acc = match m with Top(Top_Param.Set t, _) -> let acc = if Null_Behavior.zone then acc else f K.null acc in (Top_Param.O.fold f t acc) | Top(Top_Param.Top, _) -> raise Error_Top | Map m -> M.fold (fun k _ acc -> f k acc) m acc (** [fold_i f m acc] folds [f] on the bindings in [m]. @raise Error_Top if [m] is too imprecise for folding. *) let fold_i f m acc = match m with Top(Top_Param.Set _, _) -> (* In this function, we refuse to iterate on the bases of a value Top(Top_Param.Set _,_) *) raise Error_Top | Top(Top_Param.Top, _) -> raise Error_Top | Map m -> M.fold f m acc let fold_topset_ok f m acc = match m with Top(Top_Param.Set t, _) -> let acc = if Null_Behavior.zone then acc else f K.null V.top acc in Top_Param.O.fold (fun x acc -> f x V.top acc) t acc | Top(Top_Param.Top, _) -> raise Error_Top | Map m -> M.fold f m acc let fold_enum ~split_non_enumerable f m acc = match m with | Top _ -> raise Error_Top | Map m -> try M.fold (fun k vl acc -> let g one_ival acc = let one_loc = inject k one_ival in f one_loc acc in V.fold_enum ~split_non_enumerable g vl acc) m acc with V.Error_Top -> raise Error_Top include Datatype.Make_with_collections (struct type t = tt let name = M.name ^ " map_lattice" let structural_descr = Structural_descr.Structure (Structural_descr.Sum [| [| Top_Param.packed_descr; Structural_descr.p_abstract |]; [| M.packed_descr |] |]) let reprs = List.map (fun m -> Map m) M.reprs let equal = equal let compare = compare let hash = hash let rehash = Datatype.identity let copy = Datatype.undefined let internal_pretty_code = Datatype.pp_fail let pretty = pretty let mem_project = Datatype.never_any_project let varname = Datatype.undefined end) let clear_caches = M.clear_caches end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/ai/int_Base.ml0000644000175000017500000000621012155630234017233 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp type i = Top | Value of Integer.t let equal i1 i2 = match i1, i2 with | Top, Top -> true | Value i1, Value i2 -> Integer.equal i1 i2 | Top, Value _ | Value _, Top -> false let compare i1 i2 = match i1, i2 with | Top, Top -> 0 | Value i1, Value i2 -> Integer.compare i1 i2 | Top, Value _ -> -1 | Value _, Top -> 1 let hash = function | Top -> 37 | Value i -> Integer.hash i let pretty fmt = function | Top -> Format.fprintf fmt "Top" | Value i -> Format.fprintf fmt "<%a>" Int.pretty i include Datatype.Make (struct type t = i (*= Top | Value of Integer.t *) let name = "Int_Base.t" let structural_descr = Structural_descr.Structure (Structural_descr.Sum [| [| Datatype.Big_int.packed_descr |] |]) let reprs = Top :: List.map (fun v -> Value v) Datatype.Big_int.reprs let equal = equal let compare = compare let hash = hash let rehash = Datatype.identity let copy = Extlib.id let internal_pretty_code = Datatype.undefined let pretty = pretty let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) let minus_one = Value Int.minus_one let one = Value Int.one let zero = Value Int.zero let is_zero x = equal x zero let top = Top let is_top v = (v = Top) let neg x = match x with | Value v -> Value (Int.neg v) | Top -> x let inject i = Value i exception Error_Top let project = function | Top -> raise Error_Top | Value i -> i let cardinal_zero_or_one = function | Top -> false | Value _ -> true (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/ai/lattice_Interval_Set.mli0000644000175000017500000000574412155630234021777 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Sets of disjoint intervals with a lattice structure. Consecutive intervals are automatically fused. Current implementation uses a sorted list. *) open Abstract_interp type itv = Int.t * Int.t module Int_Intervals : sig include Lattice_With_Diff val id: t -> int val is_top: t -> bool val inject_bounds: Int.t -> Int.t -> t val inject: itv list -> t val from_ival_size: Ival.t -> Int_Base.t -> t (** Conversion from an ival, which represents the beginning of each interval. The size if taken from the [Int_Base.t] argument. If the result contains more than [-plevel] arguments, it is automatically approximated. *) exception Not_a_set val project_set: t -> itv list (** may raise [Not_a_set] *) val project_singleton: t -> itv option (** Iterators *) val fold: (itv -> 'a -> 'a) -> t -> 'a -> 'a val pretty_typ: Cil_types.typ option -> t Pretty_utils.formatter (** Pretty-printer that supposes the intervals are subranges of a C type, and use the type to print nice offsets *) val compare_itvs: t -> t -> int (** Comparison that lifts the standard order between two intervals to lattices. If you want constant-time comparison, use [compare]. *) end (**/**) (* This is automatically set by the Value plugin. Do not call. *) val plevel: int ref (**/**) (* Local Variables: compile-command: "make -C ../.. byte" End: *) frama-c-Fluorine-20130601/src/ai/lattice_Interval_Set.ml0000644000175000017500000004101312155630234021613 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp module V = Int module Interval = Datatype.Pair(V)(V) type itv = Interval.t let plevel = ref 200 module Unhashconsed_Int_Intervals = struct exception Error_Top exception Error_Bottom type tt = Top | Set of itv list type widen_hint = unit let bottom = Set [] let top = Top let _check t = assert ( match t with | Top -> true | Set s -> let last_stop = ref None in List.for_all (fun (a,b) -> V.compare a b <= 0 && match !last_stop with None -> last_stop := Some b; true | Some l -> last_stop := Some b; V.gt a l) s) ; t let hash l = match l with | Top -> 667 | Set l -> List.fold_left (fun acc p -> 371 * acc + Interval.hash p) 443 l let cardinal_zero_or_one v = match v with | Top -> false | Set [x,y] -> V.equal x y | Set _ -> false let cardinal_less_than v n = match v with | Top -> raise Not_less_than | Set l -> let nn = V.of_int n in let rec aux l card = match l with | [] -> card | (x,y)::t -> let card = V.add card (V.length x y) in if V.gt card nn then raise Not_less_than else aux t card in V.to_int (aux l V.zero) let splitting_cardinal_less_than ~split_non_enumerable:_ _v _n = assert false (* not implemented *) let compare e1 e2 = if e1 == e2 then 0 else match e1,e2 with | Top,_ -> 1 | _, Top -> -1 | Set e1, Set e2 -> Extlib.list_compare Interval.compare e1 e2 let equal e1 e2 = compare e1 e2 = 0 let pretty fmt t = match t with | Top -> Format.fprintf fmt "TopISet" | Set s -> if s==[] then Format.fprintf fmt "BottomISet" else Pretty_utils.pp_iter ~pre:"@[{" ~suf:"}@]" ~sep:";@ " List.iter (fun fmt (b,e) -> Format.fprintf fmt "[%a..%a]" V.pretty b V.pretty e) fmt s let widen () t1 t2 = if equal t1 t2 then t1 else top let meet v1 v2 = if v1 == v2 then v1 else (match v1,v2 with | Top, v | v, Top -> v | Set s1 , Set s2 -> Set ( let rec aux acc (l1:itv list) (l2:itv list) = match l1,l2 with | [],_|_,[] -> List.rev acc | (((b1,e1)) as i1)::r1, (((b2,e2)) as i2)::r2 -> let c = V.compare b1 b2 in if c = 0 then (* intervals start at the same value *) let ce = V.compare e1 e2 in if ce=0 then aux ((b1,e1)::acc) r1 r2 (* same intervals *) else (* one interval is included in the other *) let min,not_min,min_tail,not_min_tail = if ce > 0 then i2,i1,r2,r1 else i1,i2,r1,r2 in aux ((min)::acc) min_tail ((( (snd (min), snd (not_min)))):: not_min_tail) else (* intervals start at different values *) let _min,min_end,not_min_begin,min_tail,not_min_from = if c > 0 then b2,e2,b1,r2,l1 else b1,e1,b2,r1,l2 in let c_min = V.compare min_end not_min_begin in if c_min >= 0 then (* intersecting intervals *) aux acc (( (not_min_begin,min_end)) ::min_tail) not_min_from else (* disjoint intervals *) aux acc min_tail not_min_from in aux [] s1 s2)) let join v1 v2 = if v1 == v2 then v1 else (match v1,v2 with | Top, _ | _, Top -> Top | Set (s1:itv list) , Set (s2:itv list) -> let rec aux (l1:itv list) (l2:itv list) = match l1,l2 with | [],l|l,[] -> l | (b1,e1)::r1,(b2,e2)::r2 -> let c = V.compare b1 b2 in let min_begin,min_end,min_tail,not_min_from = if c >= 0 then b2,e2,r2,l1 else b1,e1,r1,l2 in let rec enlarge_interval stop l1 look_in_me = match look_in_me with | [] -> stop,l1,[] | ((b,e))::r -> if V.compare stop (V.pred b) >= 0 then if V.compare stop e >= 0 then enlarge_interval stop l1 r else enlarge_interval e r l1 else stop,l1,look_in_me in let stop,new_l1,new_l2 = enlarge_interval min_end min_tail not_min_from in ((min_begin,stop)):: (aux new_l1 new_l2) in Set (aux s1 s2)) let inject l = (Set l) let inject_one ~size ~value = (inject [value,V.add value (V.pred size)]) let inject_bounds min max = if V.le min max then inject [min,max] else bottom let is_included t1 t2 = (t1 == t2) || match t1,t2 with | _,Top -> true | Top,_ -> false | Set s1,Set s2 -> let rec aux l1 l2 = match l1 with | [] -> true | i::r -> let rec find (b,e as arg) l = match l with | [] -> raise Not_found | (b',e')::r -> if V.compare b b' >= 0 && V.compare e' e >= 0 then l else if V.compare e' b >= 0 then raise Not_found else find arg r in try aux r (find i l2) with Not_found -> false in aux s1 s2 let link t1 t2 = join t1 t2 (* join is in fact an exact union *) let is_included_exn v1 v2 = if not (is_included v1 v2) then raise Is_not_included let intersects t1 t2 = let m = meet t1 t2 in not (equal m bottom) let fold f v acc = match v with | Top -> raise Error_Top | Set s -> List.fold_right f s acc let narrow = meet include Datatype.Make (struct type t = tt let name = Interval.name ^ " lattice_interval_set" let structural_descr = Structural_descr.Structure (Structural_descr.Sum [| [| Structural_descr.pack (Structural_descr.t_list (Descr.str Interval.descr)) |] |]) let reprs = Top :: List.map (fun o -> Set [ o ]) Interval.reprs let equal = equal let compare = compare let hash = hash let rehash = Datatype.identity let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = pretty let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) let () = Type.set_ml_name ty None let fold_enum ~split_non_enumerable:_ _f _v _acc = assert false let pretty_typ typ fmt i = let typ = match typ with Some t -> t | None -> Cil_types.TArray (Cil_types.TInt(Cil_types.IUChar,[]), Some (Cil.kinteger64 ~loc:(Cil.CurrentLoc.get ()) Cil_types.IULongLong (Integer.of_int64 922337203685477580L) (* See Cuoq for rational *)), Cil.empty_size_cache (), []) in match i with | Top -> Format.fprintf fmt "[..]" | Set s -> if s=[] then Format.fprintf fmt "BottomISet" else begin let pp_one fmt (b,e)= assert (Int.le b e) ; ignore (Bit_utils.pretty_bits typ ~use_align:false ~align:Rel.zero ~rh_size:Int.one ~start:b ~stop:e fmt) in let pp_stmt fmt r = Format.fprintf fmt "%a;@ " pp_one r in match s with | [] -> Format.pp_print_string fmt "{}" | [r] -> pp_one fmt r | s -> Format.fprintf fmt "@[{" ; List.iter (pp_stmt fmt) s ; Format.fprintf fmt "}@]" ; end let from_ival_size_aux ival size = let max_elt_int = !plevel in let max_elt = Int.of_int max_elt_int in let add_offset x acc = join (inject_one ~value:x ~size) acc in match ival with | Ival.Top(None, _, _, _) | Ival.Top(_, None, _, _) | Ival.Float _ -> top | Ival.Top(Some mn, Some mx, _r, m) -> if Int.le m size then inject_one ~value:mn ~size:(Int.add (Int.sub mx mn) size) else let elts = Int.native_div (Int.sub mx mn) m in if Int.gt elts max_elt then begin (* too many elements to enumerate *) Kernel.result ~once:true ~current:true "more than %d(%a) elements to enumerate. Approximating." max_elt_int Int.pretty elts; inject_bounds mn (Int.pred (Int.add mx size)) end else Int.fold add_offset ~inf:mn ~sup:mx ~step:m bottom | Ival.Set(s) -> Array.fold_right add_offset s bottom let from_ival_size ival size = match size with | Int_Base.Top -> top | Int_Base.Value int -> from_ival_size_aux ival int let diff x y = if x == y then bottom else ( match x, y with | _, Top -> bottom | Top, _ -> Top | Set sx , Set sy -> Set ( let rec aux acc (l1:itv list) (l2:itv list) = match l1 with | [] -> List.rev acc (* nothing left *) | (l, u as itv)::tail -> let rec relevant_rhs rhs = match rhs with | (_, ur) :: tail when Int.lt ur l-> relevant_rhs tail | _ -> rhs in let l2 = relevant_rhs l2 in match l2 with [] -> List.rev_append acc l1 (* nothing left to remove *) | (lr, ur) :: _ -> if Int.lt u lr then aux (itv :: acc) tail l2 else let l1 = if Int.lt ur u then (Int.succ ur, u) :: tail else tail in let acc = if Int.lt l lr then (l, Int.pred lr) :: acc else acc in aux acc l1 l2 in aux [] sx sy)) end module Int_Intervals = struct type tt = { h:int; v: Unhashconsed_Int_Intervals.t; tag:int } type widen_hint = Unhashconsed_Int_Intervals.widen_hint exception Error_Bottom = Unhashconsed_Int_Intervals.Error_Bottom exception Error_Top = Unhashconsed_Int_Intervals.Error_Top let id { tag=id } = id let pretty_debug fmt x = Unhashconsed_Int_Intervals.pretty fmt x.v let pretty = pretty_debug let hash_internal {h=h} = h let equal_internal {v=v;h=h} {v=v';h=h'} = h = h' && Unhashconsed_Int_Intervals.equal v v' let name = "int_intervals" module IntIntervalsHashtbl = Buckx.MakeBig (struct type t = tt let equal = equal_internal let hash = hash_internal let pretty = pretty let id = name end) let table = IntIntervalsHashtbl.create 139 let current_tag = ref 0 ;; let wrap x = let tag = !current_tag in let new_i = { h = Unhashconsed_Int_Intervals.hash x; v = x; tag = tag} in let result = IntIntervalsHashtbl.merge table new_i in if result == new_i then current_tag := succ tag; result (* initial values go here *) let top = wrap Unhashconsed_Int_Intervals.top let bottom = wrap Unhashconsed_Int_Intervals.bottom (* end of initial values *) let compare_itvs i1 i2 = Unhashconsed_Int_Intervals.compare i1.v i2.v (* Purely for implementation purposes, nothing to do with the ordering induced by the underlying lattice *) let compare i1 i2 = Datatype.Int.compare i1.tag i2.tag include Datatype.Make (struct type t = tt let structural_descr = Structural_descr.t_record [| Structural_descr.p_int; Unhashconsed_Int_Intervals.packed_descr; Structural_descr.p_int |] let reprs = [ top; bottom ] let name = "Lattice_Interval_Set.Int_Intervals" let compare = compare let equal = ( == ) let copy = Datatype.undefined let hash x = x.h let rehash x = wrap x.v let internal_pretty_code = Datatype.undefined let pretty = pretty let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) let fold_enum ~split_non_enumerable f v acc = Unhashconsed_Int_Intervals.fold_enum ~split_non_enumerable f v.v acc let diff_if_one _ = assert false let diff x y = wrap (Unhashconsed_Int_Intervals.diff x.v y.v) let cardinal_less_than x n = Unhashconsed_Int_Intervals.cardinal_less_than x.v n let splitting_cardinal_less_than ~split_non_enumerable x n = Unhashconsed_Int_Intervals.splitting_cardinal_less_than ~split_non_enumerable x.v n let meet x y = wrap (Unhashconsed_Int_Intervals.meet x.v y.v) let link x y = wrap (Unhashconsed_Int_Intervals.link x.v y.v) let join x y = wrap (Unhashconsed_Int_Intervals.join x.v y.v) let narrow x y = wrap (Unhashconsed_Int_Intervals.narrow x.v y.v) let widen wh x y = wrap (Unhashconsed_Int_Intervals.widen wh x.v y.v) (* THERE IS ONLY ONE HASHCONSING TABLE FOR Int_intervals. IT IS SHARED BETWEEN PROJECTS *) let cardinal_zero_or_one x = Unhashconsed_Int_Intervals.cardinal_zero_or_one x.v let intersects x y = Unhashconsed_Int_Intervals.intersects x.v y.v let is_included x y = Unhashconsed_Int_Intervals.is_included x.v y.v let is_included_exn x y = Unhashconsed_Int_Intervals.is_included_exn x.v y.v let inject i = wrap (Unhashconsed_Int_Intervals.inject i) let pretty_typ typ fmt x = Unhashconsed_Int_Intervals.pretty_typ typ fmt x.v let from_ival_size iv s = wrap (Unhashconsed_Int_Intervals.from_ival_size iv s) let fold f x acc = Unhashconsed_Int_Intervals.fold f x.v acc let is_top x = equal x top exception Not_a_set let project_set x = match x.v with Unhashconsed_Int_Intervals.Top -> raise Not_a_set | Unhashconsed_Int_Intervals.Set s -> s let project_singleton x = match x.v with | Unhashconsed_Int_Intervals.Top -> None | Unhashconsed_Int_Intervals.Set [e] -> Some e | Unhashconsed_Int_Intervals.Set _ -> None let inject_bounds b e = wrap (Unhashconsed_Int_Intervals.inject_bounds b e) end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/ai/ival.mli0000644000175000017500000002614612155630234016625 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Arithmetic lattices. The interfaces of this module may change between Frama-C versions. Contact us if you need stable APIs. @plugin development guide *) module F : sig type t val of_float : float -> t val to_float : t -> float exception Nan_or_infinite val equal : t -> t -> bool val pretty : Format.formatter -> t -> unit val pretty_normal : use_hex:bool -> Format.formatter -> t -> unit end exception Can_not_subdiv module Float_abstract : sig type t exception Nan_or_infinite exception Bottom type rounding_mode = Any | Nearest_Even (** [inject] creates an abstract float interval. Does not handle infinites. Does not enlarge subnormals to handle flush-to-zero modes *) val inject : F.t -> F.t -> t (** [inject_r] creates an abstract float interval. It handles infinites and flush-to-zero. the returned boolean is true if there was reduction *) val inject_r : F.t -> F.t -> bool * t val inject_singleton : F.t -> t val min_and_max_float : t -> F.t * F.t val top : t val add_float : rounding_mode -> t -> t -> bool * t val sub_float : rounding_mode -> t -> t -> bool * t val mult_float : rounding_mode -> t -> t -> bool * t val div_float : rounding_mode -> t -> t -> bool * t val contains_zero : t -> bool val compare : t -> t -> int val pretty : Format.formatter -> t -> unit val hash : t -> int val zero : t val is_zero : t -> bool (* val rounding_inject : F.t -> F.t -> t *) val is_included : t -> t -> bool val join : t -> t -> t val meet : t -> t -> t val contains_a_zero : t -> bool val is_singleton : t -> bool val neg_float : t -> t val sqrt_float : rounding_mode -> t -> bool * t val minus_one_one : t val cos_float : t -> t val cos_float_precise : t -> t val sin_float : t -> t val sin_float_precise : t -> t val exp_float : t -> t val widen : t -> t -> t val equal_float_ieee : t -> t -> bool * bool val maybe_le_ieee_float : t -> t -> bool val maybe_lt_ieee_float : t -> t -> bool val diff : t -> t -> t val filter_le : bool -> typ_loc:Cil_types.typ -> t -> t -> t val filter_ge : bool -> typ_loc:Cil_types.typ -> t -> t -> t val filter_lt : bool -> typ_loc:Cil_types.typ -> t -> t -> t val filter_gt : bool -> typ_loc:Cil_types.typ -> t -> t -> t end module O : sig type elt = Abstract_interp.Int.t type t val empty : t val is_empty : t -> bool val mem : elt -> t -> bool val add : elt -> t -> t val singleton : elt -> t val remove : elt -> t -> t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val subset : t -> t -> bool val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val filter : (elt -> bool) -> t -> t val partition : (elt -> bool) -> t -> t * t val cardinal : t -> int val elements : t -> elt list val min_elt : t -> elt val max_elt : t -> elt val choose : t -> elt val split : elt -> t -> t * bool * t end type tt = private | Set of Abstract_interp.Int.t array | Float of Float_abstract.t | Top of Abstract_interp.Int.t option * Abstract_interp.Int.t option * Abstract_interp.Int.t * Abstract_interp.Int.t module Widen_Hints : sig include SetWithNearest.S with type elt = Integer.t val default_widen_hints: t end exception Error_Top exception Error_Bottom include Datatype.S with type t = tt type widen_hint = Widen_Hints.t val join : t -> t -> t val link : t -> t -> t val meet : t -> t -> t val narrow : t -> t -> t val bottom : t val top : t val is_bottom : t -> bool val is_included : t -> t -> bool val is_included_exn : t -> t -> unit val intersects : t -> t -> bool val partially_overlaps : Abstract_interp.Int.t -> t -> t -> bool val widen : widen_hint -> t -> t -> t val fold_enum : split_non_enumerable:int -> (t -> 'a -> 'a) -> t -> 'a -> 'a val diff : t -> t -> t val diff_if_one : t -> t -> t val add_int : t -> t -> t val neg : t -> t val sub : t -> t -> t val min_int : t -> Abstract_interp.Int.t option (** A [None] result means the argument is unbounded. *) val max_int : t -> Abstract_interp.Int.t option (** A [None] result means the argument is unbounded. *) val min_max_r_mod : t -> Abstract_interp.Int.t option * Abstract_interp.Int.t option * Abstract_interp.Int.t * Abstract_interp.Int.t val min_and_max : t -> Abstract_interp.Int.t option * Abstract_interp.Int.t option val bitwise_and : size:int -> signed:bool -> t -> t -> t val bitwise_or : size:int -> t -> t -> t val bitwise_xor : t -> t -> t val min_and_max_float : t -> F.t * F.t val inject_range : Abstract_interp.Int.t option -> Abstract_interp.Int.t option -> t (** [None] means unbounded. The interval is inclusive. *) val cardinal_zero_or_one : t -> bool val is_singleton_int : t -> bool val inject_singleton : Abstract_interp.Int.t -> t val zero : t val one : t val compare_min_float : t -> t -> int val compare_max_float : t -> t -> int val compare_min_int : t -> t -> int val compare_max_int : t -> t -> int val is_zero : t -> bool val is_one : t -> bool val inject_float : Float_abstract.t -> t val inject_float_interval : float -> float -> t val top_float : t val top_single_precision_float : t val project_float : t -> Float_abstract.t (** @raise F.Nan_or_infinite when the float is Nan or infinite. *) val force_float: Cil_types.fkind -> t -> bool * t val in_interval : Abstract_interp.Int.t -> Abstract_interp.Int.t option -> Abstract_interp.Int.t option -> Abstract_interp.Int.t -> Abstract_interp.Int.t -> bool val contains_zero : t -> bool exception Not_Singleton_Int val project_int : t -> Abstract_interp.Int.t (** @raise Not_Singleton_Int when the cardinal of the argument is not 1. *) val cardinal_less_than : t -> int -> int (** [cardinal_less_than t n] returns the cardinal of [t] is this cardinal is at most [n]. @raise Abstract_interp.Not_less_than is the cardinal of [t] is more than [n] *) val splitting_cardinal_less_than: split_non_enumerable:int -> t -> int -> int val inject_top : Abstract_interp.Int.t option -> Abstract_interp.Int.t option -> Abstract_interp.Int.t -> Abstract_interp.Int.t -> t (** [inject_top min max r m] returns the smallest lattice element that contains all integers equal to [r] modulo [m] between [min] and [max]. [None] means unbounded. *) val fold : (Abstract_interp.Int.t -> 'a -> 'a) -> t -> 'a -> 'a val apply_set : (Abstract_interp.Int.t -> Abstract_interp.Int.t -> Abstract_interp.Int.t ) -> t -> t -> t val apply_set_unary : 'a -> (Abstract_interp.Int.t -> Abstract_interp.Int.t ) -> t -> t val singleton_zero : t (** The lattice element that contains only the integer zero. *) val singleton_one : t (** The lattice element that contains only the integer one. *) val zero_or_one : t (** The lattice element that contains only the integers zero and one. *) val contains_non_zero : t -> bool val subdiv_float_interval : size:int -> t -> t * t val subdiv : size:int -> t -> t * t val scale : Abstract_interp.Int.t -> t -> t val scale_div : pos:bool -> Abstract_interp.Int.t -> t -> t val negative : t val div : t -> t -> t val scale_rem : pos:bool -> Abstract_interp.Int.t -> t -> t val c_rem : t -> t -> t val mul : t -> t -> t val shift_left : size:Abstract_interp.Int.t option -> t -> t -> t val shift_right : size:Abstract_interp.Int.t option -> t -> t -> t val interp_boolean : contains_zero:bool -> contains_non_zero:bool -> t val set_of_array : Abstract_interp.Int.t array -> O.t (** Extract bits from [start] to [stop] from the given Ival, [start] and [stop] being included. [size] is the size of the entire ival. *) val extract_bits : start:Abstract_interp.Int.t -> stop:Abstract_interp.Int.t -> size:Abstract_interp.Int.t -> t -> t val create_all_values : modu:Abstract_interp.Int.t -> signed:bool -> size:int -> t val all_values : size:Abstract_interp.Int.t -> t -> bool val filter_le_int : Abstract_interp.Int.t option -> t -> t val filter_ge_int : Abstract_interp.Int.t option -> t -> t val filter_lt_int : Abstract_interp.Int.t option -> t -> t val filter_gt_int : Abstract_interp.Int.t option -> t -> t val filter_le : t -> t -> t val filter_ge : t -> t -> t val filter_lt : t -> t -> t val filter_gt : t -> t -> t val filter_le_float : bool -> typ_loc:Cil_types.typ -> t -> t -> t val filter_ge_float : bool -> typ_loc:Cil_types.typ -> t -> t -> t val filter_lt_float : bool -> typ_loc:Cil_types.typ -> t -> t -> t val filter_gt_float : bool -> typ_loc:Cil_types.typ -> t -> t -> t val compare_C : (Abstract_interp.Int.t option -> Abstract_interp.Int.t option -> Abstract_interp.Int.t option -> Abstract_interp.Int.t option -> 'a) -> t -> t -> 'a val max_max : Abstract_interp.Int.t option -> Abstract_interp.Int.t option -> Abstract_interp.Int.t option val scale_int64base : Int_Base.t -> t -> t val cast_float_to_int : signed:bool -> size:int -> t -> (** Top *) bool * (** Overflow *) bool * t val cast_float_to_int_inverse : single_precision:bool -> tt -> tt val of_int : int -> t val of_int64 : int64 -> t val cast_int_to_float : Float_abstract.rounding_mode -> t -> bool * t val cast : size:Abstract_interp.Int.t -> signed:bool -> value:t -> t val cast_float : rounding_mode:Float_abstract.rounding_mode -> t -> bool * t val cast_double : t -> bool * t val pretty_debug : Format.formatter -> t -> unit val get_small_cardinal: unit -> int (**/**) (* This is automatically set by the Value plugin. Do not use. *) val set_small_cardinal: int -> unit (**/**) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/ai/origin.mli0000644000175000017500000000667012155630234017161 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** The datastructures of this module can be used to track the origin of a major imprecision in the values of an abstract domain. *) (** This module is generic, although currently used only by the plugin Value. Within Value, values that have an imprecision origin are "garbled mix", ie. a numeric value that contains bits extracted from at least one pointer, and that are not the result of a translation *) (** Sets of source locations *) module LocationSetLattice : sig include Abstract_interp.Lattice_Set with type O.elt = Cil_types.location val currentloc_singleton : unit -> t val compare:t -> t -> int end (** List of possible origins. Most of them also include the set of source locations where the operation took place. *) type origin = | Misalign_read of LocationSetLattice.t (** Read of not all the bits of a pointer, typicaller through a pointer cast *) | Leaf of LocationSetLattice.t (** Result of a function without a body *) | Merge of LocationSetLattice.t (** Join between two control-flows *) | Arith of LocationSetLattice.t (** Arithmetic operation that cannot be represented, eg. ['&x * 2'] *) | Well (** Imprecise variables of the intial state *) | Unknown include Datatype.S with type t = origin type kind = | K_Misalign_read | K_Leaf | K_Merge | K_Arith val current: kind -> origin (** This is automatically extracted from [Cil.CurrentLoc] *) val pretty_as_reason: Format.formatter -> t -> unit (** Pretty-print [because of ] if the origin is not {!Unknown}, or nothing otherwise *) val top: t val is_top: t -> bool val bottom: t val join: t -> t -> t val meet: t -> t -> t val narrow: t -> t -> t val is_included: t -> t -> bool val is_included_exn: t -> t -> unit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/ai/base.mli0000644000175000017500000001201112155630234016566 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Validity of variables seen as memory bases. The validity is expressed in bytes. *) open Abstract_interp type validity = | Known of Int.t * Int.t (** Valid between those two bits *) | Unknown of Int.t * Int.t option * Int.t (** Unknown(b,k,e) indicates: If k is [None], potentially valid between b and e If k is [Some k], then b <= k <= e, and the base is - valid between b and k; - potentially valid between k+1 and e: Accesses on potentially valid parts will succeed, but will also raise an alarm. *) | Periodic of Int.t * Int.t (** min-max bounds*) * Int.t (** Period *) (** Valid between the two bounds, and considered as a repetition of the given period. Only one period is stored; consequently, strong updates are impossible. *) | Invalid (** Valid nowhere. Typically used for the NULL base *) type string_id type base = private | Var of Cil_types.varinfo * validity (** Base for uninitialized variables *) | Initialized_Var of Cil_types.varinfo * validity (** Base for variables initialized to zero . *) | Null (** Base for addresses like [(int* )0x123] *) | String of int * string_id (** String constants *) include Datatype.S_with_collections with type t = base module Hptset: Hptset.S with type elt = t module SetLattice: Lattice_Set with module O = Hptset val pretty_validity : Format.formatter -> validity -> unit (** [pretty_addr fmt base] pretty-prints [base] on [fmt] with a leading ampersand if it is a variable *) val pretty_addr : Format.formatter -> t -> unit val typeof : t -> Cil_types.typ option val null : t val is_null : t -> bool val is_read_only : t -> bool val bits_sizeof : t -> Int_Base.t val id : t -> int val is_aligned_by : t -> Int.t -> bool val validity : t -> validity exception Not_valid_offset val is_valid_offset : for_writing:bool -> Int.t -> t -> Ival.t -> unit val is_function : t -> bool val is_formal_or_local : t -> Cil_types.fundec -> bool val is_any_formal_or_local : t -> bool val is_any_local : t -> bool val is_global : t -> bool val is_formal_of_prototype : t -> Cil_types.varinfo -> bool val is_local: t -> Cil_types.fundec -> bool val is_formal: t -> Cil_types.fundec -> bool val is_block_local: t -> Cil_types.block -> bool val is_hidden_variable : t -> bool val validity_from_type : Cil_types.varinfo -> validity val create_varinfo : Cil_types.varinfo -> t (** @return the base corresponding to a program variable. This function's name is short for "create_from_varinfo". The validity of the base is inferred from the type of the variable. *) exception Not_a_variable val get_varinfo: t -> Cil_types.varinfo (** @return the variable's varinfo if the base corresponds to a variable. @raise Not_a_variable if the base is not a variable. *) val create_logic : Cil_types.varinfo -> validity -> t (** @return the base corresponding to a logic variable. This function's name is short for "create_from_logic". *) val find: Cil_types.varinfo -> t (** Return the base corresponding to a variable. *) val create_initialized : Cil_types.varinfo -> validity -> t val create_string : Cil_types.exp -> t type cstring = CSString of string | CSWstring of Escape.wstring val get_string : string_id -> cstring val min_valid_absolute_address: unit -> Int.t val max_valid_absolute_address: unit -> Int.t (** Bounds for option absolute-valid-range *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/ai/abstract_interp.ml0000644000175000017500000006433112155630234020703 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) exception Not_less_than exception Is_not_included (** Generic lattice *) module type Lattice = sig exception Error_Top exception Error_Bottom include Datatype.S (** datatype of element of the lattice *) type widen_hint (** hints for the widening *) val join: t -> t -> t (** over-approximation of union *) val link: t -> t -> t (** under-approximation of union *) val meet: t -> t -> t (** under-approximation of intersection *) val narrow: t -> t -> t (** over-approximation of intersection *) val bottom: t (** the smallest *) val top: t (** the largest *) val is_included: t -> t -> bool val is_included_exn: t -> t -> unit val intersects: t -> t -> bool val widen: widen_hint -> t -> t -> t (** [widen h t1 t2] is an over-approximation of [join t1 t2]. Assumes [is_included t1 t2] *) val cardinal_zero_or_one: t -> bool (** [cardinal_less_than t v ] @raise Not_less_than whenever the cardinal of [t] is higher than [v] *) val cardinal_less_than: t -> int -> int end module type Lattice_With_Diff = sig include Lattice val diff : t -> t -> t (** [diff t1 t2] is an over-approximation of [t1-t2]. *) val diff_if_one : t -> t -> t (** [diff t1 t2] is an over-approximation of [t1-t2]. Returns [t1] if [t2] is not a singleton. *) val fold_enum : split_non_enumerable:int -> (t -> 'a -> 'a) -> t -> 'a -> 'a val splitting_cardinal_less_than: split_non_enumerable:int -> t -> int -> int val pretty_debug : Format.formatter -> t -> unit end module type Lattice_Product = sig type t1 type t2 type tt = private Product of t1*t2 | Bottom include Lattice with type t = tt val inject : t1 -> t2 -> t val fst : t -> t1 val snd : t -> t2 end module type Lattice_Sum = sig type t1 type t2 type sum = private Top | Bottom | T1 of t1 | T2 of t2 include Lattice with type t = sum val inject_t1 : t1 -> t val inject_t2 : t2 -> t end module type Lattice_Base = sig type l type tt = private Top | Bottom | Value of l include Lattice with type t = tt val project : t -> l val inject: l -> t val transform: (l -> l -> l) -> tt -> tt -> tt end module type Lattice_Set = sig module O: Datatype.Set type tt = private Set of O.t | Top include Lattice with type t = tt and type widen_hint = O.t val inject_singleton: O.elt -> t val inject: O.t -> t val empty: t val apply2: (O.elt -> O.elt -> O.elt) -> (t -> t -> t) val apply1: (O.elt -> O.elt) -> (t -> t) val fold: ( O.elt -> 'a -> 'a) -> t -> 'a -> 'a val iter: ( O.elt -> unit) -> t -> unit val exists: (O.elt -> bool) -> t -> bool val for_all: (O.elt -> bool) -> t -> bool val project : t -> O.t val mem : O.elt -> t -> bool end module type LatValue = Datatype.S_with_collections module Make_Lattice_Set(V:LatValue): Lattice_Set with type O.elt = V.t = struct exception Error_Top exception Error_Bottom module O = struct include Datatype.Set (Set.Make(V)) (V) (struct let module_name = "Make_lattice_set" end) end type tt = Set of O.t | Top type widen_hint = O.t let bottom = Set O.empty let top = Top let hash c = match c with | Top -> 12373 | Set s -> let f v acc = 67 * acc + (V.hash v) in O.fold f s 17 let compare = if O.compare == Datatype.undefined then ( Kernel.debug "%s lattice_set, missing comparison function" V.name; Datatype.undefined ) else fun e1 e2 -> if e1 == e2 then 0 else match e1,e2 with | Top,_ -> 1 | _, Top -> -1 | Set e1,Set e2 -> O.compare e1 e2 let equal v1 v2 = if v1 == v2 then true else match v1, v2 with | Top, Top -> true | Set e1, Set e2 -> O.equal e1 e2 | Top, Set _ | Set _, Top -> false let widen _wh _t1 t2 = (* [wh] isn't used *) t2 (** This is exact *) let meet v1 v2 = if v1 == v2 then v1 else match v1,v2 with | Top, v | v, Top -> v | Set s1 , Set s2 -> Set (O.inter s1 s2) (** This is exact *) let narrow = meet (** This is exact *) let join v1 v2 = if v1 == v2 then v1 else match v1,v2 with | Top, _ | _, Top -> Top | Set s1 , Set s2 -> let u = O.union s1 s2 in Set u (** This is exact *) let link = join let cardinal_less_than s n = match s with | Top -> raise Not_less_than | Set s -> let c = O.cardinal s in if c > n then raise Not_less_than; c let cardinal_zero_or_one s = try ignore (cardinal_less_than s 1) ; true with Not_less_than -> false let inject s = Set s let inject_singleton e = inject (O.singleton e) let empty = inject O.empty let transform f = fun t1 t2 -> match t1,t2 with | Top, _ | _, Top -> Top | Set v1, Set v2 -> Set (f v1 v2) let map_set f s = O.fold (fun v -> O.add (f v)) s O.empty let apply2 f s1 s2 = let distribute_on_elements f s1 s2 = O.fold (fun v -> O.union (map_set (f v) s2)) s1 O.empty in transform (distribute_on_elements f) s1 s2 let apply1 f s = match s with | Top -> top | Set s -> Set(map_set f s) let pretty fmt t = match t with | Top -> Format.fprintf fmt "TopSet" | Set s -> if O.is_empty s then Format.fprintf fmt "BottomSet" else Pretty_utils.pp_iter ~pre:"{" ~suf:"}" ~sep:";@ " O.iter (fun fmt v -> Format.fprintf fmt "@[%a@]" V.pretty v) fmt s let is_included t1 t2 = (t1 == t2) || match t1,t2 with | _,Top -> true | Top,_ -> false | Set s1,Set s2 -> O.subset s1 s2 let is_included_exn v1 v2 = if not (is_included v1 v2) then raise Is_not_included let intersects t1 t2 = let b = match t1,t2 with | _,Top | Top,_ -> true | Set s1,Set s2 -> O.exists (fun e -> O.mem e s2) s1 in (* Format.printf "[Lattice_Set]%a intersects %a: %b @\n" pretty t1 pretty t2 b;*) b let fold f elt init = match elt with | Top -> raise Error_Top | Set v -> O.fold f v init let iter f elt = match elt with | Top -> raise Error_Top | Set v -> O.iter f v let exists f = function | Top -> true | Set s -> O.exists f s let for_all f = function | Top -> false | Set s -> O.for_all f s let project o = match o with | Top -> raise Error_Top | Set v -> v let mem v s = match s with | Top -> true | Set s -> O.mem v s include Datatype.Make (struct type t = tt let name = V.name ^ " lattice_set" let structural_descr = Structural_descr.Structure (Structural_descr.Sum [| [| O.packed_descr |] |]) let reprs = Top :: List.map (fun o -> Set o) O.reprs let equal = equal let compare = compare let hash = hash let rehash = Datatype.identity let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = pretty let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) end module Make_Hashconsed_Lattice_Set(V: Hptset.Id_Datatype)(O: Hptset.S with type elt = V.t) : Lattice_Set with module O = O = struct exception Error_Top exception Error_Bottom module O = O type tt = Set of O.t | Top type widen_hint = O.t let bottom = Set O.empty let top = Top let hash c = match c with | Top -> 12373 | Set s -> let f v acc = 67 * acc + (V.id v) in O.fold f s 17 let equal e1 e2 = if e1==e2 then true else match e1,e2 with | Top,_ | _, Top -> false | Set e1,Set e2 -> O.equal e1 e2 let compare = if O.compare == Datatype.undefined then ( Kernel.debug "%s hashconsed_lattice_set, missing comparison function" V.name; Datatype.undefined ) else fun e1 e2 -> if e1 == e2 then 0 else match e1,e2 with | Top,_ -> 1 | _, Top -> -1 | Set e1,Set e2 -> O.compare e1 e2 let widen _wh _t1 t2 = (* [wh] isn't used *) t2 (** This is exact *) let meet v1 v2 = if v1 == v2 then v1 else match v1,v2 with | Top, v | v, Top -> v | Set s1 , Set s2 -> Set (O.inter s1 s2) (** This is exact *) let narrow = meet (** This is exact *) let join v1 v2 = if v1 == v2 then v1 else match v1,v2 with | Top, _ | _, Top -> Top | Set s1 , Set s2 -> let u = O.union s1 s2 in Set u (** This is exact *) let link = join let cardinal_less_than s n = match s with Top -> raise Not_less_than | Set s -> let c = O.cardinal s in if c > n then raise Not_less_than; c let cardinal_zero_or_one s = try ignore (cardinal_less_than s 1) ; true with Not_less_than -> false let inject s = Set s let inject_singleton e = inject (O.singleton e) let empty = inject O.empty let transform f = fun t1 t2 -> match t1,t2 with | Top, _ | _, Top -> Top | Set v1, Set v2 -> Set (f v1 v2) let map_set f s = O.fold (fun v -> O.add (f v)) s O.empty let apply2 f s1 s2 = let distribute_on_elements f s1 s2 = O.fold (fun v -> O.union (map_set (f v) s2)) s1 O.empty in transform (distribute_on_elements f) s1 s2 let apply1 f s = match s with | Top -> top | Set s -> Set(map_set f s) let pretty fmt t = match t with | Top -> Format.fprintf fmt "TopSet" | Set s -> if O.is_empty s then Format.fprintf fmt "BottomSet" else Pretty_utils.pp_iter ~pre:"@[{" ~suf:"}@]" ~sep:";@ " O.iter (fun fmt v -> Format.fprintf fmt "@[%a@]" V.pretty v) fmt s let is_included t1 t2 = (t1 == t2) || match t1,t2 with | _,Top -> true | Top,_ -> false | Set s1,Set s2 -> O.subset s1 s2 let is_included_exn v1 v2 = if not (is_included v1 v2) then raise Is_not_included let intersects t1 t2 = let b = match t1,t2 with | _,Top | Top,_ -> true | Set s1,Set s2 -> O.exists (fun e -> O.mem e s2) s1 in (* Format.printf "[Lattice_Set]%a intersects %a: %b @\n" pretty t1 pretty t2 b;*) b let fold f elt init = match elt with | Top -> raise Error_Top | Set v -> O.fold f v init let iter f elt = match elt with | Top -> raise Error_Top | Set v -> O.iter f v let exists f = function | Top -> true | Set s -> O.exists f s let for_all f = function | Top -> false | Set s -> O.for_all f s let project o = match o with | Top -> raise Error_Top | Set v -> v let mem v s = match s with | Top -> true | Set s -> O.mem v s include Datatype.Make (struct type t = tt let name = V.name ^ " hashconsed_lattice_set" let structural_descr = Structural_descr.Structure (Structural_descr.Sum [| [| O.packed_descr |] |]) let reprs = Top :: List.map (fun o -> Set o) O.reprs let equal = equal let compare = compare let hash = hash let rehash = Datatype.identity let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = pretty let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) let () = Type.set_ml_name ty None end module Make_Lattice_Base (V:LatValue):(Lattice_Base with type l = V.t) = struct type l = V.t type tt = Top | Bottom | Value of l type widen_hint = V.t list let bottom = Bottom let top = Top exception Error_Top exception Error_Bottom let project v = match v with | Top -> raise Error_Top | Bottom -> raise Error_Bottom | Value v -> v let cardinal_zero_or_one v = match v with | Top -> false | _ -> true let cardinal_less_than v n = match v with | Top -> raise Not_less_than | Value _ -> if n >= 1 then 1 else raise Not_less_than | Bottom -> 0 let compare = if V.compare == Datatype.undefined then (Kernel.debug "Missing function comparison for %s lattice_base" V.name; Datatype.undefined) else fun e1 e2 -> if e1==e2 then 0 else match e1,e2 with | Top,_ -> 1 | _, Top -> -1 | Bottom, _ -> -1 | _, Bottom -> 1 | Value e1,Value e2 -> V.compare e1 e2 let equal v1 v2 = match v1, v2 with | Top, Top | Bottom, Bottom -> true | Value v1, Value v2 -> V.equal v1 v2 | _ -> false let hash = function | Top -> 3 | Bottom -> 5 | Value v -> V.hash v * 7 let widen _wh t1 t2 = (* [wh] isn't used yet *) if equal t1 t2 then t1 else top (** This is exact *) let meet b1 b2 = if b1 == b2 then b1 else match b1,b2 with | Bottom, _ | _, Bottom -> Bottom | Top , v | v, Top -> v | Value v1, Value v2 -> if (V.compare v1 v2)=0 then b1 else Bottom (** This is exact *) let narrow = meet (** This is exact *) let join b1 b2 = if b1 == b2 then b1 else match b1,b2 with | Top, _ | _, Top -> Top | Bottom , v | v, Bottom -> v | Value v1, Value v2 -> if (V.compare v1 v2)=0 then b1 else Top (** This is exact *) let link = join let inject x = Value x let transform f = fun t1 t2 -> match t1,t2 with | Bottom, _ | _, Bottom -> Bottom | Top, _ | _, Top -> Top | Value v1, Value v2 -> Value (f v1 v2) let pretty fmt t = match t with | Top -> Format.fprintf fmt "Top" | Bottom -> Format.fprintf fmt "Bottom" | Value v -> Format.fprintf fmt "<%a>" V.pretty v let is_included t1 t2 = let b = (t1 == t2) || (equal (meet t1 t2) t1) in (* Format.printf "[Lattice]%a is included in %a: %b @\n" pretty t1 pretty t2 b;*) b let is_included_exn v1 v2 = if not (is_included v1 v2) then raise Is_not_included let intersects t1 t2 = not (equal (meet t1 t2) Bottom) include Datatype.Make (struct type t = tt (*= Top | Bottom | Value of l*) let name = V.name ^ " lattice_base" let structural_descr = Structural_descr.Structure (Structural_descr.Sum [| [| V.packed_descr |] |]) let reprs = Top :: Bottom :: List.map (fun v -> Value v) V.reprs let equal = equal let compare = compare let hash = hash let rehash = Datatype.identity let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = pretty let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) let () = Type.set_ml_name ty None end module Int = struct include (Integer: module type of Integer with type t = Integer.t) include (Datatype.Big_int: Datatype.S_with_collections with type t:=Integer.t) let pretty fmt v = if not (Kernel.BigIntsHex.is_default ()) then let max = of_int (Kernel.BigIntsHex.get ()) in if gt (abs v) max then Integer.pretty ~hexa:true fmt v else Integer.pretty ~hexa:false fmt v else Integer.pretty ~hexa:false fmt v (** execute [f] on [inf], [inf + step], ... *) let fold f ~inf ~sup ~step acc = (* Format.printf "Int.fold: inf:%a sup:%a step:%a@\n" pretty inf pretty sup pretty step; *) let nb_loop = div (sub sup inf) step in let next = add step in let rec fold ~counter ~inf acc = if equal counter onethousand then Kernel.warning ~once:true ~current:true "enumerating %s integers" (to_string nb_loop); if le inf sup then begin (* Format.printf "Int.fold: %a@\n" pretty inf; *) fold ~counter:(succ counter) ~inf:(next inf) (f inf acc) end else acc in fold ~counter:zero ~inf acc end (* Typing constraints are enfored directly in the .mli *) module Rel = struct include Int let check ~rem ~modu = zero <= rem && rem < modu let add_abs = add let sub_abs = sub end module type Collapse = sig val collapse : bool end (** If [C.collapse] then [L1.Bottom,_ = _,L2.Bottom = Bottom] *) module Make_Lattice_Product(L1:Lattice)(L2:Lattice)(C:Collapse): (Lattice_Product with type t1 = L1.t and type t2 = L2.t) = struct exception Error_Top exception Error_Bottom type t1 = L1.t type t2 = L2.t type tt = Product of t1*t2 | Bottom type widen_hint = L1.widen_hint * L2.widen_hint let hash = function | Bottom -> 3 | Product(v1, v2) -> L1.hash v1 + 3 * L2.hash v2 let cardinal_less_than _ = assert false let cardinal_zero_or_one v = match v with | Bottom -> true | Product (t1, t2) -> (L1.cardinal_zero_or_one t1) && (L2.cardinal_zero_or_one t2) let compare = if L1.compare == Datatype.undefined || L2.compare == Datatype.undefined then ( Kernel.debug "Missing comparison function for (%s, %s) lattice_product: \ %b %b" L1.name L2.name (L1.compare == Datatype.undefined) (L2.compare == Datatype.undefined); Datatype.undefined) else fun x x' -> if x == x' then 0 else match x,x' with | Bottom, Bottom -> 0 | Bottom, Product _ -> 1 | Product _,Bottom -> -1 | (Product (a,b)), (Product (a',b')) -> let c = L1.compare a a' in if c = 0 then L2.compare b b' else c let equal x x' = if x == x' then true else match x,x' with | Bottom, Bottom -> true | Bottom, Product _ -> false | Product _,Bottom -> false | (Product (a,b)), (Product (a',b')) -> L1.equal a a' && L2.equal b b' let top = Product(L1.top,L2.top) let bottom = Bottom let fst x = match x with Bottom -> L1.bottom | Product(x1,_) -> x1 let snd x = match x with Bottom -> L2.bottom | Product(_,x2) -> x2 let condition_to_be_bottom x1 x2 = let c1 = (L1.equal x1 L1.bottom) in let c2 = (L2.equal x2 L2.bottom) in (C.collapse && (c1 || c2)) || (not C.collapse && c1 && c2) let inject x y = if condition_to_be_bottom x y then bottom else Product(x,y) let widen (wh1, wh2) t l = let t1 = fst t in let t2 = snd t in let l1 = fst l in let l2 = snd l in inject (L1.widen wh1 t1 l1) (L2.widen wh2 t2 l2) let join x1 x2 = if x1 == x2 then x1 else match x1,x2 with | Bottom, v | v, Bottom -> v | Product (l1,ll1), Product (l2,ll2) -> Product(L1.join l1 l2, L2.join ll1 ll2) let link _ = assert false (** Not implemented yet. *) let narrow _ = assert false (** Not implemented yet. *) let meet x1 x2 = if x1 == x2 then x1 else match x1,x2 with | Bottom, _ | _, Bottom -> Bottom | Product (l1,ll1), Product (l2,ll2) -> let l1 = L1.meet l1 l2 in let l2 = L2.meet ll1 ll2 in inject l1 l2 let pretty fmt x = match x with Bottom -> Format.fprintf fmt "BotProd" | Product(l1,l2) -> Format.fprintf fmt "(%a,%a)" L1.pretty l1 L2.pretty l2 let intersects x1 x2 = match x1,x2 with | Bottom, _ | _, Bottom -> false | Product (l1,ll1), Product (l2,ll2) -> (L1.intersects l1 l2) && (L2.intersects ll1 ll2) let is_included x1 x2 = (x1 == x2) || match x1,x2 with | Bottom, _ -> true | _, Bottom -> false | Product (l1,ll1), Product (l2,ll2) -> (L1.is_included l1 l2) && (L2.is_included ll1 ll2) let is_included_exn x1 x2 = if x1 != x2 then match x1,x2 with | Bottom, _ -> () | _, Bottom -> raise Is_not_included | Product (l1,ll1), Product (l2,ll2) -> L1.is_included_exn l1 l2; L2.is_included_exn ll1 ll2 include Datatype.Make (struct type t = tt (*= Product of t1*t2 | Bottom*) let name = "(" ^ L1.name ^ ", " ^ L2.name ^ ") lattice_product" let structural_descr = Structural_descr.Structure (Structural_descr.Sum [| [| L1.packed_descr; L2.packed_descr |] |]) let reprs = Bottom :: List.fold_left (fun acc l1 -> List.fold_left (fun acc l2 -> Product(l1, l2) :: acc) acc L2.reprs) [] L1.reprs let equal = equal let compare = compare let hash = hash let rehash = Datatype.identity let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = pretty let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) let () = Type.set_ml_name ty None end module Make_Lattice_Sum (L1:Lattice) (L2:Lattice): (Lattice_Sum with type t1 = L1.t and type t2 = L2.t) = struct exception Error_Top exception Error_Bottom type t1 = L1.t type t2 = L2.t type sum = Top | Bottom | T1 of t1 | T2 of t2 type widen_hint = L1.widen_hint * L2.widen_hint let top = Top let bottom = Bottom let hash = function | Top -> 3 | Bottom -> 5 | T1 t -> 7 * L1.hash t | T2 t -> - 17 * L2.hash t let cardinal_less_than _ = assert false let cardinal_zero_or_one v = match v with | Top -> false | Bottom -> true | T1 t1 -> L1.cardinal_zero_or_one t1 | T2 t2 -> L2.cardinal_zero_or_one t2 let widen (wh1, wh2) t1 t2 = match t1,t2 with | T1 x,T1 y -> T1 (L1.widen wh1 x y) | T2 x,T2 y -> T2 (L2.widen wh2 x y) | Top,Top | Bottom,Bottom -> t1 | _,_ -> Top let compare = if L1.compare == Datatype.undefined || L2.compare == Datatype.undefined then ( Kernel.debug "Missing comparison function for (%s, %s) lattice_sum: \ %b %b" L1.name L2.name (L1.compare == Datatype.undefined) (L2.compare == Datatype.undefined); Datatype.undefined) else fun u v -> if u == v then 0 else match u,v with | Top,Top | Bottom,Bottom -> 0 | Bottom,_ | _,Top -> 1 | Top,_ |_,Bottom -> -1 | T1 _ , T2 _ -> 1 | T2 _ , T1 _ -> -1 | T1 t1,T1 t1' -> L1.compare t1 t1' | T2 t1,T2 t1' -> L2.compare t1 t1' let equal u v = if u == v then false else match u, v with | Top,Top | Bottom,Bottom -> true | Bottom,_ | _,Top | Top,_ |_,Bottom -> false | T1 _ , T2 _ -> false | T2 _ , T1 _ -> false | T1 t1,T1 t1' -> L1.equal t1 t1' | T2 t2,T2 t2' -> L2.equal t2 t2' (** Forbid [L1 Bottom] *) let inject_t1 x = if L1.equal x L1.bottom then Bottom else T1 x (** Forbid [L2 Bottom] *) let inject_t2 x = if L2.equal x L2.bottom then Bottom else T2 x let pretty fmt v = match v with | T1 x -> L1.pretty fmt x | T2 x -> L2.pretty fmt x | Top -> Format.fprintf fmt "" | Bottom -> Format.fprintf fmt "" let join u v = if u == v then u else match u,v with | T1 t1,T1 t2 -> T1 (L1.join t1 t2) | T2 t1,T2 t2 -> T2 (L2.join t1 t2) | Bottom,x| x,Bottom -> x | _,_ -> (*Format.printf "Degenerating collision : %a <==> %a@\n" pretty u pretty v;*) top let link _ = assert false (** Not implemented yet. *) let narrow _ = assert false (** Not implemented yet. *) let meet u v = if u == v then u else match u,v with | T1 t1,T1 t2 -> inject_t1 (L1.meet t1 t2) | T2 t1,T2 t2 -> inject_t2 (L2.meet t1 t2) | (T1 _ | T2 _),Top -> u | Top,(T1 _ | T2 _) -> v | Top,Top -> top | _,_ -> bottom let intersects u v = match u,v with | Bottom,_ | _,Bottom -> false | Top,_ |_,Top -> true | T1 _,T1 _ -> true | T2 _,T2 _ -> true | _,_ -> false let is_included u v = (u == v) || let b = match u,v with | Bottom,_ | _,Top -> true | Top,_ | _,Bottom -> false | T1 t1,T1 t2 -> L1.is_included t1 t2 | T2 t1,T2 t2 -> L2.is_included t1 t2 | _,_ -> false in (* Format.printf "[Lattice_Sum]%a is included in %a: %b @\n" pretty u pretty v b;*) b let is_included_exn v1 v2 = if not (is_included v1 v2) then raise Is_not_included include Datatype.Make (struct type t = sum let name = "(" ^ L1.name ^ ", " ^ L2.name ^ ") lattice_sum" let structural_descr = Structural_descr.Unknown let reprs = Top :: Bottom :: List.fold_left (fun acc t -> T2 t :: acc) (List.map (fun t -> T1 t) L1.reprs) L2.reprs let equal = equal let compare = compare let hash = hash let rehash = Datatype.undefined let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = pretty let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) let () = Type.set_ml_name ty None end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/ai/ival.ml0000644000175000017500000025615112155630234016455 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp (* Make sure all this is synchronized with the default value of -ilevel *) let small_cardinal = ref 8 let small_cardinal_Int = ref (Int.of_int !small_cardinal) let small_cardinal_log = ref 3 let set_small_cardinal i = assert (2 <= i && i <= 256); let rec log j p = if i <= p then j else log (j+1) (2*p) in small_cardinal := i; small_cardinal_Int := Int.of_int i; small_cardinal_log := log 1 2 let get_small_cardinal () = !small_cardinal exception Can_not_subdiv module F = struct type t = float let packed_descr = Structural_descr.p_float let compare f1 f2 = let i1 = Int64.bits_of_float f1 in let i2 = Int64.bits_of_float f2 in let m1 = (Int64.logand i1 Int64.min_int) in let m2 = (Int64.logand i2 Int64.min_int) in if m1 = m2 then compare f1 f2 else compare m1 m2 let () = assert ((compare (-0.) 0.) = -1) let equal f1 f2 = compare f1 f2 = 0 let zero = 0.0 let minus_zero = -0.0 exception Nan_or_infinite let max_single_precision_float = Floating_point.max_single_precision_float let most_negative_single_precision_float = Floating_point.most_negative_single_precision_float (* VP: unused function *) (* let min_single_precision_float = Int32.float_of_bits 0x800000l *) (* let neg_min_single_precision_float = -. min_single_precision_float *) let max_float = max_float let infinity = infinity let neg_infinity = neg_infinity let most_negative_float = -. max_float let min_denormal = Int64.float_of_bits 1L let neg_min_denormal = -. min_denormal let is_positive f = Int64.logand (Int64.bits_of_float f) Int64.min_int = Int64.zero let zero_of_same_sign f = if is_positive f then zero else minus_zero let is_infinity = (=) infinity let is_neg_infinity = (=) neg_infinity let wrap r = match classify_float r with FP_nan -> raise Nan_or_infinite | FP_normal | FP_subnormal | FP_infinite | FP_zero -> r let wrap_un f x = wrap (f x) let wrap_bin f x y = wrap (f x y) let add = wrap_bin (+.) let sub = wrap_bin (-.) let neg = wrap_un (~-.) let mult = wrap_bin ( *.) let div = wrap_bin (/.) let pretty_normal = Floating_point.pretty_normal let pretty = Floating_point.pretty let avg x y = let h = 0.5 in let xp = x >= 0. in let yp = y >= 0. in if xp = yp then let d = x -. y in y +. h *. d else (x +. y) *. h let le_ieee = ((<=) : float -> float -> bool) let lt_ieee = ((<) : float -> float -> bool) let sqrt = wrap_un sqrt let cos = wrap_un cos let sin = wrap_un sin let exp = wrap_un exp let minus_one = -1.0 let one = 1.0 let minus_one_half = -0.5 let ten = 10. let m_pi = 3.1415929794311523 (* single-precision *) let m_minus_pi = -. m_pi let m_pi_2 = 1.5707964897155761 (* single-precision *) let m_minus_pi_2 = -. m_pi_2 let ff = 4.5 let minus_ff = -4.5 let of_int = float_of_int let widen_up f = if f <= zero then zero else if f <= one then one else if f <= m_pi_2 then m_pi_2 else if f <= m_pi then m_pi else if f <= ten then ten else if f <= 1e10 then 1e10 else if f <= max_single_precision_float then max_single_precision_float else if f <= 1e80 then 1e80 else max_float let widen_down f = if f >= zero then zero else if f >= minus_one_half then minus_one_half else if f >= minus_one then minus_one else if f >= m_minus_pi then m_minus_pi else if f >= most_negative_single_precision_float then most_negative_single_precision_float else most_negative_float let round_normal int64fup int64fdown float = let r = Int64.bits_of_float float in let f = if r >= 0L then int64fup else int64fdown in Int64.float_of_bits (f r) let round int64fup int64fdown float = match classify_float float with FP_nan | FP_infinite -> raise Nan_or_infinite | FP_normal | FP_subnormal -> let f = round_normal int64fup int64fdown float in ( match classify_float f with FP_nan | FP_infinite -> raise Nan_or_infinite | FP_normal | FP_subnormal | FP_zero -> f ) | FP_zero -> (round_normal int64fup int64fdown (float +. min_float)) -. min_float let round_up = round Int64.succ Int64.pred let round_down = round Int64.pred Int64.succ let le f1 f2 = if f1 = zero && f2 = zero then (1. /. f1) <= (1. /. f2) else f1 <= f2 let min f1 f2 = if le f1 f2 then f1 else f2 let max f1 f2 = if le f1 f2 then f2 else f1 let equal_ieee = ((=) : float -> float -> bool) let hash = Hashtbl.hash let id = fun x -> x let of_float = wrap_un id let to_float = id let classify_float = Pervasives.classify_float end module Float_abstract = struct exception Bottom type denormal_treatment = Denormals | FTZ | DenormalsandFTZ let denormal_treatment = Denormals let _ = DenormalsandFTZ (* VP: silence warning about unused DenormalsandFTZ *) module Private_Couple : sig type t = private I of F.t * F.t val inject : F.t -> F.t -> t val inject_r : F.t -> F.t -> (bool * t) end = struct type t = I of F.t * F.t let inject b e = assert ( if not (F.le b e) then begin Format.printf "assertion 0936 failed.@\n%a .. %a@." (F.pretty_normal ~use_hex:true) b (F.pretty_normal ~use_hex:true) e; false end else true); I(b, e) let inject_r b e = if F.is_neg_infinity e || F.is_infinity b then raise Bottom; let c = F.classify_float e in let overflow_alarm, e = match c with FP_infinite | FP_subnormal -> let pos = F.le_ieee F.zero e in ( match c, pos with FP_infinite, true -> true, F.max_float | FP_infinite, false -> raise Bottom | _, true when denormal_treatment = FTZ -> false, F.zero | _, false when denormal_treatment <> Denormals -> false, F.minus_zero | _ -> false, e) | _ -> false, e in let c = F.classify_float b in let overflow_alarm, b = match c with FP_infinite | FP_subnormal -> let pos = F.le_ieee F.zero b in ( match c, pos with FP_infinite, true -> raise Bottom | FP_infinite, false -> true, F.most_negative_float | _, false when denormal_treatment = FTZ -> overflow_alarm, F.minus_zero | _, true when denormal_treatment <> Denormals -> overflow_alarm, F.zero | _ -> overflow_alarm, b) | _ -> overflow_alarm, b in overflow_alarm, inject b e end type t = Private_Couple.t (* open Private_Couple *) (* Workaround for Ocaml bug 5718 *) let structural_descr = Structural_descr.Structure (Structural_descr.Sum [| [| F.packed_descr; F.packed_descr |] |]) let packed_descr = Structural_descr.pack structural_descr let inject = Private_Couple.inject let inject_r = Private_Couple.inject_r let min_and_max_float (Private_Couple.I(b,e)) = b, e let top = inject F.most_negative_float F.max_float exception Nan_or_infinite = F.Nan_or_infinite let compare (Private_Couple.I(b1,e1)) (Private_Couple.I(b2,e2)) = let r = F.compare b1 b2 in if r <> 0 then r else F.compare e1 e2 let pretty fmt (Private_Couple.I(b,e)) = if F.equal b e then Format.fprintf fmt "%a" F.pretty b else begin if (Kernel.FloatRelative.get()) then begin Floating_point.set_round_upward (); let d = F.sub e b in Format.fprintf fmt "[%a ++ %a]" F.pretty b F.pretty d end else Format.fprintf fmt "[%a .. %a]" F.pretty b F.pretty e end let hash (Private_Couple.I(b,e)) = F.hash b + (5 * F.hash e) let inject_singleton x = inject x x let zero = inject_singleton F.zero let compare_min (Private_Couple.I(m1,_)) (Private_Couple.I(m2,_)) = F.compare m1 m2 let compare_max (Private_Couple.I(_, m1)) (Private_Couple.I(_, m2)) = F.compare m2 m1 let is_included (Private_Couple.I(b1, e1)) (Private_Couple.I(b2, e2)) = F.le b2 b1 && F.le e1 e2 let join (Private_Couple.I(b1, e1)) (Private_Couple.I(b2, e2)) = inject (F.min b1 b2) (F.max e1 e2) (*@ raises [Bottom] *) let meet (Private_Couple.I(b1, e1)) (Private_Couple.I(b2, e2)) = if F.le b2 e1 && F.le b1 e2 then inject (F.max b1 b2) (F.min e1 e2) else raise Bottom let contains_zero = is_included zero let fold_split n f (Private_Couple.I(b, e)) acc = let bound = ref b in let acc = ref acc in begin try for i = n downto 2 do let new_bound = F.add !bound (F.div (F.sub e !bound) (F.of_int i)) in acc := f (inject !bound new_bound) !acc; (* Format.printf "float fold_split %a@." pretty (!bound, new_bound); *) bound := new_bound done; with Nan_or_infinite -> () end; (* Format.printf "float fold_split %a@." pretty (!bound, e); *) f (inject !bound e) !acc let contains_a_zero (Private_Couple.I(b, e)) = F.le_ieee b F.zero && F.le_ieee F.zero e let is_zero f = 0 = compare zero f let is_singleton (Private_Couple.I(b, e)) = F.equal b e let neg_float v = let Private_Couple.I(b, e) = v in inject (F.neg e) (F.neg b) (* do not round because exact operation *) type rounding_mode = Any | Nearest_Even let top_single_precision_float = inject F.most_negative_single_precision_float F.max_single_precision_float let round_to_single_precision_float ~rounding_mode (Private_Couple.I(b, e) as _arg) = if rounding_mode = Any then Floating_point.set_round_downward () else Floating_point.set_round_nearest_even (); let b = Floating_point.round_to_single_precision_float b in if rounding_mode = Any then Floating_point.set_round_upward (); let e = Floating_point.round_to_single_precision_float e in let infb, b = match classify_float b, denormal_treatment with | FP_infinite, _ -> if F.equal_ieee b F.infinity then raise Bottom; true, F.most_negative_single_precision_float | FP_subnormal, FTZ -> false, F.zero_of_same_sign b | FP_subnormal, DenormalsandFTZ when F.is_positive b -> false, F.zero | _ -> false, b in let infe, e = match classify_float e, denormal_treatment with | FP_infinite, _ -> if F.equal_ieee e F.neg_infinity then raise Bottom; true, F.max_single_precision_float | FP_subnormal, FTZ -> false, F.zero_of_same_sign e | FP_subnormal, DenormalsandFTZ when not (F.is_positive e) -> false, F.minus_zero | _ -> false, e in infb || infe, inject b e (* in Format.printf "Casting double -> float %a -> %B %a@." pretty _arg fl pretty _res; fl, _res *) let bits_of_float64 (Private_Couple.I(l, u)) = if F.le u F.minus_zero then Int.of_int64 (Int64.bits_of_float u), Int.of_int64 (Int64.bits_of_float l) else if F.le F.zero l then Int.of_int64 (Int64.bits_of_float l), Int.of_int64 (Int64.bits_of_float u) else Int.of_int64 Int64.min_int, Int.of_int64 (Int64.bits_of_float u) let bits_of_float32 (Private_Couple.I(l, u)) = assert (F.equal l (Floating_point.round_to_single_precision_float l)); assert (F.equal u (Floating_point.round_to_single_precision_float u)); if F.le u F.minus_zero then Int.of_int32 (Int32.bits_of_float u), Int.of_int32 (Int32.bits_of_float l) else if F.le F.zero l then Int.of_int32 (Int32.bits_of_float l), Int.of_int32 (Int32.bits_of_float u) else Int.of_int32 Int32.min_int, Int.of_int32 (Int32.bits_of_float u) let add_float rounding_mode v1 v2 = let Private_Couple.I(b1, e1) = v1 in let Private_Couple.I(b2, e2) = v2 in if rounding_mode = Any then Floating_point.set_round_downward () else Floating_point.set_round_nearest_even (); let bs = F.add b1 b2 in if rounding_mode = Any then Floating_point.set_round_upward (); let es = F.add e1 e2 in inject_r bs es let sub_float rounding_mode v1 v2 = add_float rounding_mode v1 (neg_float v2) let mult_float rounding_mode v1 v2 = let Private_Couple.I(b1, e1) = v1 in let Private_Couple.I(b2, e2) = v2 in if rounding_mode = Any then Floating_point.set_round_downward () else Floating_point.set_round_nearest_even (); let a = F.mult b1 b2 in let b = F.mult b1 e2 in let c = F.mult e1 b2 in let d = F.mult e1 e2 in let min = F.min (F.min a b) (F.min c d) in let max = if rounding_mode = Any then begin Floating_point.set_round_upward (); let a = F.mult b1 b2 in let b = F.mult b1 e2 in let c = F.mult e1 b2 in let d = F.mult e1 e2 in F.max (F.max a b) (F.max c d) end else F.max (F.max a b) (F.max c d) in inject_r min max let div_float rounding_mode (Private_Couple.I(b1, e1)) (Private_Couple.I(b2, e2) as v2) = if contains_a_zero v2 then raise Nan_or_infinite; if rounding_mode = Any then Floating_point.set_round_downward () else Floating_point.set_round_nearest_even (); let c1 = F.div b1 b2 in let c2 = F.div b1 e2 in let c3 = F.div e1 b2 in let c4 = F.div e1 e2 in let min = F.min (F.min c1 c2) (F.min c3 c4) in let max = if rounding_mode = Any then begin Floating_point.set_round_upward (); let c1 = F.div b1 b2 in let c2 = F.div b1 e2 in let c3 = F.div e1 b2 in let c4 = F.div e1 e2 in F.max (F.max c1 c2) (F.max c3 c4) end else F.max (F.max c1 c2) (F.max c3 c4) in inject_r min max let sqrt_float rounding_mode (Private_Couple.I(b, e)) = if rounding_mode = Any then Floating_point.set_round_downward () else Floating_point.set_round_nearest_even (); let alarm, min = if F.le_ieee F.zero b then false, F.sqrt b else begin if not (F.le_ieee F.zero e) then raise Bottom; true, F.minus_zero end in if rounding_mode = Any then Floating_point.set_round_upward (); let max = F.sqrt e in alarm, inject min max let minus_one_one = inject F.minus_one F.one let cos_float v = Floating_point.set_round_nearest_even (); match v with Private_Couple.I(b, e) when F.equal b e -> let c = F.cos b in inject c c | _ -> minus_one_one let sin_float v = Floating_point.set_round_nearest_even (); match v with | Private_Couple.I(b, e) when F.equal b e -> let c = F.sin b in inject c c | _ -> minus_one_one let cos_float_precise v = Floating_point.set_round_nearest_even (); match v with | Private_Couple.I(b, e) -> if F.equal b e then let c = F.cos b in inject c c else if F.le_ieee b F.minus_ff || F.le_ieee F.ff e then minus_one_one else begin let allpos = F.le_ieee F.zero b in let allneg = F.le_ieee e F.zero in if F.le_ieee F.m_minus_pi b && F.le_ieee e F.m_pi then begin if allpos then inject (F.cos e) (F.cos b) else if allneg then inject (F.cos b) (F.cos e) else inject (F.min (F.cos b) (F.cos e)) F.one end else if allpos || allneg then inject F.minus_one (F.max (F.cos b) (F.cos e)) else minus_one_one end let sin_float_precise v = Floating_point.set_round_nearest_even (); match v with | Private_Couple.I(b, e) -> if F.equal b e then let c = F.sin b in inject c c else if F.le_ieee b F.minus_ff || F.le_ieee F.ff e then minus_one_one else if F.le_ieee e F.m_pi_2 then begin if F.le_ieee F.m_minus_pi_2 b then inject (F.sin b) (F.sin e) else if F.le_ieee e F.m_minus_pi_2 then inject (F.sin e) (F.sin b) else inject F.minus_one (F.max (F.sin b) (F.sin e)) end else if F.le_ieee F.m_pi_2 b then inject (F.sin e) (F.sin b) else if F.le_ieee F.m_minus_pi_2 b then inject (F.min (F.sin b) (F.sin e)) F.one else minus_one_one let exp_float v = match v with Private_Couple.I(b, e) -> inject (F.exp b) (F.exp e) let widen (Private_Couple.I(b1,e1)) (Private_Couple.I(b2, e2)) = assert (F.le b2 b1); assert (F.le e1 e2); let b = if F.equal b2 b1 then b2 else F.widen_down b2 in let e = if F.equal e2 e1 then e2 else F.widen_up e2 in inject b e let equal_float_ieee f1 f2 = let Private_Couple.I(b1, e1) = f1 in let Private_Couple.I(b2, e2) = f2 in let intersects = F.le_ieee b1 e2 && F.le_ieee b2 e1 in if not intersects then true, false else if F.equal_ieee b1 e1 && F.equal_ieee b2 e2 then false, true else true, true let maybe_le_ieee_float f1 f2 = let Private_Couple.I(b1, _e1) = f1 in let Private_Couple.I(_b2, e2) = f2 in F.le_ieee b1 e2 let maybe_lt_ieee_float f1 f2 = let Private_Couple.I(b1, _e1) = f1 in let Private_Couple.I(_b2, e2) = f2 in F.lt_ieee b1 e2 let diff (Private_Couple.I(b1, e1) as f1) (Private_Couple.I(b2, e2)) = if F.le b2 b1 && F.le e1 e2 then raise Bottom else if F.le b2 e1 && F.le e1 e2 then inject b1 b2 else if F.le b1 e2 && F.le b2 b1 then inject e2 e1 else f1 let filter_le_f allmodes ~typ_loc (Private_Couple.I(b1, e1) as f1) e2 = let e2 = if F.equal_ieee F.zero e2 then F.zero else ( match allmodes, typ_loc with false, Cil_types.TFloat (Cil_types.FFloat, _) -> Floating_point.set_round_downward (); Floating_point.round_to_single_precision_float e2 | _ -> e2 ) in if not (F.le b1 e2) then raise Bottom else if F.le e1 e2 then f1 else inject b1 e2 let filter_le allmodes ~typ_loc f1 (Private_Couple.I(_b2, e2) as _f2) = filter_le_f allmodes ~typ_loc f1 e2 let filter_lt allmodes ~typ_loc (Private_Couple.I(b1, _e1) as f1) (Private_Couple.I(_b2, e2)) = if F.le_ieee e2 b1 then raise Bottom else let e2 = if allmodes then e2 else if F.equal_ieee F.zero e2 then F.neg_min_denormal else F.round_down e2 in filter_le_f allmodes ~typ_loc f1 e2 let filter_ge_f allmodes ~typ_loc (Private_Couple.I(b1, e1) as f1) b2 = let b2 = if F.equal_ieee F.minus_zero b2 then F.minus_zero else ( match allmodes, typ_loc with false, Cil_types.TFloat (Cil_types.FFloat, _) -> Floating_point.set_round_upward (); Floating_point.round_to_single_precision_float b2 | _ -> b2 ) in if not (F.le b2 e1) then raise Bottom else if F.le b2 b1 then f1 else inject b2 e1 let filter_ge allmodes ~typ_loc f1 (Private_Couple.I(b2, _e2)) = filter_ge_f allmodes ~typ_loc f1 b2 let filter_gt allmodes ~typ_loc (Private_Couple.I(_b1, e1) as f1) (Private_Couple.I(b2, _e2)) = if F.le_ieee e1 b2 then raise Bottom else let b2 = if allmodes then b2 else if F.equal_ieee F.zero b2 then F.min_denormal else F.round_up b2 in filter_ge_f allmodes ~typ_loc f1 b2 let subdiv_float_interval ~size (Private_Couple.I(l, u) as i) = let midpoint = F.avg l u in let midpointl, midpointu = if size <> 32 && size <> 64 then midpoint, midpoint else let smidpoint = F.round_up midpoint in if size = 64 then if F.le smidpoint u then if F.round_up l = u then l, u else midpoint, smidpoint else midpoint, u else begin (* 32 *) let i1 = Int64.bits_of_float l in if i1 = Int64.min_int && (Int64.bits_of_float u) = Int64.zero then l ,u else begin Floating_point.set_round_upward (); assert (F.equal l (Floating_point.round_to_single_precision_float l)); assert (F.equal u (Floating_point.round_to_single_precision_float u)); let midpointu = Floating_point.round_to_single_precision_float smidpoint in Floating_point.set_round_downward (); let midpointl = Floating_point.round_to_single_precision_float midpoint in midpointl, midpointu end end in if F.le midpointu l || F.le u midpointl then raise Can_not_subdiv; (* Format.printf "%a %a %a %a@." (F.pretty_normal ~use_hex:true) l (F.pretty_normal ~use_hex:true) midpointl (F.pretty_normal ~use_hex:true) midpointu (F.pretty_normal ~use_hex:true) u; *) let i1 = inject l midpointl in assert (is_included i1 i); let i2 = inject midpointu u in assert (is_included i2 i); i1, i2 end module Widen_Arithmetic_Value_Set = struct module V = Int module S = SetWithNearest.Make(Int) include S let pretty fmt s = if is_empty s then Format.fprintf fmt "{}" else Pretty_utils.pp_iter ~pre:"@[{" ~suf:"}@]" ~sep:";@ " iter Int.pretty fmt s let default_widen_hints = List.fold_left (fun acc x -> add (Int.of_int x) acc) empty [ -128;-1;0;1;3;15;127;512;32767;1 lsl 29 ] end exception Infinity let opt2 f m1 m2 = match m1, m2 with None, _ | _, None -> raise Infinity | Some m1, Some m2 -> f m1 m2 let opt1 f m = match m with None -> None | Some m -> Some (f m) exception Error_Top exception Error_Bottom module O = Set.Make(Int) type pre_set = Pre_set of O.t * int | Pre_top of Int.t * Int.t * Int.t type tt = | Set of Int.t array | Float of Float_abstract.t | Top of Int.t option * Int.t option * Int.t * Int.t module Widen_Hints = Widen_Arithmetic_Value_Set type widen_hint = Widen_Hints.t let some_zero = Some Int.zero let bottom = Set (Array.make 0 Int.zero) let top = Top(None, None, Int.zero, Int.one) let set_of_array a = Array.fold_right O.add a O.empty let hash_v_option v = match v with None -> 97 | Some v -> Int.hash v let hash v = match v with Set s -> Array.fold_left (fun acc v -> 1031 * acc + (Int.hash v)) 17 s | Top(mn,mx,r,m) -> hash_v_option mn + 5501 * (hash_v_option mx) + 59 * (Int.hash r) + 13031 * (Int.hash m) | Float(f) -> 3 + 17 * Float_abstract.hash f let bound_compare x y = match x,y with None, None -> 0 | None, Some _ -> 1 | Some _, None -> -1 | Some x, Some y -> Int.compare x y exception Unequal of int let compare e1 e2 = if e1==e2 then 0 else match e1,e2 with | Set e1,Set e2 -> let l1 = Array.length e1 in let l2 = Array.length e2 in if l1 <> l2 then l1 - l2 (* no overflow here *) else (try for i=0 to l1 -1 do let r = Int.compare e1.(i) e2.(i) in if r <> 0 then raise (Unequal r) done; 0 with Unequal v -> v ) | _, Set _ -> 1 | Set _, _ -> -1 | Top(mn,mx,r,m), Top(mn',mx',r',m') -> let r1 = bound_compare mn mn' in if r1 <> 0 then r1 else let r2 = bound_compare mx mx' in if r2 <> 0 then r2 else let r3 = Int.compare r r' in if r3 <> 0 then r3 else Int.compare m m' | _, Top _ -> 1 | Top _, _ -> -1 | Float(f1), Float(f2) -> Float_abstract.compare f1 f2 (*| _, Float _ -> 1 | Float _, _ -> -1 *) let equal e1 e2 = compare e1 e2 = 0 let pretty fmt t = match t with | Top(mn,mx,r,m) -> let print_bound fmt = function None -> Format.fprintf fmt "--" | Some v -> Int.pretty fmt v in Format.fprintf fmt "[%a..%a]%t" print_bound mn print_bound mx (fun fmt -> if Int.is_zero r && Int.is_one m then Format.fprintf fmt "" else Format.fprintf fmt ",%a%%%a" Int.pretty r Int.pretty m) | Float (f) -> Float_abstract.pretty fmt f | Set s -> if Array.length s = 0 then Format.fprintf fmt "BottomMod" else begin Pretty_utils.pp_iter ~pre:"@[{" ~suf:"}@]" ~sep:";@ " Array.iter Int.pretty fmt s end let compare_elt_min elt min = match min with | None -> true | Some m -> Int.le m elt let compare_elt_max elt max = match max with | None -> true | Some m -> Int.ge m elt let all_positives min = match min with | None -> false | Some m -> Int.ge m Int.zero let all_negatives max = match max with | None -> false | Some m -> Int.le m Int.zero let check doc min max r modu = assert(assert (Int.ge r Int.zero ); assert (Int.ge modu Int.one ); (match min with | None -> () | Some m -> if not (Int.equal (Int.pos_rem m modu) r) then begin Kernel.warning ~once:true ~current:true "Make_Lattice_Mod.check: '%s'\n" doc; Kernel.feedback "min=%a modu=%a r=%a@." Int.pretty m Int.pretty modu Int.pretty r; assert false end); (match max with | None -> () | Some m -> assert (Int.equal (Int.pos_rem m modu) r)); true) let cardinal_zero_or_one v = match v with | Top _ -> false | Set s -> Array.length s <= 1 | Float (f) -> Float_abstract.is_singleton f let is_singleton_int v = match v with | Float _ | Top _ -> false | Set s -> Array.length s = 1 let is_bottom x = x == bottom let o_zero = O.singleton Int.zero let o_one = O.singleton Int.one let o_zero_or_one = O.union o_zero o_one let small_nums = Array.map (fun i -> Set [| i |]) Int.small_nums let zero = small_nums.(0) let one = small_nums.(1) let zero_or_one = Set [| Int.zero ; Int.one |] let is_zero x = x == zero let inject_singleton e = if Int.le Int.zero e && Int.le e Int.thirtytwo then small_nums.(Int.to_int e) else Set [| e |] let share_set o s = if s = 0 then bottom else if s = 1 then begin let e = O.min_elt o in inject_singleton e end else if O.equal o o_zero_or_one then zero_or_one else let a = Array.make s Int.zero in let i = ref 0 in O.iter (fun e -> a.(!i) <- e; incr i) o; assert (!i = s); Set a let share_array a s = if s = 0 then bottom else let e = a.(0) in if s = 1 && Int.le Int.zero e && Int.le e Int.thirtytwo then small_nums.(Int.to_int e) else if s = 2 && Int.is_zero e && Int.is_one a.(1) then zero_or_one else Set a let inject_float f = if Float_abstract.is_zero f then zero else Float f let inject_float_interval flow fup = let flow = F.of_float flow in let fup = F.of_float fup in if F.equal F.zero flow && F.equal F.zero fup then zero else Float (Float_abstract.inject (F.of_float flow) (F.of_float fup)) let subdiv_float_interval ~size v = match v with | Float f -> let f1, f2 = Float_abstract.subdiv_float_interval ~size f in inject_float f1, inject_float f2 | Top _ | Set _ -> assert (is_zero v); raise Can_not_subdiv (* let minus_zero = Float (Float_abstract.minus_zero, Float_abstract.minus_zero) *) let is_one = equal one let project_float v = if is_zero v then Float_abstract.zero else match v with Float f -> f | Top _ | Set _ -> raise Float_abstract.Nan_or_infinite let in_interval x min max r modu = (Int.equal (Int.pos_rem x modu) r) && (compare_elt_min x min) && (compare_elt_max x max) let array_mem v a = let l = Array.length a in let rec c i = if i = l then (-1) else let ae = a.(i) in if Int.equal ae v then i else if Int.gt ae v then (-1) else c (succ i) in c 0 let contains_zero s = match s with | Top(mn,mx,r,m) -> in_interval Int.zero mn mx r m | Set s -> (array_mem Int.zero s)>=0 | Float f -> Float_abstract.contains_zero f exception Not_Singleton_Int let project_int v = match v with | Set [| e |] -> e | _ -> raise Not_Singleton_Int let cardinal_less_than v n = let c = match v with | Top (None,_,_,_) | Top (_,None,_,_) -> raise Not_less_than | Top (Some mn, Some mx,_,m) -> Int.succ ((Int.native_div (Int.sub mx mn) m)) | Set s -> Int.of_int (Array.length s) | Float f -> if Float_abstract.is_singleton f then Int.one else raise Not_less_than in if Int.le c (Int.of_int n) then Int.to_int c (* This is smaller than the original [n] *) else raise Not_less_than let splitting_cardinal_less_than ~split_non_enumerable v n = let c = match v with | Top (None,_,_,_) | Top (_,None,_,_) -> raise Not_less_than | Top (Some mn, Some mx,_,m) -> Int.succ ((Int.native_div (Int.sub mx mn) m)) | Set s -> Int.of_int (Array.length s) | Float f -> if Float_abstract.is_singleton f then Int.one else Int.of_int split_non_enumerable in if Int.le c (Int.of_int n) then Int.to_int c else raise Not_less_than let share_top min max r modu = let r = Top (min, max, r, modu) in if equal r top then top else r let inject_top min max r modu = check "inject_top" min max r modu; match min, max with | Some mn, Some mx -> if Int.gt mx mn then let l = Int.succ (Int.div (Int.sub mx mn) modu) in if Int.le l !small_cardinal_Int then let l = Int.to_int l in let s = Array.make l Int.zero in let v = ref mn in let i = ref 0 in while (!i < l) do s.(!i) <- !v; v := Int.add modu !v; incr i done; assert (Int.equal !v (Int.add modu mx)); share_array s l else Top (min, max, r, modu) else if Int.equal mx mn then inject_singleton mn else bottom | _ -> share_top min max r modu let subdiv ~size v = match v with | Float _ -> subdiv_float_interval ~size v | Set arr -> let len = Array.length arr in assert (len > 0 ); if len <= 1 then raise Can_not_subdiv; let m = len lsr 1 in let lenhi = len - m in let lo = Array.sub arr 0 m in let hi = Array.sub arr m lenhi in share_array lo m, share_array hi lenhi | Top (Some lo, Some hi, r, modu) -> let mean = Int.native_div (Int.add lo hi) Abstract_interp.Int.two in let succmean = Abstract_interp.Int.succ mean in let hilo = Integer.round_down_to_r ~max:mean ~r ~modu in let lohi = Integer.round_up_to_r ~min:succmean ~r ~modu in inject_top (Some lo) (Some hilo) r modu, inject_top (Some lohi) (Some hi) r modu | Top _ -> raise Can_not_subdiv let inject_range min max = inject_top min max Int.zero Int.one let top_float = Float Float_abstract.top let unsafe_make_top_from_set_4 s = assert (O.cardinal s >= 2); let m = O.min_elt s in let modu = O.fold (fun x acc -> if Int.equal x m then acc else Int.pgcd (Int.sub x m) acc) s Int.zero in let r = Int.pos_rem m modu in let max = O.max_elt s in let min = m in (min,max,r,modu) let unsafe_make_top_from_array_4 s = let l = Array.length s in assert (l >= 2); let m = s.(0) in let modu = Array.fold_left (fun acc x -> if Int.equal x m then acc else Int.pgcd (Int.sub x m) acc) Int.zero s in let r = Int.pos_rem m modu in let max = Some s.(pred l) in let min = Some m in check "unsafe_make_top_from_array_4" min max r modu; (min,max,r,modu) let unsafe_make_top_from_array s = let min, max, r, modu = unsafe_make_top_from_array_4 s in share_top min max r modu let empty_ps = Pre_set (O.empty, 0) let add_ps ps x = match ps with Pre_set(o,s) -> assert (O.cardinal o = s); if (O.mem x o) (* TODO: improve *) then ps else let no = O.add x o in if s < !small_cardinal then begin assert (O.cardinal no = succ s); Pre_set (no, succ s) end else let min, max, _r, modu = unsafe_make_top_from_set_4 no in Pre_top (min, max, modu) | Pre_top (min, max, modu) -> let new_modu = if Int.equal x min then modu else Int.pgcd (Int.sub x min) modu in let new_min = Int.min min x in let new_max = Int.max max x in Pre_top (new_min, new_max, new_modu) let inject_ps ps = match ps with Pre_set(o, s) -> share_set o s | Pre_top (min, max, modu) -> Top(Some min, Some max, Int.pos_rem min modu, modu) let min_max_r_mod t = match t with | Set s -> assert (Array.length s >= 2); unsafe_make_top_from_array_4 s | Top (a,b,c,d) -> a,b,c,d | Float _ -> None, None, Int.zero, Int.one let min_and_max t = match t with | Set s -> let l = Array.length s in assert (l >= 1); Some s.(0), Some s.(pred l) | Top (a,b,_,_) -> a, b | Float _ -> None, None let min_and_max_float t = match t with Set _ when is_zero t -> F.zero, F.zero | Float f -> Float_abstract.min_and_max_float f | _ -> assert false exception Unforceable let force_float kind i = match i with Float _ -> false, i | Set _ when is_zero i -> false, i | Top _ | Set _ -> ( match kind with Cil_types.FDouble -> ( try ( match min_and_max i with Some mn, Some mx -> let mn, mx = if Int.le Int.zero mn && Int.le mx Int.bits_of_max_float then mn, mx else if Int.le Int.min_int64 mn && Int.le mx Int.bits_of_most_negative_float then mx, mn else raise Unforceable in let red, fa = Float_abstract.inject_r (Int64.float_of_bits (Int.to_int64 mn)) (Int64.float_of_bits (Int.to_int64 mx)) in assert (not red); let f = inject_float fa in (* Format.printf "cv: %a -> %a@." pretty i pretty f; *) false, f | _, _ -> true, top_float) with Unforceable -> true, top_float ) | _ -> false, i) let compare_min_int t1 t2 = let m1, _ = min_and_max t1 in let m2, _ = min_and_max t2 in match m1, m2 with None, None -> 0 | None, Some _ -> -1 | Some _, None -> 1 | Some m1, Some m2 -> Int.compare m1 m2 let compare_max_int t1 t2 = let _, m1 = min_and_max t1 in let _, m2 = min_and_max t2 in match m1, m2 with None, None -> 0 | None, Some _ -> 1 | Some _, None -> -1 | Some m1, Some m2 -> Int.compare m2 m1 let compare_min_float t1 t2 = let f1 = project_float t1 in let f2 = project_float t2 in Float_abstract.compare_min f1 f2 let compare_max_float t1 t2 = let f1 = project_float t1 in let f2 = project_float t2 in Float_abstract.compare_max f1 f2 let widen wh t1 t2 = if equal t1 t2 || cardinal_zero_or_one t1 then t2 else match t2 with Float f2 -> ( try let f1 = project_float t1 in if not (Float_abstract.is_included f1 f2) then assert false; Float (Float_abstract.widen f1 f2) with Float_abstract.Nan_or_infinite -> assert false) | Top _ | Set _ -> let (mn2,mx2,r2,m2) = min_max_r_mod t2 in let (mn1,mx1,r1,m1) = min_max_r_mod t1 in let new_mod = Int.pgcd (Int.pgcd m1 m2) (Int.abs (Int.sub r1 r2)) in let new_rem = Int.rem r1 new_mod in let new_min = if bound_compare mn1 mn2 = 0 then mn2 else match mn2 with | None -> None | Some mn2 -> try let v = Widen_Hints.nearest_elt_le mn2 wh in Some (Int.round_up_to_r ~r:new_rem ~modu:new_mod ~min:v) with Not_found -> None in let new_max = if bound_compare mx1 mx2 = 0 then mx2 else match mx2 with None -> None | Some mx2 -> try let v = Widen_Hints.nearest_elt_ge mx2 wh in Some (Int.round_down_to_r ~r:new_rem ~modu:new_mod ~max:v) with Not_found -> None in let result = inject_top new_min new_max new_rem new_mod in (* Format.printf "%a -- %a --> %a (thx to %a)@." pretty t1 pretty t2 pretty result Widen_Hints.pretty wh; *) result let compute_first_common mn1 mn2 r modu = if mn1 == None && mn2 == None then None else let m = match (mn1, mn2) with | Some m, None | None, Some m -> m | Some m1, Some m2 -> Int.max m1 m2 | None, None -> assert false (* already tested above *) in Some (Int.round_up_to_r m r modu) let compute_last_common mx1 mx2 r modu = if mx1 == None && mx2 == None then None else let m = match (mx1, mx2) with | Some m, None | None, Some m -> m | Some m1, Some m2 -> Int.min m1 m2 | None, None -> assert false (* already tested above *) in Some (Int.round_down_to_r m r modu) let min_min x y = match x,y with | None,_ | _,None -> None | Some x, Some y -> Some (Int.min x y) let max_max x y = match x,y with | None,_ | _,None -> None | Some x, Some y -> Some (Int.max x y) (* [extended_euclidian_algorithm a b] returns x,y,gcd such that a*x+b*y=gcd(x,y). *) let extended_euclidian_algorithm a b = assert (Int.gt a Int.zero); assert (Int.gt b Int.zero); let a = ref a and b = ref b in let x = ref Int.zero and lastx = ref Int.one in let y = ref Int.one and lasty = ref Int.zero in while not (Int.is_zero !b) do let (q,r) = Int.div_rem !a !b in a := !b; b := r; let tmpx = !x in (x:= Int.sub !lastx (Int.mul q !x); lastx := tmpx); let tmpy = !y in (y:= Int.sub !lasty (Int.mul q !y); lasty := tmpy); done; (!lastx,!lasty,!a) (* [JS 2013/05/23] unused right now [modular_inverse a m] returns [x] such that a*x is congruent to 1 mod m. *) let _modular_inverse a m = let (x,_,gcd) = extended_euclidian_algorithm a m in assert (Int.equal Int.one gcd); x (* This function provides solutions to the chinese remainder theorem, i.e. it finds the solutions x such that: x == r1 mod m1 && x == r2 mod m2. If no such solution exists, it raises Error_Bottom; else it returns (r,m) such that all solutions x are such that x == r mod m. *) let compute_r_common r1 m1 r2 m2 = (* (E1) x == r1 mod m1 && x == r2 mod m2 <=> \E k1,k2: x = r1 + k1*m1 && x = r2 + k2*m2 <=> \E k1,k2: x = r1 + k1*m1 && k1*m1 - k2*m2 = r2 - r1 Let c = r2 - r1. The equation (E2): k1*m1 - k2*m2 = c is diophantine; there are solutions x to (E1) iff there are solutions (k1,k2) to (E2). Let d = pgcd(m1,m2). There are solutions to (E2) only if d divides c (because d divides k1*m1 - k2*m2). Else we raise [Error_Bottom]. *) let (x1,_,pgcd) = extended_euclidian_algorithm m1 m2 in let c = Int.sub r2 r1 in let (c_div_d,c_rem) = Int.div_rem c pgcd in if not (Int.equal c_rem Int.zero) then raise Error_Bottom (* The extended euclidian algorithm has provided solutions x1,x2 to the Bezout identity x1*m1 + x2*m2 = d. x1*m1 + x2*m2 = d ==> x1*(c/d)*m1 + x2*(c/d)*m2 = d*(c/d). Thus, k1 = x1*(c/d), k2=-x2*(c/d) are solutions to (E2) Thus, x = r1 + x1*(c/d)*m1 is a particular solution to (E1). *) else let k1 = Int.mul x1 c_div_d in let x = Int.add r1 (Int.mul k1 m1) in (* If two solutions x and y exist, they are equal modulo ppcm(m1,m2). We have x == r1 mod m1 && y == r1 mod m1 ==> \E k1: x - y = k1*m1 x == r2 mod m2 && y == r2 mod m2 ==> \E k2: x - y = k2*m2 Thus k1*m1 = k2*m2 is a multiple of m1 and m2, i.e. is a multiple of ppcm(m1,m2). Thus x = y mod ppcm(m1,m2). *) let ppcm = Int.divexact (Int.mul m1 m2) pgcd in (* x may be bigger than the ppcm, we normalize it. *) (Int.rem x ppcm, ppcm) ;; let array_truncate r i = if i = 0 then bottom else if i = 1 then inject_singleton r.(0) else begin (Obj.truncate (Obj.repr r) i); assert (Array.length r = i); Set r end let array_inter a1 a2 = let l1 = Array.length a1 in let l2 = Array.length a2 in let lr_max = min l1 l2 in let r = Array.make lr_max Int.zero in let rec c i i1 i2 = if i1 = l1 || i2 = l2 then array_truncate r i else let e1 = a1.(i1) in let e2 = a2.(i2) in if Int.equal e1 e2 then begin r.(i) <- e1; c (succ i) (succ i1) (succ i2) end else if Int.lt e1 e2 then c i (succ i1) i2 else c i i1 (succ i2) in c 0 0 0 let meet v1 v2 = if v1 == v2 then v1 else let result = match v1,v2 with | Top(min1,max1,r1,modu1), Top(min2,max2,r2,modu2) -> begin try let r,modu = compute_r_common r1 modu1 r2 modu2 in inject_top (compute_first_common min1 min2 r modu) (compute_last_common max1 max2 r modu) r modu with Error_Bottom -> (*Format.printf "meet to bottom: %a /\\ %a@\n" pretty v1 pretty v2;*) bottom end | Set s1 , Set s2 -> array_inter s1 s2 | Set s, Top(min, max, rm, modu) | Top(min, max, rm, modu), Set s -> let l = Array.length s in let r = Array.create l Int.zero in let rec c i j = if i = l then array_truncate r j else let si = succ i in let x = s.(i) in if in_interval x min max rm modu then begin r.(j) <- x; c si (succ j) end else c si j in c 0 0 | Float(f1), Float(f2) -> ( try inject_float (Float_abstract.meet f1 f2) with Float_abstract.Bottom -> bottom ) | (Float f) as ff, other | other, ((Float f) as ff) -> if equal top other then ff else if (Float_abstract.contains_zero f) && contains_zero other then zero else bottom in (* Format.printf "meet: %a /\\ %a -> %a@\n" pretty v1 pretty v2 pretty result;*) result let narrow v1 v2 = match v1, v2 with | Float _, Float _ | (Top _| Set _), (Top _ | Set _) -> meet v1 v2 (* meet is exact *) | v, (Top _ as t) | (Top _ as t), v when equal t top -> v | Float f, (Set _ as s) | (Set _ as s), Float f when is_zero s -> ( try inject_float (Float_abstract.meet f Float_abstract.zero) with Float_abstract.Bottom -> bottom ) | Float _, (Set _ | Top _) | (Set _ | Top _), Float _ -> (* ill-typed case. It is better to keep the operation symmetric *) top let link _ = assert false let join v1 v2 = let result = if v1 == v2 then v1 else match v1,v2 with | Top(mn1,mx1,r1,m1), Top(mn2,mx2,r2,m2) -> check "join left" mn1 mx1 r1 m1; check "join right" mn2 mx2 r2 m2; let modu = Int.pgcd (Int.pgcd m1 m2) (Int.abs(Int.sub r1 r2)) in let r = Int.rem r1 modu in let min = min_min mn1 mn2 in let max = max_max mx1 mx2 in let r = inject_top min max r modu in r | Set s, (Top(min, max, r, modu) as t) | (Top(min, max, r, modu) as t), Set s -> let l = Array.length s in if l = 0 then t else let f modu elt = Int.pgcd modu (Int.abs(Int.sub r elt)) in let new_modu = Array.fold_left f modu s in let new_r = Int.rem r new_modu in let new_min = match min with None -> None | Some m -> Some (Int.min m s.(0)) in let new_max = match max with None -> None | Some m -> Some (Int.max m s.(pred l)) in check "inside join" new_min new_max new_r new_modu; share_top new_min new_max new_r new_modu | Set s1 , Set s2 -> let l1 = Array.length s1 in if l1 = 0 then v2 else let l2 = Array.length s2 in if l2 = 0 then v1 else (* second pass: make a set or make a top *) let second uniq = if uniq <= !small_cardinal then let r = Array.create uniq Int.zero in let rec c i i1 i2 = if i1 = l1 then begin Array.blit s2 i2 r i (l2 - i2); share_array r uniq end else if i2 = l2 then begin Array.blit s1 i1 r i (l1 - i1); share_array r uniq end else let si = succ i in let e1 = s1.(i1) in let e2 = s2.(i2) in if Int.lt e2 e1 then begin r.(i) <- e2; c si i1 (succ i2) end else begin r.(i) <- e1; let si1 = succ i1 in if Int.equal e1 e2 then begin c si si1 (succ i2) end else begin c si si1 i2 end end in c 0 0 0 else begin let m = Int.min s1.(0) s2.(0) in let accum acc x = if Int.equal x m then acc else Int.pgcd (Int.sub x m) acc in let modu = ref Int.zero in for j = 0 to pred l1 do modu := accum !modu s1.(j) done; for j = 0 to pred l2 do modu := accum !modu s2.(j) done; inject_ps (Pre_top (m, Int.max s1.(pred l1) s2.(pred l2), !modu)) end in (* first pass: count unique elements and detect inclusions *) let rec first i1 i2 uniq inc1 inc2 = let finished1 = i1 = l1 in if finished1 then begin if inc2 then v2 else second (uniq + l2 - i2) end else let finished2 = i2 = l2 in if finished2 then begin if inc1 then v1 else second (uniq + l1 - i1) end else let e1 = s1.(i1) in let e2 = s2.(i2) in if Int.lt e2 e1 then begin first i1 (succ i2) (succ uniq) false inc2 end else if Int.gt e2 e1 then begin first (succ i1) i2 (succ uniq) inc1 false end else first (succ i1) (succ i2) (succ uniq) inc1 inc2 in first 0 0 0 true true | Float(f1), Float(f2) -> inject_float (Float_abstract.join f1 f2) | Float (f) as ff, other | other, (Float (f) as ff) -> if is_zero other then inject_float (Float_abstract.join Float_abstract.zero f) else if is_bottom other then ff else top in (* Format.printf "mod_join %a %a -> %a@." pretty v1 pretty v2 pretty result; *) result (* TODO: rename this function in fold_int *) let fold f v acc = match v with Top(None,_,_,_) | Top(_,None,_,_) | Float _ -> raise Error_Top | Top(Some inf, Some sup, _, step) -> Int.fold f ~inf ~sup ~step acc | Set s -> Array.fold_left (fun acc x -> f x acc) acc s let fold_enum ~split_non_enumerable f v acc = match v with | Float (fl) when Float_abstract.is_singleton fl -> f v acc | Float (fl) -> Float_abstract.fold_split split_non_enumerable (fun fl acc -> f (inject_float fl) acc) fl acc | Top(_,_,_,_) | Set _ -> fold (fun x acc -> f (inject_singleton x) acc) v acc (** [min_is_lower mn1 mn2] is true iff mn1 is a lower min than mn2 *) let min_is_lower mn1 mn2 = match mn1, mn2 with None, _ -> true | _, None -> false | Some m1, Some m2 -> Int.le m1 m2 (** [max_is_greater mx1 mx2] is true iff mx1 is a greater max than mx2 *) let max_is_greater mx1 mx2 = match mx1, mx2 with None, _ -> true | _, None -> false | Some m1, Some m2 -> Int.ge m1 m2 let rem_is_included r1 m1 r2 m2 = (Int.is_zero (Int.rem m1 m2)) && (Int.equal (Int.rem r1 m2) r2) let array_for_all f (a : Integer.t array) = let l = Array.length a in let rec c i = i = l || ((f a.(i)) && c (succ i)) in c 0 let array_subset a1 a2 = let l1 = Array.length a1 in let l2 = Array.length a2 in if l1 > l2 then false else let rec c i1 i2 = if i1 = l1 then true else if i2 = l2 then false else let e1 = a1.(i1) in let e2 = a2.(i2) in let si2 = succ i2 in if Int.equal e1 e2 then c (succ i1) si2 else if Int.lt e1 e2 then false else c i1 si2 (* TODO: improve by not reading a1.(i1) all the time *) in c 0 0 let is_included t1 t2 = (t1 == t2) || match t1,t2 with | Top(mn1,mx1,r1,m1), Top(mn2,mx2,r2,m2) -> (min_is_lower mn2 mn1) && (max_is_greater mx2 mx1) && rem_is_included r1 m1 r2 m2 | Top _, Set _ -> false (* Top _ represents more elements than can be represented by Set _ *) | Set s, Top(min, max, r, modu) -> array_for_all (fun x -> in_interval x min max r modu) s | Set s1, Set s2 -> array_subset s1 s2 | Float(f1), Float(f2) -> Float_abstract.is_included f1 f2 | Float _, _ -> equal t2 top | _, Float (f) -> is_zero t1 && (Float_abstract.contains_zero f) let is_included_exn v1 v2 = if not (is_included v1 v2) then raise Is_not_included (* In this lattice, [meet t1 t2=bottom] iff the intersection of [t1] and [t2] is empty. *) let intersects t1 t2 = not (equal bottom (meet t1 t2)) let partially_overlaps size t1 t2 = match t1, t2 with Set s1, Set s2 -> not (array_for_all (fun e1 -> array_for_all (fun e2 -> Int.equal e1 e2 || Int.le e1 (Int.sub e2 size) || Int.ge e1 (Int.add e2 size)) s2) s1) | Set s, Top(mi, ma, r, modu) | Top(mi, ma, r, modu), Set s -> not (array_for_all (fun e -> let psize = Int.pred size in (not (compare_elt_min (Int.add e psize) mi)) || (not (compare_elt_max (Int.sub e psize) ma)) || ( Int.ge modu size && let re = Int.pos_rem (Int.sub e r) modu in Int.is_zero re || (Int.ge re size && Int.le re (Int.sub modu size)) )) s) | _ -> false (* TODO *) let map_set_exnsafe_acc f acc (s : Integer.t array) = Array.fold_left (fun acc v -> add_ps acc (f v)) acc s let map_set_exnsafe f (s : Integer.t array) = inject_ps (map_set_exnsafe_acc f empty_ps s) let apply2_notzero f (s1 : Integer.t array) s2 = inject_ps (Array.fold_left (fun acc v1 -> Array.fold_left (fun acc v2 -> if Int.is_zero v2 then acc else add_ps acc (f v1 v2)) acc s2) empty_ps s1) let apply2_n f (s1 : Integer.t array) (s2 : Integer.t array) = let ps = ref empty_ps in let l1 = Array.length s1 in let l2 = Array.length s2 in for i1 = 0 to pred l1 do let e1 = s1.(i1) in for i2 = 0 to pred l2 do ps := add_ps !ps (f e1 s2.(i2)) done done; inject_ps !ps let apply2_v f s1 s2 = match s1, s2 with [| x1 |], [| x2 |] -> inject_singleton (f x1 x2) | _ -> apply2_n f s1 s2 let apply_set f v1 v2 = match v1,v2 with | Set s1, Set s2 -> apply2_n f s1 s2 | _ -> (*ignore (CilE.warn_once "unsupported case for binary operator '%s'" info);*) top let apply_set_unary _info f v = (* TODO: improve by allocating array*) match v with | Set s -> map_set_exnsafe f s | _ -> (*ignore (CilE.warn_once "unsupported case for unary operator '%s'" info);*) top let apply_bin_1_strict_incr f x (s : Integer.t array) = let l = Array.length s in let r = Array.create l Int.zero in let rec c i = if i = l then share_array r l else let v = f x s.(i) in r.(i) <- v; c (succ i) in c 0 let apply_bin_1_strict_decr f x (s : Integer.t array) = let l = Array.length s in let r = Array.create l Int.zero in let rec c i = if i = l then share_array r l else let v = f x s.(i) in r.(l - i - 1) <- v; c (succ i) in c 0 let map_set_strict_decr f (s : Integer.t array) = let l = Array.length s in let r = Array.create l Int.zero in let rec c i = if i = l then share_array r l else let v = f s.(i) in r.(l - i - 1) <- v; c (succ i) in c 0 let map_set_decr f (s : Integer.t array) = let l = Array.length s in if l = 0 then bottom else let r = Array.create l Int.zero in let rec c srcindex dstindex last = if srcindex < 0 then begin r.(dstindex) <- last; array_truncate r (succ dstindex) end else let v = f s.(srcindex) in if Int.equal v last then c (pred srcindex) dstindex last else begin r.(dstindex) <- last; c (pred srcindex) (succ dstindex) v end in c (l-2) 0 (f s.(pred l)) let map_set_incr f (s : Integer.t array) = let l = Array.length s in if l = 0 then bottom else let r = Array.create l Int.zero in let rec c srcindex dstindex last = if srcindex = l then begin r.(dstindex) <- last; array_truncate r (succ dstindex) end else let v = f s.(srcindex) in if Int.equal v last then c (succ srcindex) dstindex last else begin r.(dstindex) <- last; c (succ srcindex) (succ dstindex) v end in c 1 0 (f s.(0)) let rec add_int v1 v2 = match v1,v2 with Float _, _ | _, Float _ -> top | Set [| x |], Set s | Set s, Set [| x |]-> apply_bin_1_strict_incr Int.add x s | Set s1, Set s2 -> apply2_n Int.add s1 s2 | Top(mn1,mx1,r1,m1), Top(mn2,mx2,r2,m2) -> let m = Int.pgcd m1 m2 in let r = Int.rem (Int.add r1 r2) m in let mn = try Some (Int.round_up_to_r (opt2 Int.add mn1 mn2) r m) with Infinity -> None in let mx = try Some (Int.round_down_to_r (opt2 Int.add mx1 mx2) r m) with Infinity -> None in inject_top mn mx r m | Set s, (Top(mn1,mx1,r1,m1) as t) | (Top(mn1,mx1,r1,m1) as t), Set s -> let l = Array.length s in if l = 0 then bottom else if l = 1 then (* only one element *) let mn = s.(0) in let incr = Int.add mn in let new_mn = opt1 incr mn1 in let new_mx = opt1 incr mx1 in let new_r = Int.pos_rem (incr r1) m1 in check "add" new_mn new_mx new_r m1 ; share_top new_mn new_mx new_r m1 else add_int t (unsafe_make_top_from_array s) (* TODO rename to neg_int *) let neg v = match v with | Float _ -> top | Set s -> map_set_strict_decr Int.neg s | Top(mn,mx,r,m) -> share_top (opt1 Int.neg mx) (opt1 Int.neg mn) (Int.pos_rem (Int.neg r) m) m let sub v1 v2 = add_int v1 (neg v2) type ext_value = Ninf | Pinf | Val of Int.t let inject_min = function None -> Ninf | Some m -> Val m let inject_max = function None -> Pinf | Some m -> Val m let ext_neg = function Ninf -> Pinf | Pinf -> Ninf | Val v -> Val (Int.neg v) let ext_mul x y = match x, y with | Ninf, Ninf | Pinf, Pinf -> Pinf | Ninf, Pinf | Pinf, Ninf -> Ninf | Val v1, Val v2 -> Val (Int.mul v1 v2) | (x, Val v | Val v, x) when (Int.gt v Int.zero) -> x | (x, Val v | Val v, x) when (Int.lt v Int.zero) -> ext_neg x | _ -> Val Int.zero let ext_min x y = match x,y with Ninf, _ | _, Ninf -> Ninf | Pinf, x | x, Pinf -> x | Val x, Val y -> Val(Int.min x y) let ext_max x y = match x,y with Pinf, _ | _, Pinf -> Pinf | Ninf, x | x, Ninf -> x | Val x, Val y -> Val(Int.max x y) let ext_proj = function Val x -> Some x | _ -> None let singleton_zero = zero let singleton_one = one let zero_or_one = join singleton_one singleton_zero let negative = Top(None, Some Int.minus_one,Int.zero,Int.one) let min_int s = match s with | Top (min,_,_,_) -> min | Set s -> if Array.length s = 0 then raise Error_Bottom else Some s.(0) | Float _ -> None let max_int s = match s with | Top (_,max,_,_) -> max | Set s -> let l = Array.length s in if l = 0 then raise Error_Bottom else Some s.(pred l) | Float _ -> None exception No_such_element let smallest_above min x = (* TODO: improve for Set *) match x with | Set s -> let r = ref None in Array.iter (fun e -> if Int.ge e min then match !r with | Some rr when Int.lt e rr -> r := Some e | None -> r := Some e | _ -> ()) s; begin match !r with None -> raise No_such_element | Some r -> r end | Top(mn,mx,r,modu) -> let some_min = Some min in if not (max_is_greater mx some_min) then raise No_such_element; if min_is_lower some_min mn then Extlib.the mn else Int.round_up_to_r ~min ~r ~modu | Float _ -> raise No_such_element let largest_below max x = (* TODO: improve for Set *) match x with | Float _ -> raise No_such_element | Set s -> let r = ref None in Array.iter (fun e -> if Int.le e max then match !r with | Some rr when Int.gt e rr -> r := Some e | None -> r := Some e | _ -> ()) s; begin match !r with None -> raise No_such_element | Some r -> r end | Top(mn,mx,r,modu) -> let some_max = Some max in if not (min_is_lower mn some_max) then raise No_such_element; if max_is_greater some_max mx then Extlib.the mx else Int.round_down_to_r ~max ~r ~modu let next_pred_power_of_two x = let x = Int.logor x (Int.shift_right x Int.one) in let x = Int.logor x (Int.shift_right x Int.two) in let rec f old = let x = Int.logor old (Int.shift_right old Int.four) in if Int.equal old x then x else f x in f x (* [different_bits min min] returns the mask of the bits that can be different for different numbers in the interval [min]..[max] *) let different_bits min max = let x = Int.logxor min max in next_pred_power_of_two x (* [pos_max_land min1 max1 min2 max2] computes an upper bound for [x1 land x2] where [x1] is in [min1]..[max1] and [x2] is in [min2]..[max2]. Precondition : [min1], [max1], [min2], [max2] must all have the same sign *) let pos_max_land min1 max1 min2 max2 = let x1 = different_bits min1 max1 in let x2 = different_bits min2 max2 in (* Format.printf "pos_max_land %a %a -> %a | %a %a -> %a@." Int.pretty min1 Int.pretty max1 Int.pretty x1 Int.pretty min2 Int.pretty max2 Int.pretty x2;*) if Int.lt x1 x2 then (*let diff = Int.sub x2 x1 in*) let mask = Int.lognot x2 in let forced = Int.logand mask min1 in let part = Int.logand forced min2 in if Int.equal part forced then Int.min max1 max2 else Int.logor part x2 else (*let diff = Int.sub x1 x2 in*) let mask = Int.lognot x1 in let forced = Int.logand mask min2 in let part = Int.logand forced min1 in if Int.equal part forced then Int.min max1 max2 else Int.logor part x1 let bitwise_or ~size:_ v1 v2 = if is_bottom v1 || is_bottom v2 then bottom else match v1, v2 with Float _, _ | _, Float _ -> top | Set s1, Set s2 -> apply2_v Int.logor s1 s2 | Top _, _ | _, Top _ -> ( match min_and_max v1 with Some mn1, Some mx1 when Int.ge mn1 Int.zero -> ( match min_and_max v2 with Some mn2, Some mx2 when Int.ge mn2 Int.zero -> let r = next_pred_power_of_two (Int.logor mx1 mx2) in inject_range (Some (Int.max mn1 mn2)) (Some r) | _ -> top ) | _ -> top ) let bitwise_xor v1 v2 = if is_bottom v1 || is_bottom v2 then bottom else match v1, v2 with | Float _, _ | _, Float _ -> top | Set s1, Set s2 -> apply2_v Int.logxor s1 s2 | Top _, _ | _, Top _ -> (match min_and_max v1 with | Some mn1, Some mx1 when Int.ge mn1 Int.zero -> (match min_and_max v2 with | Some mn2, Some mx2 when Int.ge mn2 Int.zero -> let new_max = next_pred_power_of_two (Int.logor mx1 mx2) in let new_min = Int.zero in inject_range (Some new_min) (Some new_max) | _ -> top ) | _ -> top ) let contains_non_zero v = not (is_zero v || is_bottom v) (* TODO: rename this function to scale_int *) let scale f v = if Int.is_zero f then zero else match v with | Float _ -> top | Top(mn1,mx1,r1,m1) -> let incr = Int.mul f in if Int.is_zero f then singleton_zero else if Int.gt f Int.zero then let modu = incr m1 in share_top (opt1 incr mn1) (opt1 incr mx1) (Int.pos_rem (incr r1) modu) modu else let modu = Int.neg (incr m1) in share_top (opt1 incr mx1) (opt1 incr mn1) (Int.pos_rem (incr r1) modu) modu | Set s -> if Int.ge f Int.zero then apply_bin_1_strict_incr Int.mul f s else apply_bin_1_strict_decr Int.mul f s let scale_div ~pos f v = assert (not (Int.is_zero f)); let div_f = if pos then fun a -> Int.pos_div a f else fun a -> Int.c_div a f in match v with | Top(mn1,mx1,r1,m1) -> let r, modu = if (Int.is_zero (Int.rem m1 f)) && ((Int.is_zero (Int.rem r1 f)) || (min_is_lower (some_zero) mn1) || (* all positive *) (max_is_greater (some_zero) mx1) || (* all negative *) pos (* good div *) ) then let modu = Int.abs (div_f m1) in (Int.pos_rem (div_f r1) modu), modu else (* degeneration*) Int.zero, Int.one in let divf_mn1 = opt1 div_f mn1 in let divf_mx1 = opt1 div_f mx1 in let mn, mx = if Int.gt f Int.zero then divf_mn1, divf_mx1 else divf_mx1, divf_mn1 in inject_top mn mx r modu | Set s -> if Int.lt f Int.zero then map_set_decr div_f s else map_set_incr div_f s | Float _ -> top let div_set x sy = Array.fold_left (fun acc elt -> if Int.is_zero elt then acc else join acc (scale_div ~pos:false elt x)) bottom sy (* ymin and ymax must be the same sign *) let div_range x ymn ymx = match min_and_max x with | Some xmn, Some xmx -> let c1 = Int.c_div xmn ymn in let c2 = Int.c_div xmx ymn in let c3 = Int.c_div xmn ymx in let c4 = Int.c_div xmx ymx in let min = Int.min (Int.min c1 c2) (Int.min c3 c4) in let max = Int.max (Int.max c1 c2) (Int.max c3 c4) in (* Format.printf "div: %a %a %a %a@." Int.pretty mn Int.pretty mx Int.pretty xmn Int.pretty xmx; *) inject_range (Some min) (Some max) | _ -> Kernel.warning ~once:true ~current:true "approximating result of division. Please report if it matters."; top let div x y = (*if (intersects y negative || intersects x negative) then ignore (CilE.warn_once "using 'round towards zero' semantics for '/', which only became specified in C99."); *) match y with Set sy -> div_set x sy | Top (Some mn,Some mx, r, modu) -> let result_pos = if Int.gt mx Int.zero then let lpos = if Int.gt mn Int.zero then mn else Int.round_up_to_r ~min:Int.one ~r ~modu in div_range x lpos mx else bottom in let result_neg = if Int.lt mn Int.zero then let gneg = if Int.lt mx Int.zero then mx else Int.round_down_to_r ~max:Int.minus_one ~r ~modu in div_range x mn gneg else bottom in join result_neg result_pos | Top _ | Float _-> Kernel.warning ~once:true ~current:true "approximating result of division. Please report if it matters."; top (* [scale_rem ~pos:false f v] is an over-approximation of the set of elements [x mod f] for [x] in [v]. [scale_rem ~pos:true f v] is an over-approximation of the set of elements [x pos_rem f] for [x] in [v]. *) let scale_rem ~pos f v = (* Format.printf "scale_rem %b %a %a@." pos Int.pretty f pretty v; *) if Int.is_zero f then bottom else let f = if Int.lt f Int.zero then Int.neg f else f in let rem_f a = if pos then Int.pos_rem a f else Int.c_rem a f in match v with | Top(mn,mx,r,m) -> let modu = Int.pgcd f m in let rr = Int.pos_rem r modu in let binf,bsup = if pos then (Int.round_up_to_r ~min:Int.zero ~r:rr ~modu), (Int.round_down_to_r ~max:(Int.pred f) ~r:rr ~modu) else let min = if all_positives mn then Int.zero else Int.neg (Int.pred f) in let max = if all_negatives mx then Int.zero else Int.pred f in (Int.round_up_to_r ~min ~r:rr ~modu, Int.round_down_to_r ~max ~r:rr ~modu) in let mn_rem,mx_rem = match mn,mx with | Some mn,Some mx -> let mn_rem = rem_f mn in let mx_rem = rem_f mx in (* Format.printf "scale_rem 1:%a %a %a %b %b %a %a@." Int.pretty mn Int.pretty mx Int.pretty f (Int.lt mx f) (Int.gt mn (Int.neg f)) Int.pretty mn_rem Int.pretty mx_rem;*) if ((Int.lt (Int.sub mx mn) f) || ((Int.lt mx f) && (Int.gt mn (Int.neg f)))) && (Int.le mn_rem mx_rem) then ( (*Format.printf "scale_rem 2:%a %a %a %a@." Int.pretty mn Int.pretty mx Int.pretty mn_rem Int.pretty mx_rem; *) mn_rem,mx_rem) else binf,bsup | _ -> binf,bsup in inject_top (Some mn_rem) (Some mx_rem) rr modu | Set s -> map_set_exnsafe rem_f s | Float _ -> top let c_rem x y = match y with | Top (None, _, _, _) | Top (_, None, _, _) | Float _ -> top | Top (Some mn, Some mx, _, _) -> if Int.equal mx Int.zero then bottom (* completely undefined. *) else (* Result is of the sign of x. Also, compute |x| to bound the result *) let neg, pos, max_x = match x with | Float _ -> true, true, None | Set set -> let s = Array.length set in if s = 0 then (* Bottom *) false, false, None else Int.le set.(0) Int.minus_one, Int.ge set.(s-1) Int.one, Some (Int.max (Int.abs set.(0)) (Int.abs set.(s-1))) | Top (mn, mx, _, _) -> compare_elt_min Int.minus_one mn, compare_elt_max Int.one mx, (match mn, mx with | Some mn, Some mx -> Some (Int.max (Int.abs mn) (Int.abs mx)) | _ -> None) in (* Bound the result: no more than |x|, and no more than |y|-1 *) let pos_rem = Integer.max (Int.abs mn) (Int.abs mx) in let bound = Int.pred pos_rem in let bound = Extlib.may_map (Int.min bound) ~dft:bound max_x in (* Compute result bounds using sign information *) let mn = if neg then Some (Int.neg bound) else Some Int.zero in let mx = if pos then Some bound else Some Int.zero in inject_top mn mx Int.zero Int.one | Set yy -> ( match x with Set xx -> apply2_notzero Int.c_rem xx yy | Float _ -> top | Top _ -> let f acc y = join (scale_rem ~pos:false y x) acc in Array.fold_left f bottom yy) module AllValueHashtbl = Hashtbl.Make (struct type t = Int.t * bool * int let equal (a,b,c:t) (d,e,f:t) = b=e && c=f && Int.equal a d let hash (a,b,c:t) = 257 * (Hashtbl.hash b) + 17 * (Hashtbl.hash c) + Int.hash a end) let all_values_table = AllValueHashtbl.create 7 let create_all_values ~modu ~signed ~size = let t = modu, signed, size in try AllValueHashtbl.find all_values_table t with Not_found -> let mn, mx = if signed then let b = Int.power_two (size-1) in (Int.round_up_to_r ~min:(Int.neg b) ~modu ~r:Int.zero, Int.round_down_to_r ~max:(Int.pred b) ~modu ~r:Int.zero) else let b = Int.power_two size in Int.zero, Int.round_down_to_r ~max:(Int.pred b) ~modu ~r:Int.zero in let r = inject_top (Some mn) (Some mx) Int.zero modu in AllValueHashtbl.add all_values_table t r; r let cast ~size ~signed ~value = if equal top value then create_all_values ~size:(Int.to_int size) ~signed ~modu:Int.one else let result = let factor = Int.two_power size in let mask = Int.two_power (Int.sub size Int.one) in let rem_f value = Int.cast ~size ~signed ~value in let not_p_factor = Int.lognot (Int.pred factor) in let best_effort r m = let modu = Int.pgcd factor m in let rr = Int.pos_rem r modu in let min_val = Some (if signed then Int.round_up_to_r ~min:(Int.neg mask) ~r:rr ~modu else Int.round_up_to_r ~min:Int.zero ~r:rr ~modu) in let max_val = Some (if signed then Int.round_down_to_r ~max:(Int.pred mask) ~r:rr ~modu else Int.round_down_to_r ~max:(Int.pred factor) ~r:rr ~modu) in inject_top min_val max_val rr modu in match value with | Top(Some mn,Some mx,r,m) -> let highbits_mn,highbits_mx = if signed then Int.logand (Int.add mn mask) not_p_factor, Int.logand (Int.add mx mask) not_p_factor else Int.logand mn not_p_factor, Int.logand mx not_p_factor in if Int.equal highbits_mn highbits_mx then if Int.is_zero highbits_mn then value else let new_min = rem_f mn in let new_r = Int.pos_rem new_min m in inject_top (Some new_min) (Some (rem_f mx)) new_r m else best_effort r m | Top (_,_,r,m) -> best_effort r m | Set s -> map_set_exnsafe rem_f s | Float _ -> top in (* Format.printf "Cast with size:%d signed:%b to %a@\n" size signed pretty result; *) if equal result value then value else result let top_single_precision_float = Float Float_abstract.top_single_precision_float let cast_float ~rounding_mode v = match v with | Float f -> ( try let b, f = Float_abstract.round_to_single_precision_float ~rounding_mode f in b, Float f with Float_abstract.Bottom -> true, bottom) | Set _ when is_zero v -> false, zero | Set _ | Top _ -> true, top_single_precision_float let cast_double v = match v with | Float _ -> false, v | Set _ when is_zero v -> false, v | Set _ | Top _ -> true, top_float (* TODO rename to mul_int *) let rec mul v1 v2 = (* Format.printf "mul. Args: '%a' '%a'@\n" pretty v1 pretty v2; *) let result = if is_one v1 then v2 else if is_zero v2 || is_zero v1 then zero else if is_one v2 then v1 else match v1,v2 with | Float _, _ | _, Float _ -> top | Set s1, Set [| x |] | Set [| x |], Set s1 -> if Int.ge x Int.zero then apply_bin_1_strict_incr Int.mul x s1 else apply_bin_1_strict_decr Int.mul x s1 | Set s1, Set s2 -> apply2_n Int.mul s1 s2 | Top(mn1,mx1,r1,m1), Top(mn2,mx2,r2,m2) -> check "mul left" mn1 mx1 r1 m1; check "mul right" mn2 mx2 r2 m2; let mn1 = inject_min mn1 in let mx1 = inject_max mx1 in let mn2 = inject_min mn2 in let mx2 = inject_max mx2 in let a = ext_mul mn1 mn2 in let b = ext_mul mn1 mx2 in let c = ext_mul mx1 mn2 in let d = ext_mul mx1 mx2 in let min = ext_min (ext_min a b) (ext_min c d) in let max = ext_max (ext_max a b) (ext_max c d) in (* let multipl1 = Int.pgcd m1 r1 in let multipl2 = Int.pgcd m2 r2 in let modu1 = Int.pgcd m1 m2 in let modu2 = Int.mul multipl1 multipl2 in let modu = Int.ppcm modu1 modu2 in *) let modu = Int.pgcd (Int.pgcd (Int.mul m1 m2) (Int.mul r1 m2)) (Int.mul r2 m1) in let r = Int.rem (Int.mul r1 r2) modu in (* let t = Top (ext_proj min, ext_proj max, r, modu) in Format.printf "mul. Result: '%a'@\n" pretty t; *) inject_top (ext_proj min) (ext_proj max) r modu | Set s, (Top(_,_,_,_) as t) | (Top(_,_,_,_) as t), Set s -> let l = Array.length s in if l = 0 then bottom else if l = 1 then (* only one element *) scale s.(0) t else mul t (unsafe_make_top_from_array s) in (* Format.printf "mul. result : %a@\n" pretty result;*) result let shift_left ~size x y = try let min = smallest_above Int.zero y in let min = Int.shift_left Int.one min in let max = match size with | None -> (match max_int y with Some v -> v | None -> raise No_such_element) | Some size -> largest_below (Int.pred size) y in let max = Int.shift_left Int.one max in let factor = inject_top (Some min) (Some max) Int.zero min in (* Format.printf "shift_left %a factor:%a@." pretty y pretty factor; *) mul factor x with No_such_element -> bottom let shift_right ~size x y = let result = try let min = smallest_above Int.zero y in let max = match size with | None -> (match max_int y with Some v -> v | None -> raise No_such_element) | Some size -> largest_below (Int.pred size) y in Int.fold (fun n acc -> join acc (scale_div ~pos:true (Int.shift_left Int.one n) x)) ~inf:min ~sup:max ~step:Int.one bottom with No_such_element -> bottom in (* Format.printf "shift_right %a >> %a -> %a@." pretty x pretty y pretty result; *) result let interp_boolean ~contains_zero ~contains_non_zero = match contains_zero, contains_non_zero with | true, true -> zero_or_one | true, false -> singleton_zero | false, true -> singleton_one | false, false -> bottom let filter_le_int max v = match v with | Float _ -> v | Set _ | Top _ -> narrow v (Top(None,max,Int.zero,Int.one)) let filter_ge_int min v = match v with | Float _ -> v | Set _ | Top _ -> narrow v (Top(min,None,Int.zero,Int.one)) let filter_lt_int max v = filter_le_int (opt1 Int.pred max) v let filter_gt_int min v = filter_ge_int (opt1 Int.succ min) v let filter_le v1 v2 = filter_le_int (max_int v2) v1 let filter_ge v1 v2 = filter_ge_int (min_int v2) v1 let filter_lt v1 v2 = filter_lt_int (max_int v2) v1 let filter_gt v1 v2 = filter_gt_int (min_int v2) v1 let filter_float filter v1 v2 = try let f1 = project_float v1 in let f2 = project_float v2 in inject_float (filter f1 f2) with Float_abstract.Nan_or_infinite -> v1 | Float_abstract.Bottom -> bottom let filter_le_float allmodes ~typ_loc = filter_float (Float_abstract.filter_le allmodes ~typ_loc) let filter_ge_float allmodes ~typ_loc = filter_float (Float_abstract.filter_ge allmodes ~typ_loc) let filter_lt_float allmodes ~typ_loc = filter_float (Float_abstract.filter_lt allmodes ~typ_loc) let filter_gt_float allmodes ~typ_loc = filter_float (Float_abstract.filter_gt allmodes ~typ_loc) let diff _ _ = assert false let diff_if_one value rem = match rem, value with Set [| v |], Set a -> let index = array_mem v a in if index >= 0 then let l = Array.length a in let pl = pred l in let r = Array.make pl Int.zero in Array.blit a 0 r 0 index; Array.blit a (succ index) r index (pl-index); share_array r pl else value | Set [| v |], Top (Some mn, mx, r, m) when Int.equal v mn -> inject_top (Some (Int.add mn m)) mx r m | Set [| v |], Top (mn, Some mx, r, m) when Int.equal v mx -> inject_top mn (Some (Int.sub mx m)) r m | Set [| v |], Top ((Some mn as min), (Some mx as max), r, m) when Int.equal (Int.sub mx mn) (Int.mul m !small_cardinal_Int) && in_interval v min max r m -> let r = ref mn in Set (Array.init !small_cardinal (fun _ -> let c = !r in let corrected_c = if Int.equal c v then Int.add c m else c in r := Int.add corrected_c m; corrected_c)) | _ -> value (* TODO: more cases: Float *) let rec extract_bits ~start ~stop ~size v = match v with | Set s -> inject_ps (Array.fold_left (fun acc elt -> add_ps acc (Int.extract_bits ~start ~stop elt)) empty_ps s) | Float f -> let l, u = if Int.equal size (Int.of_int 64) then Float_abstract.bits_of_float64 f else Float_abstract.bits_of_float32 f in extract_bits ~start ~stop ~size (inject_range (Some l) (Some u)) | Top _ -> inject_top some_zero (Some (Int.pred (Int.power_two (Int.to_int (Int.length start stop))))) Int.zero Int.one let b64 = Int.of_int 64 let all_values ~size v = if Int.lt b64 size then false (* values of this size cannot be enumerated anyway in C. They may occur while initializing large blocks of arrays. *) else match v with | Float _ -> false | Top (None,_,_,modu) | Top (_,None,_,modu) -> Int.is_one modu | Top (Some mn, Some mx,_,modu) -> Int.is_one modu && Int.le (Int.power_two (Int.to_int size)) (Int.succ (Int.sub mx mn)) | Set s -> let siz = Int.to_int size in Array.length s >= 1 lsl siz && equal (cast ~size ~signed:false ~value:v) (create_all_values ~size:siz ~signed:false ~modu:Int.one) let compare_C f v1 v2 = let min1 = min_int v1 in let max1 = max_int v1 in let min2 = min_int v2 in let max2 = max_int v2 in f min1 max1 min2 max2 include Datatype.Make (struct type t = tt let name = Int.name ^ " lattice_mod" open Structural_descr let structural_descr = let s_int = Descr.str Int.descr in Structure (Sum [| [| pack (t_array s_int) |]; [| Float_abstract.packed_descr |]; [| pack (t_option s_int); pack (t_option s_int); Int.packed_descr; Int.packed_descr |] |]) let reprs = [ top ; bottom ] let equal = equal let compare = compare let hash = hash let pretty = pretty let rehash x = match x with | Set a -> share_array a (Array.length a) | _ -> x let internal_pretty_code = Datatype.pp_fail let mem_project = Datatype.never_any_project let copy = Datatype.undefined let varname = Datatype.undefined end) let scale_int64base factor v = match factor with | Int_Base.Top -> top | Int_Base.Value f -> scale f v let cast_float_to_int ~signed ~size iv = let all = create_all_values ~size ~signed ~modu:Int.one in try let f = project_float iv in let Float_abstract.Private_Couple.I(min,max) = f in let min_int = Floating_point.truncate_to_integer min in let max_int = Floating_point.truncate_to_integer max in assert (Int.compare min_int max_int <= 0); let r = inject_range (Some min_int) (Some max_int) in if is_included r all then false, false, r else false, true, (narrow r all) with | Floating_point.Float_Non_representable_as_Int64 -> (* raised by Floating_point.truncate_to_integer *) false, true, all | Float_abstract.Nan_or_infinite -> (* raised by project_float *) true, true, all let cast_float_to_int_inverse ~single_precision i = match min_and_max i with | Some min, Some max when Int.le (Int.of_int (-1000)) min && Int.le max Int.onethousand -> let minf = if Int.le min Int.zero then let r = F.round_up (Int.to_float (Int.pred min)) in if single_precision then begin Floating_point.set_round_upward (); Floating_point.round_to_single_precision_float r end else r else Int.to_float min in let maxf = if Int.le Int.zero max then let r = F.round_down (Int.to_float (Int.succ max)) in if single_precision then begin Floating_point.set_round_downward (); Floating_point.round_to_single_precision_float r end else r else Int.to_float max in Float (Float_abstract.inject minf maxf) | _ -> top_float let of_int i = inject_singleton (Int.of_int i) let of_int64 i = inject_singleton (Int.of_int64 i) let negbil = Int.neg Int.billion_one let cast_int_to_float rounding_mode v = match min_and_max v with None, _ | _, None -> false (* not ok *), top_float | Some min, Some max -> ( try Floating_point.set_round_nearest_even (); (* PC: Do not even ask *) let b = F.of_float (Int.to_float min) in let e = F.of_float (Int.to_float max) in if rounding_mode = Float_abstract.Nearest_Even || (Int.le negbil min) && (Int.le max Int.billion_one) (* PC: No, really, don't ask *) then true (* ok *), inject_float (Float_abstract.inject b e) else begin let b = F.round_down b in let e = F.round_up e in true, inject_float (Float_abstract.inject b e) end with F.Nan_or_infinite | Floating_point.Float_Non_representable_as_Int64 -> false, top_float) let set_bits mn mx = match mn, mx with Some mn, Some mx -> Int.logand (Int.lognot (different_bits mn mx)) mn | _ -> Int.zero let sub_bits x = (* TODO: can be improved *) let popcnt = Int.popcount x in let rec aux cursor acc = if Int.gt cursor x then acc else let acc = if Int.is_zero (Int.logand cursor x) then acc else O.fold (fun e acc -> O.add (Int.logor cursor e) acc) acc acc in aux (Int.shift_left cursor Int.one) acc in let o = aux Int.one o_zero in let s = 1 lsl popcnt in assert (O.cardinal o = s); inject_ps (Pre_set (o, s)) let bitwise_and ~size ~signed v1 v2 = if is_bottom v1 || is_bottom v2 then bottom else let v1 = match v1 with Float _ -> create_all_values ~size ~signed ~modu:Int.one | _ -> v1 in let v2 = match v2 with Float _ -> create_all_values ~size ~signed ~modu:Int.one | _ -> v2 in match v1, v2 with Float _, _ | _, Float _ -> assert false | Top _, other | other, Top _ -> let half_range = Int.power_two (pred size) in let minint = Int.neg half_range in let max_int_v1, max_int_v2 as max_int_v1_v2 = max_int v1, max_int v2 in let min_int_v1, min_int_v2 as min_int_v1_v2 = min_int v1, min_int v2 in let vmax = match max_int_v1_v2 with Some maxv1, Some maxv2 -> if Int.lt maxv1 Int.zero && Int.lt maxv2 Int.zero then begin Some (match min_int_v1_v2 with Some minv1, Some minv2 -> pos_max_land minv1 maxv1 minv2 maxv2 | _ -> assert false) end else let max1 = (* improved min of maxv1 and maxv2*) try let bi1 = smallest_above Int.zero v1 in let bi2 = smallest_above Int.zero v2 in pos_max_land bi1 maxv1 bi2 maxv2 with No_such_element -> minint in let max2 = (* improved min of maxv1 and altmax2*) try let altmax2 = Int.add half_range (largest_below Int.minus_one v2) in let bi1 = smallest_above Int.zero v1 in let bi2 = Int.add half_range (smallest_above minint v2) in pos_max_land bi1 maxv1 bi2 altmax2 with No_such_element -> minint in let max3 = (* improved min of maxv2 and altmax1*) try let altmax1 = Int.add half_range (largest_below Int.minus_one v1) in let bi2 = smallest_above Int.zero v2 in let bi1 = Int.add half_range (smallest_above minint v1) in pos_max_land bi2 maxv2 bi1 altmax1 with No_such_element -> minint in (* Format.printf "bitwise_and v1 %a v2 %a maxv1 %a maxv2 %a \ max1 max2 max3 %a %a %a@." pretty v1 pretty v2 Int.pretty maxv1 Int.pretty maxv2 Int.pretty max1 Int.pretty max2 Int.pretty max3; *) Some (Int.max max1 (Int.max max2 max3)) | _ -> None in let somenegativev1 = intersects v1 negative in let somenegativev2 = intersects v2 negative in let vmin = if somenegativev1 && somenegativev2 then Some minint else if somenegativev1 || somenegativev2 then some_zero else begin let bits1 = set_bits min_int_v1 max_int_v1 in let bits2 = set_bits min_int_v2 max_int_v2 in let min_a = Int.logand bits1 bits2 in let min_a = if not signed then let rec find_mask x bit acc = if Int.is_zero (Int.logand x bit) then acc else find_mask x (Int.shift_right bit Int.one) (Int.logor bit acc) in match min_int_v1_v2 with Some m1, Some m2 -> let mask1 = find_mask bits1 half_range Int.zero in let min_b = Int.logand mask1 m2 in let mask2 = find_mask bits2 half_range Int.zero in let min_c = Int.logand mask2 m1 in (* Format.printf "bitwise_and v1 %a v2 %a min_b %a min_c %a@." pretty v1 pretty v2 Int.pretty min_b Int.pretty min_c; *) Int.max (Int.max min_a min_b) min_c | _ -> assert false else min_a in (* Format.printf "bitwise_and v1 %a v2 %a bits1 %a bits2 %a@." pretty v1 pretty v2 Int.pretty bits1 Int.pretty bits2; *) Some min_a end in let result = inject_top vmin vmax Int.zero Int.one in ( match other with Top _ | Float _ -> result | Set s -> if array_for_all (fun elt -> Int.ge elt Int.zero && Int.popcount elt <= !small_cardinal_log) s then let result2 = Array.fold_left (fun acc elt -> join (sub_bits elt) acc) bottom s in narrow result result2 else result) | Set s1, Set s2 -> apply2_v Int.logand s1 s2 let pretty_debug = pretty let name = "ival" (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/ai/origin.ml0000644000175000017500000001521012155630234016776 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp type kind = | K_Misalign_read | K_Leaf | K_Merge | K_Arith module LocationSetLattice = struct include Abstract_interp.Make_Lattice_Set(Cil_datatype.Location) let currentloc_singleton () = inject_singleton (Cil.CurrentLoc.get ()) end type origin = | Misalign_read of LocationSetLattice.t | Leaf of LocationSetLattice.t | Merge of LocationSetLattice.t | Arith of LocationSetLattice.t | Well | Unknown let current = function | K_Misalign_read -> Misalign_read (LocationSetLattice.currentloc_singleton()) | K_Leaf -> Leaf (LocationSetLattice.currentloc_singleton()) | K_Merge -> Merge (LocationSetLattice.currentloc_singleton()) | K_Arith -> Arith (LocationSetLattice.currentloc_singleton()) let equal o1 o2 = match o1, o2 with | Well, Well | Unknown, Unknown -> true | Leaf o1, Leaf o2 | Arith o1, Arith o2 | Merge o1, Merge o2 | Misalign_read o1, Misalign_read o2 -> LocationSetLattice.equal o1 o2 | Misalign_read _, _ -> false | _, Misalign_read _ -> false | Leaf _, _ -> false | _, Leaf _ -> false | Merge _, _ -> false | _, Merge _ -> false | Arith _, _ -> false | _, Arith _ -> false | _, Well | Well, _ -> false let compare o1 o2 = match o1, o2 with | Misalign_read s1, Misalign_read s2 | Leaf s1, Leaf s2 | Merge s1, Merge s2 | Arith s1, Arith s2 -> LocationSetLattice.compare s1 s2 | Well, Well | Unknown, Unknown -> 0 | Misalign_read _, (Leaf _ | Merge _ | Arith _ | Well | Unknown) | Leaf _, (Merge _ | Arith _ | Well | Unknown) | Merge _, (Arith _ | Well | Unknown) | Arith _, (Well | Unknown) | Well, Unknown -> -1 | Unknown, (Well | Arith _ | Merge _ | Leaf _ | Misalign_read _) | Well, (Arith _ | Merge _ | Leaf _ | Misalign_read _) | Arith _, (Merge _ | Leaf _ | Misalign_read _) | Merge _, (Leaf _ | Misalign_read _) | Leaf _, Misalign_read _ -> 1 let top = Unknown let is_top x = equal top x let pretty fmt o = match o with | Unknown -> Format.fprintf fmt "Unknown" | Misalign_read o -> Format.fprintf fmt "Misaligned@ %a" LocationSetLattice.pretty o | Leaf o -> Format.fprintf fmt "Library function@ %a" LocationSetLattice.pretty o | Merge o -> Format.fprintf fmt "Merge@ %a" LocationSetLattice.pretty o | Arith o -> Format.fprintf fmt "Arithmetic@ %a" LocationSetLattice.pretty o | Well -> Format.fprintf fmt "Well" let pretty_as_reason fmt org = if not (is_top org) then Format.fprintf fmt " because of %a" pretty org let hash o = match o with | Misalign_read o -> 2001 + (LocationSetLattice.hash o) | Leaf o -> 2501 + (LocationSetLattice.hash o) | Merge o -> 3001 + (LocationSetLattice.hash o) | Arith o -> 3557 + (LocationSetLattice.hash o) | Well -> 17 | Unknown -> 97 include Datatype.Make (struct type t = origin let name = "Origin" let structural_descr = Structural_descr.Unknown let reprs = [ Well; Unknown ] let compare = compare let equal = equal let hash = hash let rehash = Datatype.undefined let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = pretty let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) let bottom = Arith(LocationSetLattice.bottom) let join o1 o2 = let result = if o1 == o2 then o1 else match o1, o2 with | Unknown,_ | _, Unknown -> Unknown | Well,_ | _ , Well -> Well | Misalign_read o1, Misalign_read o2 -> Misalign_read(LocationSetLattice.join o1 o2) | _, (Misalign_read _ as m) | (Misalign_read _ as m), _ -> m | Leaf o1, Leaf o2 -> Leaf(LocationSetLattice.join o1 o2) | (Leaf _ as m), _ | _, (Leaf _ as m) -> m | Merge o1, Merge o2 -> Merge(LocationSetLattice.join o1 o2) | (Merge _ as m), _ | _, (Merge _ as m) -> m | Arith o1, Arith o2 -> Arith(LocationSetLattice.join o1 o2) (* | (Arith _ as m), _ | _, (Arith _ as m) -> m *) in (* Format.printf "Origin.join %a %a -> %a@." pretty o1 pretty o2 pretty result; *) result let meet o1 o2 = if o1 == o2 then o1 else match o1, o2 with | Arith o1, Arith o2 -> Arith(LocationSetLattice.meet o1 o2) | (Arith _ as m), _ | _, (Arith _ as m) -> m | Merge o1, Merge o2 -> Merge(LocationSetLattice.meet o1 o2) | (Merge _ as m), _ | _, (Merge _ as m) -> m | Leaf o1, Leaf o2 -> Leaf(LocationSetLattice.meet o1 o2) | (Leaf _ as m), _ | _, (Leaf _ as m) -> m | Misalign_read o1, Misalign_read o2 -> Misalign_read(LocationSetLattice.meet o1 o2) | _, (Misalign_read _ as m) | (Misalign_read _ as m), _ -> m | Well, Well -> Well | Well,m | m, Well -> m | Unknown, Unknown -> Unknown let narrow x _y = x (* TODO *) let is_included o1 o2 = (equal o1 (meet o1 o2)) let is_included_exn v1 v2 = if not (is_included v1 v2) then raise Is_not_included (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/ai/lattice_With_Isotropy.mli0000644000175000017500000000533112155630234022213 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module type S = sig open Abstract_interp include Lattice module Top_Param : Lattice_Set (** Are the bits independent? *) val is_isotropic : t -> bool val cast: size:Int.t -> signed:bool -> t -> t * bool val extract_bits : topify:Origin.kind -> start:Int.t -> stop:Int.t -> size:Int.t -> t -> bool * t val little_endian_merge_bits : topify:Origin.kind -> conflate_bottom:bool -> total_length:int -> value:t -> offset:Int.t -> t -> t val big_endian_merge_bits : topify:Origin.kind -> conflate_bottom:bool -> total_length:int -> length:Int.t -> value:t -> offset:Int.t -> t -> t (* Make isotropic *) val topify_merge_origin : t -> t val topify_arith_origin : t -> t val topify_misaligned_read_origin : t -> t val topify_with_origin : Origin.t -> t -> t val topify_with_origin_kind: Origin.kind -> t -> t val inject_top_origin : Origin.t -> Top_Param.O.t -> t val under_topify : t -> t val anisotropic_cast : size:Int.t -> t -> t val singleton_zero : t val of_char : char -> t val of_int64 : Int64.t -> t end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/0000755000175000017500000000000012155634040016044 5ustar mehdimehdiframa-c-Fluorine-20130601/src/kernel/messages.ml0000644000175000017500000000710312155630171020207 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module DatatypeMessages = Datatype.Make_with_collections (struct include Datatype.Serializable_undefined open Log type t = event let name = "message" let reprs = [ { evt_kind = Failure; evt_plugin = ""; evt_source = None; evt_message = "" } ] let mem_project = Datatype.never_any_project let hash (e: event)= Hashtbl.hash e let compare (e1: event) e2 = Extlib.compare_basic e1 e2 let equal = Datatype.from_compare end) module Messages = State_builder.List_ref (DatatypeMessages) (struct let name = "message_table" let dependencies = [ Ast.self ] end) let () = Ast.add_monotonic_state Messages.self module NbMessages = State_builder.Zero_ref (struct let name = "nb_messages" let dependencies = [Messages.self] end) let self = Messages.self let add_message m = NbMessages.set (NbMessages.get () + 1); Messages.set (m :: Messages.get ()) let iter f = List.iter f (List.rev (Messages.get ())) let dump_messages () = iter Log.echo let enable_collect = let not_yet = ref true in fun () -> if !not_yet then begin Kernel.debug "enable collection of error messages."; Log.add_listener ~kind:[ Log.Error; Log.Warning ] add_message; not_yet := false end module OnceTable = State_builder.Hashtbl (DatatypeMessages.Hashtbl)(Datatype.Unit) (struct let size = 37 let dependencies = [] let name = "Message.OnceTable" end) let check_not_yet evt = if OnceTable.mem evt then false else ( OnceTable.add evt () ; true) let reset_once_flag () = OnceTable.clear () let () = Log.check_not_yet := check_not_yet let () = let run () = if Kernel.Collect_messages.get () then enable_collect () in (* Set by the user on the command-line *) Cmdline.run_after_early_stage run; (* Set by a plugin *) Cmdline.run_after_configuring_stage run; ;; (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/ast.mli0000644000175000017500000001246712155630171017351 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Access to the CIL AST which must be used from Frama-C. @plugin development guide *) exception Bad_Initialization of string (** May be raised by function {!get} below. *) exception NoUntypedAst (** Might be raised by {!UntypedFiles.get} below @since Nitrogen-20111001 *) module UntypedFiles: sig val get: unit -> Cabs.file list (** The list of untyped AST that have been parsed. @raise Bad_Initialization if neither {!File.init_from_c_files} nor {!File.init_project_from_cil_file} nor {!File.init_from_cmdline} was called before. @raise NoUntypedAst if no untyped AST is available. This is in particular the case for projects obtained by code transformation from original C files. @modify Nitrogen-20111001 raise NoUntypedAst *) val set: Cabs.file list -> unit (** Should not be used by casual users. *) val self: State.t end val get: unit -> Cil_types.file (** Get the cil file representation. One of the initialisation function of module {!File} has to be called before using this function. @raise Bad_Initialization if neither {!File.init_from_c_files} nor {!File.init_project_from_cil_file} nor {!File.init_from_cmdline} was called before. @plugin development guide *) val compute: unit -> unit (** Enforce the computation of the AST. @raise Bad_Initialization if neither {!File.init_from_c_files} nor {!File.init_project_from_cil_file} nor {!File.init_from_cmdline} was called before. *) val is_computed: unit -> bool (** @return true if the AST has been computed. *) val mark_as_changed: unit -> unit (** call this function whenever you've made some changes in place inside the AST @since Oxygen-20120901 @plugin development guide *) val mark_as_grown: unit -> unit (** call this function whenever you have added something to the AST, without modifying the existing nodes @since Oxygen-20120901 @plugin development guide *) val add_monotonic_state: State.t -> unit (** indicates that the given state (which must depend on Ast.self) is robust against additions to the AST, that is, it will be able to compute information on the new nodes whenever needed. {!Ast.mark_as_grown} will not erase such states, while {!Ast.mark_as_changed} and clearing Ast.self itself will. @since Oxygen-20120901 @plugin development guide *) val self: State.t (** The state kind associated to the cil AST. @plugin development guide *) val apply_after_computed: (Cil_types.file -> unit) -> unit (** Apply the given hook just after building the AST. @since Oxygen-20120901 *) (*****************************************************************************) (** {2 Internals} Functions below should not be called by casual users. *) (*****************************************************************************) val is_last_decl: Cil_types.global -> bool (** [true] if the global is the last one in the AST to introduce a given variable. Used by visitor and printer to relate funspec with appropriate global. @since Oxygen-20120901 *) val clear_last_decl : unit -> unit (** reset the mapping between a varinfo and the last global introducing it. @since Oxygen-20120901 *) val set_file: Cil_types.file -> unit val set_default_initialization: (unit -> unit) -> unit val mark_as_computed: unit -> unit (** @since Beryllium-20090901 *) val add_hook_on_update: (unit -> unit) -> unit (** Apply the given hook each time the reference to the AST is updated, including on a project switch. @since Fluorine-20130401 *) (**/**) val add_linked_state: State.t -> unit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/cilE.mli0000644000175000017500000001315312155630171017427 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** CIL Extension for Frama-C. @plugin development guide *) (* ************************************************************************* *) (* [JS 2011/03/11] All the below stuff manage warnings of the value analysis plug-in. Refactoring required. *) (* ************************************************************************* *) type syntactic_context = | SyNone | SyCallResult | SyBinOp of Cil_types.exp * Cil_types.binop * Cil_types.exp * Cil_types.exp | SyUnOp of Cil_types.exp | SyMem of Cil_types.lval | SyMemLogic of Cil_types.term | SySep of Cil_types.lval * Cil_types.lval (** assert that two locations must be separated *) val start_stmt : Cil_types.kinstr -> unit val end_stmt : unit -> unit val current_stmt : unit -> Cil_types.kinstr val set_syntactic_context : syntactic_context -> unit val get_syntactic_context : unit -> Cil_types.kinstr*syntactic_context type alarm_behavior = { a_log: (Emitter.t * (Format.formatter -> unit)) option; (** log the alarm using the global variable that has been set with set_syntactic_context, and continue, pretending that the problematic values do not happen *) a_call: unit -> unit; (** call function after optionally emitting with field a_log. *) } val do_warn: alarm_behavior -> ((Emitter.t * (Format.formatter -> unit)) -> unit) -> unit val a_ignore: alarm_behavior type warn_mode = { imprecision_tracing: alarm_behavior (** informative messages for garbled values *); defined_logic: alarm_behavior (** operations that raise an error only in the C, not in the logic *); unspecified: alarm_behavior (** defined but unspecified behaviors *); others: alarm_behavior (** all the remaining undefined behaviors *); } (** An argument of type [warn_mode] is required by some of the access functions in {!Db.Value} (the interface to the value analysis). This argument tells what should be done with the various messages that the value analysis emits during the call. Each [warn_mode] field indicates the expected treatment for one category of message. These fields are not completely fixed yet. However, you can still used functions {!warn_all_mode} and {!warn_none_mode} below when you have to provide an argument of type [warn_mode]. *) val warn_all_mode : Emitter.t -> (Format.formatter -> unit) -> warn_mode (** Emit all messages, including alarms and informative messages regarding the loss of precision. *) val warn_none_mode : warn_mode (** Do not emit any message. *) val warn_div : warn_mode -> unit val warn_shift : warn_mode -> int -> unit val warn_shift_left_positive : warn_mode -> unit val warn_mem_read : warn_mode -> unit val warn_mem_write : warn_mode -> unit val warn_integer_overflow : warn_mode -> signed:bool -> min:Integer.t option -> max:Integer.t option -> unit val warn_float_to_int_overflow: warn_mode -> Integer.t option -> Integer.t option -> (Format.formatter -> unit) -> unit val warn_index : warn_mode -> positive:bool -> range:string -> unit (** [warn_index w ~positive ~range] emits a warning signaling an out of bounds access. The expression used as index is taken from the syntactic context. [range] is used to display the inferred values for the index. If [positive] is true, the generated assertion is of the form [e < upper_bound]; otherwise, two assertions are generated: [0 <= e] and [e < upper_bound]. *) val warn_pointer_comparison : warn_mode -> unit val warn_nan_infinite: warn_mode -> Cil_types.fkind option -> (Format.formatter -> unit) -> unit val warn_uninitialized : warn_mode -> unit val warn_escapingaddr : warn_mode -> unit (** warning to be emitted when two incompatible accesses to a location are done in unspecified order. Must be called in a [SyNone] or [SySep] context. *) val warn_separated : warn_mode -> unit val warn_overlap : Locations.location * Locations.location -> warn_mode -> unit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/globals.mli0000644000175000017500000002114112155630171020172 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Operations on globals. @plugin development guide *) open Cil_types (** Globals variables. The AST should be computed before using this module (cf. {! Ast.compute}). *) module Vars: sig (** {2 Getters} *) val find: varinfo -> initinfo val find_from_astinfo: string -> localisation -> varinfo val get_astinfo: varinfo -> string * localisation (** {2 Iterators} *) val iter: (varinfo -> initinfo -> unit) -> unit val fold: (varinfo -> initinfo -> 'a -> 'a) -> 'a -> 'a val iter_in_file_order: (varinfo -> initinfo -> unit) -> unit val fold_in_file_order: (varinfo -> initinfo -> 'a -> 'a) -> 'a -> 'a (** @since Fluorine-20130401 *) (** {2 Setters} Functions of this section should not be called by casual users. *) exception AlreadyExists of varinfo * initinfo val add: varinfo -> initinfo -> unit (** @raise AlreadyExists if the given varinfo is already registered. *) val add_decl: varinfo -> unit (** @raise AlreadyExists if the given varinfo is already registered. *) val self: State.t end (* ************************************************************************* *) (** Functions. The AST should be computed before using this module (cf. {! Ast.compute}). *) module Functions: sig val self: State.t (** {2 Getters} *) val get: varinfo -> kernel_function (** @raise Not_found if the given varinfo has no associated kernel function and is not a built-in. @plugin development guide *) val get_params: kernel_function -> varinfo list val get_vi: kernel_function -> varinfo (** {2 Searching} *) val find_by_name : string -> kernel_function (** @raise Not_found if there is no function of this name. *) val find_def_by_name : string -> kernel_function (** @raise Not_found if there is no function definition of this name. *) val find_englobing_kf: kinstr -> kernel_function option (** @deprecated since Carbon-20101201 Use [Kernel_function.find_englobing_kf] instead *) (** {2 Iterators} *) val iter: (kernel_function -> unit) -> unit val fold: (kernel_function -> 'a -> 'a) -> 'a -> 'a val iter_on_fundecs: (fundec -> unit) -> unit (** {2 Setters} Functions of this section should not be called by casual users. *) val add: cil_function -> unit (**TODO: remove this function and replace all calls by: *) val replace_by_declaration: funspec -> varinfo -> location -> unit val replace_by_definition: funspec -> fundec -> location -> unit (**TODO: do not take a funspec as argument *) val register: kernel_function -> unit end (* ************************************************************************* *) (** Globals associated to filename. *) module FileIndex : sig val self: State.t (** The state kind corresponding to the table of global C symbols. @since Boron-20100401 *) (** {2 Getters} *) val get_symbols : filename:string -> global list (** All global C symbols of the given module. @since Boron-20100401 *) val find : filename:string -> string * (global list) (** All global C symbols for valviewer. The file name to display is returned, and the [global] list reversed. *) val get_files: unit -> string list (** Get the files list containing all [global] C symbols. *) (** {2 Searching among all [global] C symbols} *) val get_globals : filename:string -> (varinfo * initinfo) list (** Global variables of the given module for the kernel user interface *) val get_global_annotations: filename:string -> global_annotation list (** Global annotations of the given module for the kernel user interface @since Nitrogen-20111001 *) val get_functions : ?declarations:bool -> filename:string -> kernel_function list (** Global functions of the given module for the kernel user interface. If [declarations] is true, functions declared in a module but defined in another module are only reported in the latter (default is false). *) val kernel_function_of_local_var_or_param_varinfo : varinfo -> (kernel_function * bool) (** kernel_function where the local variable or formal parameter is declared. The boolean result is true for a formal parameter. @raise Not_found if the varinfo is a global one. *) val remove_global_annotations: global_annotation -> unit (** @since Oxygen-20120901 *) end (* ************************************************************************* *) (** {2 Entry point} *) (* ************************************************************************* *) exception No_such_entry_point of string (** May be raised by [entry_point] below. *) val entry_point : unit -> kernel_function * bool (** @return the current function entry point and a boolean indicating if it is a library entry point. @raise No_such_entry_point if the current entrypoint name does not exist. This exception is automatically handled by the Frama-C kernel. Thus you don't have to catch it yourself, except if you do a specific work. *) val set_entry_point : string -> bool -> unit (** [set_entry_point name lib] sets [Kernel.MainFunction] to [name] and [Kernel.LibEntry] to [lib] is [true]. Moreover, clear the results of all the analysis which depend on [Kernel.MainFunction] or [Kernel.LibEntry]. @plugin development guide *) (* ************************************************************************* *) (** {2 Comments} *) (* ************************************************************************* *) val get_comments_global: global -> string list (** Gets a list of comments associated to the given global. This function is useful only when -keep-comments is on. A comment is associated to a global if it occurs after the declaration/definition of the preceding one in the file, before the end of the current declaration/definition and does not occur in the definition of a function. Note that this function is experimental and may fail to associate comments properly. Use directly {! Cabshelper.Comments.get} to retrieve comments in a given region. (see {!Globals.get_comments_stmt} for retrieving comments associated to a statement). @since Nitrogen-20111001 *) val get_comments_stmt: stmt -> string list (** Gets a list of comments associated to the given global. This function is useful only when -keep-comments is on. A comment is associated to a global if it occurs after the preceding statement and before the current statement ends (except for the last statement in a block, to which statements occuring before the end of the block are associated). Note that this function is experimental and may fail to associate comments properly. Use directly {! Cabshelper.Comments.get} to retrieve comments in a given region. @since Nitrogen-20111001 *) (* **/** *) (* Forward reference to functions defined in Kernel_function. Do not use outside of this module. *) val find_first_stmt: (kernel_function -> stmt) ref val find_enclosing_block: (stmt -> block) ref (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/stmts_graph.ml0000644000175000017500000003451012155630171020735 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (* This is a reimplementation of ocamlgraph Path.Check. Instead of using an hashtbl containing couples of stmts, we use an association map to hptmap from stmts to bool. This enforces a lot of sharing, which is very useful when stmt_can_reach is called on a lot of pairs *) module PathChecker = struct module HV = Hashtbl.Make(Stmt) module HptmapStmtBool = Hptmap.Make (struct include Stmt let id s = s.sid end) (Datatype.Bool) (Hptmap.Comp_unused) (struct let v = [ [] ] end) (struct let l = [ Ast.self ] end) (* Clear the (non-project compliant) internal caches each time the ast changes, which includes every time we switch project. *) let () = Ast.add_hook_on_update (fun _ -> HptmapStmtBool.clear_caches ()) module HashStmtHptmapStmtBool = Stmt.Hashtbl.Make(HptmapStmtBool) (* this a cache containing the path tests already computed *) type path_checker = HptmapStmtBool.t Stmt.Hashtbl.t let create () : path_checker = Stmt.Hashtbl.create 17 let find_assoc_with_default (pc : path_checker) (v: stmt) = try Stmt.Hashtbl.find pc v with Not_found -> HptmapStmtBool.empty let add_to_cache pc v1 v2 b = let assoc = find_assoc_with_default pc v1 in let assoc' = HptmapStmtBool.add v2 b assoc in Stmt.Hashtbl.replace pc v1 assoc' let check_path_using_filter filterfunc pc v1 v2 = let assoc = find_assoc_with_default pc v1 in try HptmapStmtBool.find v2 assoc with Not_found -> (* the path is not in cache; we check it with Dijkstra *) let visited = HV.create 97 in let q = Queue.create () in let rec loop () = if Queue.is_empty q then begin add_to_cache pc v1 v2 false; false end else begin let v = Queue.pop q in add_to_cache pc v1 v true; if Stmt.equal v v2 then true else begin if not (HV.mem visited v) then begin HV.add visited v (); List.iter (fun v' -> if filterfunc v' then Queue.add v' q) v.succs end; loop () end end in Queue.add v1 q; loop () let check_path = check_path_using_filter (fun _ -> true) end (* The kf is no longer useful, but we need to do a partial application anyway *) let stmt_can_reach _kf = let cache = PathChecker.create () in let check = PathChecker.check_path cache in fun s1 s2 -> (*Kernel.debug ~level:4 "CHECK PATH %d->%d@\n" s1.sid s2.sid;*) check s1 s2 let stmt_can_reach_filtered filterfunc = let cache = PathChecker.create () in let check = PathChecker.check_path_using_filter filterfunc cache in fun s1 s2 -> (*Kernel.debug ~level:4 "CHECK PATH WITH FUNC %d->%d@\n" s1.sid s2.sid;*) check s1 s2 let stmt_is_in_cycle_filtered filterfunc stmt = let reachable = stmt_can_reach_filtered filterfunc in List.exists (fun s -> filterfunc s && reachable stmt s) stmt.preds let stmt_is_in_cycle = stmt_is_in_cycle_filtered (fun _ -> true) module SG = Graph.Imperative.Digraph.Concrete(Stmt) module TP = struct include SG let graph_attributes _ = [] let pretty_raw_stmt s = let s = Pretty_utils.sfprintf "%a" Printer.pp_stmt s in if String.length s >= 50 then (String.sub s 0 49) ^ "..." else s let vertex_name s = Format.sprintf "%S" (match s.skind with | Instr _ -> Format.sprintf "INSTR <%d>\n%s" s.sid (pretty_raw_stmt s) | Return _ -> Format.sprintf "RETURN <%d>" s.sid | Goto _ -> Format.sprintf "%s <%d>\n" (pretty_raw_stmt s) s.sid | Break _ -> Format.sprintf "BREAK <%d>" s.sid | Continue _ -> Format.sprintf "CONTINUE <%d>" s.sid | If(e,_,_,_) -> Pretty_utils.sfprintf "IF <%d>\n%a" s.sid Printer.pp_exp e | 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 "UnspecifiedSequence <%d>" s.sid) let vertex_attributes s = match s.skind with | Loop _ -> [`Color 0xFF0000; `Style `Filled] | If _ -> [`Color 0x00FF00; `Style `Filled; `Shape `Diamond] | Return _ -> [`Color 0x0000FF; `Style `Filled] | Block _ -> [`Shape `Box; `Fontsize 8] | Goto _ -> [`Shape `Diamond; `Color 0x00FFFF ; `Style `Filled] | Instr (Skip _) -> [`Color 0x00FFFF ; `Style `Filled] | _ -> [] let default_vertex_attributes _ = [] let edge_attributes _ = [] let default_edge_attributes _ = [] let get_subgraph _ = None end module GPrint = Graph.Graphviz.Dot(TP) class stmt_graph_builder = object inherit nopCilVisitor val graph = SG.create () method result = graph method vstmt s = SG.add_vertex graph s; (* required for function with exactly one stmt *) List.iter (SG.add_edge graph s) s.succs; (* preds will be set latter while being visited *) DoChildren end let compute_stmtgraph_func func = let o = new stmt_graph_builder in ignore (visitCilFunction (o:>cilVisitor) func); if Kernel.debug_atleast 1 then begin Kernel.debug "Function %s: Nb vertex: %d Nb edges:%d See file '%s_cfg.dot'.@\n" func.svar.vname (SG.nb_edges o#result) (SG.nb_vertex o#result) func.svar.vname; let oc = open_out (func.svar.vname^"_cfg.dot") in GPrint.output_graph oc o#result; close_out oc; end; (* Classic.add_transitive_closure ~reflexive:true o#result*) o#result module StmtsGraphTbl= State_builder.Hashtbl (Kernel_function.Hashtbl) (Datatype.Make (struct include Datatype.Serializable_undefined type t = SG.t let name = "Stmts_Graph.SG.t" let reprs = [ SG.create () ] let mem_project = Datatype.never_any_project end)) (struct let name = "StmtsGraphTbl" let size = 17 let dependencies = [ Ast.self ] end) let get_graph kf = StmtsGraphTbl.memo (fun kf -> match kf.fundec with | Definition (f,_) -> compute_stmtgraph_func f | Declaration _ -> assert false) kf module Reachable_Stmts = Cil_state_builder.Stmt_hashtbl (Stmt) (struct let name = "reachable_stmts" let size = 97 let dependencies = [ Ast.self ] end) let reachable_stmts kf s = let g = get_graph kf in let rec apply s = if Reachable_Stmts.mem s then Reachable_Stmts.find_all s else begin SG.iter_succ (fun s' -> Reachable_Stmts.add s s'; List.iter (Reachable_Stmts.add s) (apply s')) g s; Reachable_Stmts.find_all s end in apply s (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) (** Store for each statement, the set of the statements it is composed of. For a simple statement (not containing blocks), it is only the statement itself. *) module StmtStmts = Cil_state_builder.Stmt_hashtbl (Stmt.Set) (struct let name = "StmtStmts" let size = 142 let dependencies = [ Ast.self ] end) let rec get_block_stmts blk = let add stmts s = Stmt.Set.union (get_stmt_stmts s) stmts in List.fold_left add Stmt.Set.empty blk.bstmts and get_stmt_stmts s = let compute_stmt_stmts s = match s.skind with | Instr _ | Return _ -> Stmt.Set.singleton s | Continue _ | Break _ | Goto _ -> Stmt.Set.singleton s | Block b | Switch (_, b, _, _) | Loop (_, b, _, _, _) -> Stmt.Set.add s (get_block_stmts b) | UnspecifiedSequence seq -> let b = Cil.block_from_unspecified_sequence seq in Stmt.Set.add s (get_block_stmts b) | If (_, b1, b2, _) -> let stmts = Stmt.Set.union (get_block_stmts b1)(get_block_stmts b2) in Stmt.Set.add s stmts | TryExcept (_, _, _, _) | TryFinally (_, _, _) -> Kernel.not_yet_implemented "exception handling" in StmtStmts.memo compute_stmt_stmts s (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) module EdgeDatatype = Datatype.Pair (Stmt)(Stmt) module EdgesDatatype = Datatype.List (EdgeDatatype) (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) (** Store for each statement [s], the elements in its statements that are ways out of [s], split by termination kind : [Normal | Breaks | Continues | Returns + Goto] Notice that [Exits] is not here since it cannot be determined directly : every call possibly have an [Exits] termination. *) type waysout = { normal : EdgesDatatype.t ; breaks : EdgesDatatype.t ; continues : EdgesDatatype.t ; returns : EdgesDatatype.t ; gotos : EdgesDatatype.t ; } let empty_waysout = { normal = []; breaks = []; continues = []; returns = []; gotos = [] } module WaysOutDatatype = Datatype.Make (struct include Datatype.Undefined (* TODO: unmarshal ? *) type t = waysout let reprs = [ empty_waysout ] let name = "WaysOut" let mem_project = Datatype.never_any_project end) module StmtWaysOut = Cil_state_builder.Stmt_hashtbl (WaysOutDatatype) (struct let name = "StmtWaysOut" let size = 142 let dependencies = [ StmtStmts.self ] end) let compute_stmts_out_edges stmts = let do_s s waysout = (* if [s] has a successor [s'] which is not in [stmt] statements, * add [s,s'] *) let add s acc = let do_succ acc s' = if Stmt.Set.mem s' stmts then acc else (s, s')::acc in List.fold_left do_succ acc s.succs in match s.skind with | Continue _ -> { waysout with continues = add s waysout.continues } | Break _ -> { waysout with breaks = add s waysout.breaks } | Return _ -> { waysout with returns = add s waysout.returns } | Goto _ -> begin match s.succs with | { skind = Return _ }::[] -> { waysout with returns = add s waysout.returns } | _ -> { waysout with gotos = add s waysout.gotos } end | _ -> { waysout with normal = add s waysout.normal } in Stmt.Set.fold do_s stmts empty_waysout let merge_waysout waysout = waysout.normal @ waysout.breaks @ waysout.continues @ waysout.returns @ waysout.gotos let select_waysout termination_kind waysout = match termination_kind with | Some Normal -> waysout.normal | Some Breaks -> waysout.breaks | Some Continues -> waysout.continues | Some Returns -> waysout.returns | None (* Goto *) -> waysout.gotos | Some Exits -> invalid_arg "[get_stmt_out_edges] doesn't handle [Exits] termination_kind" let compute_stmt_out_edges stmt = compute_stmts_out_edges (get_stmt_stmts stmt) let get_stmt_out_edges termination_kind stmt = let waysout = StmtWaysOut.memo compute_stmt_out_edges stmt in select_waysout termination_kind waysout let get_all_stmt_out_edges s = let waysout = StmtWaysOut.memo compute_stmt_out_edges s in merge_waysout waysout let compute_block_out_edges blk = compute_stmts_out_edges (get_block_stmts blk) let get_all_block_out_edges blk = let waysout = compute_block_out_edges blk in merge_waysout waysout let get_block_out_edges termination_kind blk = let waysout = compute_block_out_edges blk in select_waysout termination_kind waysout let get_all_stmt_last_stmts s = List.map fst (get_all_stmt_out_edges s) let get_all_block_last_stmts b = List.map fst (get_all_block_out_edges b) let get_stmt_last_stmts tk s = List.map fst (get_stmt_out_edges tk s) let get_block_last_stmts tk b = List.map fst (get_block_out_edges tk b) (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) module StmtWaysIn = Cil_state_builder.Stmt_hashtbl (Datatype.List (EdgeDatatype)) (struct let name = "StmtWaysIn" let size = 142 let dependencies = [ StmtStmts.self ] end) let compute_stmts_in_edges stmts = let add s acc = let do_pred acc s' = if (Stmt.Set.mem s' stmts) then acc else (s',s)::acc in List.fold_left do_pred acc s.preds in Stmt.Set.fold add stmts [] let compute_stmt_entry_stmts stmt = compute_stmts_in_edges (get_stmt_stmts stmt) let get_stmt_in_edges s = StmtWaysIn.memo compute_stmt_entry_stmts s let get_block_in_edges blk = compute_stmts_in_edges (get_block_stmts blk) (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) let loop_preds s = match s.skind with | Loop _ -> let loop_stmts = get_stmt_stmts s in let back_edges, entry = List.partition (fun s -> Stmt.Set.mem s loop_stmts) s.preds in entry, back_edges | _ -> invalid_arg "[loop_preds] not a loop" (* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/unicode.mli0000644000175000017500000000322512155630171020200 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Handling unicode string. *) val inset_string : unit -> string frama-c-Fluorine-20130601/src/kernel/parameter.mli0000644000175000017500000000730612155630171020536 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Parameter settable through a command line option. @since Nitrogen-20111001 @plugin development guide *) type ('a, 'b) gen_accessor = { get: unit -> 'a; set: 'a -> unit; add_set_hook: ('b -> 'b -> unit) -> unit; add_update_hook: ('b -> 'b -> unit) -> unit } type 'a accessor = ('a, 'a) gen_accessor type typed_accessor = | Bool of bool accessor * string option (** the negative option, if any *) | Int of int accessor * (unit -> int * int) (** getting range *) | String of string accessor * (unit -> string list) (** possible values *) | String_set of (string, Datatype.String.Set.t) gen_accessor | String_list of (string, string list) gen_accessor type parameter = private { name: string; (** Name of the option corresponding to the parameter. It is exactly the state name of the option (see {!State.get_name}). *) help: string; (** Help message *) accessor: typed_accessor; (** How to get and set the value of the parameter *) is_set: unit -> bool (** Is this option really set? *) } include Datatype.S_with_collections with type t = parameter val get: string -> t (** Get the parameter from the option name. *) val get_value: t -> string (** Get the current value of the parameter, as a string. *) (* TODO: to be removed. Only present for compatibility reasons. @deprecated Nitrogen-20111001 *) type kind = | Correctness (** setting the value of the parameter may change a property status (from valid to invalid, or conversely), or may change the semantics of a generated annotation. Example: -machdep *) | Tuning (** setting the value of the parameters may change the precision of a property status (from don't know to valid/invalid, or conversely), or may change a generated annotation while preserving its semantics. Example: -unrolling-level *) | Other (**/**) (** Not for casual users. Use API of {!Plugin} instead. *) val create: name:string -> help:string -> accessor:typed_accessor -> is_set: (unit -> bool) -> t (**/**) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/unroll_loops.mli0000644000175000017500000000504712155630171021305 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Syntactic loop unrolling. *) (** Performs and closes all syntactic transformations, including syntactic loop unrolling. *) val compute : Cil_types.file -> unit (** Hook for transformation to be applied just before unrolling loops. The boolean value indicates if the CFG has to be recomputed. @since Oxygen-20120901 *) val add_syntactic_transformation : (Cil_types.file * bool -> Cil_types.file * bool) -> unit (** Performs only unrolling transformation without using -ulevel option. Loop invariant \false can be emmitted on total unrolling request. Do not forget to apply [transformations_closure] afterwards. @since Oxygen-20120901 *) val apply_transformation: int -> Emitter.t -> (Cil_types.file * bool) -> (Cil_types.file * bool) (** Close syntactic transformations. @since Oxygen-20120901 *) val transformations_closure: (Cil_types.file * bool) -> (Cil_types.file * bool) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/config.mli0000644000175000017500000000620112155630171020014 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Information about version of Frama-C. The body of this module is generated from Makefile. @plugin development guide *) val version: string (** Frama-C Version identifier. *) val date: string (** Compilation date. *) val is_gui: bool ref (** Is the Frama-C GUI running? @since Beryllium-20090601-beta1 *) val ocamlc: string (** Name of the bytecode compiler. @since Boron-20100401 *) val ocamlopt: string (** Name of the native compiler. @since Boron-20100401 *) val datadir: string (** Directory where architecture independent files are. *) val libdir: string (** Directory where the Frama-C kernel library is. @since Beryllium-20090601-beta1 *) val plugin_dir: string (** Directory where the Frama-C dynamic plug-ins are. @since Beryllium-20090601-beta1 *) val static_plugins: string list (** Plug-ins statically linked within Frama-C. *) val static_gui_plugins: string list (** GUI of plug-ins statically linked within Frama-C. *) val compilation_unit_names: string list (** List of names of all kernel compilation units. @since Boron-20100401 *) val preprocessor: string (** Name of the default command to call the preprocessor. If the CPP environment variable is set, use it else use the built-in default from autoconf. Usually this is "gcc -C -E -I." @since Oxygen-20120901 *) val dot: string option (** Dot command name. @return [None] if `dot' is not installed. @since Carbon-20101201 *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/visitor.ml0000644000175000017500000010474512155630171020111 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Extlib open Cil open Cil_types (* ************************************************************************* *) (** {2 Visitors} *) (* ************************************************************************* *) (** Class type for a Db-aware visitor. *) class type frama_c_visitor = object inherit cilVisitor method frama_c_plain_copy: frama_c_visitor method vstmt_aux: Cil_types.stmt -> Cil_types.stmt visitAction method vglob_aux: Cil_types.global -> Cil_types.global list visitAction method current_kf: kernel_function option (** @plugin development guide *) method set_current_kf: kernel_function -> unit method reset_current_kf: unit -> unit end (** Extension to the cil visitor that is aware of kernel function and annotation db. This is done by defining auxiliary methods that can be redefined in inherited classes, while the corresponding ones from {!Cil.cilVisitor} {b must} retain their values as defined here. Otherwise, annotations may not be visited properly. *) class internal_generic_frama_c_visitor fundec queue current_kf behavior: frama_c_visitor = object(self) inherit internal_genericCilVisitor fundec behavior queue method frama_c_plain_copy = new internal_generic_frama_c_visitor fundec queue current_kf behavior method plain_copy_visitor = assert (self#frama_c_plain_copy#get_filling_actions == self#get_filling_actions); (self#frama_c_plain_copy :> Cil.cilVisitor) method set_current_kf kf = current_kf := Some kf method reset_current_kf () = current_kf := None method current_kf = !current_kf method private vstmt stmt = let annots = Annotations.fold_code_annot (fun e a acc -> (e, a) :: acc) stmt [] in let res = self#vstmt_aux stmt in (* Annotations will be visited and more importantly added in the same order as they were in the original AST. *) let abefore = List.sort (fun (_,a) (_,b) -> Cil_datatype.Code_annotation.compare a b) annots in let make_children_annot vis = let res_before, remove_before = List.fold_left (fun (res,remove) (e, x) -> let curr_res, keep_curr = (* only keeps non-trivial non-already existing annotations *) List.fold_left (fun (res,keep) y -> let current = x == y in let res = if (* if x is trivial, keep all annotations, including trivial ones. *) (not (Ast_info.is_trivial_annotation y) || (Ast_info.is_trivial_annotation x)) && (not current || Cil.is_copy_behavior vis#behavior) then (e, y) :: res else res in (res, keep || current)) ([],false) (* TODO: make visitCilCodeAnnotation return a list of annotations? *) [visitCilCodeAnnotation (vis:>cilVisitor) x] in (res @ curr_res, if keep_curr then remove else (e, x) :: remove) ) ([],[]) abefore in (res_before, remove_before) in let change_stmt stmt (res_before, remove) = if (res_before <> [] || remove <> []) then begin let kf = Extlib.the self#current_kf in let new_kf = Cil.get_kernel_function self#behavior kf in Queue.add (fun () -> let apply f = List.iter (fun (e, a) -> f e ~kf:new_kf stmt a) in (* eta-expansions below required to OCaml type system *) apply (fun e ~kf -> Annotations.remove_code_annot e ~kf) remove; apply (fun e ~kf -> Annotations.add_code_annot e ~kf) res_before) self#get_filling_actions end in let post_action f stmt = let annots = make_children_annot self in let stmt = f stmt in change_stmt stmt annots; stmt in let copy stmt = change_stmt stmt(make_children_annot self#frama_c_plain_copy); stmt in let plain_post = post_action (fun x -> x) in match res with | SkipChildren -> res | JustCopy -> JustCopyPost copy | JustCopyPost f -> JustCopyPost (f $ copy) | DoChildren -> DoChildrenPost plain_post | DoChildrenPost f -> DoChildrenPost (f $ plain_post) | ChangeTo _ | ChangeToPost _ -> res | ChangeDoChildrenPost (stmt,f) -> ChangeDoChildrenPost (stmt, post_action f) method vstmt_aux _ = DoChildren method vglob_aux _ = DoChildren method private vbehavior_annot ?e b = let kf = Extlib.the self#current_kf in let treat_elt emit elt acc = match e with | None -> (emit, elt) :: acc | Some e when Emitter.equal e emit -> (emit, elt) :: acc | Some _ -> acc in let fold_elt fold = fold treat_elt kf b.b_name [] in let old_requires = fold_elt Annotations.fold_requires in let old_assumes = fold_elt Annotations.fold_assumes in let old_ensures = fold_elt Annotations.fold_ensures in let old_assigns = fold_elt Annotations.fold_assigns in let old_allocates = fold_elt Annotations.fold_allocates in let res = self#vbehavior b in let new_kf = Cil.get_kernel_function self#behavior kf in let add_queue a = Queue.add a self#get_filling_actions in let visit_clauses vis f = (* Ensures that we have a table associated to new_kf in Annotations. *) add_queue (fun () -> ignore (Annotations.behaviors ~populate:false new_kf)); let module Fold = struct type 'a t = { apply: 'b. (Emitter.t -> 'a -> 'b -> 'b) -> Kernel_function.t -> string -> 'b -> 'b } end in let visit_elt visit e elt (f,acc) = let new_elt = visit (vis:>Cil.cilVisitor) elt in (* We'll add the elts afterwards, so as to keep lists in their original order as much as we can. see fold_elt below. *) f || new_elt != elt || new_kf != kf, (e,new_elt) :: acc in let check_elt visit e' elt acc = match e with | None -> visit_elt visit e' elt acc | Some e when Emitter.equal e e' -> visit_elt visit e' elt acc | Some _ -> acc in let fold_elt fold visit remove add append dft = let (changed, res) = fold.Fold.apply (check_elt visit) kf b.b_name (false,[]) in if changed then begin add_queue (fun () -> fold.Fold.apply (fun e' x () -> match e with | None -> remove e' new_kf x | Some e when Emitter.equal e e' -> remove e' new_kf x | _ -> ()) new_kf b.b_name (); List.iter (fun (e,x) -> add e new_kf b.b_name x) res) end; List.fold_left (fun acc (_,x) -> append x acc) dft res in let req = fold_elt { Fold.apply = Annotations.fold_requires } Cil.visitCilIdPredicate Annotations.remove_requires (fun e kf b r -> Annotations.add_requires e kf b [r]) (fun x l -> x :: l) [] in b.b_requires <- req; let assumes = fold_elt { Fold.apply = Annotations.fold_assumes } Cil.visitCilIdPredicate Annotations.remove_assumes (fun e kf b a -> Annotations.add_assumes e kf b [a]) (fun x l -> x :: l) [] in b.b_assumes <- assumes; let visit_ensures vis (k,p as e) = let new_p = Cil.visitCilIdPredicate (vis:>Cil.cilVisitor) p in if p != new_p then (k,new_p) else e in let ensures = fold_elt { Fold.apply = Annotations.fold_ensures } visit_ensures Annotations.remove_ensures (fun e kf b p -> Annotations.add_ensures e kf b [p]) (fun x l -> x :: l) [] in b.b_post_cond <- ensures; let add_assigns e kf b a = match a with | WritesAny -> () | _ -> Annotations.add_assigns ~keep_empty:false e kf b a in let concat_assigns new_a a = match new_a, a with | WritesAny, a | a, WritesAny -> a | Writes a1, Writes a2 -> Writes (a2 @ a1) in let a = fold_elt { Fold.apply = Annotations.fold_assigns } Cil.visitCilAssigns Annotations.remove_assigns add_assigns concat_assigns WritesAny in b.b_assigns <- a; let concat_allocation new_a a = match new_a, a with | FreeAllocAny, a | a, FreeAllocAny -> a | FreeAlloc(a1,a2), FreeAlloc(a3,a4) -> FreeAlloc (a3@a1,a4@a2) in let a = fold_elt { Fold.apply = Annotations.fold_allocates } Cil.visitCilAllocation Annotations.remove_allocates Annotations.add_allocates concat_allocation FreeAllocAny in b.b_allocation <- a; f b in let remove_and_add get remove add fold old b = let emitter = match e with None -> Emitter.end_user | Some e -> e in let elts = get b in List.iter (fun (e,x) -> if not (List.memq x elts) then add_queue (fun () -> remove e new_kf x)) old; let module M = struct exception Found of Emitter.t end in let already_there x = fold (fun e y () -> if x == y then raise (M.Found e)) new_kf b.b_name () in List.iter (fun x -> add_queue (fun () -> try already_there x; add emitter new_kf b.b_name x with M.Found e -> (* We keep x at its right place inside b. *) remove e new_kf x; add e new_kf b.b_name x)) (List.rev elts); in let register_annots b f = add_queue (fun () -> ignore (Annotations.behaviors ~populate:false new_kf)); remove_and_add (fun b -> b.b_requires) Annotations.remove_requires (fun e kf b r -> Annotations.add_requires e kf b [r]) Annotations.fold_requires old_requires b; remove_and_add (fun b -> b.b_assumes) Annotations.remove_assumes (fun e kf b r -> Annotations.add_assumes e kf b [r]) Annotations.fold_assumes old_assumes b; remove_and_add (fun b -> b.b_post_cond) Annotations.remove_ensures (fun e kf b r -> Annotations.add_ensures e kf b [r]) Annotations.fold_ensures old_ensures b; remove_and_add (fun b -> match b.b_assigns with WritesAny -> [] | a -> [a]) Annotations.remove_assigns (fun e kf b a -> match a with | WritesAny -> () | Writes _ -> Annotations.add_assigns ~keep_empty:false e kf b a) Annotations.fold_assigns old_assigns b; remove_and_add (fun b -> match b.b_allocation with FreeAllocAny -> [] | a -> [a]) Annotations.remove_allocates Annotations.add_allocates Annotations.fold_allocates old_allocates b; f b in match res with | SkipChildren -> b | JustCopy -> visit_clauses self#plain_copy_visitor Extlib.id | JustCopyPost f -> visit_clauses self#plain_copy_visitor f | ChangeTo b -> register_annots b Extlib.id | ChangeToPost (b,f) -> register_annots b f | ChangeDoChildrenPost (b,f) -> register_annots (Cil.childrenBehavior (self:>Cil.cilVisitor) b) f | DoChildren -> visit_clauses self Extlib.id | DoChildrenPost f -> visit_clauses self f method private vfunspec_annot () = let kf = Extlib.the self#current_kf in let new_kf = Cil.get_kernel_function self#behavior kf in let old_behaviors = Annotations.fold_behaviors (fun e b acc -> (e,b)::acc) kf [] in let old_complete = Annotations.fold_complete (fun e c acc -> (e,c)::acc) kf [] in let old_disjoint = Annotations.fold_disjoint (fun e d acc -> (e,d)::acc) kf [] in let old_terminates = Annotations.fold_terminates (fun e t _ -> Some (e,t)) kf None in let old_decreases = Annotations.fold_decreases (fun e d _ -> Some (e,d)) kf None in let spec = { spec_behavior = snd (List.split old_behaviors); spec_complete_behaviors = snd (List.split old_complete); spec_disjoint_behaviors = snd (List.split old_disjoint); spec_terminates = (Extlib.opt_map snd) old_terminates; spec_variant = (Extlib.opt_map snd) old_decreases } in let res = self#vspec spec in let do_children () = let new_behaviors = List.rev_map (fun (e,b) -> let b' = self#vbehavior_annot ~e b in if b != b' || kf != new_kf then begin Queue.add (fun () -> Annotations.add_behaviors ~register_children:false e new_kf [b']) self#get_filling_actions; end; b') old_behaviors in let new_terminates = Extlib.opt_map (fun (e,t) -> let t' = Cil.visitCilIdPredicate (self:>Cil.cilVisitor) t in if t != t' || kf != new_kf then Queue.add (fun () -> Annotations.remove_terminates e new_kf; Annotations.add_terminates e new_kf t') self#get_filling_actions ; t') old_terminates in let new_decreases = Extlib.opt_map (fun (e,(d,s as acc)) -> let d' = Cil.visitCilTerm (self:>Cil.cilVisitor) d in if d != d' || kf != new_kf then begin let res = (d',s) in Queue.add (fun () -> Annotations.remove_decreases e new_kf; Annotations.add_decreases e new_kf res; ) self#get_filling_actions; res end else acc ) old_decreases in if kf != new_kf then begin List.iter (fun (e,c) -> Queue.add (fun () -> Annotations.add_complete e new_kf c) self#get_filling_actions) (List.rev old_complete); List.iter (fun (e,d) -> Queue.add (fun () -> Annotations.add_disjoint e new_kf d) self#get_filling_actions) (List.rev old_disjoint) end; { spec with spec_behavior = new_behaviors; spec_terminates = new_terminates; spec_variant = new_decreases } in let change_do_children spec = let new_behaviors = Cil.mapNoCopy self#vbehavior_annot spec.spec_behavior in let new_terminates = Cil.optMapNoCopy (Cil.visitCilIdPredicate (self:>Cil.cilVisitor)) spec.spec_terminates in let new_decreases = Cil.optMapNoCopy (fun (d,s as acc) -> let d' = Cil.visitCilTerm (self:>Cil.cilVisitor) d in if d != d' then (d',s) else acc) spec.spec_variant in { spec with spec_behavior = new_behaviors; spec_terminates = new_terminates; spec_variant = new_decreases } in let register_new_components new_spec = let add_spec_components () = let populate = false in let new_behaviors = Annotations.behaviors ~populate new_kf in List.iter (fun b -> if (List.for_all (fun x -> x.b_name <> b.b_name || Cil.is_empty_behavior x) new_behaviors) then begin Annotations.add_behaviors ~register_children:false Emitter.end_user new_kf [b] end) new_spec.spec_behavior; let new_complete = Annotations.complete ~populate new_kf in List.iter (fun c -> if not (List.memq c new_complete) then begin Annotations.add_complete Emitter.end_user new_kf c end) new_spec.spec_complete_behaviors; let new_disjoint = Annotations.disjoint ~populate new_kf in List.iter (fun d -> if not (List.memq d new_disjoint) then Annotations.add_disjoint Emitter.end_user new_kf d) new_spec.spec_disjoint_behaviors; let new_terminates = Annotations.terminates ~populate new_kf in (match new_terminates, new_spec.spec_terminates with | None, None -> () | Some _, None -> () | None, Some p -> Annotations.add_terminates Emitter.end_user new_kf p | Some p1, Some p2 when p1 == p2 -> () | Some p1, Some p2 -> Kernel.fatal "Visit of spec of function %a gives \ inconsistent terminates clauses@\n\ Registered @[%a@]@\nReturned @[%a@]" Kernel_function.pretty new_kf Printer.pp_identified_predicate p1 Printer.pp_identified_predicate p2); let new_decreases = Annotations.decreases ~populate new_kf in (match new_decreases, new_spec.spec_variant with | None, None -> () | Some _, None -> () | None, Some p -> Annotations.add_decreases Emitter.end_user new_kf p | Some p1, Some p2 when p1 == p2 -> () | Some p1, Some p2 -> Kernel.fatal "Visit of spec of function %a gives \ inconsistent variant clauses@\n\ Registered %d@\n%a@\nReturned %d@\n%a" Kernel_function.pretty new_kf (Obj.magic p1) Printer.pp_decreases p1 (Obj.magic p2) Printer.pp_decreases p2) in List.iter (fun (e,c) -> if not (List.memq c new_spec.spec_complete_behaviors) then Queue.add (fun () -> Annotations.remove_complete e new_kf c) self#get_filling_actions) old_complete; List.iter (fun (e,d) -> if not (List.memq d new_spec.spec_disjoint_behaviors) then Queue.add (fun () -> Annotations.remove_disjoint e new_kf d) self#get_filling_actions) old_disjoint; List.iter (fun (e,b) -> if not (List.memq b new_spec.spec_behavior) then begin Queue.add (fun () -> if List.exists (fun x -> x.b_name = b.b_name) new_spec.spec_behavior then Annotations.remove_behavior_components e new_kf b else Annotations.remove_behavior e new_kf b) self#get_filling_actions end ) old_behaviors; Extlib.may (fun (e,t) -> if not (Extlib.may_map ~dft:false (fun t' -> t == t') new_spec.spec_terminates) then Queue.add (fun () -> Annotations.remove_terminates e new_kf) self#get_filling_actions) old_terminates; Extlib.may (fun (e,d) -> if not (Extlib.may_map ~dft:false (fun d' -> d == d') new_spec.spec_variant) then Queue.add (fun () -> Annotations.remove_decreases e new_kf) self#get_filling_actions) old_decreases; Queue.add add_spec_components self#get_filling_actions; in match res with | SkipChildren -> register_new_components spec | ChangeTo spec -> register_new_components spec | ChangeToPost (spec,f) -> register_new_components spec; ignore (f spec) | JustCopy -> register_new_components (Cil.visitCilFunspec self#plain_copy_visitor spec) | JustCopyPost f -> (register_new_components (Cil.visitCilFunspec self#plain_copy_visitor spec)); ignore (f spec) | DoChildren -> ignore (do_children ()) | DoChildrenPost f -> ignore (f (do_children ())) | ChangeDoChildrenPost(spec, f) -> let res = change_do_children spec in register_new_components res; ignore (f res) method vglob g = let fundec, has_kf = match g with | GVarDecl(_,v,_) when isFunctionType v.vtype -> let kf = try Globals.Functions.get v with Not_found -> Kernel.fatal "No kernel function for %s(%d)" v.vname v.vid in (* Just make a copy of current kernel function in case it is needed *) let new_kf = Cil.memo_kernel_function self#behavior kf in if Cil.is_copy_behavior self#behavior then new_kf.spec <- Cil.empty_funspec (); self#set_current_kf kf; None, true | GFun(f,_) -> let v = Cil.get_original_varinfo self#behavior f.svar in let kf = try Globals.Functions.get v with Not_found -> Kernel.fatal "Visitor does not found function %s in %a" v.vname Project.pretty (Project.current ()) in let new_kf = Cil.memo_kernel_function self#behavior kf in if Cil.is_copy_behavior self#behavior then new_kf.spec <- Cil.empty_funspec (); self#set_current_kf kf; Some f, true | _ -> None, false in let res = self#vglob_aux g in let make_funspec () = match g with | GVarDecl(_,v,_) when isFunctionType v.vtype && Ast.is_last_decl g -> self#vfunspec_annot (); | GFun _ when Ast.is_last_decl g -> self#vfunspec_annot () | _ -> () in (* NB: we'll loose track of the emitter of an annotation. Anyway, this is only used for SkipChildren and JustCopy/JustCopyPost (and for a copy visitor) If user sticks to DoChildren, s/he'll still have the proper correspondance between annotations and emitters. *) let get_spec () = match g with | GVarDecl(_,v,_) when isFunctionType v.vtype && Ast.is_last_decl g -> let spec = Annotations.funspec ~populate:false (Extlib.the self#current_kf) in Some (Cil.visitCilFunspec self#plain_copy_visitor spec) | GFun _ when Ast.is_last_decl g -> let spec = Annotations.funspec ~populate:false (Extlib.the self#current_kf) in Some (Cil.visitCilFunspec self#plain_copy_visitor spec) | _ -> None in let change_glob ng spec = let cond = is_copy_behavior self#behavior in match ng with | GVar(vi,init,_) -> if cond then Queue.add (fun () -> try Globals.Vars.add vi init with Globals.Vars.AlreadyExists (vi,_) -> Kernel.fatal "Visitor is trying to insert global variable %a that \ already exists in current project" Cil_datatype.Varinfo.pretty vi) self#get_filling_actions | GVarDecl(_,v,l) when isFunctionType v.vtype -> (match self#current_kf with | Some kf -> let new_kf = Cil.get_kernel_function self#behavior kf in if cond then begin Queue.add (fun () -> if Cil.hasAttribute "FC_BUILTIN" v.vattr then Cil.Frama_c_builtins.add v.vname v; if Cil_datatype.Varinfo.equal v (Kernel_function.get_vi new_kf) then begin let dft = Annotations.funspec ~populate:false new_kf in let dft = { dft with spec_behavior = dft.spec_behavior } in let spec = Extlib.opt_conv dft spec in Globals.Functions.register new_kf; Globals.Functions.replace_by_declaration spec v l; (* Format.printf "registered spec:@\n%a@." Printer.pp_funspec (Annotations.funspec ~populate:false new_kf) *) end else begin Globals.Functions.replace_by_declaration (Cil.empty_funspec()) v l end) self#get_filling_actions; if Cil_datatype.Varinfo.equal v (Kernel_function.get_vi new_kf) && Extlib.has_some spec then Queue.add (fun () -> Annotations.register_funspec ~force:true new_kf) self#get_filling_actions; end | None -> () (* User is responsible for registering the new function *) ) | GVarDecl (_,({vstorage=Extern} as v),_) (* when not (isFunctionType v.vtype) *) -> if cond then Queue.add (fun () -> try Globals.Vars.add_decl v with Globals.Vars.AlreadyExists (vi,_) -> Kernel.fatal "Visitor is trying to insert global variable %a that \ already exists in current project" Cil_datatype.Varinfo.pretty vi) self#get_filling_actions | GFun(f,l) -> if cond then begin match self#current_kf with | Some kf -> let new_kf = Cil.get_kernel_function self#behavior kf in Queue.add (fun () -> Kernel.debug "@[Adding definition %s (vid: %d) for project %s@\n\ body: %a@\n@]@." f.svar.vname f.svar.vid (Project.get_name (Project.current())) Printer.pp_block f.sbody; if cond && Cil.hasAttribute "FC_BUILTIN" f.svar.vattr then Cil.Frama_c_builtins.add f.svar.vname f.svar; if Cil_datatype.Varinfo.equal f.svar (Kernel_function.get_vi new_kf) then begin Globals.Functions.register new_kf; let spec = Extlib.opt_conv (Annotations.funspec ~populate:false new_kf) spec in Globals.Functions.replace_by_definition spec f l end else Globals.Functions.replace_by_definition (Cil.empty_funspec ()) f l ) self#get_filling_actions; if Cil_datatype.Varinfo.equal f.svar (Kernel_function.get_vi new_kf) && Extlib.has_some spec then Queue.add (fun () -> Annotations.register_funspec ~force:true new_kf) self#get_filling_actions; | None -> () (* User has to register the new function *) end | GAnnot (na,_) when cond -> let e = match g with | GAnnot (a,_) -> Annotations.emitter_of_global a | _ -> Emitter.end_user in Queue.add (fun () -> try (* Annotations might have already been added by the user. *) ignore (Annotations.emitter_of_global na) with Not_found -> Annotations.unsafe_add_global e na) self#get_filling_actions | _ -> () in let post_action g = Extlib.may self#set_current_func fundec; let spec = get_spec () in List.iter (fun g -> change_glob g spec) g; if has_kf then self#reset_current_kf(); Extlib.may (fun _ -> self#reset_current_func ()) fundec; g in let post_change_to g = List.iter (fun g -> change_glob g None) g; if has_kf then self#reset_current_kf(); g in let post_do_children f g = Extlib.may self#set_current_func fundec; make_funspec (); let res = f g in (* Spec registration is already handled at the vfunspec level. *) List.iter (fun g -> change_glob g None) res; if has_kf then self#reset_current_kf(); Extlib.may (fun _ -> self#reset_current_func ()) fundec; res in match res with | SkipChildren -> change_glob g None; if has_kf then self#reset_current_kf(); res | JustCopy -> JustCopyPost post_action | JustCopyPost f -> JustCopyPost (f $ post_action) | DoChildren -> DoChildrenPost (post_do_children Extlib.id) | DoChildrenPost f -> DoChildrenPost (post_do_children f) | ChangeTo l -> ChangeToPost (l,post_change_to) | ChangeToPost (l,f) -> ChangeToPost (l, f $ post_change_to) | ChangeDoChildrenPost (l,f) -> ChangeDoChildrenPost (l, post_do_children f) end class generic_frama_c_visitor bhv = let current_kf = ref None in let current_fundec = ref None in let queue = Queue.create () in internal_generic_frama_c_visitor current_fundec queue current_kf bhv class frama_c_copy prj = generic_frama_c_visitor (copy_visit prj) class frama_c_inplace = generic_frama_c_visitor (inplace_visit()) let visitFramacFileCopy vis f = visitCilFileCopy (vis:>cilVisitor) f let visitFramacFile vis f = visitCilFile (vis:>cilVisitor) f let visitFramacFileSameGlobals vis f = visitCilFileSameGlobals (vis:>cilVisitor) f let visitFramacGlobal vis g = let g' = visitCilGlobal (vis:>cilVisitor) g in vis#fill_global_tables; g' let visitFramacFunction vis f = vis#set_current_kf (Globals.Functions.get f.svar); let f' = visitCilFunction (vis:>cilVisitor) f in vis#reset_current_kf (); vis#fill_global_tables; f' let visitFramacExpr vis e = let e' = visitCilExpr (vis:>cilVisitor) e in vis#fill_global_tables; e' let visitFramacLval vis l = let l' = visitCilLval (vis:>cilVisitor) l in vis#fill_global_tables; l' let visitFramacOffset vis o = let o' = visitCilOffset (vis:>cilVisitor) o in vis#fill_global_tables; o' let visitFramacInitOffset vis o = let o' = visitCilInitOffset (vis:>cilVisitor) o in vis#fill_global_tables; o' let visitFramacInstr vis i = let i' = visitCilInstr (vis:>cilVisitor) i in vis#fill_global_tables; i' let visitFramacStmt vis s = let s' = visitCilStmt (vis:>cilVisitor) s in vis#fill_global_tables; s' let visitFramacBlock vis b = let b' = visitCilBlock (vis:>cilVisitor) b in vis#fill_global_tables; b' let visitFramacType vis t = let t' = visitCilType (vis:>cilVisitor) t in vis#fill_global_tables; t' let visitFramacVarDecl vis v = let v' = visitCilVarDecl (vis:>cilVisitor) v in vis#fill_global_tables; v' let visitFramacInit vis v o i = let i' = visitCilInit (vis:>cilVisitor) v o i in vis#fill_global_tables; i' let visitFramacAttributes vis a = let a' = visitCilAttributes (vis:>cilVisitor) a in vis#fill_global_tables; a' let visitFramacAnnotation vis a = let a' = visitCilAnnotation (vis:>cilVisitor) a in vis#fill_global_tables; a' let visitFramacCodeAnnotation vis c = let c' = visitCilCodeAnnotation (vis:>cilVisitor) c in vis#fill_global_tables; c' let visitFramacAssigns vis a = let a' = visitCilAssigns (vis:>cilVisitor) a in vis#fill_global_tables; a' let visitFramacFrom vis a = let a' = visitCilFrom (vis:>cilVisitor) a in vis#fill_global_tables; a' let visitFramacDeps vis a = let a' = visitCilDeps (vis:>cilVisitor) a in vis#fill_global_tables; a' let visitFramacFunspec vis f = let f' = visitCilFunspec (vis:>cilVisitor) f in vis#fill_global_tables; f' let visitFramacLogicType vis l = let l' = visitCilLogicType (vis:>cilVisitor) l in vis#fill_global_tables; l' let visitFramacPredicate vis p = let p' = visitCilPredicate (vis:>cilVisitor) p in vis#fill_global_tables; p' let visitFramacPredicateNamed vis p = let p' = visitCilPredicateNamed (vis:>cilVisitor) p in vis#fill_global_tables; p' let visitFramacIdPredicate vis p = let p' = visitCilIdPredicate (vis:>cilVisitor) p in vis#fill_global_tables; p' let visitFramacPredicates vis p = let p' = visitCilPredicates (vis:>cilVisitor) p in vis#fill_global_tables; p' let visitFramacIdTerm vis t = let t' = visitCilIdTerm (vis:>cilVisitor) t in vis#fill_global_tables; t' let visitFramacTerm vis t = let t' = visitCilTerm (vis:>cilVisitor) t in vis#fill_global_tables; t' let visitFramacTermOffset vis t = let t' = visitCilTermOffset (vis:>cilVisitor) t in vis#fill_global_tables; t' let visitFramacTermLhost vis t = let t' = visitCilTermLhost (vis:>cilVisitor) t in vis#fill_global_tables; t' let visitFramacTermLval vis t = let t' = visitCilTermLval (vis:>cilVisitor) t in vis#fill_global_tables; t' let visitFramacLogicInfo vis l = let l' = visitCilLogicInfo (vis:>cilVisitor) l in vis#fill_global_tables; l' let visitFramacBehavior vis b = let b' = visitCilBehavior (vis:>cilVisitor) b in vis#fill_global_tables; b' let visitFramacBehaviors vis b = let b' = visitCilBehaviors (vis:>cilVisitor) b in vis#fill_global_tables; b' let visitFramacModelInfo vis m = let m' = visitCilModelInfo (vis:>cilVisitor) m in vis#fill_global_tables; m' (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/alarms.ml0000644000175000017500000005066012155630171017665 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 type overflow_kind = Signed | Unsigned | Signed_downcast | Unsigned_downcast type access_kind = For_reading | For_writing type bound_kind = Lower_bound | Upper_bound let string_of_overflow_kind = function | Signed -> "signed_overflow" | Unsigned -> "unsigned_overflow" | Signed_downcast -> "signed_downcast" | Unsigned_downcast -> "unsigned_downcast" type alarm = | Division_by_zero of exp | Memory_access of lval * access_kind | Logic_memory_access (* temporary? *) of term * access_kind | Index_out_of_bound of exp (* index *) * exp option (* None = lower bound is zero; Some up = upper bound *) | Invalid_shift of exp * int option (* strict upper bound, if any *) | Pointer_comparison of exp option (* [None] when implicit comparison to 0 *) * exp | Overflow of overflow_kind * exp * Integer.t (* the bound *) * bound_kind | Float_to_int of exp * Integer.t (* the bound *) * bound_kind | Not_separated of lval * lval | Overlap of lval * lval | Uninitialized of lval | Is_nan_or_infinite of exp * fkind module D = Datatype.Make_with_collections (struct type t = alarm let name = "Alarms" let reprs = List.map (fun e -> Division_by_zero e) Exp.reprs let rank = function | Division_by_zero _ -> 0 | Memory_access _ -> 1 | Logic_memory_access _ -> 2 | Index_out_of_bound _ -> 3 | Invalid_shift _ -> 4 | Pointer_comparison _ -> 5 | Overflow _ -> 6 | Not_separated _ -> 7 | Overlap _ -> 8 | Uninitialized _ -> 9 | Is_nan_or_infinite _ -> 10 | Float_to_int _ -> 11 let compare a1 a2 = match a1, a2 with | Division_by_zero e1, Division_by_zero e2 -> Exp.compare e1 e2 | Is_nan_or_infinite (e1, fk1), Is_nan_or_infinite (e2, fk2) -> let n = Exp.compare e1 e2 in if n = 0 then Extlib.compare_basic fk1 fk2 else n | Memory_access(lv1, access_kind1), Memory_access(lv2, access_kind2) -> let n = Pervasives.compare access_kind1 access_kind2 in if n = 0 then Lval.compare lv1 lv2 else n | Logic_memory_access(t1, b1), Logic_memory_access(t2, b2) -> (* [TODO] pretty inefficient... *) let n = Pervasives.compare (b1:access_kind) b2 in if n = 0 then Term.compare t1 t2 else n | Index_out_of_bound(e11, e12), Index_out_of_bound(e21, e22) -> let n = Exp.compare e11 e21 in if n = 0 then Extlib.opt_compare Exp.compare e12 e22 else n | Invalid_shift(e1, n1), Invalid_shift(e2, n2) -> let n = Exp.compare e1 e2 in if n = 0 then Extlib.opt_compare Datatype.Int.compare n1 n2 else n | Pointer_comparison(e11, e12), Pointer_comparison(e21, e22) -> let n = Extlib.opt_compare Exp.compare e11 e21 in if n = 0 then Exp.compare e12 e22 else n | Overflow(s1, e1, n1, b1), Overflow(s2, e2, n2, b2) -> let n = Pervasives.compare (s1:overflow_kind) s2 in if n = 0 then let n = Exp.compare e1 e2 in if n = 0 then (* [TODO] pretty inefficient... *) let n = Pervasives.compare (b1:bound_kind) b2 in if n = 0 then Integer.compare n1 n2 else n else n else n | Float_to_int(e1, n1, b1), Float_to_int(e2, n2, b2) -> let n = Exp.compare e1 e2 in if n = 0 then (* [TODO] pretty inefficient... *) let n = Pervasives.compare (b1:bound_kind) b2 in if n = 0 then Integer.compare n1 n2 else n else n | Not_separated(lv11, lv12), Not_separated(lv21, lv22) | Overlap(lv11, lv12), Overlap(lv21, lv22) -> let n = Lval.compare lv11 lv21 in if n = 0 then Lval.compare lv12 lv22 else n | Uninitialized lv1, Uninitialized lv2 -> Lval.compare lv1 lv2 | _, (Division_by_zero _ | Memory_access _ | Logic_memory_access _ | Index_out_of_bound _ | Invalid_shift _ | Pointer_comparison _ | Overflow _ | Not_separated _ | Overlap _ | Uninitialized _ | Is_nan_or_infinite _ | Float_to_int _ ) -> let n = rank a1 - rank a2 in assert (n <> 0); n let equal = Datatype.from_compare let hash a = match a with | Division_by_zero e -> Hashtbl.hash (rank a, Exp.hash e) | Is_nan_or_infinite (e, fk) -> Hashtbl.hash (rank a, Exp.hash e, fk) | Memory_access(lv, b) -> Hashtbl.hash (rank a, Lval.hash lv, b) | Logic_memory_access(t, b) -> Hashtbl.hash (rank a, Term.hash t, b) | Index_out_of_bound(e1, e2) -> Hashtbl.hash (rank a, Exp.hash e1, match e2 with None -> 0 | Some e -> 17 + Exp.hash e) | Invalid_shift(e, n) -> Hashtbl.hash (rank a, Exp.hash e, n) | Pointer_comparison(e1, e2) -> Hashtbl.hash (rank a, (match e1 with None -> 0 | Some e -> 17 + Exp.hash e), Exp.hash e2) | Overflow(s, e, n, b) -> Hashtbl.hash (Hashtbl.hash (s:overflow_kind), rank a, Exp.hash e, Integer.hash n, b) | Float_to_int(e, n, b) -> Hashtbl.hash (rank a, Exp.hash e, Integer.hash n, b) | Not_separated(lv1, lv2) | Overlap(lv1, lv2) -> Hashtbl.hash (rank a, Lval.hash lv1, Lval.hash lv2) | Uninitialized lv -> Hashtbl.hash (rank a, Lval.hash lv) let structural_descr = Structural_descr.Abstract let rehash = Datatype.identity let varname = Datatype.undefined let pretty fmt = function | Division_by_zero e -> Format.fprintf fmt "Division_by_zero(@[%a@])" Printer.pp_exp e | Is_nan_or_infinite (e, fk) -> Format.fprintf fmt "Is_nan_or_infinite(@[(%a)%a@])" Printer.pp_fkind fk Printer.pp_exp e | Memory_access(lv, read) -> Format.fprintf fmt "Memory_access(@[%a@],@ %s)" Printer.pp_lval lv (match read with For_reading -> "read" | For_writing -> "write") | Logic_memory_access(t, read) -> Format.fprintf fmt "Logic_memory_access(@[%a@],@ %s)" Printer.pp_term t (match read with For_reading -> "read" | For_writing -> "write") | Index_out_of_bound(e1, e2) -> Format.fprintf fmt "Index_out_of_bound(@[%a@]@ %s@ @[%a@])" Printer.pp_exp e1 (match e2 with None -> ">=" | Some _ -> "<") Printer.pp_exp (match e2 with None -> Cil.zero e1.eloc | Some e -> e) | Invalid_shift(e, n) -> Format.fprintf fmt "Invalid_shift(@[%a@]@ %s)" Printer.pp_exp e (match n with None -> "" | Some n -> "<= " ^ string_of_int n) | Pointer_comparison(e1, e2) -> Format.fprintf fmt "Pointer_comparison(@[%a@],@ @[%a@])" Printer.pp_exp (match e1 with None -> Cil.zero e2.eloc | Some e -> e) Printer.pp_exp e2 | Overflow(s, e, n, b) -> Format.fprintf fmt "%s(@[%a@]@ %s@ @[%a@])" (String.capitalize (string_of_overflow_kind s)) Printer.pp_exp e (match b with Lower_bound -> ">=" | Upper_bound -> "<=") Datatype.Big_int.pretty n | Float_to_int(e, n, b) -> Format.fprintf fmt "Float_to_int(@[%a@]@ %s@ @[%a@])" Printer.pp_exp e (match b with Lower_bound -> ">" | Upper_bound -> "<") Datatype.Big_int.pretty ((match b with | Lower_bound -> Integer.sub | Upper_bound -> Integer.add) n Integer.one) | Not_separated(lv1, lv2) -> Format.fprintf fmt "Not_separated(@[%a@],@ @[%a@])" Lval.pretty lv1 Lval.pretty lv2 | Overlap(lv1, lv2) -> Format.fprintf fmt "Overlap(@[%a@],@ @[%a@])" Lval.pretty lv1 Lval.pretty lv2 | Uninitialized lv -> Format.fprintf fmt "Uninitialized(@[%a@])" Lval.pretty lv let internal_pretty_code = Datatype.undefined let copy = Datatype.undefined let mem_project = Datatype.never_any_project end) include D module Usable_emitter = struct include Emitter.Usable_emitter let local_clear _ h = Hashtbl.clear h let usable_get e = e end module Rank = State_builder.Counter(struct let name = "Alarms.Rank" end) module State = Emitter.Make_table (Kinstr.Hashtbl) (Usable_emitter) (D.Hashtbl.Make (Datatype.Quadruple (Code_annotation)(Kernel_function)(Stmt)(Datatype.Int))) (struct let name = "Alarms.State" let dependencies = [ Ast.self; Rank.self ] let kinds = [ Emitter.Alarm ] let size = 97 end) let must_remove_annot = ref true let () = State.add_hook_on_remove (fun e _ h -> if !must_remove_annot then D.Hashtbl.iter (fun _ (a, kf, s, _) -> Annotations.remove_code_annot (Emitter.Usable_emitter.get e) ~kf s a) h) module Alarm_of_annot = State_builder.Hashtbl (Code_annotation.Hashtbl) (D) (struct let name = "Alarms.Alarm_of_annot" let dependencies = [ Ast.self; Rank.self ] let size = 97 end) let self = State.self let () = Ast.add_monotonic_state self let emit_status emitter kf stmt annot status = let p = Property.ip_of_code_annot_single kf stmt annot in Property_status.emit emitter ~hyps:[] p ~distinct:true status let add_annotation tbl alarm emitter ?kf kinstr annot status = let add kf stmt = Annotations.add_code_annot emitter ~kf stmt annot; let id = Rank.next () in D.Hashtbl.add tbl alarm (annot, kf, stmt, id); Extlib.may (emit_status emitter kf stmt annot) status; Alarm_of_annot.add annot alarm; in match kinstr with | Kglobal -> let kf = match kf with | None -> fst (Globals.entry_point ()) | Some kf -> Kernel.fatal "[Alarm] how function `%a' can be associated to a global \ program point" Kernel_function.pretty kf in (try let stmt = Kernel_function.find_first_stmt kf in add kf stmt with Kernel_function.No_Statement -> Kernel.fatal "[Alarm] the main function has no code") | Kstmt stmt -> let kf = match kf with | None -> Kernel_function.find_englobing_kf stmt | Some kf -> kf in add kf stmt let get_name = function | Division_by_zero _ -> "division_by_zero" | Memory_access _ -> "mem_access" | Logic_memory_access _ -> "logic_mem_access" | Index_out_of_bound _ -> "index_bound" | Invalid_shift _ -> "shift" | Pointer_comparison _ -> "ptr_comparison" | Overflow(s, _, _, _) -> string_of_overflow_kind s | Not_separated _ -> "separation" | Overlap _ -> "overlap" | Uninitialized _ -> "initialisation" | Is_nan_or_infinite _ -> "is_nan_or_infinite" | Float_to_int _ -> "float_to_int" let overflowed_expr_to_term e = let loc = e.eloc in match e.enode with | UnOp(op, e, ty) -> let t = Logic_utils.expr_to_term ~cast:true e in let ty = Logic_utils.typ_to_logic_type ty in Logic_const.term ~loc (TUnOp(op, t)) ty | BinOp(op, e1, e2, ty) -> let t1 = Logic_utils.expr_to_term ~cast:true e1 in let t2 = Logic_utils.expr_to_term ~cast:true e2 in let ty = Logic_utils.typ_to_logic_type ty in Logic_const.term ~loc (TBinOp(op, t1, t2)) ty | _ -> Logic_utils.expr_to_term ~cast:true e let create_predicate ?(loc=Location.unknown) alarm = let aux = function | Division_by_zero e -> (* e != 0 *) let loc = e.eloc in let t = Logic_utils.expr_to_term ~cast:true e in Logic_const.prel ~loc (Rneq, t, Cil.lzero ()) | Memory_access(lv, read) -> (* \valid(lv) or \valid_read(lv) according to read *) let valid = match read with | For_reading -> Logic_const.pvalid_read | For_writing -> Logic_const.pvalid in let e = Cil.mkAddrOrStartOf ~loc lv in let t = Logic_utils.expr_to_term ~cast:true e in valid ~loc (Logic_const.here_label, t) | Logic_memory_access(t, read) -> (* \valid(lv) or \valid_read(lv) according to read *) let valid = match read with | For_reading -> Logic_const.pvalid_read | For_writing -> Logic_const.pvalid in valid ~loc (Logic_const.here_label, t) | Index_out_of_bound(e1, e2) -> (* 0 <= e1 < e2, left part if None, right part if Some e *) let loc = e1.eloc in let t1 = Logic_utils.expr_to_term ~cast:true e1 in (match e2 with | None -> Logic_const.prel ~loc (Rle, Cil.lzero (), t1) | Some e2 -> let t2 = Logic_utils.expr_to_term ~cast:true e2 in Logic_const.prel ~loc (Rlt, t1, t2)) | Invalid_shift(e, n) -> (* 0 <= e < n *) let loc = e.eloc in let t = Logic_utils.expr_to_term ~cast:true e in let low_cmp = Logic_const.prel ~loc (Rle, Cil.lzero (), t) in (match n with | None -> low_cmp | Some n -> let tn = Logic_const.tint ~loc (Integer.of_int n) in let up_cmp = Logic_const.prel ~loc (Rlt, t, tn) in Logic_const.pand ~loc (low_cmp, up_cmp)) | Pointer_comparison(e1, e2) -> (* \pointer_comparable(e1, e2) *) let loc = e2.eloc in let t1 = match e1 with | None -> Cil.lzero () | Some e -> Logic_utils.expr_to_term ~cast:true e in let t2 = Logic_utils.expr_to_term ~cast:true e2 in Logic_utils.pointer_comparable ~loc t1 t2 | Overflow(_, e, n, bound) -> (* n <= e or e <= n according to bound *) let loc = e.eloc in let t = overflowed_expr_to_term e in let tn = Logic_const.tint ~loc n in Logic_const.prel ~loc (match bound with Lower_bound -> Rle, tn, t | Upper_bound -> Rle, t, tn) | Float_to_int(e, n, bound) -> (* n < e or e < n according to bound *) let loc = e.eloc in let t = overflowed_expr_to_term e in let n = (match bound with Lower_bound -> Integer.sub | Upper_bound -> Integer.add) n Integer.one in let tn = Logic_const.tint ~loc n in Logic_const.prel ~loc (match bound with Lower_bound -> Rlt, tn, t | Upper_bound -> Rlt, t, tn) | Not_separated(lv1, lv2) -> (* \separated(lv1, lv2) *) let e1 = Cil.mkAddrOf ~loc lv1 in let t1 = Logic_utils.expr_to_term ~cast:true e1 in let e2 = Cil.mkAddrOf ~loc lv2 in let t2 = Logic_utils.expr_to_term ~cast:true e2 in Logic_const.pseparated ~loc [ t1; t2 ] | Overlap(lv1, lv2) -> (* (lv1 == lv2) || \separated(lv1, lv2) *) let e1 = Cil.mkAddrOf ~loc lv1 in let t1 = Logic_utils.expr_to_term ~cast:true e1 in let e2 = Cil.mkAddrOf ~loc lv2 in let t2 = Logic_utils.expr_to_term ~cast:true e2 in let eq = Logic_const.prel ~loc (Req, t1, t2) in let sep = Logic_const.pseparated ~loc [ t1; t2 ] in Logic_const.por ~loc (eq, sep) | Uninitialized lv -> (* \initialized(lv) *) let e = Cil.mkAddrOrStartOf ~loc lv in let t = Logic_utils.expr_to_term ~cast:false e in Logic_const.pinitialized ~loc (Logic_const.here_label, t) | Is_nan_or_infinite (e, fkind) -> (* \is_finite((fkind)e) *) let loc = e.eloc in let t = Logic_utils.expr_to_term ~cast:true e in let typ = match fkind with | FFloat -> Cil.floatType | FDouble -> Cil.doubleType | FLongDouble -> Cil.longDoubleType in let t = Logic_utils.mk_cast ~loc typ t in (* Different signatures, depending on the type of the argument *) let all_is_finite = Logic_env.find_all_logic_functions "\\is_finite" in let compatible li = Logic_type.equal t.term_type (List.hd li.l_profile).lv_type in let pi = try List.find compatible all_is_finite with Not_found -> Kernel.fatal "Unexpected type %a for predicate \\is_finite" Printer.pp_logic_type t.term_type in Logic_const.unamed ~loc (Papp (pi, [], [ t ])) in let p = aux alarm in assert (p.name = []); { p with name = [ get_name alarm ] } exception Found of (code_annotation * kernel_function * stmt * int) let find_alarm_in_emitters tbl alarm = try Usable_emitter.Hashtbl.iter (fun _ h -> try let triple = D.Hashtbl.find h alarm in raise (Found triple) with Not_found -> ()) tbl; None with Found x -> Some x let register emitter ?kf kinstr ?(loc=Kinstr.loc kinstr) ?status ?(save=true) alarm = (* Kernel.debug "registering alarm %a" D.pretty alarm;*) let add by_emitter alarm = (* Kernel.debug "adding alarm %a" D.pretty alarm;*) let e = Emitter.get emitter in let tbl = try Usable_emitter.Hashtbl.find by_emitter e with Not_found -> let h = D.Hashtbl.create 7 in Usable_emitter.Hashtbl.add by_emitter e h; h in let pred = create_predicate ~loc alarm in let annot = Logic_const.new_code_annotation (AAssert([], pred)) in if save then add_annotation tbl alarm emitter ?kf kinstr annot status; annot in try let by_emitter = State.find kinstr in match find_alarm_in_emitters by_emitter alarm with | None -> (* somes alarms already associated to this [kinstr], but not this [alarm] *) add by_emitter alarm, true | Some (annot, kf, stmt, _) -> (* this alarm was already emitted *) Extlib.may (emit_status emitter kf stmt annot) status; annot, false with Not_found -> (* no alarm associated to this [kinstr] *) let by_emitter = Usable_emitter.Hashtbl.create 7 in State.add kinstr by_emitter; add by_emitter alarm, true let iter f = State.iter (fun _ by_emitter -> Usable_emitter.Hashtbl.iter (fun e h -> D.Hashtbl.iter (fun alarm (annot, kf, stmt, rank) -> f (Usable_emitter.get e) kf stmt ~rank alarm annot) h) by_emitter) let fold f = State.fold (fun _ by_emitter acc -> Usable_emitter.Hashtbl.fold (fun e h acc -> D.Hashtbl.fold (fun alarm (annot, kf, stmt, rank) acc -> f (Usable_emitter.get e) kf stmt ~rank alarm annot acc) h acc) by_emitter acc) let find annot = try Some (Alarm_of_annot.find annot) with Not_found -> None let unsafe_remove ?filter ?kinstr e = let usable_e = Emitter.get e in let remove also_alarm by_emitter = try let tbl = Usable_emitter.Hashtbl.find by_emitter usable_e in let to_be_removed = D.Hashtbl.create 7 in let stmt_ref = ref Cil.dummyStmt in let extend_del a (annot, _, stmt, _ as t) = D.Hashtbl.add to_be_removed a t; Alarm_of_annot.remove annot; stmt_ref := stmt in D.Hashtbl.iter (fun alarm v -> match filter with | Some f when not (f alarm) -> () | _ -> extend_del alarm v) tbl; if also_alarm then begin let remove alarm _ = D.Hashtbl.remove tbl alarm in D.Hashtbl.iter remove to_be_removed; end; (* else the alarm is removed by the global [remove] of [filtered_remove] *) State.apply_hooks_on_remove (Emitter.get e) (Kstmt !stmt_ref) to_be_removed with Not_found -> () in let filtered_remove tbl = match filter with | None -> remove false tbl; Usable_emitter.Hashtbl.remove tbl usable_e | Some _ -> remove true tbl in match kinstr with | None -> State.iter (fun _ by_emitter -> filtered_remove by_emitter) | Some ki -> try let by_emitter = State.find ki in filtered_remove by_emitter with Not_found -> () let remove ?filter ?kinstr e = must_remove_annot := true; unsafe_remove ?filter ?kinstr e let () = Annotations.remove_alarm_ref := (fun e stmt annot -> try let a = Alarm_of_annot.find annot in must_remove_annot := false; (* [JS 2013/01/09] could be more efficient but seems we only consider the alarms of one statement, it should be enough yet *) let filter a' = a == a' in let kinstr = Kstmt stmt in remove ~filter ~kinstr (Emitter.Usable_emitter.get e) with Not_found -> ()) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/ast_info.mli0000644000175000017500000002065712155630171020364 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** AST manipulation utilities. @plugin development guide *) open Cil_types (* ************************************************************************** *) (** {2 Expressions} *) (* ************************************************************************** *) val is_integral_const: constant -> bool val possible_value_of_integral_const: constant -> Integer.t option val possible_value_of_integral_expr: exp -> Integer.t option val value_of_integral_const: constant -> Integer.t val value_of_integral_expr: exp -> Integer.t val constant_expr: loc:location -> Integer.t -> exp val is_null_expr: exp -> bool val is_non_null_expr: exp -> bool (* ************************************************************************** *) (** {2 Logical terms} *) (* ************************************************************************** *) val is_integral_logic_const: logic_constant -> bool (** @return [true] if the constant has integral type [(integer, char, enum)]. [false] otherwise. @since Oxygen-20120901 *) val possible_value_of_integral_logic_const: logic_constant -> Integer.t option (** @return [Some n] if the constant has integral type [(integer, char, enum)]. [None] otherwise. @since Oxygen-20120901 *) val value_of_integral_logic_const: logic_constant -> Integer.t (** @return the value of the constant. Assume the argument is an integral constant. @since Oxygen-20120901 *) val possible_value_of_integral_term: term -> Integer.t option (** @return [Some n] if the term has integral type [(integer, char, enum)]. [None] Otherwise. @since Oxygen-20120901 *) val term_lvals_of_term: term -> term_lval list (** @return the list of all the term lvals of a given term. Purely syntactic function. *) val is_trivial_predicate: predicate -> bool val is_trivial_named_predicate: predicate named -> bool val is_trivial_annotation: code_annotation -> bool val precondition : funspec -> predicate named (** Builds the precondition from [b_assumes] and [b_requires] clauses. @since Carbon-20101201 *) val behavior_assumes : funbehavior -> predicate named (** Builds the conjonction of the [b_assumes]. @since Nitrogen-20111001 *) val behavior_precondition : funbehavior -> predicate named (** Builds the precondition from [b_assumes] and [b_requires] clauses. @since Carbon-20101201 *) val behavior_postcondition : funbehavior -> termination_kind -> predicate named (** Builds the postcondition from [b_assumes] and [b_post_cond] clauses. @modify Boron-20100401 added termination kind as filtering argument. *) val disjoint_behaviors : funspec -> string list -> predicate named (** Builds the [disjoint_behaviors] property for the behavior names. @since Nitrogen-20111001 *) val complete_behaviors : funspec -> string list -> predicate named (** Builds the [disjoint_behaviors] property for the behavior names. @since Nitrogen-20111001 *) val merge_assigns_from_complete_bhvs: ?warn:bool -> ?ungarded:bool -> funbehavior list -> string list list -> identified_term assigns (** @return the assigns of an unguarded behavior (when [ungarded]=true) or a set of complete behaviors. - the funbehaviors can come from either a statement contract or a function contract. - the list of sets of behavior names can come from the contract of the related function. Optional [warn] argument can be used to force emmiting or cancelation of warnings. @since Oxygen-20120901 *) val merge_assigns_from_spec: ?warn:bool -> funspec -> identified_term assigns (** It is a shortcut for [merge_assigns_from_complete_bhvs spec.spec_complete_behaviors spec.spec_behavior]. Optional [warn] argument can be used to force emmiting or cancelation of warnings @return the assigns of an unguarded behavior or a set of complete behaviors. @since Oxygen-20120901 *) val merge_assigns: ?warn:bool -> funbehavior list -> identified_term assigns (** Returns the assigns of an unguarded behavior. @modify Oxygen-20120901 Optional [warn] argument added which can be used to force emmiting or cancelation of warnings. *) val variable_term: location -> logic_var -> term val constant_term: location -> Integer.t -> term val is_null_term: term -> bool (* ************************************************************************** *) (** {2 Predicates} *) (* ************************************************************************** *) val predicate: location -> predicate -> predicate named (* ************************************************************************** *) (** {2 Statements} *) (* ************************************************************************** *) val is_loop_statement: stmt -> bool val get_sid: kinstr -> int val mkassign: lval -> exp -> location -> instr val mkassign_statement: lval -> exp -> location -> stmt (** determines if a var is local to a block. *) val is_block_local: varinfo -> block -> bool (* ************************************************************************** *) (** {2 Types} *) (* ************************************************************************** *) val array_type: ?length:exp -> ?attr:attributes -> typ -> typ val direct_array_size: typ -> Integer.t val array_size: typ -> Integer.t val direct_element_type: typ -> typ val element_type: typ -> typ val direct_pointed_type: typ -> typ val pointed_type: typ -> typ (* ************************************************************************** *) (** {2 Functions} *) (* ************************************************************************** *) val is_function_type : varinfo -> bool (** Return [true] iff the type of the given varinfo is a function type. *) (** Operations on cil function. *) module Function: sig val formal_args: varinfo -> (string * typ * attributes) list (** Returns the list of the named formal arguments of a function. Never call on a variable of non functional type.*) val is_formal: varinfo -> fundec -> bool val is_local: varinfo -> fundec -> bool val is_formal_or_local: varinfo -> fundec -> bool val is_formal_of_prototype: varinfo (* to check *) -> varinfo (* of the prototype *) -> bool (** [is_formal_of_prototype v f] returns [true] iff [f] is a prototype and [v] is one of its formal parameters. *) val is_definition: cil_function -> bool val get_vi: cil_function -> varinfo val get_name: cil_function -> string val get_id: cil_function -> int end (* ************************************************************************** *) (** {2 Predefined} *) (* ************************************************************************** *) val can_be_cea_function : string -> bool val is_cea_function : string -> bool val is_cea_dump_function : string -> bool val is_cea_dump_file_function : string -> bool val is_frama_c_builtin : string -> bool (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/plugin.mli0000644000175000017500000005206312155630171020054 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Provided plug-general services for plug-ins. @since Beryllium-20090601-beta1 @plugin development guide *) (* ************************************************************************* *) (** {2 Signatures} *) (* ************************************************************************* *) type group = Cmdline.Group.t (** Group of parameters. @since Beryllium-20090901 *) (** Generic signature of a parameter. @plugin development guide *) module type Parameter = sig type t (** Type of the parameter (an int, a string, etc). It is concrete for each module implementing this signature. *) val parameter: Parameter.t (** @since Nitrogen-20111001 *) val set: t -> unit (** Set the option. *) val add_set_hook: (t -> t -> unit) -> unit (** Add a hook to be called whenafter the function {!set} is called. The first parameter of the hook is the old value of the parameter while the second one is the new value. *) val add_update_hook: (t -> t -> unit) -> unit (** Add a hook to be called when the value of the parameter changes (by calling {!set} or indirectly by the project library. The first parameter of the hook is the old value of the parameter while the second one is the new value. Note that it is **not** specified if the hook is applied just before or just after the effective change. @since Nitrogen-20111001 *) val get: unit -> t (** Option value (not necessarly set on the current command line). *) val clear: unit -> unit (** Set the option to its default value, that is the value if [set] was never called. *) val is_default: unit -> bool (** Is the option equal to its default value? *) val option_name: string (** Name of the option on the command-line @since Carbon-20110201 *) val print_help: Format.formatter -> unit (** Print the help of the parameter in the given formatter as it would be printed on the command line by --help. For invisible parameters, the string corresponds to the one returned if it would be not invisible. @since Oxygen-20120901 *) include State_builder.S val equal: t -> t -> bool val add_aliases: string list -> unit (** Add some aliases for this option. That is other option names which have exactly the same semantics that the initial option. @raise Invalid_argument if one of the strings is empty *) val add_alias: string list -> unit (** Equivalent to [add_aliases]. @deprecated since Carbon-20110201 *) (**/**) val is_set: unit -> bool (** Is the function {!set} has already been called since the last call to function {!clear}? This function is for special uses and should mostly never be used. *) val unsafe_set: t -> unit (** Set but without clearing the dependencies.*) (**/**) end (** Signature for a boolean parameter. @plugin development guide *) module type Bool = sig include Parameter with type t = bool val on: unit -> unit (** Set the boolean to [true]. *) val off: unit -> unit (** Set the boolean to [false]. *) end (** Signature for a boolean parameter that causes something to be output. *) module type WithOutput = sig include Bool val set_output_dependencies: State.t list -> unit (** Set the dependencies for the output of the option. Two successive calls to [output] below will cause only one output, unless some of the supplied dependencies have changed between the two calls. *) val output: (unit -> unit) -> unit (** To be used by the plugin to output the results of the option in a controlled way. See [set_output_dependencies] details. *) end (** Signature for an integer parameter. @plugin development guide *) module type Int = sig include Parameter with type t = int val incr: unit -> unit (** Increment the integer. *) val set_range: min:int -> max:int -> unit (** Set what is the possible range of values for this parameter. @since Beryllium-20090901 *) val get_range: unit -> int * int (** What is the possible range of values for this parameter. @since Beryllium-20090901 *) end (** Signature for a string parameter. *) module type String = sig include Parameter with type t = string val set_possible_values: string list -> unit (** Set what are the acceptable values for this parameter. If the given list is empty, then all values are acceptable. @since Beryllium-20090901 *) val get_possible_values: unit -> string list (** What are the acceptable values for this parameter. If the returned list is empty, then all values are acceptable. @since Beryllium-20090901 *) end (** Signature for a generic set of strings option. *) module type String_collection = sig include Parameter val add: string -> unit (** Add a string to the string set option. *) val remove: string -> unit (** Remove a string from the option. *) val is_empty: unit -> bool (** Check if the set is empty. *) val get_set: ?sep:string -> unit -> string (** Get a string which concatenates each string in the set with a separator. The default separator is ", ". *) val iter: (string -> unit) -> unit (** Iter on each string in the set. *) val fold: (string -> 'a -> 'a) -> 'a -> 'a (** Fold on each string in the set. @since Oxygen-20120901 *) val exists: (string -> bool) -> bool (** Checks if at least one element of the set satisfies the predicate. @since Carbon-20101201 *) val set_possible_values: string list -> unit (** Set what are the acceptable values for this parameter. If the given list is empty, then all values are acceptable. @since Oxygen-20120901 *) val get_possible_values: unit -> string list (** What are the acceptable values for this parameter. If the returned list is empty, then all values are acceptable. @since Oxygen-20120901 *) end (** @plugin development guide *) module type String_set = String_collection with type t = Datatype.String.Set.t module type String_list = String_collection with type t = string list (** @since Boron-20100401 *) module type String_hashtbl = sig include String_collection with type t = Datatype.String.Set.t type value (** @since Boron-20100401 *) val find: string -> value (** @since Boron-20100401 *) end (** {3 Complex values indexed by strings} *) (** option interface *) module type Indexed_val = sig include String type value (** the real type for the option*) val add_choice: string -> value -> unit (** adds a new choice for the option. *) val get_val: unit -> value (** the currently selected value. *) end (** Minimal signature to implement for each parameter corresponding to an option on the command line argument. *) module type Parameter_input = sig val option_name: string (** The name of the option *) val help: string (** A description for this option (e.g. used by -help). If [help = ""], then it has the special meaning "undocumented" *) end (** Minimal signature to implement for each parameter corresponding to an option on the command line argument which requires an argument. *) module type Parameter_input_with_arg = sig include Parameter_input val arg_name: string (** A standard name for the argument which may be used in the description. If empty, a generic arg_name is generated. *) end (** input signature for [IndexedVal] *) module type Indexed_val_input = sig include Parameter_input_with_arg type t (** the type to be serialized *) val default_val: t (** the default value *) val default_key: string (** the default index *) val ty: t Type.t end module type S = sig include Log.Messages val add_group: ?memo:bool -> string -> group (** Create a new group inside the plug-in. The given string must be different of all the other group names of this plug-in if [memo] is [false]. If [memo] is [true] the function will either create a fresh group or return an existing group of the same name in the same plugin. [memo] defaults to [false] @since Beryllium-20090901 *) module Help: Bool (** @deprecated since Oxygen-20120901 *) module Verbose: Int module Debug: Int module Debug_category: String_set (** prints debug messages having the corresponding key. @since Oxygen-20120901 @modify Fluorine-20130401 Set instead of list *) (** Handle the specific `share' directory of the plug-in. @since Oxygen-20120901 *) module Share: sig exception No_dir val dir: ?error:bool -> unit -> string (** [share_dir ~error ()] returns the share directory of the plug-in, if any. Otherwise, Frama-C halts on an user error if [error] orelse it raises [No_dir]. Default of [error] is [true]. @raise No_dir if there is no share directory for this plug-in and [not error]. *) val file: ?error:bool -> string -> string (** [share_file basename] returns the complete filename of a file stored in the plug-in' share directory. If there is no such directory, Frama-C halts on an user error if [error] orelse it raises [No_dir]. Default of [error] is [true]. @raise No_dir if there is no share directory for this plug-in and [not error]. *) end val help: group (** The group containing option -*-help. @since Boron-20100401 *) val messages: group (** The group containing options -*-debug and -*-verbose. @since Boron-20100401 *) val parameters: unit -> Parameter.t list (** List of parameters created by this plug-in. @since Nitrogen-20111001 *) end type plugin = private { p_name: string; p_shortname: string; p_help: string; p_parameters: (string, Parameter.t list) Hashtbl.t } (** Only iterable parameters (see {!do_iterate} and {!do_not_iterate}) are registered in the field [p_parameters]. @since Beryllium-20090901 *) (** @plugin development guide *) module type General_services = sig include S (** {2 Functors for generating a new parameter} *) module Bool (X:sig include Parameter_input val default: bool (** The default value of the parameter. So giving the option [option_name] to Frama-C, change the value of the parameter to [not default]. *) end) : Bool (** Build a boolean option initialized fo [false], that is not saved. *) module Action(X: Parameter_input) : Bool (** Build a boolean option initialized to [false]. @plugin development guide *) module False(X: Parameter_input) : Bool (** Build a boolean option initialized to [true]. @plugin development guide *) module True(X: Parameter_input) : Bool (** Build a boolean option initialized to [false]. The returned [output] function must be used to display the results of this option. The results will be displayed if [X.output_by_default] is [true], or if option [-foo-print] is given by the user (where [foo] is [X.option_name]). @since Nitrogen-20111001 *) module WithOutput (X: sig include Parameter_input val output_by_default: bool end) : WithOutput (** Build an integer option. @plugin development guide *) module Int (X: sig val default: int include Parameter_input_with_arg end) : Int (** Build an integer option initialized to [0]. @plugin development guide *) module Zero(X:Parameter_input_with_arg) : Int (** Build a string option. @plugin development guide *) module String (X: sig include Parameter_input_with_arg val default: string end) : String (** Build a string option initialized to [""]. *) module EmptyString(X: Parameter_input_with_arg) : String (** Build an option as a set of strings, initialized to the empty set. @plugin development guide *) module StringSet(X: Parameter_input_with_arg) : String_set (** Build an option as a set of strings, initialized with the given values. *) module FilledStringSet (X: sig include Parameter_input_with_arg val default: Datatype.String.Set.t end) : String_set module StringList(X: Parameter_input_with_arg) : String_list module IndexedVal (V:Indexed_val_input) : Indexed_val with type value = V.t (** Should not be used by casual users. Build an option as a hashtable whose keys are string. The provided [parse] function tells how to parser the (key,value) pair. @since Boron-20100401 *) module StringHashtbl (X: Parameter_input_with_arg) (V: sig include Datatype.S val parse: string -> string * t (** @since Oxygen-20120901 *) val redefine_binding: string -> old:t -> t -> t val no_binding: string -> t end) : String_hashtbl with type value = V.t end (* ************************************************************************* *) (** {2 Configuration of functor applications generating parameters} You can apply the below functions juste before applying one of the functors provided by the functor [Register] and generating a new parameter. *) (* ************************************************************************* *) val set_cmdline_stage: Cmdline.stage -> unit (** Set the stage where the option corresponding to the parameter is recognized. Default is [Cmdline.Configuring]. @since Beryllium-20090601-beta1 *) val do_not_journalize: unit -> unit (** Prevent journalization of the parameter. @since Beryllium-20090601-beta1 *) val do_not_projectify: unit -> unit (** Prevent projectification of the parameter: its state is shared by all the existing projects. Also imply {!do_not_save}. @since Beryllium-20090601-beta1 *) val do_not_save: unit -> unit (** Prevent serialization of the parameter. @since Carbon-20110201 *) val set_negative_option_name: string -> unit (** For boolean parameters, set the name of the negative option generating automatically from the positive one (the given option name). The default used value prefixes the given option name by "-no". Assume that the given string is a valid option name or empty. If it is empty, no negative option is created. @since Beryllium-20090601-beta1 @plugin development guide *) val set_negative_option_help: string -> unit (** For boolean parameters, set the help message of the negative option generating automatically. Assume that the given string is non empty. @since Beryllium-20090601-beta1 *) val set_unset_option_name: string -> unit (** For string collection parameters, set the name of an option that will remove elements from the set. There is no default value: if the this function is not called (or if it is the empty string), it will only be possible to add elements from the command line. @since Fluorine-20130401 *) val set_unset_option_help: string -> unit (** For string collection parameters, gives the help message for the corresponding unset option. Useless if [set_unset_option_name] has not been called before. No default. @since Fluorine-20130401 *) val set_optional_help: (unit, Format.formatter, unit) format -> unit (** Concatenate an additional description just after the default one. @since Beryllium-20090601-beta1 @deprecated since Oxygen-20120901: directly use the help string instead. *) val set_group: group -> unit (** Affect a group to the parameter. @since Beryllium-20090901 *) val is_invisible: unit -> unit (** Prevent the help to list the parameter. Also imply {!do_not_iterate}. @since Carbon-20101201 @modify Nitrogen-20111001 does not appear in the help *) val argument_is_function_name: unit -> unit (** Indicate that the string argument of the parameter must be a valid function name (or a set of valid function names). A valid function name is the name of a function defined in the analysed C program. Do nothing if the following applied functor has type [String], [String_set] or [String_list]. @since Oxygen-20120901 *) val do_iterate: unit -> unit (** Ensure that {!iter_on_plugins} is applied to this parameter. By default only parameters corresponding to options registered at the {!Cmdline.Configuring} stage are iterable. @since Nitrogen-20111001 *) val do_not_iterate: unit -> unit (** Prevent {!iter_on_plugins} to be applied on the parameter. By default, only parameters corresponding to options registered at the {!Cmdline.Configuring} stage are iterable. @since Nitrogen-20111001 *) (**/**) val register_kernel: unit -> unit (** Begin to register parameters of the kernel. Not for casual users. @since Beryllium-20090601-beta1 *) val set_module_name: string -> unit (** For **kernel** parameters, set the name of the module name corresponding to the parameter. Not for casual users. *) (**/**) (** Functors for registering a new plug-in. It provides access to several services. @plugin development guide *) module Register (P: sig val name: string (** Name of the module. Arbitrary non-empty string. *) val shortname: string (** Prefix for plugin options. No space allowed. *) val help: string (** description of the module. Free-form text. *) end) : General_services val is_share_visible: unit -> unit (** Made visible to the end-user the --share option. To be called just before applying {!Register} to create plug-in services. @since Oxygen-20120901 *) (* ************************************************************************* *) (** {2 Handling groups of parameters} *) (* ************************************************************************* *) val get_from_shortname: string -> plugin (** Get a plug-in from its shortname. @since Oxygen-20120901 *) val get_from_name: string -> plugin (** Get a plug-in from its name. @since Oxygen-20120901 *) val get: string -> plugin (** Get a plug-in from its name. @deprecated since Oxygen-20120901 *) val iter_on_plugins: (plugin -> unit) -> unit (** Iterate on each registered plug-ins. @since Beryllium-20090901 *) val get_selection: ?is_set:bool -> unit -> State_selection.t (** Selection of all the settable parameters. [is_set] is [true] by default (for backward compatibility): in such a case, for each option, the extra internal state indicating whether it is set also belongs to the selection. @plugin development guide *) val get_selection_context: ?is_set:bool -> unit -> State_selection.t (** Selection of all the parameters which may have an impact on some analysis. *) (* ************************************************************************* *) (** {2 Deprecated API} *) (* ************************************************************************* *) val at_normal_exit: (unit -> unit) -> unit (** Now replaced by {!Cmdline.at_normal_exit}. @since Beryllium-20090901 @deprecated since Boron-20100401 *) val run_normal_exit_hook: unit -> unit (** Now replaced by {!Cmdline.run_normal_exit_hook}. @since Beryllium-20090901 @deprecated since Boron-20100401 *) (**/**) (* ************************************************************************* *) (** {2 Internal kernel stuff} *) (* ************************************************************************* *) val positive_debug_ref: int ref (** @since Boron-20100401 *) val set_function_names: (unit -> string list) -> unit (** @since Oxygen-20120901 *) val set_ast_hook: ((Cil_types.file -> unit) -> unit) -> unit (** @since Oxygen-20120901 *) val init_ast_hooks: (Cil_types.file -> unit) list ref (** @since Oxygen-20120901 *) (**/**) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/task.ml0000644000175000017500000003633112155630171017347 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let dkey = Kernel.register_category "task" (* -------------------------------------------------------------------------- *) (* --- Error Messages --- *) (* -------------------------------------------------------------------------- *) let error = function | Failure msg -> msg | Sys_error msg -> msg | Unix.Unix_error(e,_,"") -> Unix.error_message e | Unix.Unix_error(e,_,p) -> Printf.sprintf "%s (%s)" (Unix.error_message e) p | exn -> Printexc.to_string exn (* ------------------------------------------------------------------------ *) (* --- High Level Interface to Command --- *) (* ------------------------------------------------------------------------ *) type 'a status = | Timeout | Canceled | Result of 'a | Failed of exn let map f = function | Timeout -> Timeout | Canceled -> Canceled | Result x -> Result (f x) | Failed e -> Failed e let pretty pp fmt = function | Timeout -> Format.pp_print_string fmt "timeout" | Canceled -> Format.pp_print_string fmt "canceled" | Result x -> Format.fprintf fmt "result %a" pp x | Failed (Failure msg) -> Format.fprintf fmt "failed (%s)" msg | Failed e -> Format.fprintf fmt "failed (%s)" (Printexc.to_string e) let protect f arg on_fail = try f arg with e -> if Kernel.debug_atleast 1 then begin Kernel.debug ~dkey "Current task raised an exception:@\n%s@\n%s" (Printexc.to_string e) (Printexc.get_backtrace ()) end; on_fail (Failed e) type 'a ping = | DONE of 'a status | RUN of (unit -> unit) | NEXT of (unit -> unit) * (unit -> 'a ping) type 'a pinger = unit -> 'a ping type 'a running = | Waiting | Running of (unit -> unit) | Finished of 'a status module Monad : sig type 'a t val return : 'a status -> 'a t val bind : 'a t -> ('a status -> 'b t) -> 'b t val running : 'a pinger -> 'a t val waiting : (unit -> 'b pinger) -> 'b t val state : 'a t -> 'a running val execute : 'a t -> 'a status option val start : 'a t -> unit val cancel : 'a t -> unit end = struct type 'a process = | Wait of (unit -> 'a pinger) | Ping of 'a pinger | Done of 'a status type 'a t = 'a process ref let finished e = DONE e let pinger e () = DONE e let return r = ref (Done r) let waiting starter = ref (Wait starter) let running pinger = ref (Ping pinger) let run task p = let ping = protect p () finished in match ping with | DONE r -> task := Done r ; ping | NEXT(_,f) -> task := Ping f ; ping | RUN _ -> ping let state_of_ping = function DONE r -> Finished r | NEXT(k,_) | RUN k -> Running k let result_of_ping = function DONE r -> Some r | NEXT _ | RUN _ -> None let state task = match !task with | Wait _ -> Waiting | Done r -> Finished r | Ping p -> state_of_ping (run task p) let start task = match !task with | Wait s -> let f = protect s () pinger in task := Ping f ; ignore (run task f) | Ping f -> ignore (run task f) | Done _ -> () let execute task = match !task with | Wait s -> let f = protect s () pinger in task := Ping f ; result_of_ping (run task f) | Ping f -> result_of_ping (run task f) | Done r -> Some r let cancel task = match state task with | Waiting -> task := Done Canceled | Running kill -> begin protect (fun () -> task := Done Canceled ; kill ()) () (fun st -> task := Done st) end | Finished _ -> () let get_pinger task = match !task with | Done r -> pinger r | Wait s -> protect s () pinger | Ping f -> f let next_ping s k = let b = protect k s return in let kill = fun () -> cancel b in let ping = get_pinger b in NEXT(kill,ping) let next_pinger s k () = next_ping s k let rec bind_pinger f k () = match f () with | DONE s -> next_ping s k | NEXT(kill,f') -> NEXT(kill,bind_pinger f' k) | RUN kill -> RUN kill let bind_waiter s k () = bind_pinger (protect s () pinger) k let bind a k = match !a with | Wait s -> ref (Wait(bind_waiter s k)) | Ping f -> ref (Ping(bind_pinger f k)) | Done s -> ref (Ping(next_pinger s k)) end type 'a task = 'a Monad.t (* ------------------------------------------------------------------------ *) (* --- Monadic Constructors --- *) (* ------------------------------------------------------------------------ *) let status = Monad.return let return r = Monad.return (Result r) let raised e = Monad.return (Failed e) let canceled () = Monad.return Canceled let failed text = let buffer = Buffer.create 80 in Format.kfprintf (fun fmt -> Format.pp_print_flush fmt () ; Monad.return (Failed(Failure (Buffer.contents buffer)))) (Format.formatter_of_buffer buffer) text let bind a k = Monad.bind a (function | Canceled -> Monad.return Canceled | s -> k s) let sequence a k = Monad.bind a (function | Result r -> k r | Failed e -> Monad.return (Failed e) | Timeout -> Monad.return Timeout | Canceled -> Monad.return Canceled) let nop = Monad.return (Result()) let call f x = Monad.running (fun () -> DONE (Result(f x))) let todo f = sequence nop f let job job = sequence job (fun _ -> nop) let finally t cb = Monad.bind t (fun s -> cb s ; Monad.return s) let callback t cb = Monad.bind t (fun s -> cb s ; nop) let (>>>) = Monad.bind let (>>=) = sequence let (>>?) = finally let (>>!) = callback (* ------------------------------------------------------------------------ *) (* --- Critical Sections --- *) (* ------------------------------------------------------------------------ *) type mutex = bool ref let mutex () = ref false let wait = RUN (fun () -> ()) let next = DONE (Result ()) let lock m = Monad.running (fun () -> if !m then wait else (m:=true ; next)) let unlock m = if not !m then Kernel.failure "Suspiscious lock" ; m := false let sync m t = lock m >>= t >>? fun _ -> unlock m (* ------------------------------------------------------------------------ *) (* --- Run Operations --- *) (* ------------------------------------------------------------------------ *) let start = Monad.start let ping = Monad.state let cancel = Monad.cancel let rec wait task = (try !Db.progress () with Db.Cancel -> Monad.cancel task) ; match Monad.state task with | Finished r -> r | _ -> Unix.sleep 1 ; wait task (* ------------------------------------------------------------------------ *) (* --- System Commands --- *) (* ------------------------------------------------------------------------ *) type cmd = { name : string ; timed : bool ; timeout : int ; time_start : float ; time_stop : float ; chrono : float ref option ; async : (unit -> Command.process_result) ; } let set_chrono cmd = match cmd.chrono with | None -> () | Some r -> r := max !r (Unix.time () -. cmd.time_start) let set_time cmd t = match cmd.chrono with | None -> () | Some r -> r := max !r t let start_command ~timeout ?time ?stdout ?stderr cmd args = begin Kernel.debug ~dkey "execute task '@[%t'@]" (fun fmt -> Format.pp_print_string fmt cmd ; Array.iter (fun c -> Format.fprintf fmt "@ %s" c) args) ; let timed = timeout > 0 || time <> None in let time_start = if timed then Unix.time () else 0.0 in let time_stop = if timeout > 0 then time_start +. float_of_int timeout else 0.0 in let async = Command.command_async ?stdout ?stderr cmd args in { name = cmd ; timed = timed ; timeout = timeout ; time_start = time_start ; time_stop = time_stop ; chrono = time ; async = async ; } end let ping_command cmd () = try match cmd.async () with | Command.Not_ready kill -> let time_now = if cmd.timed then Unix.time () else 0.0 in if cmd.timeout > 0 && time_now > cmd.time_stop then begin set_time cmd (time_now -. cmd.time_start) ; Kernel.debug ~dkey "timeout '%s'" cmd.name ; kill () ; DONE Timeout end else RUN kill | Command.Result (Unix.WEXITED s) -> set_chrono cmd ; Kernel.debug ~dkey "exit '%s' [%d]" cmd.name s ; DONE (Result s) | Command.Result (Unix.WSIGNALED s|Unix.WSTOPPED s) -> set_chrono cmd ; Kernel.debug ~dkey "signal '%s' [%d]" cmd.name s ; let err = Failure (Printf.sprintf "Unix.SIGNAL %d" s) in DONE (Failed err) with e -> set_chrono cmd ; Kernel.debug ~dkey "failure '%s' [%s]" cmd.name (Printexc.to_string e) ; DONE (Failed e) let command ?(timeout=0) ?time ?stdout ?stderr cmd args = Monad.waiting begin fun () -> ping_command (start_command ~timeout ?time ?stdout ?stderr cmd args) end (* ------------------------------------------------------------------------ *) (* --- Shared Tasks --- *) (* ------------------------------------------------------------------------ *) module Shared : sig type 'a t val make : descr:string -> retry:bool -> (unit -> 'a task) -> 'a t val share : 'a t -> 'a task end = struct type 'a t = { descr : string ; retry : bool ; builder : unit -> 'a task ; mutable running : 'a task option ; mutable clients : int ; } let make ~descr ~retry cc = { descr=descr ; retry=retry ; builder=cc ; running=None ; clients=0 } let kill s () = Kernel.debug ~dkey "Cancel instance of task '%s' (over %d)" s.descr s.clients ; if s.clients > 0 then begin s.clients <- pred s.clients ; if s.clients = 0 then match s.running with | Some k -> Kernel.debug ~dkey "Kill shared task '%s'" s.descr ; Monad.cancel k ; s.running <- None | None -> () end let ping s () = let task = match s.running with | None -> let t = protect s.builder () Monad.return in s.running <- Some t ; t | Some t -> t in match Monad.execute task with | None -> RUN (kill s) | Some r -> let release = match r with | Result _ -> false | Failed _ -> s.retry | Timeout | Canceled -> true in if release then s.running <- None ; (DONE r : 'a ping) let share s = s.clients <- succ s.clients ; Kernel.debug ~dkey "New instance of task '%s' (%d)" s.descr s.clients ; Monad.waiting (fun () -> ping s) end type 'a shared = 'a Shared.t let shared = Shared.make let share = Shared.share (* ------------------------------------------------------------------------ *) (* --- Server --- *) (* ------------------------------------------------------------------------ *) type callbacks = (unit -> unit) list (* Invariant: terminated + (length running) + Sum ( length queue.(i) ) == scheduled *) type server = { queue : unit task Queue.t array ; mutable scheduled : int ; mutable terminated : int ; mutable running : unit task list ; mutable procs : int ; mutable activity : callbacks ; mutable start : callbacks ; mutable stop : callbacks ; } let fire callbacks = List.iter (fun f -> protect f () (fun _ -> ())) callbacks let server ?(stages=1) ?(procs=4) () = { queue = Array.init stages (fun _ -> Queue.create ()) ; running = [] ; procs = procs ; scheduled = 0 ; terminated = 0 ; activity = [] ; start = [] ; stop = [] ; } let on_idle = ref (fun f -> try while f () do Extlib.usleep 50000 (* wait for 50ms *) done with Db.Cancel -> ()) let set_procs s p = s.procs <- p let on_server_activity s cb = s.activity <- s.activity @ [cb] let on_server_start s cb = s.start <- s.start @ [cb] let on_server_stop s cb = s.stop <- s.stop @ [cb] let cancel_all server = begin Array.iter (Queue.iter cancel) server.queue ; List.iter cancel server.running ; end let spawn server ?(stage=0) task = begin Queue.push task server.queue.(stage) ; (* queue(i) ++ *) server.scheduled <- succ server.scheduled ; (* scheduled ++ *) end (* invariant holds *) let scheduled s = s.scheduled let terminated s = s.terminated let alive task = match Monad.state task with | Waiting -> true | Running _ -> true | Finished _ -> false let running task = match Monad.execute task with | Some _ -> false | None -> true let schedule server q = try while List.length server.running < server.procs do let task = Queue.take q in (* queue ++ *) if running task then server.running <- task :: server.running (* running++ => invariant holds *) else server.terminated <- succ server.terminated (* terminated++ => invariant holds *) done with Queue.Empty -> () let rec run_server server () = begin server.running <- List.filter (fun task -> if alive task then true else ( (* running -- ; terminated ++ => invariant preserved *) server.terminated <- succ server.terminated ; false ) ) server.running ; Array.iter (schedule server) server.queue ; try !Db.progress () ; fire server.activity ; if server.running <> [] then true else begin fire server.stop ; server.scheduled <- 0 ; server.terminated <- 0 ; false end with _ -> (* Db.Cancel ... *) cancel_all server ; run_server server () end let launch server = if server.scheduled > server.terminated then ( fire server.start ; !on_idle (run_server server) ) let run t = !on_idle (fun () -> running t) frama-c-Fluorine-20130601/src/kernel/cmdline.mli0000644000175000017500000002624312155630171020172 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Command line parsing. @plugin development guide *) (** {2 Stage configurations} Frama-C uses several stages for parsing its command line. Each of them may be customized. *) type stage = | Early (** @plugin development guide *) | Extending (** @plugin development guide *) | Extended (** @plugin development guide *) | Exiting (** @plugin development guide *) | Loading (** @plugin development guide *) | Configuring (** @plugin development guide *) (** The different stages, from the first to be executed to the last one. @since Beryllium-20090601-beta1 *) val run_after_early_stage: (unit -> unit) -> unit (** Register an action to be executed at the end of the early stage. @plugin development guide @since Beryllium-20090901 *) val run_during_extending_stage: (unit -> unit) -> unit (** Register an action to be executed during the extending stage. @plugin development guide @since Beryllium-20090901 *) val run_after_extended_stage: (unit -> unit) -> unit (** Register an action to be executed at the end of the extended stage. @plugin development guide @since Beryllium-20090901 *) type exit (** @since Beryllium-20090901 *) val nop : exit (** @since Beryllium-20090901 @plugin development guide *) exception Exit (** @since Beryllium-20090901 @plugin development guide *) val run_after_exiting_stage: (unit -> exit) -> unit (** Register an action to be executed at the end of the exiting stage. The guarded action must finish by [exit n]. @plugin development guide @since Beryllium-20090601-beta1 *) val run_after_loading_stage: (unit -> unit) -> unit (** Register an action to be executed at the end of the loading stage. @plugin development guide @since Beryllium-20090601-beta1 *) val is_going_to_load: unit -> unit (** To be call if one action is going to run after the loading stage. It is not necessary to call this function if the running action is set by an option put on the command line. @since Beryllium-20090601-beta1 @plugin development guide *) val run_after_configuring_stage: (unit -> unit) -> unit (** Register an action to be executed at the end of the configuring stage. @plugin development guide @since Beryllium-20090601-beta1 *) val run_after_setting_files: (string list -> unit) -> unit (** Register an action to be executed just after setting the files put on the command line. The argument of the function is the list of files. @plugin development guide @since Carbon-20101201 *) val protect: exn -> string (** Messages for exceptions raised by Frama-C @since Boron-20100401 *) val catch_at_toplevel: exn -> bool (** @since Boron-20100401 *) val catch_toplevel_run: f:(unit -> unit) -> quit:bool -> at_normal_exit:(unit -> unit) -> on_error:(unit -> unit) -> unit (** Run [f]. When done, either call [at_normal_exit] if running [f] was ok; or call [on_error] in other cases. Set [quit] to [true] iff Frama-C must stop after running [f]. @modify Boron-20100401 additional arguments. They are now labelled *) val at_normal_exit: (unit -> unit) -> unit (** Register a hook executed whenever Frama-C exits without error (the exit code is 0). @since Boron-20100401 *) val run_normal_exit_hook: unit -> unit (** Run all the hooks registered by {!at_normal_exit}. @since Boron-20100401 *) val at_error_exit: (unit -> unit) -> unit (** Register a hook executed whenever Frama-C exits with error (the exit code is greater than 0). @since Boron-20100401 *) val run_error_exit_hook: unit -> unit (** Run all the hooks registered by {!at_normal_exit}. @since Boron-20100401 *) val error_occured: unit -> unit (** Remember that an error occured. So {!run_error_exit_hook} will be called when Frama-C will exit. @since Boron-20100401 *) val bail_out: unit -> 'a (** Stop Frama-C with exit 0. @since Boron-20100401 *) (** {2 Special functions} These functions should not be used by a standard plug-in developer. *) val parse_and_boot: (string option -> (unit -> unit) -> unit) -> (unit -> (unit -> unit) -> unit) -> (unit -> unit) -> unit (** Not for casual users. [parse_and_boot on_from_name get_toplevel play] performs the parsing of the command line, then play the analysis with the good toplevel provided by [get_toplevel]. [on_from_name] is [Project.on] on the project corresponding to the given (unique) name (or the default project if [None]). @since Beryllium-20090901 @modify Carbon-20101201 *) val nb_given_options: unit -> int (** Number of options provided by the user on the command line. Should not be called before the end of the command line parsing. @since Beryllium-20090601-beta1 *) val use_cmdline_files: (string list -> unit) -> unit (** What to do with the list of files put on the command lines. @since Beryllium-20090601-beta1 *) (** @since Beryllium-20090901 *) module Group : sig type t (** @since Beryllium-20090901 *) val default: t (** @since Beryllium-20090901 *) val add: ?memo:bool -> plugin:string -> string -> t * bool (** Add a new group of options to the given plugin. If [memo] is [true], just return the already registered group if any. If [memo] is [false], cannot add twice a group with the same name. @return the group corresponding to the given name. Also return [true] iff the group has just been created. @since Beryllium-20090901 *) val name: t -> string (** @since Beryllium-20090901 *) end val help: unit -> exit (** Display the help of Frama-C @since Beryllium-20090601-beta1 *) val plugin_help: string -> exit (** Display the help of the given plug-in (given by its shortname). @since Beryllium-20090601-beta1 *) val print_option_help: Format.formatter -> plugin:string -> group:Group.t -> string -> unit (** Pretty print the help of the option (given by its plug-in, its group and its name) in the provided formatter. @since Oxygen-20120901 *) val add_plugin: ?short:string -> string -> help:string -> unit (** [add_plugin ~short name ~help] adds a new plug-in recognized by the command line of Frama-C. If the shortname is not specified, then the name is used as the shortname. By convention, if the name and the shortname are equal to "", then the register "plug-in" is the Frama-C kernel itself. @raise Invalid_argument if the same shortname is registered twice @since Beryllium-20090601-beta1 *) (** @since Beryllium-20090601-beta1 *) type option_setting = | Unit of (unit -> unit) | Int of (int -> unit) | String of (string -> unit) | String_list of (string list -> unit) val add_option: string -> plugin:string -> group:Group.t -> stage -> ?argname:string -> help:string -> visible:bool -> ext_help:(unit,Format.formatter,unit) format -> option_setting -> unit (** [add_option name ~plugin stage ~argname ~help setting] adds a new option of the given [name] recognized by the command line of Frama-C. If the [name] is the empty string, nothing is done. [plugin] is the shortname of the plug-in. [argname] is the name of the argument which can be used of the description [help]. Both of them are used by the help of the registered option. If [help] is [None], then the option is not shown in the help. @since Beryllium-20090601-beta1 @modify Carbon-20101201 @modify Oxygen-20120901 change type of ~help and add ~visible. *) val add_option_without_action: string -> plugin:string -> group:Group.t -> ?argname:string -> help:string -> visible:bool -> ext_help:(unit,Format.formatter,unit) format -> unit -> unit (** Equivalent to [add_option] without option setting. Thus do not add the option to any stage of the command line... Thus should not be used by casual users ;-). @since Carbon-20101201 *) val add_aliases: string -> plugin:string -> group:Group.t -> stage -> string list -> unit (** [add_aliases orig plugin group aliases] adds a list of aliases to the given option name [orig]. @Invalid_argument if an alias name is the empty string @since Carbon-20110201 *) (** {2 Special parameters} Frama-c parameters depending on the command line argument and set at the very beginning of the Frama-C initialisation. They should not be used directly by a standard plug-in developer. *) (** @since Fluorine-20130401 *) module type Level = sig val value_if_set: int option ref val get: unit -> int val set: int -> unit end module Debug_level: Level (** @since Fluorine-20130401 *) module Verbose_level: Level (** @since Fluorine-20130401 *) module Kernel_debug_level: Level (** @since Fluorine-20130401 *) module Kernel_verbose_level: Level (** @since Fluorine-20130401 *) val kernel_debug_atleast_ref: (int -> bool) ref (** @since Boron-20100401 *) val kernel_verbose_atleast_ref: (int -> bool) ref (** @since Boron-20100401 *) val journal_enable: bool (** @since Beryllium-20090601-beta1 *) val journal_isset: bool (** -journal-enable/disable explicitly set on the command line. @since Boron-20100401 *) val journal_name: string (** @since Beryllium-20090601-beta1 *) val use_obj: bool (** @since Beryllium-20090601-beta1 *) val use_type: bool (** @since Beryllium-20090601-beta1 *) val quiet: bool (** Must not be used for something else that initializing values @since Beryllium-20090601-beta1 *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/task.mli0000644000175000017500000002107312155630171017515 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** High Level Interface to Command. @since Carbon-20101201 @plugin development guide *) (* ************************************************************************* *) (** {2 Task} *) (* ************************************************************************* *) type 'a task type 'a status = | Timeout | Canceled | Result of 'a | Failed of exn type 'a running = | Waiting | Running of (unit -> unit) | Finished of 'a status val error : exn -> string (** Extract error message form exception *) val start : 'a task -> unit val cancel : 'a task -> unit val wait : 'a task -> 'a status (** Blocks until termination. *) val ping : 'a task -> 'a running val map : ('a -> 'b) -> 'a status -> 'b status val pretty : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a status -> unit (* ************************************************************************* *) (** {2 Monadic Constructors} *) (* ************************************************************************* *) val nop : unit task (** The task that immediately returns unit *) val return : 'a -> 'a task (** The task that immediately returns a result *) val raised : exn -> 'a task (** The task that immediately fails with an exception *) val canceled : unit -> 'a task (** The task that is immediately canceled *) val failed : ('a,Format.formatter,unit,'b task) format4 -> 'a (** The task that immediately fails by raising a [Failure] exception. Typically: [[let exit d : 'a task = failed "exit status %d" k]] *) val call : ('a -> 'b) -> 'a -> 'b task (** The task that, when started, invokes a function and immediately returns the result. *) val todo : (unit -> 'a task) -> 'a task val status : 'a status -> 'a task (** The task that immediately finishes with provided status *) val bind : 'a task -> ('a status -> 'b task) -> 'b task (** [bind t k] first runs [t]. Then, when [t] exit with status [s], it starts task [k s]. Remark: If [t] was cancelled, [k s] is still evaluated, but immediately canceled as well. This allows [finally]-like behaviors to be implemented. To evaluate [k r] only when [t] terminates normally, make use of the [sequence] operator. *) val sequence : 'a task -> ('a -> 'b task) -> 'b task (** [sequence t k] first runs [t]. If [t] terminates with [Result r], then task [k r] is started. Otherwise, failure or cancelation of [t] is returned. *) val job : 'a task -> unit task val finally : 'a task -> ('a status -> unit) -> 'a task (** [finally t cb] runs task [t] and {i always} calls [cb s] when [t] exits with status [s]. Then [s] is returned. If the callback [cb] raises an exception, the returned status is emitted. *) val callback : 'a task -> ('a status -> unit) -> unit task (** Same as [finally] but the status of the task is discarded. *) val (>>>) : 'a task -> ('a status -> 'b task) -> 'b task (** [bind] infix. *) val (>>=) : 'a task -> ('a -> 'b task) -> 'b task (** [sequence] infix. *) val (>>?) : 'a task -> ('a status -> unit) -> 'a task (** [finally] infix. *) val (>>!) : 'a task -> ('a status -> unit) -> unit task (** [callback] infix. *) (* ************************************************************************* *) (** {2 Synchroneous Command} *) (* ************************************************************************* *) type mutex val mutex : unit -> mutex val sync : mutex -> (unit -> 'a task) -> 'a task (** Schedules a task such that only one can run simultaneously for a given mutex. *) (* ************************************************************************* *) (** {2 System Command} *) (* ************************************************************************* *) val command : ?timeout:int -> ?time:float ref -> ?stdout:Buffer.t -> ?stderr:Buffer.t -> string -> string array -> int task (** Immediately launch a system-process. Default timeout is [0], which means no-timeout at all. Standard outputs are discarded unless optional buffers are provided. To make the task start later, simply use [todo (command ...)]. *) (* ************************************************************************* *) (** {2 Shared Tasks} When two tasks [A] and [B] share a common sub-task [S], cancelling [A] will make [B] fail either. To prevent this, it is necessary to make [S] {i shareable} and to use two distinct {i instances} of [S] in [A] and [B]. Shared tasks manage the number of their instance and actually run or cancel a unique task on demand. In particular, shared tasks can be canceled and re-started later. @since Oxygen-20120901 *) (* ************************************************************************* *) type 'a shared (** Shareable tasks. *) val shared : descr:string -> retry:bool -> (unit -> 'a task) -> 'a shared (** Build a shareable task. The build function is called whenever a new instance is required but no shared instance task is actually running. Interrupted tasks (by Cancel or Timeout) are retried for further instances. If the task failed, it can be re-launch if [retry] is [true]. Otherwize, further instances will return [Failed] status. *) val share : 'a shared -> 'a task (** New instance of shared task. *) (* ************************************************************************* *) (** {2 Task Server} *) (* ************************************************************************* *) val run : unit task -> unit (** Runs one single task in the background. Typically using [on_idle]. *) type server val server : ?stages:int -> ?procs:int -> unit -> server (** Creates a server of commands. @param stages number of queues in the server. Stage 0 tasks are issued first. Default is 1. @param procs maximum number of running tasks. Default is 4. *) val spawn : server -> ?stage:int -> unit task -> unit (** Schedules a task on the server. The task is not immediately started. *) val launch : server -> unit (** Starts the server if not running yet *) val cancel_all : server -> unit (** Cancel all scheduled tasks *) val set_procs : server -> int -> unit (** Adjusts the maximum number of running process. *) val on_server_activity : server -> (unit -> unit) -> unit (** Idle server callback *) val on_server_start : server -> (unit -> unit) -> unit (** On-start server callback *) val on_server_stop : server -> (unit -> unit) -> unit (** On-stop server callback *) val scheduled : server -> int (** Number of scheduled process *) val terminated : server -> int (** Number of terminated process *) (* ************************************************************************* *) (** {2 GUI Configuration} *) (* ************************************************************************* *) val on_idle : ((unit -> bool) -> unit) ref (** Typically modified by GUI. [!on_idle f] should repeatedly calls [f] until it returns [false]. Default implementation rely on [Unix.sleep 1] and [Db.progress]. See also [Gtk_helper] module implementation. *) frama-c-Fluorine-20130601/src/kernel/plugin.ml0000644000175000017500000013460112155630171017702 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let empty_string = "" let positive_debug_ref = ref 0 let dummy_deprecated = fun _ ~now:_ _ -> assert false let deprecated_ref = ref dummy_deprecated let deprecated_ref2 = ref dummy_deprecated let deprecated_ref3 = ref dummy_deprecated (* several distinct functions since type variables cannot be generalized. Okay: quite hackish :( *) let at_normal_exit f = !deprecated_ref "Plugin.at_normal_exit" ~now:"Cmdline.at_normal_exit" Cmdline.at_normal_exit f let run_normal_exit_hook () = !deprecated_ref2 "Plugin.run_normal_exit_hook" ~now:"Cmdline.run_normal_exit_hook" Cmdline.run_normal_exit_hook () type group = Cmdline.Group.t let selection : (State.t * bool) list ref = ref [] let get_selection ?(is_set=true) () = let l = if is_set then List.map fst !selection else List.fold_left (fun acc (x, b) -> if b then acc else x :: acc) [] !selection in State_selection.of_list l let extend_selection is_set s = selection := (s, is_set) :: !selection let get_selection_context ?is_set () = let has_dependencies s = State_dependency_graph.G.out_degree State_dependency_graph.graph s > 0 in (* automatically select all options which have some dependencies: they have an impact of some analysis. *) let states = State_selection.fold (fun s acc -> if has_dependencies s then s :: acc else acc) (get_selection ?is_set ()) [] in State_selection.of_list states (* ************************************************************************* *) (** {2 Delayed Kernel Initialisation} *) (* ************************************************************************* *) let function_names = ref (fun _ -> []) let set_function_names f = function_names := f let no_ast_hook = fun _ -> () let ast_hook = ref no_ast_hook let init_ast_hooks = ref [] let set_ast_hook f = ast_hook := f let apply_ast_hook f = let ah = !ast_hook in if ah == no_ast_hook then init_ast_hooks := f :: !init_ast_hooks else ah f (* ************************************************************************* *) (** {2 Signatures} *) (* ************************************************************************* *) module type Parameter = sig type t val parameter: Parameter.t val set: t -> unit val add_set_hook: (t -> t -> unit) -> unit val add_update_hook: (t -> t -> unit) -> unit val get: unit -> t val clear: unit -> unit val is_default: unit -> bool val option_name: string val print_help: Format.formatter -> unit include State_builder.S val equal: t -> t -> bool val add_aliases: string list -> unit val add_alias: string list -> unit val is_set: unit -> bool val unsafe_set: t -> unit end module type Bool = sig include Parameter with type t = bool val on: unit -> unit val off: unit -> unit end module type WithOutput = sig include Bool val set_output_dependencies: State.t list -> unit val output: (unit -> unit) -> unit end module type Int = sig include Parameter with type t = int val incr: unit -> unit val set_range: min:int -> max:int -> unit val get_range: unit -> int * int end module type String = sig include Parameter with type t = string val set_possible_values: string list -> unit val get_possible_values: unit -> string list end module type String_collection = sig include Parameter val add: string -> unit val remove: string -> unit val is_empty: unit -> bool val get_set: ?sep:string -> unit -> string val iter: (string -> unit) -> unit val fold: (string -> 'a -> 'a) -> 'a -> 'a val exists: (string -> bool) -> bool val set_possible_values: string list -> unit val get_possible_values: unit -> string list end module type String_set = String_collection with type t = Datatype.String.Set.t module type String_list = String_collection with type t = string list module type String_hashtbl = sig include String_collection with type t = Datatype.String.Set.t type value val find: string -> value end (** option interface *) module type Indexed_val = sig include String type value (** the real type for the option*) val add_choice: string -> value -> unit (** adds a new choice for the option. *) val get_val: unit -> value end module type Parameter_input = sig val option_name: string val help: string end module type Parameter_input_with_arg = sig include Parameter_input val arg_name: string end (** input signature for [IndexedVal] *) module type Indexed_val_input = sig include Parameter_input_with_arg type t (** the type to be serialized *) val default_val: t (** the default value *) val default_key: string (** the default index *) val ty: t Type.t end module type S = sig include Log.Messages val add_group: ?memo:bool -> string -> group module Help: Bool module Verbose: Int module Debug: Int module Debug_category: String_set module Share: sig exception No_dir val dir: ?error:bool -> unit -> string val file: ?error:bool -> string -> string end val help: group val messages: group val parameters: unit -> Parameter.t list end module type General_services = sig include S (** {2 Functors for generating a new parameter} *) module Bool (X:sig include Parameter_input val default: bool end) : Bool module Action(X: Parameter_input) : Bool module False(X: Parameter_input) : Bool module True(X: Parameter_input) : Bool module WithOutput(X: sig include Parameter_input val output_by_default: bool end) : WithOutput module Int (X: sig val default: int include Parameter_input_with_arg end) : Int module Zero(X:Parameter_input_with_arg) : Int module String (X: sig include Parameter_input_with_arg val default: string end) : String module EmptyString(X: Parameter_input_with_arg) : String module StringSet(X: Parameter_input_with_arg) : String_set module FilledStringSet (X: sig include Parameter_input_with_arg val default: Datatype.String.Set.t end) : String_set module StringList(X: Parameter_input_with_arg) : String_list module IndexedVal (V:Indexed_val_input) : Indexed_val with type value = V.t module StringHashtbl (X: Parameter_input_with_arg) (V: sig include Datatype.S val parse: string -> string * t val redefine_binding: string -> old:t -> t -> t val no_binding: string -> t end) : String_hashtbl with type value = V.t end (* ************************************************************************* *) (** {2 Optional parameters of functors} *) (* ************************************************************************* *) let kernel = ref false let kernel_ongoing = ref false let register_kernel = let used = ref false in fun () -> if !used then invalid_arg "The Frama-C kernel should be registered only once." else begin kernel := true; used := true end let is_kernel () = !kernel let share_visible_ref = ref false let is_share_visible () = share_visible_ref := true let reset_plugin () = kernel := false; share_visible_ref := false let cmdline_stage_ref = ref Cmdline.Configuring let set_cmdline_stage s = cmdline_stage_ref := s let journalize_ref = ref true let do_not_journalize () = journalize_ref := false let negative_option_name_ref = ref None let set_negative_option_name s = negative_option_name_ref := Some s let negative_option_help_ref = ref empty_string let set_negative_option_help s = negative_option_help_ref := s let unset_option_name_ref = ref empty_string let set_unset_option_name s = unset_option_name_ref := s let unset_option_help_ref = ref empty_string let set_unset_option_help s = unset_option_help_ref := s let must_save_ref = ref true let do_not_save () = must_save_ref := false let projectify_ref = ref true let do_not_projectify () = projectify_ref := false; do_not_save () let empty_format = ("": (unit, Format.formatter, unit) format) let optional_help_ref = ref empty_format let set_optional_help fmt = optional_help_ref := fmt let set_optional_help fmt = !deprecated_ref3 "Plugin.set_optional_help" ~now:"" set_optional_help fmt let module_name_ref = ref empty_string let set_module_name s = module_name_ref := s let argument_is_function_name_ref = ref false let argument_is_function_name () = argument_is_function_name_ref := true let group_ref = ref Cmdline.Group.default let set_group s = group_ref := s let do_iterate_ref = ref None let do_iterate () = do_iterate_ref := Some true let do_not_iterate () = do_iterate_ref := Some false let is_visible_ref = ref true let is_invisible () = is_visible_ref := false; do_not_iterate () let reset () = cmdline_stage_ref := Cmdline.Configuring; journalize_ref := true; negative_option_name_ref := None; negative_option_help_ref := empty_string; unset_option_name_ref:= empty_string; unset_option_help_ref:= empty_string; optional_help_ref := empty_format; projectify_ref := true; must_save_ref := true; module_name_ref := empty_string; group_ref := Cmdline.Group.default; do_iterate_ref := None; is_visible_ref := true; argument_is_function_name_ref := false (* ************************************************************************* *) (** {2 Generic functors} *) (* ************************************************************************* *) let kernel_name = "kernel" type plugin = { p_name: string; p_shortname: string; p_help: string; p_parameters: (string, Parameter.t list) Hashtbl.t } let plugins: plugin list ref = ref [] let iter_on_plugins f = let cmp p1 p2 = (* the kernel is the smaller plug-in *) match p1.p_name, p2.p_name with | s1, s2 when s1 = kernel_name && s2 = kernel_name -> 0 | s1, _ when s1 = kernel_name -> -1 | _, s2 when s2 = kernel_name -> 1 | s1, s2 -> String.compare s1 s2 in List.iter f (List.sort cmp !plugins) let get_from_name s = List.find (fun p -> p.p_name = s) !plugins ;; let get_from_shortname s = List.find (fun p -> p.p_shortname = s) !plugins (* type [plugin] must be declared before [deprecated_ref4] *) let deprecated_ref4 = ref dummy_deprecated let get s = !deprecated_ref4 "Plugin.get" ~now:"Plugin.get_from_name" get_from_name s let iter_on_this_parameter stage = match !do_iterate_ref, stage with | Some false, _ | None, (Cmdline.Early | Cmdline.Extending | Cmdline.Extended | Cmdline.Exiting | Cmdline.Loading) -> false | Some true, _ | None, Cmdline.Configuring -> true module Build (X:sig include Datatype.S val default: unit -> t val option_name: string val functor_name: string end) = struct let is_dynamic = (*not !kernel_ongoing*)true let projectify = !projectify_ref let must_save = !must_save_ref let is_visible = !is_visible_ref let module_name = !module_name_ref let group = !group_ref module D = Datatype let () = match !cmdline_stage_ref with | Cmdline.Early | Cmdline.Extending | Cmdline.Extended | Cmdline.Exiting | Cmdline.Loading -> do_not_projectify () | Cmdline.Configuring -> () (* quite an inlining of [State_builder.Ref]; but handle [projectify_ref] *) module Option_state_builder (X:sig include Datatype.S val unique_name: string val pretty_name: string val default: unit -> t end) = struct type data = X.t let create () = ref (X.default ()) let state = ref (create ()) include State_builder.Register (struct include Datatype.Ref(X) let descr = if must_save then descr else Descr.unmarshable end) (struct type t = data ref let get () = !state let create = if projectify then create else (* do an alias *) get let clear x = if projectify then x := X.default () let set x = if projectify then state := x (* else there is already an alias *) let clear_some_projects _ _ = false (* parameters cannot be projects *) end) (struct let name = X.pretty_name let unique_name = X.unique_name let dependencies = [] end) let set v = !state := v let get () = !(!state) end module Internal_state = Option_state_builder (struct include X let unique_name = X.option_name let pretty_name = if X.option_name = empty_string then "Input C files" else X.option_name end) include Internal_state let self = Internal_state.self type t = Internal_state.data let () = extend_selection false self let is_default () = X.equal (X.default ()) (Internal_state.get ()) module Is_set = Option_state_builder (struct include D.Bool let pretty_name = X.option_name ^ " is set" let unique_name = pretty_name let default () = false end) let () = State_dependency_graph.add_dependencies ~from:Is_set.self [ self ]; extend_selection true Is_set.self module Set_hook = Hook.Build(struct type t = X.t * X.t end) let add_set_hook f = Set_hook.extend (fun (old, x) -> f old x) let add_update_hook f = add_set_hook f; add_hook_on_update (fun x -> let old = get () in let new_ = !x in if not (X.equal old new_) then f old new_) let gen_journalized name ty set = let name = if is_dynamic then Dynamic.Parameter.get_name X.functor_name name X.option_name else "Kernel." ^ module_name ^ "." ^ name in if !journalize_ref then Journal.register ~is_dyn:is_dynamic name (D.func ty D.unit) set else set (* like set, but do not clear the dependencies *) let unsafe_set = let set x = Is_set.set true; let old = Internal_state.get () in if not (X.equal x old) then begin Internal_state.set x; Set_hook.apply (old, x) end in gen_journalized "unsafe_set" X.ty set let force_set x = let old = Internal_state.get () in if projectify then begin (* [JS 2009/05/25] first clear the dependency and next apply the hooks since these hooks may set some states in the dependencies *) let selection = State_selection.diff (State_selection.with_dependencies self) (State_selection.singleton Is_set.self) in Project.clear ~selection () end; Internal_state.set x; Set_hook.apply (old, x) let journalized_force_set = gen_journalized "set" X.ty force_set let set x = Is_set.set true; if not (X.equal x (Internal_state.get ())) then journalized_force_set x let unguarded_clear = gen_journalized "clear" D.unit (fun () -> force_set (X.default ()); Is_set.set false) let clear () = (* write this call in the journal if and only if there is something to do *) if Is_set.get () || not (is_default ()) then unguarded_clear () let equal = X.equal let register_dynamic name ty1 ty2 f = if is_dynamic then let ty = D.func ty1 ty2 in Dynamic.register ~plugin:empty_string (Dynamic.Parameter.get_name X.functor_name name X.option_name) ~journalize:false ty f else f let get, set, clear, is_set, is_default = register_dynamic "get" D.unit X.ty Internal_state.get, register_dynamic "set" X.ty D.unit set, register_dynamic "clear" D.unit D.unit clear, register_dynamic "is_set" D.unit D.bool Is_set.get, register_dynamic "is_default" D.unit D.bool is_default let stage = !cmdline_stage_ref let option_name = X.option_name end (* ************************************************************************* *) (** {2 The functor [Register]} *) (* ************************************************************************* *) module Register (P: sig val name: string (* the name is "" for the kernel *) val shortname: string val help: string end) = struct let parameters_ref : Parameter.t list ref = ref [] let parameters () = !parameters_ref let verbose_level = ref (fun () -> 1) let debug_level = ref (fun () -> 0) include Log.Register (struct let channel = if is_kernel () then Log.kernel_channel_name else P.shortname let label = if is_kernel () then Log.kernel_label_name else P.shortname let debug_atleast level = !debug_level () >= level let verbose_atleast level = !verbose_level () >= level end) let () = if is_kernel () then begin deprecated_ref := deprecated; deprecated_ref2 := deprecated; deprecated_ref3 := deprecated; deprecated_ref4 := deprecated; Cmdline.kernel_verbose_atleast_ref := verbose_atleast; Cmdline.kernel_debug_atleast_ref := debug_atleast end let plugin = let name = if is_kernel () then kernel_name else P.name in let tbl = Hashtbl.create 17 in Hashtbl.add tbl empty_string []; { p_name = name; p_shortname = P.shortname; p_help = P.help; p_parameters = tbl } let add_parameter group stage param = if iter_on_this_parameter stage then begin parameters_ref := param :: !parameters_ref; let parameter_groups = plugin.p_parameters in try let group_name = Cmdline.Group.name group in let parameters = Hashtbl.find plugin.p_parameters group_name in Hashtbl.replace parameter_groups group_name (param :: parameters) with Not_found -> assert false end let add_group ?memo name = let parameter_groups = plugin.p_parameters in let g, new_g = Cmdline.Group.add ?memo ~plugin:P.shortname name in if new_g then Hashtbl.add parameter_groups name []; g let () = (try Cmdline.add_plugin P.name ~short:P.shortname ~help:P.help with Invalid_argument s -> abort "cannot register plug-in `%s': %s" P.name s); kernel_ongoing := is_kernel (); plugins := plugin :: !plugins module Bool (X:sig val default: bool include Parameter_input end) = struct include Build (struct include Datatype.Bool include X let default () = default let functor_name = "Bool" end) let on = register_dynamic "on" D.unit D.unit (fun () -> set true) let off = register_dynamic "off" D.unit D.unit (fun () -> set false) let generic_add_option name help visible value = Cmdline.add_option name ~plugin:P.shortname ~group ~help ~visible ~ext_help:!optional_help_ref stage (Cmdline.Unit (fun () -> set value)) let negative_option_name name = let s = !negative_option_name_ref in match s with | None -> (* do we match '-shortname-'? (one dash before, one after) *) let len = String.length P.shortname + 2 in if String.length name <= len || P.shortname = empty_string then "-no" ^ name else let bef = Str.string_before name len in if bef = "-" ^ P.shortname ^ "-" then bef ^ "no-" ^ Str.string_after name len else "-no" ^ name | Some s -> assert (s <> empty_string); s let default_message opp = Pretty_utils.sfprintf " (set by default%s)" opp let add_option opp name = let opp_msg name = "opposite option is " ^ negative_option_name name in let help = if X.default then if X.help = empty_string then empty_string else X.help ^ if opp then default_message (", " ^ opp_msg name) else default_message "" else if opp then Pretty_utils.sfprintf "%s (%s)" X.help (opp_msg name) else X.help in generic_add_option name help is_visible true let add_negative_option name = let neg_name = negative_option_name name in let mk_help s = if is_visible then if X.default then s else s ^ default_message "" else "" in let neg_help, neg_visible = match !negative_option_name_ref, !negative_option_help_ref with | None, "" -> (* no user-specific config: no help *) "", false | Some _, "" -> mk_help ("opposite of option \"" ^ name ^ "\""), is_visible | _, s -> assert (s <> empty_string); mk_help s, is_visible in generic_add_option neg_name neg_help neg_visible false; neg_name let add_aliases = Cmdline.add_aliases X.option_name ~plugin:P.shortname ~group stage let add_alias = deprecated "Plugin.add_alias" ~now:"Plugin.add_aliases" add_aliases let parameter = let negative_option = match !negative_option_name_ref, stage with | Some "", _ | None, Cmdline.Exiting -> add_option false X.option_name; None | _ -> add_option true X.option_name; Some (add_negative_option X.option_name) in let accessor = Parameter.Bool ({ Parameter.get = get; set = set; add_set_hook = add_set_hook; add_update_hook = add_update_hook }, negative_option) in let p = Parameter.create ~name:Internal_state.name ~help:X.help ~accessor:accessor ~is_set in add_parameter !group_ref stage p; reset (); if is_dynamic then Dynamic.register ~plugin:empty_string X.option_name Parameter.ty ~journalize:false p else p let print_help fmt = Cmdline.print_option_help fmt ~plugin:P.shortname ~group X.option_name end module False(X: Parameter_input) = Bool(struct include X let default = false end) module True(X: Parameter_input) = Bool(struct include X let default = true end) module Action(X: Parameter_input) = struct (* [JS 2011/09/29] The ugly hack seems to be required anymore neither for Value nor Wp. Maybe it is time to remove it? :-) *) (* do not save it but restore the "good" behavior when creating by copy *) let () = do_not_save () (* [JS 2011/01/19] Not saving this kind of options is a quite bad hack with several drawbacks (see Frama-C commits 2011/01/19, message of JS around 15 PM). I'm quite sure there is a better way to not display results too many times (e.g. by using the "isset" flag). That is also the origin of bug #687 *) include False(X) let () = Project.create_by_copy_hook (fun src p -> Project.copy ~selection:(State_selection.singleton Is_set.self) ~src p; let selection = State_selection.singleton self in let opt = Project.on ~selection src get () in if opt then Project.on ~selection p set true) end (** {3 Integer} *) module Int(X: sig include Parameter_input_with_arg val default: int end) = struct include Build (struct include Datatype.Int include X let default () = default let functor_name = "Int" end) let incr = let incr () = set (succ (get ())) in register_dynamic "incr" D.unit D.unit incr let add_option name = Cmdline.add_option name ~argname:X.arg_name ~help:X.help ~visible:is_visible ~ext_help:!optional_help_ref ~plugin:P.shortname ~group stage (Cmdline.Int set) let add_aliases = Cmdline.add_aliases X.option_name ~plugin:P.shortname ~group stage let add_alias = deprecated "Plugin.add_alias" ~now:"Plugin.add_aliases" add_aliases let range = ref (min_int, max_int) let set_range ~min ~max = range := min, max let get_range () = !range let parameter = add_set_hook (fun _ n -> let min, max = !range in if n < min then abort "argument of %s must be at least %d." Internal_state.name min; if n > max then abort "argument of %s must be no more than %d." Internal_state.name max); let accessor = Parameter.Int ({ Parameter.get = get; set = set; add_set_hook = add_set_hook; add_update_hook = add_update_hook }, get_range) in let p = Parameter.create ~name:Internal_state.name ~help:X.help ~accessor ~is_set:is_set in add_parameter !group_ref stage p; add_option X.option_name; reset (); if is_dynamic then Dynamic.register ~plugin:empty_string X.option_name Parameter.ty ~journalize:false p else p let print_help fmt = Cmdline.print_option_help fmt ~plugin:P.shortname ~group X.option_name end module Zero(X: Parameter_input_with_arg) = Int(struct include X let default = 0 end) (** {3 String} *) module Pervasives_string = String module String (X: sig include Parameter_input_with_arg val default: string end) = struct include Build (struct include Datatype.String include X let default () = default let functor_name = "String" end) let add_option name = Cmdline.add_option name ~argname:X.arg_name ~help:X.help ~visible:is_visible ~ext_help:!optional_help_ref ~plugin:P.shortname ~group stage (Cmdline.String set) let add_aliases = Cmdline.add_aliases X.option_name ~plugin:P.shortname ~group stage let add_alias = deprecated "Plugin.add_alias" ~now:"Plugin.add_aliases" add_aliases let possible_values = ref [] let set_possible_values s = possible_values := s let get_possible_values () = !possible_values let () = if !argument_is_function_name_ref then begin apply_ast_hook (fun _ -> set_possible_values (!function_names ())) end let parameter = add_set_hook (fun _ s -> match !possible_values with | [] -> () | v when List.mem s v -> () | _ -> abort "invalid input `%s' for %s" s Internal_state.name); let accessor = Parameter.String ({ Parameter.get = get; set = set; add_set_hook = add_set_hook; add_update_hook = add_update_hook }, get_possible_values) in let p = Parameter.create ~name:Internal_state.name ~help:X.help ~accessor ~is_set in add_parameter !group_ref stage p; add_option X.option_name; reset (); if is_dynamic then Dynamic.register ~plugin:empty_string X.option_name Parameter.ty ~journalize:false p else p let print_help fmt = Cmdline.print_option_help fmt ~plugin:P.shortname ~group X.option_name end module EmptyString(X: Parameter_input_with_arg) = String(struct include X let default = empty_string end) (** {3 String set and string list} *) module Build_string_set (S: sig include Datatype.S val empty: t val is_empty: t -> bool val add: string -> t -> t val remove: string -> t -> t val mem: string -> t -> bool val for_all: (string -> bool) -> t -> bool val fold: (string -> 'acc -> 'acc) -> t -> 'acc -> 'acc val iter: (string -> unit) -> t -> unit val exists: (string -> bool) -> t -> bool val functor_name: string val default: unit -> t end) (X:Parameter_input_with_arg) = struct include Build (struct include S include X end) let add = let add x = set (S.add x (get ())) in let add = gen_journalized "add" D.string add in register_dynamic "add" D.string D.unit add let remove = let remove x = set (S.remove x (get ())) in let remove = gen_journalized "remove" D.string remove in register_dynamic "remove" D.string D.unit remove let split_set = Str.split (Str.regexp "[ \t]*,[ \t]*") let possible_values = ref [] let set_possible_values s = possible_values := s let get_possible_values () = !possible_values let () = if !argument_is_function_name_ref then apply_ast_hook (fun _ -> set_possible_values (!function_names ())) let guarded_set_set x = match split_set x with | [] when not (S.is_empty (get ())) -> set S.empty | l -> List.iter (fun s -> if !possible_values != [] then if not (List.mem s !possible_values) then abort "invalid input `%s' for %s" s Internal_state.name) l; if not (List.for_all (fun s -> S.mem s (get ())) l) || not (S.for_all (fun s -> List.mem s l) (get ())) then set (List.fold_right S.add l S.empty) let get_set ?(sep=", ") () = S.fold (fun s acc -> if acc <> empty_string then s ^ sep ^ acc else s) (get ()) empty_string let is_empty = let is_empty () = S.is_empty (get ()) in register_dynamic "is_empty" D.unit D.bool is_empty let iter = let iter f = S.iter f (get ()) in register_dynamic "iter" (D.func D.string D.unit) D.unit iter let fold f = S.fold f (get ()) let exists = let exists f = S.exists f (get()) in register_dynamic "exists" (D.func D.string D.bool) D.bool exists let add_generic_option name help f = Cmdline.add_option name ~plugin:P.shortname ~group ~argname:X.arg_name ~help ~visible:is_visible ~ext_help:!optional_help_ref stage (Cmdline.String_list (List.iter f)) let add_option name help = add_generic_option name help add let add_option_unset name help = add_generic_option name help remove let add_aliases = Cmdline.add_aliases X.option_name ~plugin:P.shortname ~group stage let add_alias = deprecated "Plugin.add_alias" ~now:"Plugin.add_aliases" add_aliases let print_help fmt = Cmdline.print_option_help fmt ~plugin:P.shortname ~group X.option_name end module FilledStringSet (X: sig include Parameter_input_with_arg val default: Datatype.String.Set.t end) = struct include Build_string_set (struct include Datatype.String.Set let functor_name = "StringSet" let default () = X.default end) (X) let parameter = let accessor = Parameter.String_set { Parameter.get = get_set; set = guarded_set_set; add_set_hook = add_set_hook; add_update_hook = add_update_hook } in let p = Parameter.create ~name:Internal_state.name ~help:X.help ~accessor:accessor ~is_set in add_parameter !group_ref stage p; add_option X.option_name X.help; if !unset_option_name_ref <> "" then begin let help = if !unset_option_help_ref = "" then "opposite of option " ^ X.option_name else !unset_option_help_ref in add_option_unset !unset_option_name_ref help end; reset (); if is_dynamic then Dynamic.register ~plugin:empty_string X.option_name Parameter.ty ~journalize:false p else p end module StringSet(X: Parameter_input_with_arg) = FilledStringSet (struct include X let default = Datatype.String.Set.empty end) module StringList(X: Parameter_input_with_arg) = struct include Build_string_set (struct include Datatype.List(Datatype.String) let empty = [] let is_empty = equal [] let add s l = l @ [ s ] let remove s l = List.filter ((<>) s) l let mem s = List.exists (((=) : string -> _) s) let for_all = List.for_all let fold f l acc = List.fold_left (fun acc x -> f x acc) acc l let iter = List.iter let exists = List.exists let functor_name = "StringList" let default () = [] end) (X) let parameter = let accessor = Parameter.String_list { Parameter.get = get_set; set = guarded_set_set; add_set_hook = add_set_hook; add_update_hook = add_update_hook } in let p = Parameter.create ~name:Internal_state.name ~help:X.help ~accessor:accessor ~is_set in add_parameter !group_ref stage p; add_option X.option_name X.help; reset (); if is_dynamic then Dynamic.register ~plugin:empty_string X.option_name Parameter.ty ~journalize:false p else p end module StringHashtbl (X: Parameter_input_with_arg) (V: sig include Datatype.S val parse: string -> string * t val redefine_binding: string -> old:t -> t -> t val no_binding: string -> t end) = struct module Initial_Datatype = Datatype include StringSet(X) module H = State_builder.Hashtbl (Initial_Datatype.String.Hashtbl) (V) (struct let name = X.option_name ^ " (hashtbl)" let size = 7 let dependencies = [ self ] end) type value = V.t let self = H.self let parse () = iter (fun s -> let k, v = V.parse s in let v = try let old = H.find k in V.redefine_binding k ~old v with Not_found -> v in H.replace k v); H.mark_as_computed () let find s = if not (H.is_computed ()) then parse (); try H.find s with Not_found -> V.no_binding s end (** {3 Complex values indexed by strings} *) module IndexedVal (V:Indexed_val_input) : Indexed_val with type value = V.t = struct type value = V.t let is_dynamic = not !kernel_ongoing let options = Hashtbl.create 13 let add_choice k v = Hashtbl.add options k v let () = add_choice V.default_key V.default_val let create () = ref V.default_key let curr_choice = ref (create ()) module StateAux = struct let name = V.option_name let unique_name = V.option_name let create = create type t = string ref let get () = !curr_choice let set s = if s != get () then let v = !s in if Hashtbl.mem options v then curr_choice := s else abort "invalid input %s for %s" v V.option_name let clear tbl = tbl := V.default_key let dependencies = [] let clear_some_projects _ _ = false (* a parameter cannot be a project *) end module State = State_builder.Register(Datatype.Ref(Datatype.String))(StateAux)(StateAux) include State let () = extend_selection false self type t = string let equal : t -> t -> _ = (=) let get () = !(!curr_choice) let get_val () = Hashtbl.find options (get()) module Set_hook = Hook.Build(struct type t = string * string end) let add_set_hook f = Set_hook.extend (fun (old, x) -> f old x) let add_update_hook f = add_set_hook f; add_hook_on_update (fun x -> (* this hook is applied just **before** the value is set *) let old = get () in let new_ = !x in if old <> new_ then f old new_) let unguarded_set s = if Hashtbl.mem options s then begin let old = !(!curr_choice) in !curr_choice := s; Set_hook.apply (old, s) end else warning "identifier %s is not a valid index for parameter %s. \ Option is unchanged.\n" s V.option_name let set s = if s <> get () then unguarded_set s let clear () = !curr_choice := V.default_key (* [JS 2009/04/17] TODO: reimplement is_set according to its new specification *) let is_set () = (*!(!curr_choice) <> V.default_key*) assert false let is_default () = !(!curr_choice) = V.default_key let unsafe_set = set let stage = !cmdline_stage_ref let group = !group_ref let add_option name = Cmdline.add_option name ~plugin:P.shortname ~group ~argname:V.arg_name ~help:V.help ~visible:!is_visible_ref ~ext_help:!optional_help_ref stage (Cmdline.String unguarded_set) let add_aliases = Cmdline.add_aliases V.option_name ~plugin:P.shortname ~group stage let add_alias = deprecated "Plugin.add_alias" ~now:"Plugin.add_aliases" add_aliases let possible_values = ref [] let set_possible_values s = possible_values := s let get_possible_values () = !possible_values let option_name = V.option_name let print_help fmt = Cmdline.print_option_help fmt ~plugin:P.shortname ~group V.option_name let parameter = let accessor = Parameter.String ({ Parameter.get = get; set = set; add_set_hook = add_set_hook; add_update_hook = add_update_hook }, (fun () -> [])) in let p = Parameter.create ~name:V.option_name ~help:V.help ~accessor ~is_set in if is_dynamic then Dynamic.register ~plugin:empty_string V.option_name Parameter.ty ~journalize:false p else p let () = add_option V.option_name; reset (); end let messages = add_group "Output Messages" (** Options that directly cause an output. *) module WithOutput (X: sig include Parameter_input val output_by_default: bool end) = struct (* Requested command-line option *) include False(X) (* Command-line option for output. *) let () = set_group messages module Output = Bool(struct let default = X.output_by_default let option_name = X.option_name ^ "-print" let help = "print results for option " ^ X.option_name end) (* Boolean that indicates whether the results have never been output in the current mode. As usual, change in dependencies automatically reset the value *) module ShouldOutput = State_builder.True_ref(struct let dependencies = [] (* To be filled by the user when calling the output function *) let name = X.option_name ^ "ShouldOutput" end) (* Output has been requested by the user. Set the "output should be printed" boolean to true *) let () = Output.add_set_hook (fun _ v -> if v then ShouldOutput.set true) let set_output_dependencies deps = State_dependency_graph.add_codependencies ~onto:ShouldOutput.self deps let output f = (* Output only if our two booleans are at true *) if Output.get () && ShouldOutput.get () then begin (* One output will occur, do not output anything next time (unless dependencies change, or the user requests it on the command-line) *) ShouldOutput.set false; f (); end end (** {3 Generic options for each plug-in} *) let prefix = if P.shortname = empty_string then "-kernel-" else "-" ^ P.shortname ^ "-" module Share = struct let is_visible = !share_visible_ref let () = set_cmdline_stage Cmdline.Extended let () = if is_visible then do_iterate () else is_invisible () module SpecificShare = EmptyString (struct let option_name = prefix ^ "share" let arg_name = "dir" let help = if is_visible then "set the plug-in share directory to \ (may be used if the plug-in is not installed at the same place than Frama-C)" else "" end) exception No_dir let get_and_check_dir ?(error=true) f = if (try Sys.is_directory f with Sys_error _ -> false) then Filepath.normalize f else if error then abort "no share directory %s for plug-in %s." f P.name else raise No_dir let dir ?error () = let d = if is_visible then SpecificShare.get () else empty_string in if d = empty_string then if P.shortname = empty_string then get_and_check_dir ?error Config.datadir else get_and_check_dir ?error (Config.datadir ^ "/" ^ P.shortname) else get_and_check_dir ?error d let file ?error f = dir ?error () ^ "/" ^ f end let help = add_group "Getting Information" let () = set_group help let () = set_cmdline_stage Cmdline.Exiting let () = if is_kernel () then set_module_name "Help" module Help = False (struct let option_name = prefix ^ "help" let help = if is_kernel () then "help of the Frama-C kernel" else "help of plug-in " ^ P.name end) let () = Cmdline.run_after_exiting_stage (fun () -> if Help.get () then Cmdline.plugin_help P.shortname else Cmdline.nop); Help.add_aliases [ prefix ^ "h" ] let output_mode modname optname = set_group messages; do_not_projectify (); do_not_journalize (); do_iterate (); if is_kernel () then begin set_cmdline_stage Cmdline.Early; set_module_name modname; "-" ^ kernel_name ^ "-" ^ optname end else begin set_cmdline_stage Cmdline.Extended; prefix ^ optname end let verbose_optname = output_mode "Verbose" "verbose" module Verbose = struct include Int(struct let default = !verbose_level () let option_name = verbose_optname let arg_name = "n" let help = (if is_kernel () then "level of verbosity for the Frama-C kernel" else "level of verbosity for plug-in " ^ P.name) ^ " (default to " ^ string_of_int default ^ ")" end) let get () = if is_set () then get () else Cmdline.Verbose_level.get () let () = verbose_level := get; (* line order below matters *) set_range ~min:0 ~max:max_int; if is_kernel () then match !Cmdline.Kernel_verbose_level.value_if_set with | None -> () | Some n -> set n end let debug_optname = output_mode "Debug" "debug" module Debug = struct include Int(struct let default = !debug_level () let option_name = debug_optname let arg_name = "n" let help = (if is_kernel () then "level of debug for the Frama-C kernel" else "level of debug for plug-in " ^ P.name) ^ " (default to " ^ string_of_int default ^ ")" end) let get () = if is_set () then get () else Cmdline.Debug_level.get () let () = debug_level := get; (* line order below matters *) set_range ~min:0 ~max:max_int; add_set_hook (fun old n -> (* the level of verbose is at least the level of debug *) if n > Verbose.get () then Verbose.set n; if n = 0 then Pervasives.decr positive_debug_ref else if old = 0 then Pervasives.incr positive_debug_ref); if is_kernel () then match !Cmdline.Kernel_debug_level.value_if_set with | None -> () | Some n -> set n end let debug_category_optname = output_mode "Msg_key" "msg-key" let () = set_unset_option_name (output_mode "Msg_key" "msg-key-unset") let () = set_unset_option_help "disables message display for categories ,...," module Debug_category = struct include StringSet(struct let option_name = debug_category_optname let arg_name="k1[,...,kn]" let help = "enables message display for categories ,...,. Use " ^ debug_category_optname ^ " help to get a list of available categories, and * to enable \ all categories" end) let () = add_set_hook (fun before after -> if not (D.String.Set.mem "help" before) && D.String.Set.mem "help" after then begin (* level 0 just in case user ask to display all categories in an otherwise quiet run *) feedback ~level:0 "@[Available message categories are:%a@]" (fun fmt set -> Category_set.iter (fun s -> let s = (s:category:>string) in if s <> "" then Format.fprintf fmt "@;%s" s) set) (get_all_categories ()) end; let add_category c s = D.String.Set.add (c:category:>string) s in let subcategory_closure s = D.String.Set.fold (fun s acc -> Category_set.union (get_category s) acc) s Category_set.empty in let string_of_cat_set s = Category_set.fold add_category s D.String.Set.empty in let remove = D.String.Set.diff before after in let added = D.String.Set.diff after before in let added = subcategory_closure added in let remove = subcategory_closure remove in add_debug_keys added; del_debug_keys remove; (* we add the subcategories to ourselves *) let after = D.String.Set.union after (string_of_cat_set added) in let after = D.String.Set.diff after (string_of_cat_set remove) in Internal_state.set after; (* implicitly set debugging to 1 if at least one category is enabled. *) if Debug.get () < 1 && not (D.String.Set.is_empty after) then Debug.set 1 ) end let () = reset_plugin () end (* Register *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/gui_init.mli0000644000175000017500000000341612155630171020363 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Very early initialisation step required by any GUI. This interface should be empty. @plugin development guide *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/kernel.ml0000644000175000017500000007341112155630171017665 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ************************************************************************* *) (** {2 Kernel as an almost standard plug-in} *) (* ************************************************************************* *) let () = Plugin.register_kernel () module P = Plugin.Register (struct let name = "" let shortname = "" let help = "General options provided by the Frama-C kernel" end) include (P: Plugin.S) let () = Cmdline.run_after_early_stage (fun () -> (* Project uses an alias for [Log.Register], but debug keys cannot be shared automatically *) Project_skeleton.Output.add_debug_keys (Category_set.fold (fun s acc -> Project_skeleton.Output.Category_set.union (Project_skeleton.Output.get_category (s:category:>string)) acc) (get_debug_keys()) Project_skeleton.Output.Category_set.empty)) (* ************************************************************************* *) (** {2 Specialised functors for building kernel parameters} *) (* ************************************************************************* *) module type Parameter_input = sig include Plugin.Parameter_input val module_name: string end module type Parameter_input_with_arg = sig include Plugin.Parameter_input_with_arg val module_name: string end module Bool(X:sig include Parameter_input val default: bool end) = P.Bool(struct let () = Plugin.set_module_name X.module_name include X end) module False(X: Parameter_input) = P.False(struct let () = Plugin.set_module_name X.module_name include X end) module True(X: Parameter_input) = P.True(struct let () = Plugin.set_module_name X.module_name include X end) module Int (X: sig val default: int include Parameter_input_with_arg end) = P.Int(struct let () = Plugin.set_module_name X.module_name include X end) module Zero(X:Parameter_input_with_arg) = P.Zero(struct let () = Plugin.set_module_name X.module_name include X end) module String (X: sig include Parameter_input_with_arg val default: string end) = P.String(struct let () = Plugin.set_module_name X.module_name include X end) module EmptyString(X: Parameter_input_with_arg) = P.EmptyString (struct let () = Plugin.set_module_name X.module_name include X end) module StringSet(X: Parameter_input_with_arg) = P.StringSet (struct let () = Plugin.set_module_name X.module_name include X end) module StringList(X: Parameter_input_with_arg) = P.StringList (struct let () = Plugin.set_module_name X.module_name include X end) (* ************************************************************************* *) (** {2 Installation Information} *) (* ************************************************************************* *) let () = Plugin.set_group help let () = Plugin.set_cmdline_stage Cmdline.Exiting let () = Plugin.do_not_journalize () let () = Plugin.set_negative_option_name "" module GeneralHelp = False (struct let option_name = "-help" let help = "display a general help" let module_name = "GeneralHelp" end) let run_help () = if GeneralHelp.get () then Cmdline.help () else Cmdline.nop let () = Cmdline.run_after_exiting_stage run_help let () = GeneralHelp.add_aliases [ "--help"; "-h" ] let () = Plugin.set_group help let () = Plugin.set_cmdline_stage Cmdline.Early let () = Plugin.set_negative_option_name "" module PrintVersion = False (struct let option_name = "-version" let module_name = "PrintVersion" let help = "print version information" end) let () = PrintVersion.add_aliases [ "-v"; "--version" ] let () = Plugin.set_group help let () = Plugin.set_cmdline_stage Cmdline.Early let () = Plugin.set_negative_option_name "" module PrintShare = False(struct let option_name = "-print-share-path" let module_name = "PrintShare" let help = "print the Frama-C share path" end) let () = PrintShare.add_aliases [ "-print-path" ] let () = Plugin.set_group help let () = Plugin.set_cmdline_stage Cmdline.Early let () = Plugin.set_negative_option_name "" module PrintLib = False(struct let option_name = "-print-lib-path" let module_name = "PrintLib" let help = "print the path of the Frama-C kernel library" end) let () = PrintLib.add_aliases [ "-print-libpath" ] let () = Plugin.set_group help let () = Plugin.set_cmdline_stage Cmdline.Early let () = Plugin.set_negative_option_name "" module PrintPluginPath = False (struct let option_name = "-print-plugin-path" let module_name = "PrintPluginPath" let help = "print the path where the Frama-C dynamic plug-ins are searched into" end) let () = Plugin.set_group help let () = Plugin.set_negative_option_name "" module DumpDependencies = EmptyString (struct let module_name = "DumpDependencies" let option_name = "-dump-dependencies" let help = "" let arg_name = "" end) let () = at_exit (fun () -> if not (DumpDependencies.is_default ()) then State_dependency_graph.dump (DumpDependencies.get ())) (* ************************************************************************* *) (** {2 Output Messages} *) (* ************************************************************************* *) let () = Plugin.set_group messages let () = Plugin.do_not_projectify () let () = Plugin.do_not_journalize () let () = Plugin.set_cmdline_stage Cmdline.Early let () = Plugin.do_iterate () module GeneralVerbose = Int (struct let default = 1 let option_name = "-verbose" let arg_name = "n" let help = "general level of verbosity" let module_name = "GeneralVerbose" end) let () = (* line order below matters *) GeneralVerbose.set_range ~min:0 ~max:max_int; GeneralVerbose.add_set_hook (fun _ n -> Cmdline.Verbose_level.set n); match !Cmdline.Verbose_level.value_if_set with | None -> () | Some n -> GeneralVerbose.set n let () = Plugin.set_group messages let () = Plugin.do_not_projectify () let () = Plugin.do_not_journalize () let () = Plugin.set_cmdline_stage Cmdline.Early let () = Plugin.do_iterate () module GeneralDebug = Zero (struct let option_name = "-debug" let arg_name = "n" let help = "general level of debug" let module_name = "GeneralDebug" end) let () = (* line order below matters *) GeneralDebug.set_range ~min:0 ~max:max_int; GeneralDebug.add_set_hook (fun old n -> if n = 0 then decr Plugin.positive_debug_ref else if old = 0 then incr Plugin.positive_debug_ref; Cmdline.Debug_level.set n); match !Cmdline.Debug_level.value_if_set with | None -> () | Some n -> GeneralDebug.set n let () = Plugin.set_group messages let () = Plugin.set_negative_option_name "" let () = Plugin.set_cmdline_stage Cmdline.Early let () = Plugin.do_iterate () let () = Plugin.do_not_projectify () let () = Plugin.do_not_journalize () module Quiet = Bool (struct let default = Cmdline.quiet let option_name = "-quiet" let module_name = "Quiet" let help = "sets -verbose and -debug to 0" end) let () = Quiet.add_set_hook (fun _ b -> assert b; GeneralVerbose.set 0; GeneralDebug.set 0) let () = Plugin.set_group messages let () = Plugin.do_not_journalize () let () = Plugin.do_not_projectify () module Unicode = struct include True (struct let option_name = "-unicode" let module_name = "Unicode" let help = "use utf8 in messages" end) (* This function behaves nicely with the Gui, that detects if command-line arguments have been set by the user at some point. One possible improvment would be to bypass journalization entirely, but this requires an API change in Plugin *) let without_unicode f arg = let old, default = get (), not (is_set ()) in off (); let r = f arg in if default then clear () else set old; r end module UseUnicode = struct include Unicode let set = deprecated "UseUnicode.set" ~now:"Unicode.set" set let on = deprecated "UseUnicode.on" ~now:"Unicode.on" on let off = deprecated "UseUnicode.off" ~now:"Unicode.off" off let get = deprecated "UseUnicode.get" ~now:"Unicode.get" get end let () = Plugin.set_group messages module Time = EmptyString (struct let module_name = "Time" let option_name = "-time" let arg_name = "filename" let help = "append process time and timestamp to at exit" end) let () = Plugin.set_group messages let () = Plugin.set_negative_option_name "-do-not-collect-messages" let () = Plugin.do_not_projectify () let () = Plugin.set_cmdline_stage Cmdline.Early module Collect_messages = Bool (struct let module_name = "Collect_messages" let option_name = "-collect-messages" let help = "collect warning and error messages for displaying them in \ the GUI (set by default iff the GUI is launched)" let default = !Config.is_gui (* ok: Config.is_gui already initialised by Gui_init *) end) (* ************************************************************************* *) (** {2 Input / Output Source Code} *) (* ************************************************************************* *) let inout_source = add_group "Input/Output Source Code" let () = Plugin.set_group inout_source module PrintCode = False (struct let module_name = "PrintCode" let option_name = "-print" let help = "pretty print original code with its comments" end) let () = Plugin.set_group inout_source let () = Plugin.do_not_projectify () module PrintComments = False (struct let module_name = "PrintComments" let option_name = "-keep-comments" let help = "try to keep comments in C code" end) module CodeOutput = struct let () = Plugin.set_group inout_source include EmptyString (struct let module_name = "CodeOutput" let option_name = "-ocode" let arg_name = "filename" let help = "when printing code, redirects the output to file " end) let streams = Hashtbl.create 7 let output job = let file = get () in if file = "" then Log.print_delayed job else try let fmt = try fst (Hashtbl.find streams file) with Not_found -> let out = open_out file in let fmt = Format.formatter_of_out_channel out in Hashtbl.add streams file (fmt,out) ; fmt in job fmt with Sys_error s -> warning "Fail to open file \"%s\" for code output@\nSystem error: %s.@\n\ Code is output on stdout instead." file s ; Log.print_delayed job let close_all () = Hashtbl.iter (fun file (fmt,cout) -> try Format.pp_print_flush fmt () ; close_out cout ; with Sys_error s -> failure "Fail to close output file \"%s\"@\nSystem error: %s." file s) streams let () = at_exit close_all end let () = Plugin.set_group inout_source module FloatNormal = False (struct let option_name = "-float-normal" let module_name = "FloatNormal" let help = "display floats with internal routine" end) let () = Plugin.set_group inout_source module FloatRelative = False (struct let option_name = "-float-relative" let module_name = "FloatRelative" let help = "display float intervals as [lower_bound ++ width]" end) let () = Plugin.set_group inout_source module FloatHex = False (struct let option_name = "-float-hex" let module_name = "FloatHex" let help = "display floats as hexadecimal" end) let () = Plugin.set_group inout_source module BigIntsHex = Int(struct let module_name = "BigIntsHex" let option_name = "-big-ints-hex" let arg_name = "max" let help = "display integers larger than using hexadecimal \ notation" let default = -1 end) (* ************************************************************************* *) (** {2 Save/Load} *) (* ************************************************************************* *) let saveload = add_group "Saving or Loading Data" let () = Plugin.set_group saveload let () = Plugin.do_not_projectify () module SaveState = EmptyString (struct let module_name = "SaveState" let option_name = "-save" let arg_name = "filename" let help = "at exit, save the session into file " end) let () = Plugin.set_group saveload let () = Plugin.set_cmdline_stage Cmdline.Loading (* must be projectified: when loading, this option will be automatically reset *) (*let () = Plugin.do_not_projectify ()*) module LoadState = EmptyString (struct let module_name = "LoadState" let option_name = "-load" let arg_name = "filename" let help = "load a previously-saved session from file " end) let () = Plugin.set_group saveload let () = Plugin.set_cmdline_stage Cmdline.Extending let () = Plugin.do_not_projectify () module AddPath = StringList (struct let option_name = "-add-path" let module_name = "AddPath" let arg_name = "p1, ..., pn" let help = "prepend paths to dynamic plugins search path" end) let () = AddPath.add_set_hook (fun _ _ -> AddPath.iter (fun s -> ignore (Dynamic.add_path s))) let () = Plugin.set_group saveload let () = Plugin.set_cmdline_stage Cmdline.Extending let () = Plugin.do_not_projectify () module LoadModule = StringSet (struct let option_name = "-load-module" let module_name = "LoadModule" let arg_name = "m1, ..., mn" let help = "load the given modules dynamically" end) let () = LoadModule.add_set_hook (fun _ _ -> LoadModule.iter Dynamic.load_module) let () = Plugin.set_group saveload let () = Plugin.set_cmdline_stage Cmdline.Extending let () = Plugin.do_not_projectify () module Dynlink = True (struct let option_name = "-dynlink" let module_name = "Dynlink" let help = "if set, load all the found dynamic plug-ins" end) let () = Dynlink.add_set_hook (fun _ -> Dynamic.set_default) let () = Plugin.set_group saveload let () = Plugin.set_cmdline_stage Cmdline.Extending let () = Plugin.do_not_projectify () module LoadScript = StringSet (struct let option_name = "-load-script" let module_name = "LoadScript" let arg_name = "m1, ..., mn" let help = "load the given OCaml scripts dynamically" end) let () = LoadScript.add_set_hook (fun _ _ -> LoadScript.iter Dynamic.load_script) module Journal = struct let () = Plugin.set_negative_option_name "-journal-disable" let () = Plugin.set_cmdline_stage Cmdline.Early let () = Plugin.set_group saveload let () = Plugin.do_not_projectify () module Enable = struct include Bool (struct let module_name = "Journal.Enable" let default = Cmdline.journal_enable let option_name = "-journal-enable" let help = "dump a journal while Frama-C exit" end) let is_set () = Cmdline.journal_isset end let () = Plugin.set_group saveload let () = Plugin.do_not_projectify () module Name = String (struct let module_name = "Journal.Name" let option_name = "-journal-name" let default = Journal.get_name () let arg_name = "s" let help = "set the filename of the journal (do not write any extension)" end) end (* ************************************************************************* *) (** {2 Customizing Normalization} *) (* ************************************************************************* *) let normalisation = add_group "Customizing Normalization" let () = Plugin.set_group normalisation module UnrollingLevel = Zero (struct let module_name = "UnrollingLevel" let option_name = "-ulevel" let arg_name = "l" let help = "unroll loops n times (defaults to 0) before analyzes. \ A negative value hides UNROLL loop pragmas." end) let () = Plugin.set_group normalisation module Machdep = String (struct let module_name = "Machdep" let option_name = "-machdep" let default = "x86_32" let arg_name = "machine" let help = "use as the current machine dependent configuration. \ See \"-machdep help\" for a list" end) let () = Plugin.set_group normalisation module Enums = EmptyString (struct let module_name = "Enums" let option_name = "-enums" let arg_name = "repr" let help = "use to decide how enumerated types should be represented. \ -enums help gives the list of available representations" end) let enum_reprs = ["gcc-enums"; "gcc-short-enums"; "int";] let () = Enums.set_possible_values ("help"::enum_reprs) let () = Enums.add_set_hook (fun _ o -> if o = "help" then feedback "Possible enums representation are: %a" (Pretty_utils.pp_list ~sep:", " Format.pp_print_string) enum_reprs) let () = Plugin.set_group normalisation module ReadAnnot = True(struct let module_name = "ReadAnnot" let option_name = "-annot" let help = "read annotation" end) let () = Plugin.set_group normalisation module PreprocessAnnot = False(struct let module_name = "PreprocessAnnot" let option_name = "-pp-annot" let help = "pre-process annotations (if they are read)" end) let () = Plugin.set_group normalisation module CppCommand = EmptyString (struct let module_name = "CppCommand" let option_name = "-cpp-command" let arg_name = "cmd" let help = " is used to build the preprocessing command.\n\ Default to $CPP environment variable or else \"gcc -C -E -I.\".\n\ If unset, the command is built as follow:\n\ CPP -o \n\ %1 and %2 can be used into CPP string to mark the position of \ and respectively" end) let () = Plugin.set_group normalisation module CppExtraArgs = StringList (struct let module_name = "CppExtraArgs" let option_name = "-cpp-extra-args" let arg_name = "args" let help = "additional arguments passed to the preprocessor while \ preprocessing the C code but not while preprocessing annotations" end) let () = Plugin.set_group normalisation let () = Plugin.set_negative_option_name "" module TypeCheck = True(struct let module_name = "TypeCheck" let option_name = "-typecheck" let help = "only typechecks the source files" end) let () = Plugin.set_group normalisation module ContinueOnAnnotError = False(struct let module_name = "ContinueOnAnnotError" let option_name = "-continue-annot-error" let help = "When an annotation fails to type-check, emit \ a warning and discard the annotation instead of \ generating an error (errors in C are still fatal)" end) let () = Plugin.set_group normalisation module SimplifyCfg = False (struct let module_name = "SimplifyCfg" let option_name = "-simplify-cfg" let help = "remove break, continue and switch statements before analyses" end) let () = Plugin.set_group normalisation module KeepSwitch = False(struct let option_name = "-keep-switch" let module_name = "KeepSwitch" let help = "keep switch statements despite -simplify-cfg" end) let () = Plugin.set_group normalisation let () = Plugin.set_negative_option_name "-remove-unused-specified-functions" module Keep_unused_specified_functions = True(struct let option_name = "-keep-unused-specified-functions" let module_name = "Keep_unused_specified_functions" let help = "keep specified-but-unused functions" end) let () = Plugin.set_group normalisation module Constfold = False (struct let option_name = "-constfold" let module_name = "Constfold" let help = "fold all constant expressions in the code before analysis" end) let () = Plugin.set_group normalisation module InitializedPaddingLocals = True (struct let option_name = "-initialized-padding-locals" let module_name = "InitializedPaddingLocals" let help = "Implicit initialization of locals sets padding bits to 0. \ If false, padding bits are left uninitialized. \ Defaults to true." end) module Files = struct let () = Plugin.is_invisible () include StringList (struct let option_name = "" let module_name = "Files" let arg_name = "" let help = "" end) let () = Cmdline.use_cmdline_files set let () = Plugin.set_group normalisation module Check = False(struct let option_name = "-check" let module_name = "Files.Check" let help = "performs consistency checks over the Abstract Syntax \ Tree" end) let () = Plugin.set_group normalisation module Copy = False(struct let option_name = "-copy" let module_name = "Files.Copy" let help = "always perform a copy of the original AST before analysis begin" end) let () = Plugin.set_group normalisation module Orig_name = False(struct let option_name = "-orig-name" let module_name = "Files.Orig_name" let help = "prints a message each time a variable is renamed" end) end let () = Plugin.set_group normalisation module AllowDuplication = True(struct let option_name = "-allow-duplication" let module_name = "AllowDuplication" let help = "allow duplication of small blocks during normalization" end) let () = Plugin.set_group normalisation module DoCollapseCallCast = True(struct let option_name = "-collapse-call-cast" let module_name = "DoCollapseCallCast" let help = "Allow some implicit casts between returned value of a function \ and the lvalue it is assigned to." end) let () = Plugin.set_group normalisation module ForceRLArgEval = False(struct let option_name = "-force-rl-arg-eval" let module_name = "ForceRLArgEval" let help = "Force right to left evaluation order for \ arguments of function calls" end) let () = Plugin.set_group normalisation module WarnUndeclared = True(struct let option_name = "-warn-undeclared-callee" let help = "Warn when a function is called before it has been declared." let module_name = "WarnUndeclared" end) let () = Plugin.set_group normalisation module WarnDecimalFloat = String(struct let option_name = "-warn-decimal-float" let arg_name = "freq" let help = "Warn when floating-point constants cannot be exactly \ represented; freq must be one of none, once or all" let default = "once" let module_name = "WarnDecimalFloat" end) let () = WarnDecimalFloat.set_possible_values ["none"; "once"; "all"] let normalization_parameters = [ ForceRLArgEval.parameter; UnrollingLevel.parameter; Machdep.parameter; CppCommand.parameter; CppExtraArgs.parameter; SimplifyCfg.parameter; KeepSwitch.parameter; Keep_unused_specified_functions.parameter; Constfold.parameter; AllowDuplication.parameter; DoCollapseCallCast.parameter; ] (* ************************************************************************* *) (** {2 Analysis Options} *) (* ************************************************************************* *) let analysis_options = add_group "Analysis Options" let () = Plugin.set_group analysis_options let () = Plugin.argument_is_function_name () module MainFunction = String (struct let module_name = "MainFunction" let default = "main" let option_name = "-main" let arg_name = "f" let help = "use as entry point for analysis. See \"-lib-entry\" \ if this is not for a complete application. Defaults to main" end) let () = Plugin.set_group analysis_options module LibEntry = False (struct let module_name = "LibEntry" let option_name = "-lib-entry" let help ="run analysis for an incomplete application e.g. an API call. See the -main option to set the entry point" end) let () = Plugin.set_group analysis_options module UnspecifiedAccess = False(struct let module_name = "UnspecifiedAccess" let option_name = "-unspecified-access" let help = "do not assume that read/write accesses occuring \ between sequence points are separated" end) let () = Plugin.set_negative_option_name "-unsafe-arrays" let () = Plugin.set_group analysis_options module SafeArrays = True (struct let module_name = "SafeArrays" let option_name = "-safe-arrays" let help = "for multidimensional arrays or arrays that are fields \ inside structs, assume that accesses are in bounds" end) let () = Plugin.set_group analysis_options module AbsoluteValidRange = struct module Info = struct let option_name = "-absolute-valid-range" let arg_name = "min-max" let help = "min and max must be integers in decimal, hexadecimal (0x, 0X), octal (0o) or binary (0b) notation and fit in 64 bits. Assume that that all absolute addresses outside of the [min-max] range are invalid. In the absence of this option, all absolute addresses are assumed to be invalid" let default = "" let module_name = "AbsoluteValidRange" end include String(Info) end (* Signed overflows are undefined behaviors. *) let () = Plugin.set_group analysis_options module SignedOverflow = True (struct let module_name = "SignedOverflow" let option_name = "-warn-signed-overflow" let help = "generate alarms for signed operations that overflow." end) (* Unsigned overflows are ok, but might not always be a behavior the programmer wants. *) let () = Plugin.set_group analysis_options module UnsignedOverflow = False (struct let module_name = "UnsignedOverflow" let option_name = "-warn-unsigned-overflow" let help = "generate alarms for unsigned operations that overflow" end) (* Signed downcast are implementation-defined behaviors. *) let () = Plugin.set_group analysis_options module SignedDowncast = False (struct let module_name = "SignedDowncast" let option_name = "-warn-signed-downcast" let help = "generate alarms when signed downcasts may exceed the \ destination range" end) (* Unsigned downcasts are ok, but might not always be a behavior the programmer wants. *) let () = Plugin.set_group analysis_options module UnsignedDowncast = False (struct let module_name = "UnsignedDowncast" let option_name = "-warn-unsigned-downcast" let help = "generate alarms when unsigned downcasts may exceed the \ destination range" end) (* ************************************************************************* *) (** {2 Others options} *) (* ************************************************************************* *) let misc = add_group "Miscellaneous Options" let () = Cmdline.add_option_without_action "-then" ~plugin:"" ~group:(misc :> Cmdline.Group.t) ~help:"parse options before `-then' and execute Frama-C \ accordingly, then parse options after `-then' and re-execute Frama-C" ~visible:true ~ext_help:"" () let () = Cmdline.add_option_without_action "-then-on" ~plugin:"" ~argname:"p" ~group:(misc :> Cmdline.Group.t) ~help:"like `-then', but the second group of actions is executed \ on project

    " ~visible:true ~ext_help:"" () let () = Plugin.set_group misc let () = Plugin.set_negative_option_name "" let () = Plugin.set_cmdline_stage Cmdline.Early module NoType = Bool (struct let module_name = "NoType" let default = not Cmdline.use_type let option_name = "-no-type" let help = "" end) let () = Plugin.set_group misc let () = Plugin.set_negative_option_name "" let () = Plugin.set_cmdline_stage Cmdline.Early module NoObj = Bool (struct let module_name = "NoObj" let default = not Cmdline.use_obj let option_name = "-no-obj" let help = "" end) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/command.mli0000644000175000017500000001346412155630171020176 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Useful high-level system operations. @plugin development guide *) (* ************************************************************************* *) (** {2 File Utilities} *) (* ************************************************************************* *) val filename : string -> string -> string val pp_to_file : string -> (Format.formatter -> unit) -> unit (** [pp_to_file file pp] runs [pp] on a formatter that writes into [file]. The formatter is always properly flushed and closed on return. Exceptions in [pp] are re-raised after closing. *) val pp_from_file : Format.formatter -> string -> unit (** [pp_from_file fmt file] dumps the content of [file] into the [fmt]. Exceptions in [pp] are re-raised after closing. *) val bincopy : string -> in_channel -> out_channel -> unit (** [copy buffer cin cout] reads [cin] until end-of-file and copy it in [cout]. [buffer] is a temporary string used during the copy. Recommanded size is [2048]. *) val copy : string -> string -> unit (** [copy source target] copies source file to target file using [bincopy]. *) val read_file : string -> (in_channel -> 'a) -> 'a (** Properly close the channel and re-raise exceptions *) val read_lines : string -> (string -> unit) -> unit (** Iter over all text lines in the file *) val write_file : string -> (out_channel -> 'a) -> 'a (** Properly close the channel and re-raise exceptions *) val print_file : string -> (Format.formatter -> 'a) -> 'a (** Properly flush and close the channel and re-raise exceptions *) (* ************************************************************************* *) (** {2 Timing Utility} *) (* ************************************************************************* *) type timer = float ref type 'a result = Result of 'a | Error of exn val catch : ('a -> 'b) -> 'a -> 'b result val return : 'a result -> 'a val time : ?rmax:timer -> ?radd:timer -> ('a -> 'b) -> 'a -> 'b (** Compute the ellapsed time with [Sys.time]. The [rmax] timer is maximized and the [radd] timer is cumulated. Computed result is returned, or exception is re-raised. *) (* ************************************************************************* *) (** {2 System commands} *) (* ************************************************************************* *) val full_command : string -> string array -> stdin:Unix.file_descr -> stdout:Unix.file_descr -> stderr:Unix.file_descr -> Unix.process_status (** Same arguments as {Unix.create_process} but returns only when execution is complete. @raise Sys_error when a system error occurs *) type process_result = | Not_ready of (unit -> unit) | Result of Unix.process_status (** [Not_ready f] means that the child process is not yet finished and may be terminated manually with [f ()]. *) val full_command_async : string -> string array -> stdin:Unix.file_descr -> stdout:Unix.file_descr -> stderr:Unix.file_descr -> (unit -> process_result) (** Same arguments as {Unix.create_process}. @return a function to call to check if the process execution is complete. You must call this function until it returns a Result to prevent Zombie processes. @raise Sys_error when a system error occurs *) val command_async : ?stdout:Buffer.t -> ?stderr:Buffer.t -> string -> string array -> (unit -> process_result) (** Same arguments as {Unix.create_process}. @return a function to call to check if the process execution is complete. You must call this function until it returns a Result to prevent Zombie processes. When this function returns a Result, the stdout and stderr of the child process will be filled into the arguments buffer. @raise Sys_error when a system error occurs *) val command : ?timeout:int -> ?stdout:Buffer.t -> ?stderr:Buffer.t -> string -> string array -> Unix.process_status (** Same arguments as {Unix.create_process}. When this function returns, the stdout and stderr of the child process will be filled into the arguments buffer. @raise Sys_error when a system error occurs @raise Db.Cancel when the computation is interrupted or on timeout *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/globals.ml0000644000175000017500000005143112155630171020026 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Cil (* ************************************************************************* *) (** {2 Global variables} *) (* ************************************************************************* *) (* redefinition from Kernel_function.ml *) let get_formals f = match f.fundec with | Definition(d, _) -> d.sformals | Declaration(_, _, None, _) -> [] | Declaration(_,_,Some args,_) -> args let get_locals f = match f.fundec with | Definition(d, _) -> d.slocals | Declaration(_, _, _, _) -> [] let find_first_stmt = Extlib.mk_fun "Globals.find_first_stmt" let find_enclosing_block = Extlib.mk_fun "Globals.find_enclosing_block" module Vars = struct include Cil_state_builder.Varinfo_hashtbl (Initinfo) (struct let name = "Globals.Vars" let dependencies = [ Ast.self ] let size = 17 end) exception AlreadyExists of varinfo * initinfo let add vi info = ignore (memo ~change:(fun info -> raise (AlreadyExists(vi, info))) (fun _ -> info) vi) let add_decl vi = add vi { init = None } let get_astinfo_ref : (Cil_types.varinfo -> string * localisation) ref = Extlib.mk_fun "get_astinfo_ref" exception Found of varinfo let find_from_astinfo name = function | VGlobal -> (try iter (fun v _ -> if v.vname = name then raise (Found v)); raise Not_found with Found v -> v) | VLocal kf -> List.find (fun v -> v.vname = name) (get_locals kf) | VFormal kf -> List.find (fun v -> v.vname = name) (get_formals kf) let get_astinfo vi = !get_astinfo_ref vi let pp_varinfo p fmt v = let name, loc = get_astinfo v in let pp fmt = Format.fprintf fmt "@[Globals.Vars.find_from_astinfo@;%S@;%a@]" name (Cil_datatype.Localisation.internal_pretty_code Type.Call) loc in Type.par p Type.Call fmt pp let () = Varinfo.internal_pretty_code_ref := pp_varinfo let iter_in_file_order f = let treat_global = function | GVar(vi,init,_) -> f vi init | GVarDecl (_,vi,_) when not (Cil.isFunctionType vi.vtype) -> f vi { init = None } | GType _ | GCompTag _ | GCompTagDecl _ | GEnumTag _ | GEnumTagDecl _ | GVarDecl _ | GFun _ | GAsm _ | GPragma _ | GText _ | GAnnot _ -> () in List.iter treat_global (Ast.get ()).globals let fold_in_file_order f acc = let treat_global acc g = match g with | GVar(vi,init,_) -> f vi init acc | GVarDecl (_,vi,_) when not (Cil.isFunctionType vi.vtype) -> f vi { init = None } acc | GType _ | GCompTag _ | GCompTagDecl _ | GEnumTag _ | GEnumTagDecl _ | GVarDecl _ | GFun _ | GAsm _ | GPragma _ | GText _ | GAnnot _ -> acc in List.fold_left treat_global acc (Ast.get ()).globals end let () = Ast.add_linked_state Vars.self (* ************************************************************************* *) (** {2 Functions} *) (* ************************************************************************* *) module Functions = struct module State = Cil_state_builder.Varinfo_hashtbl (Cil_datatype.Kf) (struct let name = "Functions" let dependencies = [ Ast.self ] let size = 17 end) let self = State.self (* Maintain an alphabetical ordering of the functions, so that iteration stays independent from vid numerotation scheme. NB: Might be possible to have a map from string to vi in order to use the structure for find_by_name *) module VarinfoAlphaOrderSet = struct let compare x y = let res = String.compare x.vname y.vname in if res = 0 then Datatype.Int.compare x.vid y.vid else res module Data = Set.Make (struct type t = varinfo let compare = compare end) module Elts = struct include Cil_datatype.Varinfo let compare = compare end include Datatype.Set (Data)(Elts)(struct let module_name = "VarinfoAlphaOrderSet" end) end module Iterator = State_builder.Set_ref (VarinfoAlphaOrderSet) (struct let name = "FunctionsOrder" let dependencies = [ State.self ] end) let init_kernel_function f spec = { fundec = f; return_stmt = None; spec = spec } let fundec_of_decl spec v l = let args = try Some (getFormalsDecl v) with Not_found -> try setFormalsDecl v v.vtype; Some (getFormalsDecl v) with Not_found -> None (* function with 0 arg. See setFormalsDecl code for details *) in Declaration(spec, v, args, l) let register_declaration action spec v l = action (fun v -> init_kernel_function (fundec_of_decl spec v l) spec) v let add_declaration = register_declaration (fun f v -> Iterator.add v; State.memo f v) let update_kf kf fundec spec = kf.fundec <- fundec; (* Kernel.feedback "UPDATE Spec of function %a (%a)" Cil_datatype.Kf.pretty kf Printer.pp_funspec spec;*) let loc = match kf.fundec with | Definition (_, loc) | Declaration (_, _, _, loc) -> loc in Cil.CurrentLoc.set loc; Logic_utils.merge_funspec kf.spec spec; kf.return_stmt <- None let replace_by_declaration s v l= (* Kernel.feedback "replacing %a by decl" Cil_datatype.Varinfo.pretty v;*) if State.mem v then begin let fundec = fundec_of_decl s v l in let kf = State.find v in update_kf kf fundec s end else register_declaration (fun f v -> Iterator.add v; State.replace v (f v)) s v l let replace_by_definition spec f l = (* Kernel.feedback "replacing %a" Cil_datatype.Varinfo.pretty f.svar;*) Iterator.add f.svar; if State.mem f.svar then update_kf (State.find f.svar) (Definition (f,l)) spec else State.replace f.svar (init_kernel_function (Definition (f, l)) spec); try ignore (Cil.getFormalsDecl f.svar) with Not_found -> Cil.unsafeSetFormalsDecl f.svar f.sformals let add f = match f with | Definition (n, l) -> Kernel.debug "@[Register definition %a with specification@. \"%a\"@]" Varinfo.pretty_vname n.svar Cil_printer.pp_funspec n.sspec ; replace_by_definition n.sspec n l; (* Kernel.MainFunction.set_possible_values (n.svar.vname :: Kernel.MainFunction.get_possible_values ()) *) | Declaration (spec, v,_,l) -> Kernel.debug "@[Register declaration %a with specification@ \"%a\"@]" Varinfo.pretty_vname v Cil_printer.pp_funspec spec; replace_by_declaration spec v l let iter f = Iterator.iter (fun v -> f (State.find v)) let fold f = Iterator.fold (fun v acc -> f (State.find v) acc) let iter_on_fundecs f = iter (fun kf -> match kf.fundec with | Definition (fundec,_) -> f fundec | Declaration _ -> ()) let get vi = (*Kernel.feedback "get %a in %a" Cil_datatype.Varinfo.pretty vi Project.pretty (Project.current()); *) if not (Ast_info.is_function_type vi) then raise Not_found; let add v = (* Builtins don't automatically get a kernel function (unless they are used explicitly), but might still be accessed after AST elaboration. Corresponding kf will be built according to needs. Other functions must exist in the table whatever happens. *) (*Kernel.feedback "adding empty fun for %a" Cil_datatype.Varinfo.pretty vi; *) if Cil.is_special_builtin v.vname then add_declaration (empty_funspec ()) v v.vdecl else raise Not_found in State.memo add vi let get_params kf = match kf.fundec with | Definition(f,_loc) -> f.sformals | Declaration(_spec,_v,params,_loc) -> match params with None -> [] | Some ls -> ls let get_vi kf = match kf.fundec with | Definition(f,_loc) -> f.svar | Declaration(_spec,v,_params,_loc) -> v let register kf = let vi = get_vi kf in let add _ = kf in let change old_kf = if old_kf != kf then Kernel.fatal "Trying to associate two distinct \ kernel functions with same varinfo %a" Cil_datatype.Varinfo.pretty vi else old_kf in ignore (State.memo ~change add vi); Iterator.add vi exception Found_kf of kernel_function let find_by_name fct_name = let f kf = if Ast_info.Function.get_name kf.fundec = fct_name then raise (Found_kf kf) in try iter f; raise Not_found with Found_kf kf -> kf let find_def_by_name fct_name = let f kf = if Ast_info.Function.is_definition kf.fundec && Ast_info.Function.get_name kf.fundec = fct_name then raise (Found_kf kf) in try iter f; raise Not_found with Found_kf kf -> kf let () = Plugin.set_function_names (fun () -> State.fold (fun _ kf acc -> let f = kf.fundec in if Ast_info.Function.is_definition f then Ast_info.Function.get_name f :: acc else acc) []) let find_englobing_kf ki = match ki with | Kglobal -> None | Kstmt s -> try iter (fun kf -> match kf.fundec with | Definition (fundec,_) -> if List.exists (fun sa -> sa.sid = s.sid) fundec.sallstmts then raise (Found_kf kf) | Declaration _ -> ()); None with Found_kf kf -> Some kf let find_englobing_kf = Kernel.deprecated "Globals.Functions.find_englobing_kf" ~now:"Kernel_function.find_englobing_kf" find_englobing_kf exception Found of kernel_function let get_astinfo vi = vi.vname, if vi.vglob then VGlobal else begin if vi.vformal then begin try iter (fun kf -> if List.exists (Cil_datatype.Varinfo.equal vi) (get_formals kf) then raise (Found kf)); assert false with Found kf -> VFormal kf end else begin try iter (fun kf -> if List.exists (Cil_datatype.Varinfo.equal vi) (get_locals kf) then raise (Found kf)); assert false with Found kf -> VLocal kf end end let () = Vars.get_astinfo_ref := get_astinfo; Ast.add_linked_state State.self; Ast.add_linked_state Iterator.self end (* ************************************************************************* *) (** {2 Globals associated to filename} *) (* ************************************************************************* *) module FileIndex = struct let name = "FileIndex" module S = State_builder.Hashtbl (Datatype.String.Hashtbl) (Datatype.Pair(Datatype.String)(Datatype.List(Global))) (struct let name = name let dependencies = [ Ast.self ] let size = 7 end) let compute, self = let compute () = iterGlobals (Ast.get ()) (fun glob -> let f = (fst (Global.loc glob)).Lexing.pos_fname in if Kernel.debug_atleast 1 then Kernel.debug "Indexing global in file %s@." f; ignore (S.memo ~change:(fun (f,l) -> f, glob:: l) (fun _ -> f,[ glob ]) f)) in State_builder.apply_once "FileIndex.compute" [ S.self ] compute let remove_global_annotations a = let f = (fst (Global_annotation.loc a)).Lexing.pos_fname in try let _, l = S.find f in let l = List.filter (fun g -> match g with | GAnnot(a', _) -> not (Global_annotation.equal a a') | _ -> true) l in S.replace f (f, l) with Not_found -> assert false let get_files () = compute (); S.fold (fun key _ keys -> key :: keys) [] let get_symbols ~filename = compute (); try S.find filename with Not_found -> (* ??? *) S.find (Filename.basename filename) let find ~filename = let f,l = get_symbols ~filename in f, List.rev l let get_symbols ~filename = snd (get_symbols ~filename) (** get all global variables as (varinfo, initinfo) list with only one occurence of a varinfo *) let get_globals ~filename = compute (); let varinfo_set = let l = try snd (S.find filename) with Not_found -> [] in List.fold_right (fun glob acc -> let is_glob_varinfo x = if x.vglob then match x.vtype with | TFun _ -> None | _ -> Some x else None in let is_glob_var v = match v with | Cil_types.GVar (vi, _, _) -> is_glob_varinfo vi | Cil_types.GVarDecl(_,vi, _) -> is_glob_varinfo vi | _ -> None in match is_glob_var glob with | None -> acc | Some vi -> Varinfo.Set.add vi acc) l Varinfo.Set.empty in Varinfo.Set.fold (fun vi acc -> (vi, Vars.find vi) :: acc) varinfo_set [] let get_global_annotations ~filename = compute (); let l = try snd (S.find filename) with Not_found -> [] in List.fold_right (fun glob acc -> match glob with | Cil_types.GAnnot(g, _) -> g :: acc | _ -> acc) l [] let get_functions ?(declarations=false) ~filename = compute (); let varinfo_set = let l = try snd (S.find filename) with Not_found -> [] in List.fold_right (fun glob acc -> let is_func v = match v with | Cil_types.GFun(fundec, _) -> Some (fundec.svar) | Cil_types.GVarDecl(_,x, _) -> if x.vglob then match x.vtype with | TFun _ -> if declarations || (match (Functions.get x).fundec with Definition _ -> false | Declaration _ -> true) then Some x else None | _ -> None else None | _ -> None in match is_func glob with | None -> acc | Some vi -> Varinfo.Set.add vi acc) l Varinfo.Set.empty in Varinfo.Set.fold (fun vi acc -> Functions.get vi :: acc) varinfo_set [] let kernel_function_of_local_var_or_param_varinfo x = compute (); let is_param = ref false in let pred g = let pred symb = (x.Cil_types.vid = symb.Cil_types.vid) in match g with | Cil_types.GFun (fundec, _) -> if List.exists pred fundec.Cil_types.slocals then true else if List.exists pred fundec.Cil_types.sformals then (is_param := true; true) else false | _ -> false in let file = (fst x.Cil_types.vdecl).Lexing.pos_fname in match List.find pred (snd (S.find file)) with | Cil_types.GFun (fundec, _) -> Functions.get fundec.Cil_types.svar, !is_param | _ -> assert (false) end (* ************************************************************************* *) (** {2 Entry point} *) (* ************************************************************************* *) exception No_such_entry_point of string let entry_point () = Ast.compute (); let kf_name, lib = Kernel.MainFunction.get (), Kernel.LibEntry.get () in try Functions.find_by_name kf_name, lib with Not_found -> raise (No_such_entry_point (Format.sprintf "cannot find entry point `%s'.@;\ Please use option `-main' for specifying a valid entry point." kf_name)) let set_entry_point name lib = let clear_from_entry_point () = let selection = State_selection.union (State_selection.with_dependencies Kernel.MainFunction.self) (State_selection.with_dependencies Kernel.LibEntry.self) in Project.clear ~selection () in let has_changed = lib <> Kernel.LibEntry.get () || name <> Kernel.MainFunction.get () in if has_changed then begin clear_from_entry_point (); Kernel.MainFunction.unsafe_set name; Kernel.LibEntry.unsafe_set lib; end (* ************************************************************************* *) (** {2 Global Comments} *) (* ************************************************************************* *) module Comments_global_cache = State_builder.Hashtbl (Cil_datatype.Global.Hashtbl) (Datatype.List(Datatype.String)) (struct let name = "Comments_global_cache" let dependencies = [ Cabshelper.Comments.self; FileIndex.self ] let size = 17 end) module Comments_stmt_cache = State_builder.Hashtbl (Cil_datatype.Stmt.Hashtbl) (Datatype.List(Datatype.String)) (struct let name = "Comments_stmt_cache" let dependencies = [ Cabshelper.Comments.self; FileIndex.self ] let size = 17 end) let get_comments_global g = let last_pos f = { Lexing.pos_fname = f; Lexing.pos_lnum = max_int; Lexing.pos_cnum = max_int; Lexing.pos_bol = max_int } in let add g = let my_loc = Cil_datatype.Global.loc g in let file = (fst my_loc).Lexing.pos_fname in let globs = FileIndex.get_symbols file in let globs = List.sort (fun g1 g2 -> Cil_datatype.Location.compare (Cil_datatype.Global.loc g1) (Cil_datatype.Global.loc g2)) globs in let rec find_prev l = match l with | [] -> Kernel.fatal "Cannot find global %a in file %s" Cil_printer.pp_global g file | g' :: l when Cil_datatype.Global.equal g g' -> { Lexing.pos_fname = file; Lexing.pos_lnum = 1; Lexing.pos_cnum = 0; Lexing.pos_bol = 0; }, l = [] | g' :: g'' :: l when Cil_datatype.Global.equal g'' g -> snd (Cil_datatype.Global.loc g'), l = [] | _ :: l -> find_prev l in let first, is_last = find_prev globs in match g with GFun (f,_) -> let kf = Functions.get f.svar in let s = !find_first_stmt kf in let last = fst (Cil_datatype.Stmt.loc s) in let comments = Cabshelper.Comments.get (first,last) in if is_last then begin let first = snd my_loc in let last = last_pos file in comments @ (Cabshelper.Comments.get (first, last)) end else comments | _ -> let last = if is_last then last_pos file else snd my_loc in Cabshelper.Comments.get (first,last) in Comments_global_cache.memo add g let get_comments_stmt s = let add s = let b = !find_enclosing_block s in let rec find_prev l = match l with | [] -> Kernel.fatal "Cannot find statement %d in its enclosing block" s.sid | s' :: _ when Cil_datatype.Stmt.equal s s' -> fst (Cil_datatype.Stmt.loc s') | s' :: s'' :: _ when Cil_datatype.Stmt.equal s'' s -> snd (Cil_datatype.Stmt.loc s') | { skind = UnspecifiedSequence l1} :: l2 -> find_prev ((List.map (fun (x,_,_,_,_) -> x) l1) @ l2) | _::l -> find_prev l in let first = find_prev b.bstmts in let last = snd (Cil_datatype.Stmt.loc s) in Cabshelper.Comments.get (first,last) in Comments_stmt_cache.memo add s (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/cilE.ml0000644000175000017500000003760112155630171017262 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Cil extensions for Frama-C *) open Cil_types open Cil (* ************************************************************************* *) (* [JS 2011/03/11] All the below stuff manage warnings of the value analysis plug-in. Refactoring required. *) (* ************************************************************************* *) (* [JS 2012/10/17] pretty printing hack to preserve previous behavior which displays low <= lv < high whenever possible. Currently, the default printer does not do that. *) let local_printer: Printer.extensible_printer = object (self) inherit Printer.extensible_printer () as super method predicate fmt = function | Pand({ content = Prel(rel1, low, t) }, { content = Prel(rel2, _, up) }) -> (* explicit use the undocumented form of the built annotation... *) Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@]" super#term low Printer.pp_relation rel1 super#term t Printer.pp_relation rel2 super#term up | p -> super#predicate fmt p method code_annotation fmt ca = match ca.annot_content with | AAssert(_, p) -> (* ignore the name *) Format.fprintf fmt "@[assert@ %a;@]" self#predicate p.content | _ -> assert false end let current_stmt_tbl = let s = Stack.create () in Stack.push Kglobal s; s let start_stmt ki = Stack.push ki current_stmt_tbl let end_stmt () = try ignore (Stack.pop current_stmt_tbl) with Stack.Empty -> assert false let current_stmt () = try Stack.top current_stmt_tbl with Stack.Empty -> assert false type syntactic_context = | SyNone | SyCallResult | SyBinOp of Cil_types.exp * Cil_types.binop * Cil_types.exp * Cil_types.exp | SyUnOp of Cil_types.exp | SyMem of Cil_types.lval | SyMemLogic of Cil_types.term | SySep of Cil_types.lval * Cil_types.lval let syntactic_context = ref SyNone let set_syntactic_context e = (* (match e with | SyBinOp (e1,e2) -> ignore (Cil.warn "New binary context: %a %a\n" Cil.d_exp e1 Cil.d_exp e2) | SyUnOp e -> ignore (Cil.warn "New unary context: %a\n" Cil.d_exp e) | SyMem e -> ignore (Cil.warn "New mem context: %a\n" Cil.d_lval e) | SyNone -> ignore (Cil.warn "New null context\n"));*) syntactic_context := e let get_syntactic_context () = current_stmt (),!syntactic_context let sc_kinstr_loc ki = match ki with | Kglobal -> (* can occur in case of obscure bugs (already happended) with wacky initializers. Module Initial_state of value analysis correctly positions the loc *) assert (Cil_datatype.Kinstr.equal Kglobal (fst (get_syntactic_context ()))); CurrentLoc.get () | Kstmt s -> Cil_datatype.Stmt.loc s type alarm_behavior = { a_log: (Emitter.t * (Format.formatter -> unit)) option; a_call: unit -> unit;} let a_ignore = {a_log=None;a_call=Extlib.nop} type warn_mode = {imprecision_tracing:alarm_behavior; defined_logic: alarm_behavior; unspecified: alarm_behavior; others: alarm_behavior;} let warn_all_mode emitter suffix = let alog = {a_log=Some (emitter, suffix); a_call=Extlib.nop} in { imprecision_tracing = alog; defined_logic = alog; unspecified = alog; others = alog; } let warn_none_mode = { imprecision_tracing = a_ignore; defined_logic = a_ignore; unspecified = a_ignore; others=a_ignore; } let do_warn {a_log=log;a_call=call} f = Extlib.may f log; call () let register_alarm ?kf ?(status=Property_status.Dont_know) e ki a = Alarms.register ~loc:(sc_kinstr_loc ki) ?kf ~status e ki a let warn_div warn_mode = do_warn warn_mode.others (fun (emitter, suffix) -> match get_syntactic_context () with | _,SyNone -> () | _,(SyUnOp _ | SyMem _ | SyMemLogic _ | SySep _ | SyCallResult) -> assert false | ki, (SyBinOp (_, (Div|Mod), _, e)) -> let annot, is_new = register_alarm emitter ki (Alarms.Division_by_zero e) in if is_new then Kernel.warning ~current:true "@[division by zero:@ %a@]%t" local_printer#code_annotation annot suffix; |_, SyBinOp _ -> assert false) (** Auxiliary function that displays two simultaneous alarms as a conjunction *) let warn_conjuctive_annots warn annot1 annot2 = match annot1, annot2 with | Some annot, None | None, Some annot -> warn annot | Some { annot_content = AAssert(_, pmn) }, Some { annot_content = AAssert(_, pmx) } -> let p = Logic_const.pand (pmn, pmx) in let annot = Logic_const.new_code_annotation (AAssert([], p)) in warn annot | _, _ -> () let warn_integer_overflow warn_mode ~signed ~min:mn ~max:mx = do_warn warn_mode.others (fun (emitter, suffix) -> match get_syntactic_context () with | ki, (SyUnOp e | SyBinOp(e, _, _, _)) -> let warn annot = Kernel.warning ~current:true "@[%s overflow.@ %a@]%t" (if signed then "signed" else "unsigned") local_printer#code_annotation annot suffix in let signed lower bound = Extlib.may_map ~dft:None (fun n -> let kind = if signed then Alarms.Signed else Alarms.Unsigned in let annot, is_new = register_alarm emitter ki (Alarms.Overflow(kind, e, n, lower)) in if is_new then Some annot else None) bound in warn_conjuctive_annots warn (signed Alarms.Lower_bound mn) (signed Alarms.Upper_bound mx) | _ -> assert false) let warn_float_to_int_overflow warn_mode mn mx msg = do_warn warn_mode.others (fun (emitter, suffix) -> match get_syntactic_context () with | ki, SyUnOp e -> let warn annot = Kernel.warning ~current:true "@[overflow@ in conversion@ of %t@ from@ floating-point@ \ to integer.@ %a@]%t" msg local_printer#code_annotation annot suffix in let aux lower bound = Extlib.may_map ~dft:None (fun n -> let annot, is_new = register_alarm emitter ki (Alarms.Float_to_int(e, n, lower)) in if is_new then Some annot else None ) bound in warn_conjuctive_annots warn (aux Alarms.Lower_bound mn) (aux Alarms.Upper_bound mx) | _ -> assert false) let warn_shift warn_mode size = do_warn warn_mode.others (fun (emitter, suffix) -> match get_syntactic_context () with | _,SyNone -> () | _,(SyUnOp _ | SyMem _ | SyMemLogic _ | SySep _ | SyCallResult) -> assert false | ki,SyBinOp (_, (Shiftrt | Shiftlt),_,exp_d) -> let annot, is_new = register_alarm emitter ki (Alarms.Invalid_shift(exp_d, Some size)) in if is_new then Kernel.warning ~current:true "@[invalid RHS operand for shift.@ %a@]%t" local_printer#code_annotation annot suffix; | _, SyBinOp _ -> assert false) let warn_shift_left_positive warn_mode = do_warn warn_mode.others (fun (emitter, suffix) -> match get_syntactic_context () with | _,SyNone -> () | _, (SyUnOp _ | SyMem _ | SyMemLogic _ | SySep _ | SyCallResult) -> assert false | ki, SyBinOp (_, (Shiftrt | Shiftlt),exp_l,_) -> let annot, is_new = register_alarm emitter ki (Alarms.Invalid_shift(exp_l, None)) in if is_new then Kernel.warning ~current:true "@[invalid LHS operand for left shift.@ %a@]%t" local_printer#code_annotation annot suffix | _, SyBinOp _ -> assert false) let pretty_warn_mem_mode fmt m = Format.pp_print_string fmt (match m with Alarms.For_reading -> "read" | Alarms.For_writing -> "write") let warn_mem warn_mode wmm = do_warn warn_mode.others (fun (emitter, suffix) -> let warn_term ki mk_alarm = let valid = wmm in let annot, is_new = register_alarm emitter ki (mk_alarm valid) in if is_new then Kernel.warning ~current:true "@[out of bounds %a.@ %a@]%t" pretty_warn_mem_mode wmm local_printer#code_annotation annot suffix; in match get_syntactic_context () with | _,SyNone -> () | _,(SyBinOp _ | SyUnOp _ | SySep _ | SyCallResult) -> assert false | ki,SyMem lv_d -> warn_term ki (fun v -> Alarms.Memory_access(lv_d, v)); (match lv_d with | Mem _,_ | _, (Index _ | Field _) -> () | Var v, NoOffset -> match Base.validity_from_type v with | Base.Invalid | Base.Unknown _ | Base.Periodic _ -> () | Base.Known _ -> (* Invalid syntactic context, or deep bug *) Kernel.fatal "ERR 937: %a@." Printer.pp_lval lv_d) | ki,SyMemLogic term -> warn_term ki (fun v -> Alarms.Logic_memory_access(term, v))) let warn_mem_read warn_mode = warn_mem warn_mode Alarms.For_reading let warn_mem_write warn_mode = warn_mem warn_mode Alarms.For_writing let warn_index warn_mode ~positive ~range = do_warn warn_mode.others (fun (emitter, suffix) -> match get_syntactic_context () with | _,SyNone -> () | _,(SyMem _ | SyMemLogic _ | SyUnOp _ | SySep _ | SyCallResult) -> assert false | ki ,SyBinOp (_, IndexPI, e1, e2) -> let left = if not positive then Some (register_alarm emitter ki (Alarms.Index_out_of_bound(e1, None))) else None in let annot, is_new = register_alarm emitter ki (Alarms.Index_out_of_bound(e1, Some e2)) in let warn a = Kernel.warning ~current:true "@[accessing out of bounds index %s.@ @[%a@]@]%t" range local_printer#code_annotation a suffix in if is_new then let a = match left, annot with | None, _ | Some(_, false), _ -> annot | Some({ annot_content = AAssert(_, l) }, true), { annot_content = AAssert(_, r) } -> let p = Logic_const.pand (l, r) in Logic_const.new_code_annotation (AAssert([], p)) | Some _, _ -> assert false in warn a else Extlib.may (fun (a, b) -> if b then warn a) left | _, SyBinOp _ -> assert false) let warn_pointer_comparison warn_mode = do_warn warn_mode.defined_logic (fun (emitter, suffix) -> let aux ki e1 e2 = let annot, is_new = register_alarm emitter ki (Alarms.Pointer_comparison (e1, e2)) in if is_new then Kernel.warning ~current:true "@[pointer comparison:@ %a@]%t" local_printer#code_annotation annot suffix; in match get_syntactic_context () with | _,SyNone -> () | _,(SyMem _ | SyMemLogic _ | SySep _ | SyCallResult) -> assert false | ki, SyUnOp e -> aux ki None e | ki, SyBinOp (_, (Eq|Ne|Ge|Le|Gt|Lt), e1, e2) -> aux ki (Some e1) e2 | _, SyBinOp _ -> assert false) let warn_nan_infinite warn_mode fkind pp = let sfkind = match fkind with | None -> "real" | Some FFloat -> "float" | Some FDouble -> "double" | Some FLongDouble -> "long double" in do_warn warn_mode.others (fun (emitter, suffix) -> match get_syntactic_context () with | _,SyNone -> () | _,(SyBinOp _ | SyMem _ | SyMemLogic _ | SySep _) -> assert false | _, SyCallResult -> (* cf. bug 997 *) Kernel.warning ~current:true ~once:true "@[non-finite@ %s@ value being@ returned:@ \ assert(\\is_finite(\\returned_value))@]%t" sfkind suffix; | ki,SyUnOp (exp_r) -> (* Should always be called with a non-none fkind, except in logic mode (in which case this code is not executed *) let fkind = Extlib.the fkind in let annot, is_new = register_alarm emitter ki (Alarms.Is_nan_or_infinite (exp_r, fkind)) in if is_new then Kernel.warning ~current:true ~once:true "@[non-finite@ %s@ value@ (%t):@ %a@]" sfkind pp local_printer#code_annotation annot) let warn_uninitialized warn_mode = do_warn warn_mode.unspecified (fun (emitter, suffix) -> match get_syntactic_context () with | _, SyNone | _, (SyBinOp _ | SyUnOp _ | SySep _ | SyMemLogic _) -> assert false | _, SyCallResult -> Kernel.warning ~once:true ~current:true "@[returned value may be uninitialized:@ \ assert \\initialized(\\returned_value)@]%t" suffix; | ki, SyMem lv_d -> let annot, is_new = register_alarm emitter ki (Alarms.Uninitialized lv_d) in if is_new then Kernel.warning ~current:true "@[accessing uninitialized left-value:@ %a@]" local_printer#code_annotation annot) let warn_escapingaddr warn_mode = do_warn warn_mode.unspecified (fun (_emitter, suffix) -> match get_syntactic_context () with | _,SyNone -> () | _,(SyBinOp _ | SyUnOp _ | SySep _ | SyMemLogic _) -> assert false | _, SyCallResult -> Kernel.warning ~once:true ~current:true "@[returned value may be contain escaping addresses:@ \ assert \\defined(\\returned_value)@]%t" suffix; | _,SyMem lv_d -> (* TODO Ook *) Kernel.warning ~once:true ~current:true "@[accessing left-value@ that contains@ escaping@ addresses;\ @ assert(\\defined(&%a))@]%t" Printer.pp_lval lv_d suffix) let warn_separated warn_mode = do_warn warn_mode.others (fun (emitter, suffix) -> match get_syntactic_context () with | _,SyNone -> () | _,(SyBinOp _ | SyUnOp _ | SyMem _ | SyMemLogic _| SyCallResult) -> assert false | ki,SySep(lv1,lv2) -> let annot, is_new = register_alarm emitter ki (Alarms.Not_separated(lv1, lv2)) in if is_new then Kernel.warning ~current:true "@[undefined multiple accesses in expression.@ %a@]%t" local_printer#code_annotation annot suffix) let warn_overlap (loc1, loc2) warn_mode = do_warn warn_mode.others (fun (emitter, suffix) -> match get_syntactic_context () with | _,SyNone -> () | _,(SyBinOp _ | SyUnOp _ | SyMem _ | SyMemLogic _| SyCallResult) -> assert false | ki,SySep(lv1,lv2) -> let annot, is_new = register_alarm emitter ki (Alarms.Overlap(lv1, lv2)) in if is_new then Kernel.warning ~current:true "@[partially overlapping@ lvalue assignment@ \ (%a,@ size %a bits;@ %a,@ size %a bits).@ %a@]%t" (Locations.pretty_english ~prefix:false) loc1 Int_Base.pretty loc1.Locations.size (Locations.pretty_english ~prefix:false) loc2 Int_Base.pretty loc2.Locations.size local_printer#code_annotation annot suffix) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/unroll_loops.ml0000644000175000017500000005070612155630171021136 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Syntactic loop unrolling. *) open Cil_types open Cil open Cil_datatype open Visitor let dkey = Kernel.register_category "ulevel" let extract_from_pragmas s times = let annot = Annotations.code_annot s in let pragmas = Logic_utils.extract_loop_pragma annot in let get_nb_times (found_times,_ as elt) p = let get_nb_times _ spec = match spec with | {term_type=typ} when Logic_typing.is_integral_type typ -> if found_times then (Kernel.warning ~once:true ~current:true "ignoring unrolling directive (directive already defined)"; raise Not_found) else (try begin match isInteger (Cil.constFold true (!Db.Properties.Interp.term_to_exp None spec)) with | Some i -> Some (Integer.to_int i) | None -> Kernel.warning ~once:true ~current:true "ignoring unrolling directive (not a constant expression)"; raise Not_found end with Invalid_argument s -> Kernel.warning ~once:true ~current:true "ignoring unrolling directive (%s)" s; raise Not_found) | _ -> None in match p with | Unroll_specs specs -> (try begin match List.fold_left get_nb_times None specs with | Some i -> true, i | None -> elt end with Not_found -> elt) | _ -> elt in let times = snd (List.fold_left get_nb_times (false, times) pragmas) in let is_total_unrolling spec = match spec with | {term_node=TConst (LStr "completely") } -> true | _ -> false in let is_total_unrolling = function | Unroll_specs specs -> List.exists is_total_unrolling specs | _ -> false in times, (List.exists is_total_unrolling pragmas) let fresh_label = let counter = ref (-1) in fun ?loc ?label_name () -> decr counter; let loc, orig = match loc with | None -> CurrentLoc.get (), false | Some loc -> loc, true and new_label_name = let prefix = match label_name with None -> "" | Some s -> s ^ "_" in Format.sprintf "%sunrolling_%d_loop" prefix (- !counter) in Label (new_label_name, loc, orig) let copy_var = let counter = ref (-1) in fun () -> decr counter; fun vi -> let vi' = Cil_const.copy_with_new_vid vi in let name = vi.vname ^ "_unroll_" ^ (string_of_int (- !counter)) in Cil_const.change_varinfo_name vi' name; vi' let refresh_vars new_var old_var = let assoc = List.combine old_var new_var in let visit = object inherit Visitor.frama_c_inplace method vvrbl vi = try ChangeTo (snd (List.find (fun (x,_) -> x.vid = vi.vid) assoc)) with Not_found -> SkipChildren end in Visitor.visitFramacStmt visit (* Takes care of local gotos and labels into C. *) let update_gotos sid_tbl block = let goto_updater = object inherit nopCilVisitor method vstmt s = match s.skind with | Goto(sref,_loc) -> (try (* A deep copy has already be done. Just modifies the reference in place. *) let new_stmt = Cil_datatype.Stmt.Map.find !sref sid_tbl in sref := new_stmt with Not_found -> ()) ; DoChildren | _ -> DoChildren (* speed up: skip non interesting subtrees *) method vvdec _ = SkipChildren (* via visitCilFunction *) method vspec _ = SkipChildren (* via visitCilFunction *) method vcode_annot _ = SkipChildren (* via Code_annot stmt *) method vloop_annot _ = SkipChildren (* via Loop stmt *) method vexpr _ = SkipChildren (* via stmt such as Return, IF, ... *) method vlval _ = SkipChildren (* via stmt such as Set, Call, Asm, ... *) method vattr _ = SkipChildren (* via Asm stmt *) end in visitCilBlock (goto_updater:>cilVisitor) block let is_referenced stmt l = let module Found = struct exception Found end in let vis = object inherit Visitor.frama_c_inplace method vlogic_label l = match l with | StmtLabel s when !s == stmt -> raise Found.Found | _ -> DoChildren end in try List.iter (fun x -> ignore (Visitor.visitFramacStmt vis x)) l; false with Found.Found -> true (* Deep copy of annotations taking care of labels into annotations. *) let copy_annotations kf assoc labelled_stmt_tbl (stmt_src,stmt_dst) = let fresh_annotation a = let visitor = object inherit Visitor.frama_c_copy (Project.current()) method vlogic_var_use vi = match vi.lv_origin with None -> SkipChildren | Some vi -> begin try let vi'= snd (List.find (fun (x,_) -> x.vid = vi.vid) assoc) in ChangeTo (Extlib.the vi'.vlogic_var_assoc) with Not_found -> SkipChildren | Invalid_argument _ -> Kernel.abort "Loop unrolling: cannot find new representative for \ local var %s" vi.vname end method vlogic_label (label:logic_label) = match label with | StmtLabel (stmt) -> (try (* A deep copy has already be done. Just modifies the reference in place. *) let new_stmt = Cil_datatype.Stmt.Map.find !stmt labelled_stmt_tbl in ChangeTo (StmtLabel (ref new_stmt)) with Not_found -> SkipChildren) ; | LogicLabel (None, _str) -> SkipChildren | LogicLabel (Some _stmt, str) -> ChangeTo (LogicLabel (None, str)) end in visitCilCodeAnnotation (visitor:>cilVisitor) (Logic_const.refresh_code_annotation a) in let new_annots = Annotations.fold_code_annot (fun emitter annot acc -> Kernel.debug ~dkey "Copying an annotation to stmt %d from stmt %d@." stmt_dst.sid stmt_src.sid; let new_annot = fresh_annotation annot in (emitter, new_annot) :: acc) stmt_src [] in List.iter (fun (e, a) -> Annotations.add_code_annot e ~kf stmt_dst a) new_annots let update_loop_current kf loop_current block = let vis = object(self) inherit Visitor.frama_c_inplace initializer self#set_current_kf kf method vlogic_label = function | LogicLabel(_,"LoopCurrent") -> ChangeTo (StmtLabel (ref loop_current)) | _ -> DoChildren method vstmt_aux s = match s.skind with | Loop _ -> SkipChildren (* loop init and current are not the same here. *) | _ -> DoChildren end in ignore (Visitor.visitFramacBlock vis block) let update_loop_entry kf loop_entry stmt = let vis = object(self) inherit Visitor.frama_c_inplace initializer self#set_current_kf kf method vlogic_label = function | LogicLabel(_,"LoopEntry") -> ChangeTo (StmtLabel (ref loop_entry)) | _ -> DoChildren method vstmt_aux s = match s.skind with | Loop _ -> SkipChildren (* loop init and current are not the same here. *) | _ -> DoChildren end in ignore (Visitor.visitFramacStmt vis stmt) (* Deep copy of a block taking care of local gotos and labels into C code and annotations. *) let copy_block kf break_continue_must_change bl = let assoc = ref [] in let fundec = try Kernel_function.get_definition kf with Kernel_function.No_Definition -> assert false and annotated_stmts = ref [] and labelled_stmt_tbl = Stmt.Map.empty and calls_tbl = Stmt.Map.empty in let rec copy_stmt break_continue_must_change labelled_stmt_tbl calls_tbl stmt = let result = { labels = []; sid = Sid.next (); succs = []; preds = []; skind = stmt.skind; ghost = stmt.ghost} in let new_labels,labelled_stmt_tbl = if stmt.labels = [] then [], labelled_stmt_tbl else let new_tbl = Stmt.Map.add stmt result labelled_stmt_tbl and new_labels = List.fold_left (fun lbls -> function | Label (s, loc, gen) -> (if gen then fresh_label ~label_name:s () else fresh_label ~label_name:s ~loc () ) :: lbls | Case _ | Default _ as lbl -> lbl :: lbls ) [] stmt.labels in new_labels, new_tbl in let new_calls_tbl = match stmt.skind with | Instr(Call _) -> Stmt.Map.add stmt result calls_tbl | _ -> calls_tbl in let new_stmkind,new_labelled_stmt_tbl, new_calls_tbl = copy_stmtkind break_continue_must_change labelled_stmt_tbl new_calls_tbl stmt.skind in if stmt.labels <> [] then result.labels <- new_labels; result.skind <- new_stmkind; if Annotations.has_code_annot stmt then begin Kernel.debug ~dkey "Found an annotation to copy for stmt %d from stmt %d@." result.sid stmt.sid; annotated_stmts := (stmt,result) :: !annotated_stmts; end; result, new_labelled_stmt_tbl, new_calls_tbl and copy_stmtkind break_continue_must_change labelled_stmt_tbl calls_tbl stkind = match stkind with |(Instr _ | Return _) as keep -> keep,labelled_stmt_tbl,calls_tbl | Goto (stmt_ref, loc) -> Goto (ref !stmt_ref, loc),labelled_stmt_tbl,calls_tbl | If (exp,bl1,bl2,loc) -> CurrentLoc.set loc; let new_block1,labelled_stmt_tbl,calls_tbl = copy_block break_continue_must_change labelled_stmt_tbl calls_tbl bl1 in let new_block2,labelled_stmt_tbl,calls_tbl = copy_block break_continue_must_change labelled_stmt_tbl calls_tbl bl2 in If(exp,new_block1,new_block2,loc),labelled_stmt_tbl,calls_tbl | Loop (a,bl,loc,_,_) -> CurrentLoc.set loc; let new_block,labelled_stmt_tbl,calls_tbl = copy_block None (* from now on break and continue can be kept *) labelled_stmt_tbl calls_tbl bl in Loop (a,new_block,loc,None,None),labelled_stmt_tbl,calls_tbl | Block bl -> let new_block,labelled_stmt_tbl,calls_tbl = copy_block break_continue_must_change labelled_stmt_tbl calls_tbl bl in Block (new_block),labelled_stmt_tbl,calls_tbl | UnspecifiedSequence seq -> let change_calls lst calls_tbl = List.map (fun x -> ref (Stmt.Map.find !x calls_tbl)) lst in let new_seq,labelled_stmt_tbl,calls_tbl = List.fold_left (fun (seq,labelled_stmt_tbl,calls_tbl) (stmt,modified,writes,reads,calls) -> let stmt,labelled_stmt_tbl,calls_tbl = copy_stmt break_continue_must_change labelled_stmt_tbl calls_tbl stmt in (stmt,modified,writes,reads,change_calls calls calls_tbl)::seq, labelled_stmt_tbl,calls_tbl) ([],labelled_stmt_tbl,calls_tbl) seq in UnspecifiedSequence (List.rev new_seq),labelled_stmt_tbl,calls_tbl | Break loc -> (match break_continue_must_change with | None -> stkind | Some (brk_lbl_stmt,_) -> Goto ((ref brk_lbl_stmt),loc)), labelled_stmt_tbl, calls_tbl | Continue loc -> (match break_continue_must_change with | None -> stkind | Some (_,continue_lbl_stmt) -> Goto ((ref continue_lbl_stmt),loc)), labelled_stmt_tbl, calls_tbl | Switch (e,block,stmts,loc) -> (* from now on break and continue can be kept *) let new_block,new_labelled_stmt_tbl,calls_tbl = copy_block None labelled_stmt_tbl calls_tbl block in let stmts' = List.map (fun s -> Stmt.Map.find s new_labelled_stmt_tbl) stmts in Switch(e,new_block,stmts',loc),new_labelled_stmt_tbl,calls_tbl | TryFinally _ | TryExcept _ -> assert false and copy_block break_continue_must_change labelled_stmt_tbl calls_tbl bl = let new_stmts,labelled_stmt_tbl,calls_tbl = List.fold_left (fun (block_l,labelled_stmt_tbl,calls_tbl) v -> let new_block,labelled_stmt_tbl,calls_tbl = copy_stmt break_continue_must_change labelled_stmt_tbl calls_tbl v in new_block::block_l, labelled_stmt_tbl,calls_tbl) ([],labelled_stmt_tbl,calls_tbl) bl.bstmts in let new_locals = List.map (copy_var ()) bl.blocals in fundec.slocals <- fundec.slocals @ new_locals; assoc:=(List.combine bl.blocals new_locals) @ !assoc; let new_block = mkBlock (List.rev_map (refresh_vars new_locals bl.blocals) new_stmts) in new_block.blocals <- new_locals; new_block,labelled_stmt_tbl,calls_tbl in let new_block, labelled_stmt_tbl, _calls_tbl = (* [calls_tbl] is internal. No need to fix references afterwards here. *) copy_block break_continue_must_change labelled_stmt_tbl calls_tbl bl in List.iter (copy_annotations kf !assoc labelled_stmt_tbl) !annotated_stmts ; update_gotos labelled_stmt_tbl new_block (* Update to take into account annotations*) class do_it (emitter,(times:int)) = object(self) inherit Visitor.frama_c_inplace (* We sometimes need to move labels between statements. This table maps the old statement to the new one *) val moved_labels = Cil_datatype.Stmt.Hashtbl.create 17 val mutable gotos = [] ; val mutable has_unrolled_loop = false ; val mutable file_has_unrolled_loop = false ; method get_file_has_unrolled_loop () = file_has_unrolled_loop ; method vfunc fundec = assert (gotos = []) ; assert (not has_unrolled_loop) ; let post_goto_updater = (fun id -> if has_unrolled_loop then List.iter (fun s -> match s.skind with Goto(sref,_loc) -> (try let new_stmt = Cil_datatype.Stmt.Hashtbl.find moved_labels !sref in sref := new_stmt with Not_found -> ()) | _ -> assert false) gotos ; has_unrolled_loop <- false ; gotos <- [] ; Cil_datatype.Stmt.Hashtbl.clear moved_labels ; id) in ChangeDoChildrenPost (fundec, post_goto_updater) method vstmt_aux s = match s.skind with | Goto _ -> gotos <- s::gotos; (* gotos that may need to be updated *) DoChildren | Switch _ -> (* Update the labels pointed to by the switch if needed *) let update s = if has_unrolled_loop then (match s.skind with | Switch (e', b', lbls', loc') -> let labels_moved = ref false in let update_label s = try let s = Cil_datatype.Stmt.Hashtbl.find moved_labels s in labels_moved := true ; s with Not_found -> s in let moved_lbls = List.map update_label lbls' in if !labels_moved then s.skind <- Switch (e', b', moved_lbls, loc'); | _ -> ()); s in ChangeDoChildrenPost (s, update) | Loop _ -> let number, is_total_unrolling = extract_from_pragmas s times in let f sloop = Kernel.debug ~dkey "Unrolling loop stmt %d (%d times) inside function %a@." sloop.sid number Kernel_function.pretty (Extlib.the self#current_kf); file_has_unrolled_loop <- true ; has_unrolled_loop <- true ; match sloop.skind with | Loop(_,block,loc,_,_) -> (* Note: loop annotations are kept into the remaining loops, but are not transformed into statement contracts inside the unrolled parts. *) (* TODO: transforms loop annotations into statement contracts inside the unrolled parts. *) CurrentLoc.set loc; let break_lbl_stmt = let break_label = fresh_label () in let break_lbl_stmt = mkEmptyStmt () in break_lbl_stmt.labels <- [break_label]; break_lbl_stmt.sid <- Cil.Sid.next (); break_lbl_stmt in let mk_continue () = let continue_label = fresh_label () in let continue_lbl_stmt = mkEmptyStmt () in continue_lbl_stmt.labels <- [continue_label] ; continue_lbl_stmt.sid <- Cil.Sid.next (); continue_lbl_stmt in let current_continue = ref (mk_continue ()) in let new_stmts = ref [sloop] in for _i=0 to number-1 do new_stmts:=!current_continue::!new_stmts; let new_block = copy_block (Extlib.the self#current_kf) (Some (break_lbl_stmt,!current_continue)) block in current_continue := mk_continue (); update_loop_current (Extlib.the self#current_kf) !current_continue new_block; (match new_block.blocals with [] -> new_stmts:= new_block.bstmts @ !new_stmts; | _ -> (* keep the block in order to preserve locals decl *) new_stmts:= mkStmt (Block new_block) :: !new_stmts); done; let new_stmt = match !new_stmts with | [ s ] -> s | l -> List.iter (update_loop_entry (Extlib.the self#current_kf) !current_continue) l; let l = if is_referenced !current_continue l then !current_continue :: l else l in let new_stmts = l @ [break_lbl_stmt] in let new_block = mkBlock new_stmts in let snew = mkStmt (Block new_block) in (* Move the labels in front of the original loop at the top of the new code *) Cil_datatype.Stmt.Hashtbl.add moved_labels sloop snew; snew.labels <- sloop.labels; sloop.labels <- []; snew; in new_stmt | _ -> assert false in let g sloop new_stmts = let annot = Logic_const.new_code_annotation (AInvariant ([],true,Logic_const.pfalse)) in Annotations.add_code_annot emitter ~kf:(Extlib.the self#current_kf) sloop annot; new_stmts in let f = if number > 0 then f else (fun s -> s) in let g sloop = if is_total_unrolling then g sloop else (fun s -> s) in let fg sloop = g sloop (f sloop) in ChangeDoChildrenPost (s, fg) | _ -> DoChildren end (* Performs unrolling transformation without using -ulevel option. Do not forget to apply [transformations_closure] afterwards. *) let apply_transformation nb emitter (file,recompute_cfg) = (* [nb] default number of unrolling used when there is no UNROLL loop pragma. When [nb] is negative, no unrolling is done; all UNROLL loop pragmas are ignored. *) if nb >= 0 then let visitor = new do_it (emitter, nb) in Kernel.debug ~dkey "Using -ulevel %d option and UNROLL loop pragmas@." nb; visitFramacFileSameGlobals (visitor:>Visitor.frama_c_visitor) file ; file,(recompute_cfg || (visitor#get_file_has_unrolled_loop ())) else begin Kernel.debug ~dkey "No unrolling is done; all UNROLL loop pragmas are ignored@."; file, recompute_cfg end let transformations_closure (file,recompute_cfg) = if recompute_cfg then begin (* The CFG has be to recomputed *) Kernel.debug ~dkey "Closure: recomputing CFG@."; Cfg.clearFileCFG ~clear_id:false file; Cfg.computeFileCFG file; Ast.mark_as_changed () end ; (file, false) module Syntactic_transformations = Hook.Fold(struct type t = (Cil_types.file * bool) end) let add_syntactic_transformation = Syntactic_transformations.extend (* Performs and closes all syntactic transformations *) let compute file = let acc = Syntactic_transformations.apply (file,false) in let nb = Kernel.UnrollingLevel.get () in ignore (transformations_closure (apply_transformation nb Emitter.end_user acc)) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/stmts_graph.mli0000644000175000017500000001100012155630171021073 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Statements graph. @plugin development guide *) open Cil_types open Cil_datatype val stmt_can_reach: kernel_function -> stmt -> stmt -> bool (** [stmt_can_reach kf s1 s2] is [true] iff the control flow can reach [s2] starting at [s1] in function [kf]. *) val stmt_can_reach_filtered : (stmt -> bool) -> stmt -> stmt -> bool (** Just like [stmt_can_reach] but uses a function to filter the nodes of the graph it operates on. Note that the output of the filter function must be functionally dependent on its input *) val stmt_is_in_cycle : stmt -> bool (** [stmt_is_in_cycle s] is [true] iff [s] is reachable through a non trival path * starting at [s]. *) val stmt_is_in_cycle_filtered : (stmt -> bool) -> stmt -> bool (** Just like [stmt_is_in_cycle] but uses a function to filter the nodes of the graph it operates on. Note that the output of the filter function must be functionally dependent on its input *) val reachable_stmts: kernel_function -> stmt -> stmt list (** Get the statements that compose [s]. For a simple statement (not containing blocks), it is only the statement itself. *) val get_stmt_stmts : stmt -> Stmt.Set.t val get_block_stmts : block -> Stmt.Set.t (** Find the last statements in [s], meaning that if [s'] is in the returned statements, [s'] is in [s] statements, but a least one of its successor is not. *) val get_all_stmt_last_stmts : stmt -> stmt list val get_all_block_last_stmts : block -> stmt list (** Subset of [get_all_stmt_last_stmts] according to [termination_kind]. [termination_kind = None] means [Goto]. @raise Invalid_argument for [termination_kind = Some Exits] since every call possibly have an [Exits] termination: it should be handled differently. *) val get_stmt_last_stmts : termination_kind option -> stmt -> stmt list val get_block_last_stmts : termination_kind option -> block -> stmt list (** Find the entry edges that go inside [s] statements, * meaning that if the pair [(s1,s2)] is in the returned information, * [s2] is a successor of [s1] and [s2] is in [s] statements, but [s1] is not. * @since Nitrogen-20111001 **) val get_stmt_in_edges : stmt -> (stmt * stmt) list val get_block_in_edges : block -> (stmt * stmt) list (** Like [get_stmt_in_edges] but for edges going out of [s] statements. * Similar to [get_all_stmt_last_stmts] but gives the edge information * instead of just the first statement. * @since Nitrogen-20111001 *) val get_all_stmt_out_edges : stmt -> (stmt * stmt) list val get_all_block_out_edges : block -> (stmt * stmt) list (** Split the loop predecessors into: - the entry point : coming for outside the loop - the back edges. Notice that there might be nothing in the entry point when the loop if the first statement. @raise Invalid_argument if the statement is not a loop. *) val loop_preds : stmt -> stmt list * stmt list (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/ast.ml0000644000175000017500000001500112155630171017163 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 module Initial_datatype = Datatype include State_builder.Option_ref (Cil_datatype.File) (struct let name = "AST" let dependencies = [ Cil.selfMachine; Kernel.SimplifyCfg.self; Kernel.KeepSwitch.self; Kernel.UnrollingLevel.self; Kernel.Constfold.self; Kernel.ReadAnnot.self; Kernel.PreprocessAnnot.self; Kernel.Files.self; Cil.selfFormalsDecl ] end) let mark_as_computed () = mark_as_computed () (* eta-expansion required *) let linked_states = ref [ Logic_env.Logic_info.self; Logic_env.Logic_type_info.self; Logic_env.Logic_ctor_info.self; Logic_env.Model_info.self; Logic_env.Lemmas.self; Cil.selfFormalsDecl ] let add_linked_state state = linked_states := state :: !linked_states let monotonic_states = ref [] let add_monotonic_state state = monotonic_states := state :: !monotonic_states let mark_as_changed () = let depends = State_selection.only_dependencies self in let no_remove = State_selection.list_state_union !linked_states in let selection = State_selection.diff depends no_remove in Project.clear ~selection () let mark_as_grown () = let depends = State_selection.only_dependencies self in let no_remove = State_selection.list_state_union !linked_states in let no_remove = State_selection.union no_remove (State_selection.list_state_union !monotonic_states) in let selection = State_selection.diff depends no_remove in Project.clear ~selection () let () = State_dependency_graph.add_dependencies ~from:self [ Cil_datatype.Stmt.Hptset.self; Cil_datatype.Varinfo.Hptset.self ]; add_monotonic_state Cil_datatype.Stmt.Hptset.self; add_monotonic_state Cil_datatype.Varinfo.Hptset.self; Cil.register_ast_dependencies self; Logic_env.init_dependencies self; module After_building = Hook.Build(struct type t = Cil_types.file end) let apply_after_computed = After_building.extend let () = Plugin.set_ast_hook apply_after_computed let () = List.iter apply_after_computed !Plugin.init_ast_hooks exception Bad_Initialization of string exception NoUntypedAst let default_initialization = ref (fun () -> raise (Bad_Initialization "Cil file not initialized")) let set_default_initialization f = default_initialization := f let syntactic_constant_folding ast = Cil.visitCilFileSameGlobals (Cil.constFoldVisitor true) ast let force_compute () = Kernel.feedback ~level:2 "computing the AST"; !default_initialization (); let s = get () in (* Syntactic constant folding before analysing files if required *) if Kernel.Constfold.get () then syntactic_constant_folding s; After_building.apply s; s let get () = memo (fun () -> force_compute ()) let is_computed () = is_computed () let compute () = if not (is_computed ()) then ignore (force_compute ()) let set_file file = let change old_file = if old_file == file then old_file else raise (Bad_Initialization "Too many AST initializations") in ignore (memo ~change (fun () -> mark_as_computed (); After_building.apply file; file)) module UntypedFiles = struct let compute_untyped () = if not (is_computed()) then ignore (force_compute()) else raise NoUntypedAst include State_builder.Option_ref (Initial_datatype.List(Cil_datatype.Cabs_file)) (struct let name = "Untyped AST" let dependencies = (* the others delayed until file.ml *) [ Cil.selfMachine; self (* can't be computed without the AST *) ] end) let get () = memo (fun () -> compute_untyped (); get ()) end module LastDecl = State_builder.Hashtbl (Cil_datatype.Varinfo.Hashtbl) (Cil_datatype.Global) (struct let name = "Ast.LastDecl" let dependencies = [ self ] let size = 47 end) let compute_last_decl () = (* Only meaningful when we have definitely computed the AST. *) if is_computed () && not (LastDecl.is_computed ()) then begin let globs = (get ()).globals in let update_one_global g = match g with | GVarDecl(_,v,_) when Cil.isFunctionType v.vtype -> LastDecl.replace v g | GFun (f,_) -> LastDecl.replace f.svar g | _ -> () in List.iter update_one_global globs; LastDecl.mark_as_computed () end let is_last_decl g = (* Not_found mainly means that the information is irrelevant at this stage, not that there is a dangling varinfo. *) let is_eq v = compute_last_decl (); try (LastDecl.find v == g) with Not_found -> false in match g with | GVarDecl(_,v,_) -> is_eq v | GFun(f,_) -> is_eq f.svar | _ -> false let clear_last_decl () = let selection = State_selection.Static.with_dependencies LastDecl.self in Project.clear ~selection () let add_hook_on_update f = add_hook_on_update (fun _ -> f ()) let () = add_hook_on_update Cil_datatype.clear_caches (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/journal.mli0000644000175000017500000001202512155630171020222 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Journalization of functions. @plugin development guide *) (* ****************************************************************************) (** {2 Journalization} *) (* ****************************************************************************) val register: string -> 'a Type.t -> ?comment:(Format.formatter -> unit) -> ?is_dyn:bool -> 'a -> 'a (** [register name ty ~comment ~is_dyn v] journalizes the value [v] of type [ty] with the name [name]. [name] must exactly match the caml long name of the value (i.e. "List.iter" and not "iter" even though the module List is already opened). Journalisation of anonymous value is not possible. If the [comment] argument is set, the given pretty printer will be applied in an OCaml comment when the function is journalized. Set [is_dyn] to [true] to journalize a dynamic function. *) val never_write: string -> 'a -> 'a (** [never_write name f] returns a closure [g] observationaly equal to [f] except that trying to write a call to [g] in the journal is an error. If [f] is not a closure, then [never_write name f] raises [Invalid_argument]. *) val prevent: ('a -> 'b) -> 'a -> 'b (** [prevent f x] applies [x] to [f] without printing anything in the journal, even if [f] is journalized. *) module Binding: sig val add: 'a Type.t -> 'a -> string -> unit (** [add ty v var] binds the value [v] to the variable name [var]. Thus, [pp ty v] prints [var] and not use the standard pretty printer. Very useful to pretty print values with no associated pretty printer. *) exception Name_already_exists of string val add_once: 'a Type.t -> 'a -> string -> unit (** Same as function [add] above but raise the exception [Already_exists] if the binding previously exists *) end (* JS 2012/02/07: useful only for BM introspection testing ;-) *) module Reverse_binding: sig (* Raised by [find] *) exception Unbound_value of string exception Incompatible_type of string val fill: unit -> unit val find: string -> 'a Type.t -> 'a val iter: (string -> 'a Type.t -> 'a -> unit) -> unit val pretty: Format.formatter -> unit -> unit end (* ****************************************************************************) (** {2 Journal management} *) (* ****************************************************************************) val get_name: unit -> string (** @return the filename which the journal will be written into. *) val set_name: string -> unit (** [set_journal_name name] changes the filename into the journal will be written. The new filename is [name ^ ".ml"]. *) val write: unit -> unit (** [write ()] writes the content of the journal into the file set by [set_name] (or in "frama_c_journal.ml" by default); without clearing the journal. *) val save: unit -> unit (** Save the current state of the journal for future restauration. @since Beryllium-20090901 *) val restore: unit -> unit (** Restore a previously saved journal. @since Beryllium-20090901 *) (* ****************************************************************************) (** {2 Internal use only} *) (* ****************************************************************************) val keep_file: string -> unit (** This function has not to be used explictely. Only offers functions retrieving when running a journal file. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/emitter.mli0000644000175000017500000001435712155630171020233 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Emitter. An emitter is the Frama-C entity which is able to emit annotations and property status. Thus you have to create (at least) one of your own if you want to do such tasks. @since Nitrogen-20111001 @plugin development guide *) (**************************************************************************) (** {2 API for Plug-ins Developers} *) (**************************************************************************) type emitter type kind = Property_status | Alarm | Code_annot | Funspec | Global_annot (** When selecting [Alarm], [Code_annot] is also automatically selected *) include Datatype.S_with_collections with type t = emitter val create: string -> kind list -> correctness:Parameter.t list -> tuning:Parameter.t list -> t (** [Emitter.create name kind ~correctness ~tuning] creates a new emitter with the given name. The given parameters are the ones which impact the generated annotations/status. A "correctness" parameter may fully change a generated element when its value changes (for instance, a valid status may become invalid and conversely). A "tuning" parameter may improve a generated element when its value changes (for instance, a "dont_know" status may become valid or invalid, but a valid status cannot become invalid). The given name must be unique. @raise Invalid_argument if an emitter with the given name already exist @plugin development guide *) val get_name: t -> string val correctness_parameters: t -> string list val tuning_parameters: t -> string list val end_user: t (** The special emitter corresponding to the end-user. Only the kernel should use this emitter when emitting annotations or statuses. @since Oxygen-20120901 *) val kernel: t (** The special emitter corresponding to the kernel. Only the kernel should use this emitter when emitting annotations or statuses. @since Oxygen-20120901 *) (** Usable emitters are the ones which can really emit something. *) module Usable_emitter: sig include Datatype.S_with_collections val get: t -> emitter (** Get the emitter from an usable emitter. Not so efficient. @since Oxygen-20120901 *) val get_name: t -> string val get_unique_name: t -> string val correctness_parameters: t -> string list val tuning_parameters: t -> string list val pretty_parameter: Format.formatter -> tuning:bool -> t -> string -> unit (** Pretty print the parameter (given by its name) with its value. @raise Not_found if the parameter is not one of the given emitter *) end val distinct_tuning_parameters: Usable_emitter.t -> Datatype.String.Set.t (** Return the tuning parameter which distinguishes this usable emitter from the other ones. @since Oxygen-20120901 *) val distinct_correctness_parameters: Usable_emitter.t -> Datatype.String.Set.t (** Return the correctness_parameters which distinguishes this usable emitter from the other ones. @since Oxygen-20120901 *) (* ********************************************************************** *) (** {2 Kernel Internal API} *) (* ********************************************************************** *) val get: t -> Usable_emitter.t (** Get the emitter which is really able to emit something. This function must be called at the time of the emission. No action must occur between the call to [get] and the emission (in particular no update of any parameter of the emitter. *) val self: State.t (** Table indexing: key -> emitter (or equivalent data) -> value. Quick access + handle cleaning in the right way (only remove relevant bindings when required. @since Oxygen-20120901 *) module Make_table (H: Datatype.Hashtbl) (E: sig include Datatype.S_with_collections val local_clear: H.key -> 'a Hashtbl.t -> unit val usable_get: t -> Usable_emitter.t val get: t -> emitter end) (D: Datatype.S) (Info: sig include State_builder.Info_with_size val kinds: kind list end) : sig type internal_tbl = D.t E.Hashtbl.t val self: State.t val add: H.key -> internal_tbl -> unit val find: H.key -> internal_tbl val mem: H.key -> bool val iter: (H.key -> internal_tbl -> unit) -> unit val fold: (H.key -> internal_tbl -> 'a -> 'a) -> 'a -> 'a val remove: H.key -> unit val add_hook_on_remove: (E.t -> H.key -> D.t -> unit) -> unit (** Register a hook to be applied whenever a binding is removed from the table. @since Fluorine-20130401 *) val apply_hooks_on_remove: E.t -> H.key -> D.t -> unit (** This function must be called on each binding which is removed from the table without directly calling the function {!remove}. @since Fluorine-20130401 *) end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/messages.mli0000644000175000017500000000454512155630171020367 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Stored messages. Storing of messages can be changed using {Kernel.Collect_messages.set} (at initialization time only); currently, only warning and error messages are stored if thus requested. *) val iter: (Log.event -> unit) -> unit (** Iter over all stored messages. The messages are passed in emission order. @modify Nitrogen-20111001 Messages are now passed in emission order. *) val dump_messages: unit -> unit (** Dump stored messages to standard channels *) val self: State.t (** Internal state of stored messages *) val reset_once_flag : unit -> unit (** Reset the [once] flag of pretty-printers. Messages already printed will be printed again. @since Boron-20100401 *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/boot.ml0000644000175000017500000000672412155630171017353 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Frama-C Entry Point (last linked module). @plugin development guide *) let run_plugins () = if Kernel.TypeCheck.get () then if Kernel.Files.get () <> [] || Kernel.TypeCheck.is_set () then begin Ast.compute (); (* Printing files before anything else (in debug mode only) *) if Kernel.debug_atleast 1 && Kernel.Debug_category.exists (fun s -> s = "ast") then File.pretty_ast () end; try Dynamic.Main.apply (); (* for Helium-compatibility purpose only *) Db.Main.apply (); (* Printing code if required, have to be done at end *) if Kernel.PrintCode.get () then File.pretty_ast (); with Globals.No_such_entry_point msg -> Kernel.abort "%s" msg let on_from_name name f = match name with | None -> f () | Some s -> try Project.on (Project.from_unique_name s) f () with Not_found -> Kernel.abort "no project %S." s let () = Db.Main.play := run_plugins (* ************************************************************************* *) (** Booting Frama-C *) (* ************************************************************************* *) (* Customisation of pretty-printers' parameters. *) let boot_cil () = Cil.miscState.Cil.lineDirectiveStyle <- None; Cil.miscState.Cil.printCilAsIs <- Kernel.debug_atleast 1; Cil_printer.state.Printer_api.line_directive_style <- None; Cil_printer.state.Printer_api.print_cil_as_is <- Kernel.debug_atleast 1 (* Main: let's go! *) let () = boot_cil (); Sys.catch_break true; Cmdline.catch_toplevel_run ~f:(fun () -> Journal.set_name (Kernel.Journal.Name.get ()); ignore (Project.create "default"); Cmdline.parse_and_boot on_from_name (fun () -> !Db.Toplevel.run) run_plugins) ~at_normal_exit:Cmdline.run_normal_exit_hook ~quit:true ~on_error:Cmdline.run_error_exit_hook; (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/special_hooks.mli0000644000175000017500000000344612155630171021402 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Nothing is export: just register some special hooks for Frama-C. @since Beryllium-20090601-beta1 @plugin development guide *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.. -j" End: *) frama-c-Fluorine-20130601/src/kernel/loop.mli0000644000175000017500000000425112155630171017523 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Operations on (natural) loops. @plugin development guide *) open Cil_types exception No_such_while val get_loop_stmts : kernel_function -> stmt -> Cil_datatype.Stmt.Set.t (** Precondition: the kernel function is not a leaf function. @raise No_such_while if [stmt.skind] is not a [While]. *) val is_natural : kernel_function -> stmt -> bool val get_naturals : kernel_function -> (stmt * stmt list) list val back_edges : kernel_function -> stmt -> stmt list val while_for_natural_loop : kernel_function -> stmt -> stmt (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/db.mli0000644000175000017500000023267612155630171017155 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Database in which static plugins are registered. @plugin development guide *) (** Modules providing general services: - {!Dynamic}: API for plug-ins linked dynamically - {!Journal}: journalisation - {!Log}: message outputs and printers - {!Plugin}: general services for plug-ins - {!Project} and associated files: {!Kind}, {!Datatype} and {!State_builder}. Other main kernel modules: - {!Ast}: the cil AST - {!Ast_info}: syntactic value directly computed from the Cil Ast - {!File}: Cil file initialization - {!Globals}: global variables, functions and annotations - {!Annotations}: annotations associated with a statement - {!Properties_status}: status of annotations - {!Kernel_function}: C functions as seen by Frama-C - {!Stmts_graph}: the statement graph - {!Loop}: (natural) loops - {!Visitor}: frama-c visitors - {!Kernel}: general parameters of Frama-C (mostly set from the command line) *) open Cil_types open Cil open Cil_datatype (* ************************************************************************* *) (** {2 Registering} *) (* ************************************************************************* *) (** How to journalize the given function. @since Beryllium-20090601-beta1 *) type 'a how_to_journalize = | Journalize of string * 'a Type.t (** Journalize the value with the given name and type. *) | Journalization_not_required (** Journalization of this value is not required (usually because it has no effect on the Frama-C global state). *) | Journalization_must_not_happen of string (** Journalization of this value should not happen (usually because it is a low-level function: this function is always called from a journalized function). The string is the function name which is used for displaying suitable error message. *) val register: 'a how_to_journalize -> 'a ref -> 'a -> unit (** Plugins must register values with this function. *) val register_compute: string -> State.t list -> (unit -> unit) ref -> (unit -> unit) -> State.t (** @modify Boron-20100401 now return the state of the computation. *) val register_guarded_compute: string -> (unit -> bool) -> (unit -> unit) ref -> (unit -> unit) -> unit (** Frama-C main interface. @since Lithium-20081201 @plugin development guide *) module Main: sig val extend : (unit -> unit) -> unit (** Register a function to be called by the Frama-C main entry point. @plugin development guide *) val play: (unit -> unit) ref (** Run all the Frama-C analyses. This function should be called only by toplevels. @since Beryllium-20090901 *) (**/**) val apply: unit -> unit (** Not for casual user. *) (**/**) end module Toplevel: sig val run: ((unit -> unit) -> unit) ref (** Run a Frama-C toplevel playing the game given in argument (in particular, applying the argument runs the analyses). @since Beryllium-20090901 *) end (* ************************************************************************* *) (** {2 Graphs} *) (* ************************************************************************* *) (** Callgraph computed by value analysis. It contains function pointers! *) module Semantic_Callgraph : sig val dump: (unit -> unit) ref (** Dump the semantic callgraph in stdout or in a file. *) val topologically_iter_on_functions : ((kernel_function -> unit) -> unit) ref (** Compute values if required. *) val iter_on_callers : ((kernel_function -> unit) -> kernel_function -> unit) ref (** Compute values if required. *) val accept_base : (with_formals:bool -> with_locals:bool -> kernel_function -> Base.t -> bool (** [accept_base formals locals kf b] returns [true] if and only [b] is - a global - a formal or local of one of the callers of [kf] - a formal or local of [kf] and the corresponding argument is [true] *) ) ref end (* ************************************************************************* *) (** {2 Values} *) (* ************************************************************************* *) (** The Value analysis itself. @see <../value/index.html> internal documentation. @plugin development guide *) module Value : sig type state = Cvalue.Model.t (** Internal state of the value analysis. *) type t = Cvalue.V.t (** Internal representation of a value. *) exception Aborted val self : State.t (** Internal state of the value analysis from projects viewpoint. @plugin development guide *) val mark_as_computed: unit -> unit (** Indicate that the value analysis has been done already. *) val compute : (unit -> unit) ref (** Compute the value analysis using the entry point of the current project. You may set it with {!Globals.set_entry_point}. @raise Globals.No_such_entry_point if the entry point is incorrect @raise Db.Value.Incorrect_number_of_arguments if some arguments are specified for the entry point using {!Db.Value.fun_set_args}, and an incorrect number of them is given. @plugin development guide *) val is_computed: unit -> bool (** Return [true] iff the value analysis has been done. @plugin development guide *) module Table: State_builder.Hashtbl with type key = stmt and type data = state (** Table containing the results of the value analysis, ie. the state before the evaluation of each reachable statement. *) module AfterTable: State_builder.Hashtbl with type key = stmt and type data = state (** Table containing the state of the value analysis after the evaluation of each reachable and evaluable statement. Filled only if [Value_parameters.ResultsAfter] is set. *) val degeneration_occurred: (Cil_types.kinstr -> Cil_types.lval option -> unit) ref (** This hook is called by the value analysis in the seldom case a total degeneration occurs. *) val ignored_recursive_call: kernel_function -> bool (** This functions returns true if the value analysis found and ignored a recursive call to this function during the analysis. *) val condition_truth_value: stmt -> bool * bool (** Provided [stmt] is an 'if' construct, [fst (condition_truth_value stmt)] (resp. snd) is true if and only if the condition of the 'if' has been evaluated to true (resp. false) at least once during the analysis. *) (** {3 Parameterization} *) exception Outside_builtin_possibilities (** Type for a Value builtin function *) type builtin_sig = (** Memory state at the beginning of the function *) state -> (** Args for the function: the expressions corresponding to the formals of the functions at the call site, the actual value of those formals, and a more precise view of those formals using offsetmaps (for eg. structs) *) (Cil_types.exp * Cvalue.V.t * Cvalue.V_Offsetmap.t) list -> Value_types.call_result val register_builtin: (string -> builtin_sig -> unit) ref (** [!record_builtin name ?override f] registers an abstract function [f] to use everytime a C function named [name] is called in the program. See also option [-val-builtin] *) val mem_builtin: (string -> bool) ref val use_spec_instead_of_definition: (kernel_function -> bool) ref (** To be called by derived analyses to determine if they must use the body of the function (if available), or only its spec. Used for value builtins, and option -val-use-spec. *) (** {4 Arguments of the main function} *) (** The functions below are related to the arguments that are passed to the function that is analysed by the value analysis. Specific arguments are set by [fun_set_args]. Arguments reset to default values when [fun_use_default_args] is called, when the ast is changed, or if the options [-libentry] or [-main] are changed. *) (** Specify the arguments to use. This function is not journalized, and will generate an error when the journal is replayed *) val fun_set_args : t list -> unit val fun_use_default_args : unit -> unit (** For this function, the result [None] means that default values are used for the arguments. *) val fun_get_args : unit -> t list option exception Incorrect_number_of_arguments (** Raised by [Db.Compute] when the arguments set by [fun_set_args] are not coherent with the prototype of the function (if there are too few or too many of them) *) (** {4 Initial state of the analysis} *) (** The functions below are related to the the value of the global variables when the value analysis is started. If [globals_set_initial_state] has not been called, the given state is used. A default state (which depends on the option [-libentry]) is used when [globals_use_default_initial_state] is called, or when the ast changes. *) (** Specify the initial state to use. This function is not journalized, and will generate an error when the journal is replayed *) val globals_set_initial_state : state -> unit val globals_use_default_initial_state : unit -> unit (** Initial state used by the analysis *) val globals_state : unit -> state (** Returns [true] if the initial state for globals used by the value analysis has been supplied by the user (through [globals_set_initial_state]), or [false] if it is automatically computed by the value analysis *) val globals_use_supplied_state : unit -> bool (** {3 Getters} *) (** State of the analysis at various points *) val get_initial_state : kernel_function -> state val get_state : kinstr -> state val get_stmt_state_callstack: after:bool -> stmt -> state Value_types.Callstack.Hashtbl.t option val get_stmt_state : stmt -> state (** @plugin development guide *) val find : state -> Locations.location -> t (** {3 Evaluations} *) val eval_lval : (with_alarms:CilE.warn_mode -> Locations.Zone.t option -> state -> lval -> Locations.Zone.t option * t) ref val eval_expr : (with_alarms:CilE.warn_mode -> state -> exp -> t) ref val eval_expr_with_state : (with_alarms:CilE.warn_mode -> state -> exp -> state * t) ref val find_lv_plus : (with_alarms:CilE.warn_mode -> Cvalue.Model.t -> Cil_types.exp -> (Cil_types.lval * Ival.t) list) ref (** returns the list of all decompositions of [expr] into the sum an lvalue and an interval. *) (** {3 Values and kernel functions} *) val expr_to_kernel_function : (kinstr -> with_alarms:CilE.warn_mode -> deps:Locations.Zone.t option -> exp -> Locations.Zone.t * Kernel_function.Hptset.t) ref val expr_to_kernel_function_state : (state -> deps:Locations.Zone.t option -> exp -> Locations.Zone.t * Kernel_function.Hptset.t) ref exception Not_a_call val call_to_kernel_function : stmt -> Kernel_function.Hptset.t (** Return the functions that can be called from this call. @raise Not_a_call if the statement is not a call. *) val valid_behaviors: (kernel_function -> state -> funbehavior list) ref val add_formals_to_state: (state -> kernel_function -> exp list -> state) ref (** [add_formals_to_state state kf exps] evaluates [exps] in [state] and binds them to the formal arguments of [kf] in the resulting state *) (** {3 Reachability} *) val is_accessible : kinstr -> bool val is_reachable : state -> bool (** @plugin development guide *) val is_reachable_stmt : stmt -> bool (** {3 About kernel functions} *) exception Void_Function val find_return_loc : kernel_function -> Locations.location (** Return the location of the returned lvalue of the given function. @raise Void_Function if the function does not return any value. *) val is_called: (kernel_function -> bool) ref val callers: (kernel_function -> (kernel_function*stmt list) list) ref (** @return the list of callers with their call sites. Each function is present only once in the list. *) (** {3 State before a kinstr} *) val access : (kinstr -> lval -> t) ref val access_expr : (kinstr -> exp -> t) ref val access_location : (kinstr -> Locations.location -> t) ref (** {3 State after a kinstr} *) val access_after : (kinstr -> lval -> t) ref (** @raise Not_found if the kinstr has no accessible successors. @deprecated since Carbon-20110201 Use {Record_Value_After_Callbacks} or ask for a better interface if you need this functionality *) val access_location_after : (kinstr -> Locations.location -> t) ref (** @raise Not_found if the kinstr has no accessible successors. @deprecated since Carbon-20110201 Use {Record_Value_After_Callbacks} or ask for a better interface if you need this functionality *) val lval_to_offsetmap_after : (kinstr -> lval -> Cvalue.V_Offsetmap.t option) ref (** @raise Not_found if the kinstr has no accessible successors. @deprecated since Carbon-20110201 Use {Record_Value_After_Callbacks} or ask for a better interface if you need this functionality *) (** {3 Locations of left values} *) val lval_to_loc : (kinstr -> with_alarms:CilE.warn_mode -> lval -> Locations.location) ref val lval_to_loc_with_deps : (kinstr -> with_alarms:CilE.warn_mode -> deps:Locations.Zone.t -> lval -> Locations.Zone.t * Locations.location) ref val lval_to_loc_with_deps_state : (state -> deps:Locations.Zone.t -> lval -> Locations.Zone.t * Locations.location) ref val lval_to_loc_state : (state -> lval -> Locations.location) ref val lval_to_offsetmap : ( kinstr -> lval -> with_alarms:CilE.warn_mode -> Cvalue.V_Offsetmap.t option) ref val lval_to_offsetmap_state : (state -> lval -> Cvalue.V_Offsetmap.t option) ref (** @since Carbon-20110201 *) val lval_to_zone : (kinstr -> with_alarms:CilE.warn_mode -> lval -> Locations.Zone.t) ref val lval_to_zone_state : (state -> lval -> Locations.Zone.t) ref (** Does not emit alarms. *) (** Evaluation of the [\from] clause of an [assigns] clause.*) val assigns_inputs_to_zone : (state -> identified_term assigns -> Locations.Zone.t) ref (** Evaluation of the left part of [assigns] clause (without [\from]).*) val assigns_outputs_to_zone : (state -> result:varinfo option -> identified_term assigns -> Locations.Zone.t) ref (** Evaluation of the left part of [assigns] clause (without [\from]). Each assigns term results in one location. *) val assigns_outputs_to_locations : (state -> result:varinfo option -> identified_term assigns -> Locations.location list) ref (** {3 Callbacks} *) type callstack = Value_types.callstack (** Actions to perform at end of each function analysis. Not compatible with option [-memexec-all] *) module Record_Value_Callbacks: Hook.Iter_hook with type param = callstack * (state Stmt.Hashtbl.t) Lazy.t module Record_Value_Superposition_Callbacks: Hook.Iter_hook with type param = callstack * (state list Stmt.Hashtbl.t) Lazy.t module Record_Value_After_Callbacks: Hook.Iter_hook with type param = callstack * (state Stmt.Hashtbl.t) Lazy.t (**/**) (* Temporary API, do not use *) module Record_Value_Callbacks_New: Hook.Iter_hook with type param = callstack * (state Stmt.Hashtbl.t) Lazy.t Value_types.callback_result (**/**) val no_results: (fundec -> bool) ref (** Returns [true] if the user has requested that no results should be recorded for this function. If possible, hooks registered on [Record_Value_Callbacks] and [Record_Value_Callbacks_New] should not force their lazy argument *) (** Actions to perform at each treatment of a "call" statement. *) module Call_Value_Callbacks: Hook.Iter_hook with type param = state * callstack (** {3 Pretty printing} *) val pretty : Format.formatter -> t -> unit val pretty_state_without_null : Format.formatter -> state -> unit val pretty_state : Format.formatter -> state -> unit val display : Format.formatter -> kernel_function -> unit val display_globals : Format.formatter -> unit -> unit (**/**) (** {3 Internal use only} *) val noassert_get_state : kinstr -> state (** To be used during the value analysis itself (instead of {!get_state}). *) val noassert_get_stmt_state : stmt -> state (** To be used during the value analysis itself (instead of {!get_stmt_state}). *) val recursive_call_occurred: kernel_function -> unit val merge_conditions: int Cil_datatype.Stmt.Hashtbl.t -> unit val mask_then: int val mask_else: int val initial_state_only_globals : (unit -> state) ref val update_table : stmt -> state -> unit (* Merge the given state with others associated to the given stmt. *) val update_callstack_table: after:bool -> stmt -> callstack -> state -> unit (* Merge a new state in the table indexed by callstacks. *) val memoize : (kernel_function -> unit) ref (* val compute_call : (kernel_function -> call_kinstr:kinstr -> state -> (exp*t) list -> Cvalue.V_Offsetmap.t option (** returned value of [kernel_function] *) * state) ref *) val merge_initial_state : kernel_function -> state -> unit (** Store an additional possible initial state for the given function as well as its values for actuals. *) val initial_state_changed: (unit -> unit) ref end (** Functional dependencies between function inputs and function outputs. @see <../from/index.html> internal documentation. *) module From : sig val compute_all : (unit -> unit) ref val compute_all_calldeps : (unit -> unit) ref val compute : (kernel_function -> unit) ref val is_computed: (kernel_function -> bool) ref (** Check whether the from analysis has been performed for the given function. @return true iff the analysis has been performed *) val get : (kernel_function -> Function_Froms.t) ref val access : (Locations.Zone.t -> Lmap_bitwise.From_Model.t -> Locations.Zone.t) ref val find_deps_no_transitivity : (stmt -> exp -> Locations.Zone.t) ref val find_deps_no_transitivity_state : (Value.state -> exp -> Locations.Zone.t) ref val self: State.t ref (** {3 Pretty printing} *) val pretty : (Format.formatter -> kernel_function -> unit) ref val display : (Format.formatter -> unit) ref (** {3 Internal use only} *) val update : (Locations.location -> Locations.Zone.t -> Lmap_bitwise.From_Model.t -> Lmap_bitwise.From_Model.t) ref module Record_From_Callbacks: Hook.Iter_hook with type param = Kernel_function.t Stack.t * Lmap_bitwise.From_Model.t Stmt.Hashtbl.t * (Kernel_function.t * Lmap_bitwise.From_Model.t) list Stmt.Hashtbl.t module Callwise : sig val iter : ((kinstr -> Function_Froms.t -> unit) -> unit) ref val find : (kinstr -> Function_Froms.t) ref end end (** Functions used by another function. @see <../users/index.html> internal documentation. *) module Users : sig val get: (kernel_function -> Kernel_function.Hptset.t) ref end (** Do not use yet. *) module Access_path : sig type t = (Locations.Zone.t * Locations.Location_Bits.t) Base.Map.t val compute: (Cvalue.Model.t -> Base.Set.t -> t) ref val filter: (t -> Locations.Zone.t -> t) ref val pretty: (Format.formatter -> t -> unit) ref end (* ************************************************************************* *) (** {2 Properties} *) (* ************************************************************************* *) (** Dealing with logical properties. *) module Properties : sig (** Interpretation of logic terms. *) module Interp : sig (** {3 From C terms to logic terms} *) val lval : (kernel_function -> stmt -> string -> Cil_types.term_lval) ref val expr : (kernel_function -> stmt -> string -> Cil_types.term) ref (** {3 From logic terms to C terms} *) val term_lval_to_lval: (result: Cil_types.varinfo option -> term_lval -> Cil_types.lval) ref (** @raise Invalid_argument if the argument is not a left value. *) val term_to_lval: (result: Cil_types.varinfo option -> term -> Cil_types.lval) ref (** @raise Invalid_argument if the argument is not a left value. *) val term_to_exp: (result: Cil_types.varinfo option -> term -> Cil_types.exp) ref (** @raise Invalid_argument if the argument is not a valid expression. *) val loc_to_exp: (result: Cil_types.varinfo option -> term -> Cil_types.exp list) ref (** @return a list of C expressions. @raise Invalid_argument if the argument is not a valid set of expressions. *) val loc_to_lval: (result: Cil_types.varinfo option -> term -> Cil_types.lval list) ref (** @return a list of C locations. @raise Invalid_argument if the argument is not a valid set of left values. *) val term_offset_to_offset: (result: Cil_types.varinfo option -> term_offset -> offset) ref (** @raise Invalid_argument if the argument is not a valid offset. *) val loc_to_offset: (result: Cil_types.varinfo option -> term -> Cil_types.offset list) ref (** @return a list of C offset provided the term denotes location who have all the same base address. *) (** {3 From logic terms to Locations.location} *) val loc_to_loc: (result: Cil_types.varinfo option -> Value.state -> term -> Locations.location) ref (** @raise Invalid_argument if the translation fails. *) val loc_to_locs: (result: Cil_types.varinfo option -> Value.state -> term -> Locations.location list * Locations.Zone.t) ref (** Translate a term more precisely than [loc_to_loc] if the term evaluates to an ACSL tset. The zone returned is the locations that have been read during evaluation. Warning: This API is not stabilized, and is likely to change in the future. @raise Invalid_argument in some cases. *) val identified_term_zone_to_loc: (result: Cil_types.varinfo option -> Value.state -> Cil_types.identified_term -> Locations.location) ref (** @raise Invalid_argument in some cases. @deprecated Carbon-20110201 use [loc_to_loc (...) x.it_content] instead *) (** {3 From logic terms to Zone.t} *) module To_zone : sig type t_ctx = {state_opt:bool option; ki_opt:(stmt * bool) option; kf:Kernel_function.t} val mk_ctx_func_contrat: (kernel_function -> state_opt:bool option -> t_ctx) ref (** To build an interpretation context relative to function contracts. *) val mk_ctx_stmt_contrat: (kernel_function -> stmt -> state_opt:bool option -> t_ctx) ref (** To build an interpretation context relative to statement contracts. *) val mk_ctx_stmt_annot: (kernel_function -> stmt -> t_ctx) ref (** To build an interpretation context relative to statement annotations. *) type t = {before:bool ; ki:stmt ; zone:Locations.Zone.t} type t_zone_info = (t list) option (** list of zones at some program points. * None means that the computation has failed. *) type t_decl = {var: Varinfo.Set.t ; (* related to vars of the annot *) lbl: Logic_label.Set.t} (* related to labels of the annot *) type t_pragmas = {ctrl: Stmt.Set.t ; (* related to //@ slice pragma ctrl/expr *) stmt: Stmt.Set.t} (* related to statement assign and //@ slice pragma stmt *) val from_term: (term -> t_ctx -> t_zone_info * t_decl) ref (** Entry point to get zones needed to evaluate the [term] relative to the [ctx] of interpretation. *) val from_terms: (term list -> t_ctx -> t_zone_info * t_decl) ref (** Entry point to get zones needed to evaluate the list of [terms] relative to the [ctx] of interpretation. *) val from_pred: (predicate named -> t_ctx -> t_zone_info * t_decl) ref (** Entry point to get zones needed to evaluate the [predicate] relative to the [ctx] of interpretation. *) val from_preds: (predicate named list -> t_ctx -> t_zone_info * t_decl) ref (** Entry point to get zones needed to evaluate the list of [predicates] relative to the [ctx] of interpretation. *) val from_zones: (identified_term list -> t_ctx -> t_zone_info * t_decl) ref (** Entry point to get zones needed to evaluate the list of [predicates] relative to the [ctx] of interpretation. @deprecated Carbon-20110201 use [from_terms (..) x.it_content] instead *) val from_zone: (identified_term -> t_ctx -> t_zone_info * t_decl) ref (** Entry point to get zones needed to evaluate the [zone] relative to the [ctx] of interpretation. *) val from_stmt_annot: (code_annotation -> stmt * kernel_function -> (t_zone_info * t_decl) * t_pragmas) ref (** Entry point to get zones needed to evaluate annotations of this [stmt]. @deprecated Carbon-20110201 use [from_terms (..) x.it_content] instead *) val from_stmt_annots: ((code_annotation -> bool) option -> stmt * kernel_function -> (t_zone_info * t_decl) * t_pragmas) ref (** Entry point to get zones needed to evaluate annotations of this [stmt]. *) val from_func_annots: (((stmt -> unit) -> kernel_function -> unit) -> (code_annotation -> bool) option -> kernel_function -> (t_zone_info * t_decl) * t_pragmas) ref (** Entry point to get zones needed to evaluate annotations of this [kf]. *) val code_annot_filter: (code_annotation -> threat:bool -> user_assert:bool -> slicing_pragma:bool -> loop_inv:bool -> loop_var:bool -> others:bool -> bool) ref (** To quickly build an annotation filter *) end (** Does the interpretation of the predicate rely on the intepretation of the term result? @since Carbon-20110201 *) val to_result_from_pred: (predicate named -> bool) ref (** {3 Internal use only} *) val code_annot : (kernel_function -> stmt -> string -> code_annotation) ref end (** {3 Assertions} *) val add_assert: Emitter.t -> kernel_function -> stmt -> string -> unit (** @deprecated since Oxygen-20120901 Ask for {ACSL_importer plug-in} if you need such functionality. @modify Boron-20100401 takes as additional argument the computation which adds the assert. @modify Oxygen-20120901 replaces the State.t list by an Emitter.t *) end (* ************************************************************************* *) (** {2 Plugins} *) (* ************************************************************************* *) (** Interface for the syntactic_callgraph plugin. @see <../syntactic_callgraph/index.html> internal documentation. *) module Syntactic_Callgraph: sig val dump: (unit -> unit) ref end (** Declarations common to the various postdominators-computing modules *) module PostdominatorsTypes: sig exception Top (** Used for postdominators-related functions, when the postdominators of a statement cannot be computed. It means that there is no path from this statement to the function return. *) module type Sig = sig val compute: (kernel_function -> unit) ref val stmt_postdominators: (kernel_function -> stmt -> Stmt.Hptset.t) ref (** @raise Top (see above) *) val is_postdominator: (kernel_function -> opening:stmt -> closing:stmt -> bool) ref val display: (unit -> unit) ref val print_dot : (string -> kernel_function -> unit) ref (** Print a representation of the postdominators in a dot file whose name is [basename.function_name.dot]. *) end end (** Syntaxic postdominators plugin. @see <../postdominators/index.html> internal documentation. *) module Postdominators: PostdominatorsTypes.Sig (** Postdominators using value analysis results. @see <../postdominators/index.html> internal documentation. *) module PostdominatorsValue: PostdominatorsTypes.Sig (** Dominators plugin. @see <../postdominators/index.html> internal documentation. *) module Dominators: sig val compute: (kernel_function -> unit) ref exception Top (** Used for {!stmt_dominators} when the dominators of a statement cannot be computed. It means that there is no path from the entry point to this statement. *) val stmt_dominators: (kernel_function -> stmt -> Stmt.Hptset.t) ref (** @raise Top (see above) *) val is_dominator: (kernel_function -> opening:stmt -> closing:stmt -> bool) ref val display: (unit -> unit) ref val print_dot : (string -> kernel_function -> unit) ref (** Print a representation of the dominators in a dot file whose name is [basename.function_name.dot]. *) end (** Runtime Error Annotation Generation plugin. @see <../rte/index.html> internal documentation. *) module RteGen : sig val compute : (unit -> unit) ref val annotate_kf : (kernel_function -> unit) ref val self: State.t ref val do_precond : (kernel_function -> unit) ref val do_all_rte : (kernel_function -> unit) ref val do_rte : (kernel_function -> unit) ref type status_accessor = string (* name *) * (kernel_function -> bool -> unit) (* for each kf and each kind of annotation, set/unset the fact that there has been generated *) * (kernel_function -> bool) (* is this kind of annotation generated in kf? *) val get_all_status : (unit -> status_accessor list) ref val get_precond_status : (unit -> status_accessor) ref val get_signedOv_status : (unit -> status_accessor) ref val get_divMod_status : (unit -> status_accessor) ref val get_downCast_status : (unit -> status_accessor) ref val get_memAccess_status : (unit -> status_accessor) ref val get_unsignedOv_status : (unit -> status_accessor) ref val get_unsignedDownCast_status : (unit -> status_accessor) ref end (** Dump Properties-Status consolidation tree. *) module Report : sig val print : (unit -> unit) ref end (** Constant propagation plugin. @see <../constant_propagation/index.html> internal documentation. *) module Constant_Propagation: sig val get : (Datatype.String.Set.t -> cast_intro:bool -> Project.t) ref (** Propagate constant into the functions given by name. note: the propagation is performed into all functions when the set is empty; and casts can be introduced when [cast_intro] is true. *) val compute: (unit -> unit) ref (** Propage constant into the functions given by the parameters (in the same way that {!get}. Then pretty print the resulting program. @since Beryllium-20090901 *) end (** Impact analysis. @see <../impact/index.html> internal documentation. *) module Impact : sig val compute_pragmas: (unit -> stmt list) ref (** Compute the impact analysis from the impact pragma in the program. Print and slice the results according to the parameters -impact-print and -impact-slice. @return the impacted statements *) val from_stmt: (stmt -> stmt list) ref (** Compute the impact analysis of the given statement. @return the impacted statements *) val slice: (stmt list -> unit) ref (** Slice the given statement according to the impact analysis. *) end (** Security analysis. @see <../security/index.html> internal documentation. *) module Security : sig val run_whole_analysis: (unit -> unit) ref (** Run all the security analysis. *) val run_ai_analysis: (unit -> unit) ref (** Only run the analysis by abstract interpretation. *) val run_slicing_analysis: (unit -> Project.t) ref (** Only run the security slicing pre-analysis. *) val self: State.t ref end (** Program Dependence Graph. @see <../pdg/index.html> PDG internal documentation. *) module Pdg : sig exception Bottom (** Raised by most function when the PDG is Bottom because we can hardly do nothing with it. It happens when the function is unreachable because we have no information about it. *) exception Top (** Raised by most function when the PDG is Top because we can hardly do nothing with it. It happens when we didn't manage to compute it, for instance for a variadic function. *) type t = PdgTypes.Pdg.t (** PDG type *) (* Values of type PdgIndex.Key.t are used as keys to identify elements of a function. See {!module:PdgIndex.Key} to know more about it and to get functions to build some keys. *) type t_nodes_and_undef = ((PdgTypes.Node.t * Locations.Zone.t option) list * Locations.Zone.t option) (** type for the return value of many [find_xxx] functions when the answer can be a list of [(node, z_part)] and an [undef zone]. For each node, [z_part] can specify which part of the node is used in terms of zone ([None] means all). *) val self : State.t ref (** {3 Getters} *) val get : (kernel_function -> t) ref (** Get the PDG of a function. Build it if it doesn't exist yet. *) val node_key : (PdgTypes.Node.t -> PdgIndex.Key.t) ref val from_same_fun : t -> t -> bool (** {3 Finding PDG nodes} *) val find_decl_var_node : (t -> Cil_types.varinfo -> PdgTypes.Node.t) ref (** Get the node corresponding the declaration of a local variable or a formal parameter. @raise Not_found if the variable is not declared in this function. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_ret_output_node : (t -> PdgTypes.Node.t) ref (** Get the node corresponding return stmt. @raise Not_found if the ouptut state in unreachable @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_output_nodes : (t -> PdgIndex.Signature.out_key -> t_nodes_and_undef) ref (** Get the nodes corresponding to a call output key in the called pdg. @raise Not_found if the ouptut state in unreachable @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_input_node : (t -> int -> PdgTypes.Node.t) ref (** Get the node corresponding to a given input (parameter). @raise Not_found if the number is not an input number. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_all_inputs_nodes : (t -> PdgTypes.Node.t list) ref (** Get the nodes corresponding to all inputs. {!node_key} can be used to know their numbers. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_stmt_node : (t -> Cil_types.stmt -> PdgTypes.Node.t) ref (** Get the node corresponding to the statement. It shouldn't be a call statement. See also {!find_simple_stmt_nodes} or {!find_call_stmts}. @raise Not_found if the given statement is unreachable. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_simple_stmt_nodes : (t -> Cil_types.stmt -> PdgTypes.Node.t list) ref (** Get the nodes corresponding to the statement. It is usualy composed of only one node (see {!find_stmt_node}), except for call statement. Be careful that for block statements, it only retuns a node corresponding to the elementary stmt (see {!find_stmt_and_blocks_nodes} for more) @raise Not_found if the given statement is unreachable. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_label_node : (t -> Cil_types.stmt -> Cil_types.label -> PdgTypes.Node.t) ref (** Get the node corresponding to the label. @raise Not_found if the given label is not in the PDG. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_stmt_and_blocks_nodes : (t -> Cil_types.stmt -> PdgTypes.Node.t list) ref (** Get the nodes corresponding to the statement like * {!find_simple_stmt_nodes} but also add the nodes of the enclosed * statements if [stmt] contains blocks. @raise Not_found if the given statement is unreachable. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_top_input_node : (t -> PdgTypes.Node.t) ref (** @raise Not_found if there is no top input in the PDG. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_entry_point_node : (t -> PdgTypes.Node.t) ref (** Find the node that represent the entry point of the function, i.e. the higher level block. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_location_nodes_at_stmt : (t -> Cil_types.stmt -> before:bool -> Locations.Zone.t -> t_nodes_and_undef) ref (** Find the nodes that define the value of the location at the given program point. Also return a zone that might be undefined at that point. @raise Not_found if the given statement is unreachable. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_location_nodes_at_end : (t -> Locations.Zone.t -> t_nodes_and_undef) ref (** Same than {!find_location_nodes_at_stmt} for the program point located at the end of the function. @raise Not_found if the output state is unreachable. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_location_nodes_at_begin : (t -> Locations.Zone.t -> t_nodes_and_undef) ref (** Same than {!find_location_nodes_at_stmt} for the program point located at the beginning of the function. Notice that it can only find formal argument nodes. The remaining zone (implicit input) is returned as undef. @raise Not_found if the output state is unreachable. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_call_stmts: (kernel_function -> caller:kernel_function -> Cil_types.stmt list) ref (** Find the call statements to the function (can maybe be somewhere else). @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_call_ctrl_node : (t -> Cil_types.stmt -> PdgTypes.Node.t) ref (** @raise Not_found if the call is unreachable. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_call_input_node : (t -> Cil_types.stmt -> int -> PdgTypes.Node.t) ref (** @raise Not_found if the call is unreachable or has no such input. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_call_output_node : (t -> Cil_types.stmt -> PdgTypes.Node.t) ref (** @raise Not_found if the call is unreachable or has no output node. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_code_annot_nodes : (t -> Cil_types.stmt -> Cil_types.code_annotation -> PdgTypes.Node.t list * PdgTypes.Node.t list * (t_nodes_and_undef option)) ref (** The result is composed of three parts : - the first part of the result are the control dependencies nodes of the annotation, - the second part is the list of declaration nodes of the variables used in the annotation; - the third part is similar to [find_location_nodes_at_stmt] result but for all the locations needed by the annotation. When the third part is globally [None], it means that we were not able to compute this information. @raise Not_found if the statement is unreachable. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val find_fun_precond_nodes : (t -> Cil_types.predicate -> PdgTypes.Node.t list * (t_nodes_and_undef option)) ref (** Similar to [find_code_annot_nodes] (no control dependencies nodes) *) val find_fun_postcond_nodes : (t -> Cil_types.predicate -> PdgTypes.Node.t list * (t_nodes_and_undef option)) ref (** Similar to [find_fun_precond_nodes] *) val find_fun_variant_nodes : (t -> Cil_types.term -> (PdgTypes.Node.t list * t_nodes_and_undef option)) ref (** Similar to [find_fun_precond_nodes] *) (** {3 Propagation} See also [Pdg.mli] for more function that cannot be here because they use polymorphic types. **) val find_call_out_nodes_to_select : (t -> PdgTypes.NodeSet.t -> t -> Cil_types.stmt -> PdgTypes.Node.t list) ref (** [find_call_out_nodes_to_select pdg_called called_selected_nodes pdg_caller call_stmt] @return the call outputs nodes [out] such that [find_output_nodes pdg_called out_key] intersects [called_selected_nodes]. *) val find_in_nodes_to_select_for_this_call : (t -> PdgTypes.NodeSet.t -> Cil_types.stmt -> t -> PdgTypes.Node.t list) ref (** [find_in_nodes_to_select_for_this_call pdg_caller caller_selected_nodes call_stmt pdg_called] @return the called input nodes such that the corresponding nodes in the caller intersect [caller_selected_nodes] @raise Not_found if the statement is unreachable. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) (** {3 Dependencies} *) val direct_dpds : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref (** Get the nodes to which the given node directly depend on. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val direct_ctrl_dpds : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref (** Similar to {!direct_dpds}, but for control dependencies only. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val direct_data_dpds : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref (** Similar to {!direct_dpds}, but for data dependencies only. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val direct_addr_dpds : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref (** Similar to {!direct_dpds}, but for address dependencies only. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val all_dpds : (t -> PdgTypes.Node.t list -> PdgTypes.Node.t list) ref (** Transitive closure of {!direct_dpds} for all the given nodes. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val all_data_dpds : (t -> PdgTypes.Node.t list -> PdgTypes.Node.t list) ref (** Gives the data dependencies of the given nodes, and recursively, all the dependencies of those nodes (regardless to their kind). @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val all_ctrl_dpds : (t -> PdgTypes.Node.t list -> PdgTypes.Node.t list) ref (** Similar to {!all_data_dpds} for control dependencies. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val all_addr_dpds : (t -> PdgTypes.Node.t list -> PdgTypes.Node.t list) ref (** Similar to {!all_data_dpds} for address dependencies. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val direct_uses : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref (** build a list of all the nodes that have direct dependencies on the given node. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val direct_ctrl_uses : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref (** Similar to {!direct_uses}, but for control dependencies only. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val direct_data_uses : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref (** Similar to {!direct_uses}, but for data dependencies only. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val direct_addr_uses : (t -> PdgTypes.Node.t -> PdgTypes.Node.t list) ref (** Similar to {!direct_uses}, but for address dependencies only. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val all_uses : (t -> PdgTypes.Node.t list -> PdgTypes.Node.t list) ref (** build a list of all the nodes that have dependencies (even indirect) on the given nodes. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val custom_related_nodes : ((PdgTypes.Node.t -> PdgTypes.Node.t list) -> PdgTypes.Node.t list -> PdgTypes.Node.t list) ref (** [custom_related_nodes get_dpds node_list] build a list, starting from the node in [node_list], and recursively add the nodes given by the function [get_dpds]. For this function to work well, it is important that [get_dpds n] returns a subset of the nodes directly related to [n], ie a subset of [direct_uses] U [direct_dpds]. @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) val iter_nodes : ((PdgTypes.Node.t -> unit) -> t -> unit) ref (** apply a given function to all the PDG nodes @raise Bottom if given PDG is bottom. @raise Top if the given pdg is top. *) (** {3 Pretty printing} *) val extract : (t -> string -> unit) ref (** Pretty print pdg into a dot file. @see <../pdg/index.html> PDG internal documentation. *) val pretty_node : (bool -> Format.formatter -> PdgTypes.Node.t -> unit) ref (** Pretty print information on a node : * with [short=true] if only print a number of the node, * else it prints a bit more. *) val pretty_key : (Format.formatter -> PdgIndex.Key.t -> unit) ref (** Pretty print information on a node key *) val pretty : (?bw:bool -> Format.formatter -> t -> unit) ref (** For debugging... Pretty print pdg information. * Print codependencies rather than dependencies if [bw=true]. * *) (* (** {3 Functors to compute marks for the PDG} *) (** [F_FctMarks] can be used to propagate marks It also provides information for an interprocedural analysis. Alternatively, one can use [F_ProjMarks] below. *) module F_FctMarks (M:PdgMarks.T_Mark) : PdgMarks.T_Fct with type t_mark = M.t and type t_call_info = M.t_call_info *) (* [F_ProjMarks] handle the full interprocedural propagation (cf. [Pdg.Register.F_Proj]) *) (* type 't_mark t_info_caller_inputs = 't_mark PdgMarks.t_info_caller_inputs type 't_mark t_info_inter = 't_mark PdgMarks.t_info_inter *) end (** Interface for the Scope plugin. @see <../scope/index.html> internal documentation. *) module Scope : sig val get_data_scope_at_stmt : (kernel_function -> stmt -> lval -> Stmt.Set.t * (Stmt.Set.t * Stmt.Set.t)) ref (** * @raise Kernel_function.No_Definition if [kf] has no definition. * @return 3 statement sets related to the value of [lval] before [stmt] : * - the forward selection, * - the both way selection, * - the backward selection. *) val get_prop_scope_at_stmt : (kernel_function -> stmt -> code_annotation -> Stmt.Set.t * code_annotation list) ref (** compute the set of statements where the given annotation has the same * value than it has before the given stmt. * Also return the *) val check_asserts : (unit -> code_annotation list) ref (** Print how many assertions could be removed based on the previous * analysis ([get_prop_scope_at_stmt]) and return the annotations * that can be removed. *) val rm_asserts : (unit -> unit) ref (** Same analysis than [check_asserts] but change assert to remove by true * *) val get_defs : (kernel_function -> stmt -> lval -> (Stmt.Set.t * Locations.Zone.t option) option) ref (** @return the set of statements that define [lval] before [stmt] in [kf]. * Also returns the zone that is possibly not defined. * Can return [None] when the information is not available (Pdg missing). * *) val get_defs_with_type : (kernel_function -> stmt -> lval -> ((bool * bool) Stmt.Map.t * Locations.Zone.t option) option) ref (** @return a map from the statements that define [lval] before [stmt] in [kf]. The first boolean indicates the possibility of a direct modification at this statement, ie. [lval = ...] or [lval = f()]. The second boolean indicates a possible indirect modification through a call. Also returns the zone that is possibly not defined. Can return [None] when the information is not available (Pdg missing). *) (** {3 Zones} *) type t_zones = Locations.Zone.t Stmt.Hashtbl.t val build_zones : (kernel_function -> stmt -> lval -> Stmt.Set.t * t_zones) ref val pretty_zones : (Format.formatter -> t_zones -> unit) ref val get_zones : (t_zones -> Cil_types.stmt -> Locations.Zone.t) ref end (** Interface for the unused code detection. @see <../sparecode/index.html> internal documentation. *) module Sparecode : sig val get: (select_annot:bool -> select_slice_pragma:bool -> Project.t) ref (** Remove in each function what isn't used to compute its outputs, * or its annotations when [select_annot] is true, * or its slicing pragmas when [select_slice_pragmas] is true. * @return a new project where the sparecode has been removed. *) val rm_unused_globals : (?new_proj_name:string -> ?project:Project.t -> unit -> Project.t) ref (** Remove unused global types and variables from the given project * (the current one if no project given). * The source project is not modified. * The result is in the returned new project. * optional argument [new_proj_name] added @since Carbon-20110201 * *) end (** Interface for the occurrence plugin. @see <../occurrence/index.html> internal documentation. *) module Occurrence: sig type t = (kernel_function option * kinstr * lval) list val get: (varinfo -> t) ref (** Return the occurrences of the given varinfo. An occurrence [ki, lv] is a left-value [lv] which uses the location of [vi] at the position [ki]. *) val get_last_result: (unit -> (t * varinfo) option) ref (** @return the last result computed by occurrence *) val print_all: (unit -> unit) ref (** Print all the occurrence of each variable declarations. *) val self: State.t ref end (** Interface for the slicing tool. @see <../slicing/index.html> internal documentation. *) module Slicing : sig exception No_Project exception Existing_Project val self: State.t ref (** Internal state of the slicing tool from project viewpoints. *) val set_modes : (?calls:int -> ?callers:bool -> ?sliceUndef:bool -> ?keepAnnotations:bool -> ?print:bool -> unit -> unit) ref (** Slicing project management. *) module Project : sig type t = SlicingTypes.sl_project (** Abstract data type for slicing project. *) val dyn_t : t Type.t (** For dynamic type checking and journalization. *) val mk_project : (string -> t) ref (** To use to start a new slicing project. Several projects from a same current project can be managed. @raise Existing_Project if an axisting project has the same name.*) val from_unique_name : (string -> t) ref (** Find a slicing project from its name. @raise No_Project when no project is found. *) val get_all : (unit -> t list) ref (** Get all slicing projects. *) val set_project : (t option -> unit) ref (** Get the current project. *) val get_project : (unit -> t option) ref (** Get the current project. *) val get_name : (t -> string) ref (** Get the slicing project name. *) (** {3 Kernel function} *) val is_called : (t -> kernel_function -> bool) ref (** Return [true] iff the source function is called (even indirectly via transitivity) from a [Slice.t]. *) val has_persistent_selection : (t -> kernel_function -> bool) ref (** return [true] iff the source function has persistent selection *) val change_slicing_level : (t -> kernel_function -> int -> unit) ref (** change the slicing level of this function (see the [-slicing-level] option documentation to know the meaning of the number) @raise SlicingTypes.ExternalFunction if [kf] has no definition. @raise SlicingTypes.WrongSlicingLevel if [n] is not valid. *) (** {3 Extraction} *) val default_slice_names : (kernel_function -> bool -> int -> string) ref val extract : (string -> ?f_slice_names:(kernel_function -> bool -> int -> string) -> t -> Project.t) ref (** Build a new [Db.Project.t] from all [Slice.t] of a project. * Can optionally specify how to name the sliced functions * by defining [f_slice_names]. * [f_slice_names kf src_visi num_slice] has to return the name * of the exported functions based on the source function [kf]. * - [src_visi] tells if the source function name is used * (if not, it can be used for a slice) * - [num_slice] gives the number of the slice to name. * The entry point function is only exported once : * it is VERY recommanded to give to it its original name, * even if it is sliced. * *) val print_extracted_project : (?fmt:Format.formatter -> extracted_prj:Project.t -> unit) ref (** Print the extracted project when "-slice-print" is set. *) val print_dot : (filename:string -> title:string -> t -> unit) ref (** Print a representation of the slicing project (call graph) in a dot file which name is the given string. *) (** {3 Internal use only} *) val pretty : (Format.formatter -> t -> unit) ref (** For debugging... Pretty print project information. *) val is_directly_called_internal : (t -> kernel_function -> bool) ref (** Return [true] if the source function is directly (even via pointer function) called from a [Slice.t]. *) end (** Acces to slicing results. *) module Mark : sig type t = SlicingTypes.sl_mark (** Abtract data type for mark value. *) val dyn_t : t Type.t (** For dynamic type checking and journalization. *) val make : (data:bool -> addr:bool -> ctrl:bool -> t) ref (** To construct a mark such as [(is_ctrl result, is_data result, isaddr result) = (~ctrl, ~data, ~addr)], [(is_bottom result) = false] and [(is_spare result) = not (~ctrl || ~data || ~addr)]. *) val compare : (t -> t -> int) ref (** A total ordering function similar to the generic structural comparison function [compare]. Can be used to build a map from [t] marks to, for exemple, colors for the GUI. *) val is_bottom : (t -> bool) ref (** [true] iff the mark is empty: it is the only case where the associated element is invisible. *) val is_spare : (t -> bool) ref (** Smallest visible mark. Usually used to mark element that need to be visible for compilation purpose, not really for the selected computations. *) val is_data : (t -> bool) ref (** The element is used to compute selected data. Notice that a mark can be [is_data] and/or [is_ctrl] and/or [is_addr] at the same time. *) val is_ctrl : (t -> bool) ref (** The element is used to control the program point of a selected data. *) val is_addr : (t -> bool) ref (** The element is used to compute the address of a selected data. *) val get_from_src_func : (Project.t -> kernel_function -> t) ref (** The mark [m] related to all statements of a source function [kf]. Property : [is_bottom (get_from_func proj kf) = not (Project.is_called proj kf) ] *) val pretty : (Format.formatter -> t -> unit) ref (** For debugging... Pretty mark information. *) end (** Slicing selections. *) module Select : sig type t = SlicingTypes.sl_select (** Internal selection. *) val dyn_t : t Type.t (** For dynamic type checking and journalization. *) type set = SlicingTypes.Fct_user_crit.t Cil_datatype.Varinfo.Map.t (** Set of colored selections. *) val dyn_set : set Type.t (** For dynamic type checking and journalization. *) val empty_selects : set (** Empty selection. *) val select_stmt : (set -> spare:bool -> stmt -> kernel_function -> set) ref (** To select a statement. *) val select_stmt_ctrl : (set -> spare:bool -> stmt -> kernel_function -> set) ref (** To select a statement reachability. Note: add also a transparent selection on the whole statement. *) val select_stmt_lval_rw : (set -> Mark.t -> rd:Datatype.String.Set.t -> wr:Datatype.String.Set.t -> stmt -> scope:stmt -> eval:stmt -> kernel_function -> set) ref (** To select rw accesses to lvalues (given as string) related to a statement. Variables of [~rd] and [~wr] string are bounded relatively to the scope of the statement [~scope]. The interpretation of the address of the lvalues is done just before the execution of the statement [~eval]. The selection preserve the [~rd] and ~[wr] accesses contained into the statement [ki]. Note: add also a transparent selection on the whole statement. *) val select_stmt_lval : (set -> Mark.t -> Datatype.String.Set.t -> before:bool -> stmt -> scope:stmt -> eval:stmt -> kernel_function -> set) ref (** To select lvalues (given as string) related to a statement. Variables of [lval_str] string are bounded relatively to the scope of the statement [~scope]. The interpretation of the address of the lvalue is done just before the execution of the statement [~eval]. The selection preserve the value of these lvalues before or after (c.f. boolean [~before]) the statement [ki]. Note: add also a transparent selection on the whole statement. *) val select_stmt_zone : (set -> Mark.t -> Locations.Zone.t -> before:bool -> stmt -> kernel_function -> set) ref (** To select a zone value related to a statement. Note: add also a transparent selection on the whole statement. *) val select_stmt_term : (set -> Mark.t -> term -> stmt -> kernel_function -> set) ref (** To select a predicate value related to a statement. Note: add also a transparent selection on the whole statement. *) val select_stmt_pred : (set -> Mark.t -> predicate named -> stmt -> kernel_function -> set) ref (** To select a predicate value related to a statement. Note: add also a transparent selection on the whole statement. *) val select_stmt_annot : (set -> Mark.t -> spare:bool -> code_annotation -> stmt -> kernel_function -> set) ref (** To select the annotations related to a statement. Note: add also a transparent selection on the whole statement. *) val select_stmt_annots : (set -> Mark.t -> spare:bool -> threat:bool -> user_assert:bool -> slicing_pragma:bool -> loop_inv:bool -> loop_var:bool -> stmt -> kernel_function -> set) ref (** To select the annotations related to a statement. Note: add also a transparent selection on the whole statement. *) val select_func_lval_rw : (set -> Mark.t -> rd:Datatype.String.Set.t -> wr:Datatype.String.Set.t -> scope:stmt -> eval:stmt -> kernel_function -> set) ref (** To select rw accesses to lvalues (given as a string) related to a function. Variables of [~rd] and [~wr] string are bounded relatively to the scope of the statement [~scope]. The interpretation of the address of the lvalues is done just before the execution of the statement [~eval]. The selection preserve the value of these lvalues into the whole project. *) val select_func_lval : (set -> Mark.t -> Datatype.String.Set.t -> kernel_function -> set) ref (** To select lvalues (given as a string) related to a function. Variables of [lval_str] string are bounded relatively to the scope of the first statement of [kf]. The interpretation of the address of the lvalues is done just before the execution of the first statement [kf]. The selection preserve the value of these lvalues before execution of the return statement. *) val select_func_zone : (set -> Mark.t -> Locations.Zone.t -> kernel_function -> set) ref (** To select an output zone related to a function. *) val select_func_return : (set -> spare:bool -> kernel_function -> set) ref (** To select the function result (returned value). *) val select_func_calls_to : (set -> spare:bool -> kernel_function -> set) ref (** To select every calls to the given function, i.e. the call keeps its semantics in the slice. *) val select_func_calls_into : (set -> spare:bool -> kernel_function -> set) ref (** To select every calls to the given function without the selection of its inputs/outputs. *) val select_func_annots : (set -> Mark.t -> spare:bool -> threat:bool -> user_assert:bool -> slicing_pragma:bool -> loop_inv:bool -> loop_var:bool -> kernel_function -> set) ref (** To select the annotations related to a function. *) (** {3 Internal use only} *) val pretty : (Format.formatter -> t -> unit) ref (** For debugging... Pretty print selection information. *) val get_function : (t -> kernel_function) ref (** The function related to an internal selection. *) val merge_internal : (t -> t -> t) ref (** The function related to an internal selection. *) val add_to_selects_internal : (t -> set -> set) ref val iter_selects_internal : ((t -> unit) -> set -> unit) ref val fold_selects_internal : (('a -> t -> 'a) -> 'a -> set -> 'a) val select_stmt_internal : (kernel_function -> ?select:t -> stmt -> Mark.t -> t) ref (** Internally used to select a statement : - if [is_ctrl_mark m], propagate ctrl_mark on ctrl dependencies of the statement - if [is_addr_mark m], propagate addr_mark on addr dependencies of the statement - if [is_data_mark m], propagate data_mark on data dependencies of the statement - mark the node with a spare_mark and propagate so that the dependencies that were not selected yet will be marked spare. When the statement is a call, its functionnal inputs/outputs are also selected (The call is still selected even it has no output). When the statement is a composed one (block, if, etc...), all the sub-statements are selected. @raise SlicingTypes.NoPdg if ? *) val select_label_internal : (kernel_function -> ?select:t -> Logic_label.t -> Mark.t -> t) ref val select_min_call_internal : (kernel_function -> ?select:t -> stmt -> Mark.t -> t) ref (** Internally used to select a statement call without its inputs/outputs so that it doesn't select the statements computing the inputs of the called function as [select_stmt_internal] would do. Raise [Invalid_argument] when the [stmt] isn't a call. @raise SlicingTypes.NoPdg if ? *) val select_stmt_zone_internal : (kernel_function -> ?select:t -> stmt -> before:bool -> Locations.Zone.t -> Mark.t -> t) ref (** Internally used to select a zone value at a program point. @raise SlicingTypes.NoPdg if ? *) val select_zone_at_entry_point_internal : (kernel_function -> ?select:t -> Locations.Zone.t -> Mark.t -> t) ref (** Internally used to select a zone value at the beginning of a function. * For a defined function, it is similar to [select_stmt_zone_internal] * with the initial statement, but it can also be used for undefined * functions. * @raise SlicingTypes.NoPdg if ? *) val select_zone_at_end_internal : (kernel_function -> ?select:t -> Locations.Zone.t -> Mark.t -> t) ref (** Internally used to select a zone value at the end of a function. * For a defined function, it is similar to [select_stmt_zone_internal] * with the return statement, but it can also be used for undefined * functions. * @raise SlicingTypes.NoPdg if ? *) val select_modified_output_zone_internal : (kernel_function -> ?select:t -> Locations.Zone.t -> Mark.t -> t) ref (** Internally used to select the statements that modify the * given zone considered as in output. * Be careful that it is NOT the same than selectiong the zone at end ! * ( the 'undef' zone is not propagated...) * *) val select_stmt_ctrl_internal : (kernel_function -> ?select:t -> stmt -> t) ref (** Internally used to select a statement reachability : Only propagate a ctrl_mark on the statement control dependencies. @raise SlicingTypes.NoPdg if ? *) val select_pdg_nodes_internal : (kernel_function -> ?select:t -> PdgTypes.Node.t list -> Mark.t -> t) ref (** Internally used to select PDG nodes : - if [is_ctrl_mark m], propagate ctrl_mark on ctrl dependencies of the statement - if [is_addr_mark m], propagate addr_mark on addr dependencies of the statement - if [is_data_mark m], propagate data_mark on data dependencies of the statement - mark the node with a spare_mark and propagate so that the dependencies that were not selected yet will be marked spare. *) val select_entry_point_internal : (kernel_function -> ?select:t -> Mark.t -> t) ref val select_return_internal : (kernel_function -> ?select:t -> Mark.t -> t) ref val select_decl_var_internal : (kernel_function -> ?select:t -> Cil_types.varinfo -> Mark.t -> t) ref val select_pdg_nodes : (set -> Mark.t -> PdgTypes.Node.t list -> kernel_function -> set) ref end (** Function slice. *) module Slice : sig type t = SlicingTypes.sl_fct_slice (** Abtract data type for function slice. *) val dyn_t : t Type.t (** For dynamic type checking and journalization. *) val create : (Project.t -> kernel_function -> t) ref (** Used to get an empty slice (nothing selected) related to a function. *) val remove : (Project.t -> t -> unit) ref (** Remove the slice from the project. The slice shouldn't be called. *) val remove_uncalled : (Project.t -> unit) ref (** Remove the uncalled slice from the project. *) (** {3 Getters} *) val get_all: (Project.t -> kernel_function -> t list) ref (** Get all slices related to a function. *) val get_function : (t -> kernel_function) ref (** To get the function related to a slice *) val get_callers : (t -> t list) ref (** Get the slices having direct calls to a slice. *) val get_called_slice : (t -> stmt -> t option) ref (** To get the slice directly called by the statement of a slice. Returns None when the statement mark is bottom, or else the statement isn't a call or else the statement is a call to one or several (via pointer) source functions. *) val get_called_funcs : (t -> stmt -> kernel_function list) ref (** To get the source functions called by the statement of a slice. Returns an empty list when the statement mark is bottom, or else the statement isn't a call or else the statement is a call to a function slice. *) val get_mark_from_stmt : (t -> stmt -> Mark.t) ref (** Get the mark value of a statement. *) val get_mark_from_label : (t -> stmt -> Cil_types.label -> Mark.t) ref (** Get the mark value of a label. *) val get_mark_from_local_var : (t -> varinfo -> Mark.t) ref (** Get the mark value of local variable. *) val get_mark_from_formal : (t -> varinfo -> Mark.t) ref (** Get the mark from the formal of a function. *) val get_user_mark_from_inputs : (t -> Mark.t) ref (** Get a mark that is the merged user inputs marks of the slice *) (** {3 Internal use only} *) val get_num_id : (t -> int) ref val from_num_id : (Project.t -> kernel_function -> int -> t) ref val pretty : (Format.formatter -> t -> unit) ref (** For debugging... Pretty print slice information. *) end (** Requests for slicing jobs. Slicing resquests are part of a slicing project. So, user requests affect slicing project. *) module Request : sig val apply_all: (Project.t -> propagate_to_callers:bool -> unit) ref (** Apply all slicing requests. *) (** {3 Adding a request} *) val add_selection: (Project.t -> Select.set -> unit) ref (** Add a selection request to all slices (existing) of a function to the project requests. *) val add_persistent_selection: (Project.t -> Select.set -> unit) ref (** Add a persistent selection request to all slices (already existing or created later) of a function to the project requests. *) val add_persistent_cmdline : (Project.t -> unit) ref (** Add persistent selection from the command line. *) val is_already_selected_internal: (Slice.t -> Select.t -> bool) ref (** Return true when the requested selection is already selected into the * slice. *) val add_slice_selection_internal: (Project.t -> Slice.t -> Select.t -> unit) ref (** Internaly used to add a selection request for a function slice to the project requests. *) val add_selection_internal: (Project.t -> Select.t -> unit) ref (** Internaly used to add a selection request to the project requests. This selection will be applied to every slicies of the function (already existing or created later). *) val add_call_slice: (Project.t -> caller:Slice.t -> to_call:Slice.t -> unit) ref (** change every call to any [to_call] source or specialisation in order to call [to_call] in [caller]. *) val add_call_fun: (Project.t -> caller:Slice.t -> to_call:kernel_function -> unit) ref (** change every call to any [to_call] source or specialisation * in order to call the source function [to_call] in [caller] *) val add_call_min_fun: (Project.t -> caller:Slice.t -> to_call:kernel_function -> unit) ref (** For each call to [to_call] in [caller] such so that, at least, it will be visible at the end, ie. call either the source function or one of [to_call] slice (depending on the [slicing_level]). *) (** {3 Internal use only} *) val apply_all_internal: (Project.t -> unit) ref (** Internaly used to apply all slicing requests. *) val apply_next_internal: (Project.t -> unit) ref (** Internaly used to apply the first slicing request of the project list and remove it from the list. That may modify the contents of the remaing list. For exemple, new requests may be added to the list. *) val is_request_empty_internal: (Project.t -> bool) ref (** Internaly used to know if internal requests are pending. *) val merge_slices: (Project.t -> Slice.t -> Slice.t -> replace:bool -> Slice.t) ref (** Build a new slice which marks is a merge of the two given slices. [choose_call] requests are added to the project in order to choose the called functions for this new slice. If [replace] is true, more requests are added to call this new slice instead of the two original slices. When these requests will be applied, the user will be able to remove those two slices using [Db.Slicing.Slice.remove]. *) val copy_slice: (Project.t -> Slice.t -> Slice.t) ref (** Copy the input slice. The new slice is not called, * so it is the user responsability to change the calls if he wants to. *) val split_slice: (Project.t -> Slice.t -> Slice.t list) ref (** Copy the input slice to have one slice for each call of the original * slice and generate requests in order to call them. * @return the newly created slices. *) val propagate_user_marks : (Project.t -> unit) ref (** Apply pending request then propagate user marks to callers recursively then apply pending requests *) val pretty : (Format.formatter -> Project.t -> unit) ref (** For debugging... Pretty print the resquest list. *) end end (** Signature common to some Inout plugin options. The results of the computations are available on a per function basis. *) module type INOUTKF = sig type t val self_internal: State.t ref val self_external: State.t ref val compute : (kernel_function -> unit) ref val get_internal : (kernel_function -> t) ref (** Inputs/Outputs with local and formal variables *) val get_external : (kernel_function -> t) ref (** Inputs/Outputs without either local or formal variables *) (** {3 Pretty printing} *) val display : (Format.formatter -> kernel_function -> unit) ref val pretty : Format.formatter -> t -> unit end (** Signature common to inputs and outputs computations. The results are also available on a per-statement basis. *) module type INOUT = sig include INOUTKF val statement : (stmt -> t) ref val kinstr : kinstr -> t option end (** State_builder.of read inputs. That is over-approximation of zones read by each function. @see <../inout/Inputs.html> internal documentation. *) module Inputs : sig include INOUT with type t = Locations.Zone.t val expr : (stmt -> exp -> t) ref val self_with_formals: State.t ref val get_with_formals : (kernel_function -> t) ref (** Inputs with formals and without local variables *) val display_with_formals: (Format.formatter -> kernel_function -> unit) ref end (** State_builder.of outputs. That is over-approximation of zones written by each function. @see <../inout/Outputs.html> internal documentation. *) module Outputs : sig include INOUT with type t = Locations.Zone.t val display_external : (Format.formatter -> kernel_function -> unit) ref end (** State_builder.of operational inputs. That is: - over-approximation of zones whose input values are read by each function, State_builder.of sure outputs - under-approximation of zones written by each function. @see <../inout/Context.html> internal documentation. *) module Operational_inputs : sig include INOUTKF with type t = Inout_type.t val get_internal_precise: (?stmt:stmt -> kernel_function -> Inout_type.t) ref (** More precise version of [get_internal] function. If [stmt] is specified, and is a possible call to the given kernel_function, returns the operational inputs for this call (if option -inout-callwise has been set). *) (**/**) (* Internal use *) module Record_Inout_Callbacks: Hook.Iter_hook with type param = Value_types.callstack * Inout_type.t (**/**) end (**/**) (** Do not use yet. @see <../inout/Derefs.html> internal documentation. *) module Derefs : INOUT with type t = Locations.Zone.t (**/**) (** {3 GUI} *) (** This function should be called from time to time by all analysers taking time. In GUI mode, this will make the interface reactive. @plugin development guide *) val progress: (unit -> unit) ref (** This exception may be raised by {!progress} to interrupt computations. *) exception Cancel (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/file.mli0000644000175000017500000001736512155630171017503 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Frama-c preprocessing and Cil AST initialization. @plugin development guide *) type file = | NeedCPP of string * string (** The first string is the filename of the [.c] to preprocess. The second one is the preprocessor command ([filename.c -o tempfilname.i] will be appended at the end).*) | NoCPP of string (** Already pre-processed file [.i] *) | External of string * string (** file that can be translated into a Cil AST through an external function, together with the recognized suffix. *) include Datatype.S with type t = file val new_file_type: string -> (string -> Cil_types.file * Cabs.file) -> unit (** [new_file_type suffix func funcname] registers a new type of files (with corresponding suffix) as recognized by Frama-C through [func]. *) val new_machdep: string -> (module Cil.Machdeps) -> unit (** [new_machdep name module] registers a new machdep name as recognized by Frama-C through The usual uses is [Cmdline.run_after_loading_stage (fun () -> File.new_machdep "my_machdep" (module My_machdep_implem: Cil.Machdeps))] @since Nitrogen-20111001 @modify Fluorine-20130401 Receives the machdep (as a module) as argument @raise Invalid_argument if the given name already exists *) val get_suffixes: unit -> string list (** @return the list of accepted suffixes of input source files @since Boron-20100401 *) val get_name: t -> string (** File name. *) val get_preprocessor_command: unit -> string (** Return the preprocessor command to use. *) val pre_register: t -> unit (** Register some file as source file before command-line files *) val get_all: unit -> t list (** Return the list of toplevel files. *) val from_filename: ?cpp:string -> string -> t (** Build a file from its name. The optional argument is the preprocessor command. Default is [!get_preprocessor_command ()]. *) (* ************************************************************************* *) (** {2 Initializers} *) (* ************************************************************************* *) class check_file: string -> Visitor.frama_c_visitor (** visitor that performs various consistency checks over the AST. The string argument will be used in the error message in case of inconsistency, in order to trace the issue. *) val prepare_from_c_files: unit -> unit (** Initialize the AST of the current project according to the current filename list. @raise File_types.Bad_Initialization if called more than once. *) val init_from_c_files: t list -> unit (** Initialize the cil file representation of the current project. Should be called at most once per project. @raise File_types.Bad_Initialization if called more than once. @plugin development guide *) val init_project_from_cil_file: Project.t -> Cil_types.file -> unit (** Initialize the cil file representation with the given file for the given project from the current one. Should be called at most once per project. @raise File_types.Bad_Initialization if called more than once. @plugin development guide *) val init_project_from_visitor: ?reorder:bool -> Project.t -> Visitor.frama_c_visitor -> unit (** [init_project_from_visitor prj vis] initialize the cil file representation of [prj]. [prj] must be essentially empty: it can have some options set, but not an existing cil file; [proj] is filled using [vis], which must be a copy visitor that puts its results in [prj]. if [reorder] is [true] (default is [false]) the new AST in [prj] will be reordered. @since Oxygen-20120901 @modify Fluorine-20130401 added reorder optional argument @plugin development guide *) val create_project_from_visitor: ?reorder:bool -> string -> (Project.t -> Visitor.frama_c_visitor) -> Project.t (** Return a new project with a new cil file representation by visiting the file of the current project. If [reorder] is [true], the globals in the AST of the new project are reordered (default is [false]). The visitor is responsible to avoid sharing between old file and new file (i.e. it should use {!Cil.copy_visit} at some point). @raise File_types.Bad_Initialization if called more than once. @since Beryllium-20090601-beta1 @modify Fluorine-20130401 added reorder optional argument @plugin development guide *) val create_rebuilt_project_from_visitor: ?reorder:bool -> ?preprocess:bool -> string -> (Project.t -> Visitor.frama_c_visitor) -> Project.t (** Like {!create_project_from_visitor}, but the new generated cil file is generated into a temp .i or .c file according to [preprocess], then re-built by Frama-C in the returned project. For instance, use this function if the new cil file contains a constructor {!GText} as global. Not that the generation of a preprocessed C file may fail in some cases (e.g. if it includes headers already included). Thus the generated file is NOT preprocessed by default. @raise File_types.Bad_Initialization if called more than once. @since Nitrogen-20111001 @modify Fluorine-20130401 added reorder optional argument *) val init_from_cmdline: unit -> unit (** Initialize the cil file representation with the file given on the command line. Should be called at most once per project. @raise File_types.Bad_Initialization if called more than once. @plugin development guide *) val reorder_ast: unit -> unit (** reorder globals so that all uses of an identifier are preceded by its declaration. This may introduce new declarations in the AST. @since Oxygen-20120901 *) (* ************************************************************************* *) (** {2 Pretty printing} *) (* ************************************************************************* *) val pretty_ast : ?prj:Project.t -> ?fmt:Format.formatter -> unit -> unit (** Print the project CIL file on the given Formatter. The default project is the current one. The default formatter is [Kernel.CodeOutput.get_fmt ()]. @raise File_types.Bad_Initialization if the file is not initialized. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/emitter.ml0000644000175000017500000004760212155630171020061 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* Modules [Hashtbl] and [Kernel] are not usable here. Thus use above modules instead. *) module Output = Project_skeleton.Output (**************************************************************************) (** {2 Datatype} *) (**************************************************************************) type kind = Property_status | Alarm | Code_annot | Funspec | Global_annot type emitter = { name: string; kinds: kind list; tuning_parameters: Parameter.t list; correctness_parameters: Parameter.t list } module D = Datatype.Make_with_collections (struct type t = emitter let name = "Emitter.t" let rehash = Datatype.identity let structural_descr = Structural_descr.Unknown let reprs = [ { name = ""; kinds = []; tuning_parameters = []; correctness_parameters = [] } ] (* does not use (==) in order to prevent unmarshalling issue + in order to be able to compare emitters coming from Usable_emitter.get *) let equal x y = Datatype.String.equal x.name y.name let compare x y = Datatype.String.compare x.name y.name let hash x = Datatype.String.hash x.name let copy x = x (* strings are immutable here *) let pretty fmt x = Format.pp_print_string fmt x.name let internal_pretty_code = Datatype.undefined let varname _ = assert false (* unused while [internal_pretty_code] unimplemented *) let mem_project = Datatype.never_any_project end) type usable_emitter = { u_id: int; u_name: string; u_kinds: kind list; mutable used: bool; mutable version: int; (* maps below associate the parameter to its value (as a string) at the time of using. *) tuning_values: string Datatype.String.Map.t; correctness_values: string Datatype.String.Map.t } let has_several_versions_ref = Extlib.mk_fun "Emitter.has_several_versions" module Usable_emitter = struct include Datatype.Make_with_collections (struct type t = usable_emitter let name = "Emitter.Usable_emitter.t" let rehash = Datatype.identity let structural_descr = Structural_descr.Abstract let reprs = let p = Datatype.String.Map.empty in [ { u_id = -1; u_name = ""; u_kinds = [ Property_status ]; used = false; version = -1; tuning_values = p; correctness_values = p } ] let equal = ( == ) let compare x y = if x == y then 0 else Datatype.Int.compare x.u_id y.u_id let hash x = Datatype.Int.hash x.u_id let copy x = x (* strings are immutable here *) let pretty fmt x = let name = x.u_name in if !has_several_versions_ref name then Format.fprintf fmt "%s (v%d)" name x.version else Format.pp_print_string fmt name let internal_pretty_code = Datatype.undefined let varname _ = assert false (* unused while [internal_pretty_code] unimplemented *) let mem_project = Datatype.never_any_project end) let get e = let get_params map = Datatype.String.Map.fold (fun s _ acc -> Parameter.get s :: acc) map [] in { name = e.u_name; kinds = e.u_kinds; correctness_parameters = get_params e.correctness_values; tuning_parameters = get_params e.tuning_values } let get_name e = e.u_name let get_unique_name e = Pretty_utils.sfprintf "%a" pretty e let correctness_parameters e = Datatype.String.Map.fold (fun p _ acc -> p :: acc) e.correctness_values [] let tuning_parameters e = Datatype.String.Map.fold (fun p _ acc -> p :: acc) e.tuning_values [] let pretty_parameter fmt ~tuning e s = let map = if tuning then e.tuning_values else e.correctness_values in let v = Datatype.String.Map.find s map in Format.fprintf fmt "%s %s" s v end (**************************************************************************) (** {2 Implementation for Plug-in Developers} *) (**************************************************************************) let names: unit Datatype.String.Hashtbl.t = Datatype.String.Hashtbl.create 7 let create name kinds ~correctness ~tuning = if Datatype.String.Hashtbl.mem names name then Kernel.fatal "emitter %s already exists with the same parameters" name; let e = { name = name; kinds = kinds; correctness_parameters = correctness; tuning_parameters = tuning } in Datatype.String.Hashtbl.add names name (); e let get_name e = e.name let correctness_parameters e = List.map (fun p -> p.Parameter.name) e.correctness_parameters let tuning_parameters e = List.map (fun p -> p.Parameter.name) e.tuning_parameters let end_user = create "End-User" [ Property_status; Code_annot; Funspec; Global_annot ] ~correctness:[] ~tuning:[] let kernel = create "Frama-C kernel" [ Property_status; Funspec ] ~correctness:[] ~tuning:[] (**************************************************************************) (** {2 State of all known emitters} *) (**************************************************************************) module Usable_id = State_builder.SharedCounter(struct let name = "Emitter.Usable_id" end) (* For each emitter, the info required to be able to get the right usable emitter. *) module Usable_emitters_of_emitter = State_builder.Hashtbl (Datatype.String.Hashtbl) (Datatype.Pair (Datatype.Ref(Usable_emitter)) (* current usable emitter with the current parameter values *) (Datatype.Ref(Usable_emitter.Set))) (* existing usables emitters with the old parameter values *) (struct let name = "Emitter.Usable_emitters_of_emitter" let size = 7 let dependencies = [ Usable_id.self ] end) let self = Usable_emitters_of_emitter.self let has_several_versions name = try let _, set = Usable_emitters_of_emitter.find name in Usable_emitter.Set.cardinal !set > 1 with Not_found -> Kernel.fatal "Unknown emitter %s" name let () = has_several_versions_ref := has_several_versions let distinct_parameters get_them tuning e = let name = e.u_name in let values = get_them e in let get e s = Pretty_utils.sfprintf "%t" (fun fmt -> Usable_emitter.pretty_parameter fmt ~tuning e s) in try let _, set = Usable_emitters_of_emitter.find name in Usable_emitter.Set.fold (fun e' acc -> List.fold_left2 (fun acc s1 s2 -> if get e s1 = get e' s2 then acc else Datatype.String.Set.add s1 acc) acc values (get_them e)) !set Datatype.String.Set.empty with Not_found -> Kernel.fatal "Unknown emitter %s" name let distinct_tuning_parameters = distinct_parameters Usable_emitter.tuning_parameters true let distinct_correctness_parameters = distinct_parameters Usable_emitter.correctness_parameters false (**************************************************************************) (** {2 Kernel Internal Implementation} *) (**************************************************************************) (* set the value of a parameter of an emitter *) let update_usable_emitter tuning ~used usable_e param_name value = let id = Usable_id.next () in let name = usable_e.u_name in let kinds = usable_e.u_kinds in let add = Datatype.String.Map.add param_name value in if tuning then { u_id = id; u_name = name; u_kinds = kinds; used = used; version = -1; (* delayed *) tuning_values = add usable_e.tuning_values; correctness_values = usable_e.correctness_values } else { u_id = id; u_name = name; u_kinds = kinds; used = used; version = -1; (* delayed *) tuning_values = usable_e.tuning_values; correctness_values = add usable_e.correctness_values } exception Found of Usable_emitter.t let update_parameter tuning usable_e p = let param_name = p.Parameter.name in let value = Parameter.get_value p in try let _, set = Usable_emitters_of_emitter.find usable_e.u_name in try Usable_emitter.Set.iter (fun e -> let map = if tuning then e.tuning_values else e.correctness_values in let exists = try Datatype.String.equal value (Datatype.String.Map.find param_name map) with Not_found -> false in if exists then raise (Found e)) !set; (* we are setting the value of a parameter, but we are not sure yet that the corresponding usable emitter will be used *) let e = update_usable_emitter tuning ~used:false usable_e param_name value in set := Usable_emitter.Set.add e !set; e with Found e -> (* we already create an usable emitter with this value for this parameter *) e with Not_found -> (* we are creating the first usable emitter of the given name: it is going to be used *) update_usable_emitter tuning ~used:true usable_e param_name value let kinds: (kind, State.t list) Hashtbl.t = Hashtbl.create 7 let iter_on_kinds f l = List.iter (fun k -> try let states = Hashtbl.find kinds k in f states with Not_found -> ()) l let correctness_states: unit State.Hashtbl.t = State.Hashtbl.create 7 let register_correctness_parameter name kinds = let state = State.get name in State.Hashtbl.replace correctness_states state (); iter_on_kinds (State_dependency_graph.add_dependencies ~from:state) kinds let parameter_hooks : (unit -> unit) Datatype.String.Hashtbl.t Parameter.Hashtbl.t = Parameter.Hashtbl.create 97 let register_tuning_parameter name p = let update () = try let current, set = Usable_emitters_of_emitter.find name in let c = !current in let v = c.version in let new_e = update_parameter true c p in if c.used then new_e.version <- v + 1 else begin set := Usable_emitter.Set.remove c !set; new_e.version <- v end; current := new_e with Not_found -> (* in multi-sessions mode (e.g. save/load), the emitters could exist in the previous session but not in the current one. In this case, there is nothing to do. Additionnally, even if it still exists, it could be not yet restored since the project library does not ensure that it restores the table of emitters before the states of parameters. In such a case, it is also possible to do nothing since the right table in the right state is going to be restored. *) () in try let tbl = Parameter.Hashtbl.find parameter_hooks p in Datatype.String.Hashtbl.replace tbl name update with Not_found -> Kernel.fatal "[Emitter] no hook table for parameter %s" p.Parameter.name let () = Cmdline.run_after_extended_stage (fun () -> State_selection.Static.iter (fun s -> let tbl = Datatype.String.Hashtbl.create 7 in let p = Parameter.get (State.get_name s) in Parameter.Hashtbl.add parameter_hooks p tbl; let update () = Datatype.String.Hashtbl.iter (fun _ f -> f ()) tbl in match p.Parameter.accessor with (* factorisation requires GADT (OCaml 4.01) *) | Parameter.Bool(a, _) -> a.Parameter.add_set_hook (fun _ _ -> update ()) | Parameter.Int(a, _) -> a.Parameter.add_set_hook (fun _ _ -> update ()) | Parameter.String(a, _) -> a.Parameter.add_set_hook (fun _ _ -> update ()) | Parameter.String_set a -> a.Parameter.add_set_hook (fun _ _ -> update ()) | Parameter.String_list a -> a.Parameter.add_set_hook (fun _ _ -> update ())) (* [JS 2012/02/07] should be limited to [Plugin.get_selection_context], but it is not possible while each plug-in (including Wp) is not projectified *) (* (Plugin.get_selection_context ~is_set:false ()))*) (Plugin.get_selection ~is_set:false ())) let update_table tbl = (* remove old stuff *) Usable_emitters_of_emitter.iter (fun _ (_, all_usable_e) -> Usable_emitter.Set.iter (fun e -> (* remove dependencies corresponding to old correctness parameters *) Datatype.String.Map.iter (fun p _ -> iter_on_kinds (State_dependency_graph.remove_dependencies ~from:(State.get p)) e.u_kinds) e.correctness_values; (* remove hooks corresponding to old tuning parameters *) Parameter.Hashtbl.iter (fun _ tbl -> Datatype.String.Hashtbl.clear tbl) parameter_hooks) !all_usable_e); (* register new stuff *) Datatype.String.Hashtbl.iter (fun e_name (_, all_usable_e) -> Usable_emitter.Set.iter (fun e -> Datatype.String.Map.iter (fun p _ -> register_correctness_parameter p e.u_kinds) e.correctness_values; Datatype.String.Map.iter (fun p _ -> register_tuning_parameter e_name (Parameter.get p)) e.tuning_values) !all_usable_e) tbl let () = Usable_emitters_of_emitter.add_hook_on_update update_table let register_parameter tuning usable_e p = let usable_e = update_parameter tuning usable_e p in if tuning then register_tuning_parameter usable_e.u_name p else register_correctness_parameter p.Parameter.name usable_e.u_kinds; usable_e let create_usable_emitter e = let id = Usable_id.next () in let usable_e = { u_id = id; u_name = e.name; u_kinds = e.kinds; used = true; version = -1; (* delayed *) tuning_values = Datatype.String.Map.empty; correctness_values = Datatype.String.Map.empty } in let usable_e = List.fold_left (register_parameter true) usable_e e.tuning_parameters in let usable_e = List.fold_left (register_parameter false) usable_e e.correctness_parameters in usable_e.version <- 1; usable_e let get e = let name = e.name in try let current, _ = Usable_emitters_of_emitter.find name in let c = !current in c.used <- true; c with Not_found -> let usable_e = create_usable_emitter e in Usable_emitters_of_emitter.add name (ref usable_e, ref (Usable_emitter.Set.singleton usable_e)); usable_e module ED = D (* for debugging *) module Make_table (H: Datatype.Hashtbl) (E: sig include Datatype.S_with_collections val local_clear: H.key -> 'a Hashtbl.t -> unit val usable_get: t -> Usable_emitter.t val get: t -> emitter end) (D: Datatype.S) (Info: sig include State_builder.Info_with_size val kinds: kind list end) = struct module Remove_hooks = Hook.Build(struct type t = E.t * H.key * D.t end) let add_hook_on_remove f = Remove_hooks.extend (fun (e, k, d) -> f e k d) let apply_hooks_on_remove e k d = Remove_hooks.apply (e, k, d) (* this list is computed after defining [self] *) let static_dependencies = ref [] let must_clear_all sel = List.exists (State_selection.mem sel) !static_dependencies (* [KNOWN LIMITATION] only works iff the selection contains the parameter' state. In particular, that does not work if one writes something like let selection = State_selection.only_dependencies Kernel.MainFunction.self in Project.clear ~selection () *) let must_local_clear sel = try State.Hashtbl.iter (fun s () -> if State_selection.mem sel s then raise Exit) correctness_states; true with Exit -> false let create () = H.create Info.size let state = ref (create ()) module Tbl = E.Hashtbl.Make(D) type internal_tbl = Tbl.t module H_datatype = H.Make(Tbl) let dkey = Kernel.register_category "emitter" (* standard projectified hashtbl, but an ad-hoc function 'clear' *) include State_builder.Register (H_datatype) (struct type t = Tbl.t H.t let create = create let clear tbl = let sel = Project.get_current_selection () in (* Kernel.feedback "SELECT: %a" State_selection.pretty sel;*) if must_clear_all sel then begin (* someone explicitly requires to fully reset the table *) Kernel.debug ~dkey ~level:3 "FULL CLEAR of %s in %a" Info.name Project.pretty (Project.current ()); H.clear tbl end else (* AST is unchanged *) if must_local_clear sel then begin (* one have to clear the table, but we have to keep the keys *) Kernel.debug ~dkey ~level:3 "LOCAL CLEAR of %s in %a" Info.name Project.pretty (Project.current ()); H.iter (fun k h -> if not (Remove_hooks.is_empty ()) then E.Hashtbl.iter (fun e x -> apply_hooks_on_remove e k x) h; E.local_clear k h) tbl; end else begin (* we have to clear only the bindings corresponding to the selected correctness parameters *) let to_be_removed = ref [] in H.iter (fun k h -> E.Hashtbl.iter (fun e x -> let is_param_selected = List.exists (fun p -> State_selection.mem sel (State.get p)) (Usable_emitter.correctness_parameters (E.usable_get e)) in if is_param_selected then to_be_removed := (k, e, x) :: !to_be_removed) h) tbl; List.iter (fun (k, e, x) -> try let h = H.find tbl k in Kernel.debug ~dkey ~level:3 "CLEARING binding %a of %s in %a" ED.pretty (E.get e) Info.name Project.pretty (Project.current ()); E.Hashtbl.remove h e; apply_hooks_on_remove e k x with Not_found -> assert false) !to_be_removed end let get () = !state let set x = state := x let clear_some_projects _f _h = false end) (struct include Info let unique_name = name let dependencies = self :: dependencies end) let add_kind k = try let l = Hashtbl.find kinds k in Hashtbl.replace kinds k (self :: l) with Not_found -> Hashtbl.add kinds k [ self ] (* compute which states always impact this one (i.e. [self]) *) let () = List.iter add_kind Info.kinds; let get_dependencies () = State_dependency_graph.G.fold_pred (fun s acc -> s :: acc) State_dependency_graph.graph self [] in Cmdline.run_after_early_stage (fun () -> static_dependencies := get_dependencies ()) let add key v = H.add !state key v let find key = H.find !state key let mem key = H.mem !state key let iter f = H.iter f !state let fold f acc = H.fold f !state acc let remove key = if not (Remove_hooks.is_empty ()) then begin try let tbl = find key in E.Hashtbl.iter (fun e v -> apply_hooks_on_remove e key v) tbl; with Not_found -> () end; H.remove !state key; end include D (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/visitor.mli0000644000175000017500000002010612155630171020246 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (** Frama-C visitors dealing with projects. @plugin development guide *) (** Class type for a Db-aware visitor. This is done by defining auxiliary methods that can be redefined in inherited classes, while the corresponding ones from {!Cil.cilVisitor} {b must} retain their values as defined here. Otherwise, annotations may not be visited properly. The replaced functions are - [vstmt] (use [vstmt_aux] instead) - [vglob] (use [vglob_aux] instead) {b A few hints on how to use correctly this visitor} - when initializing a new project with it (see {!File.init_project_from_visitor}), use a visitor with copy behavior - [SkipChildren] and [ChangeTo] must be used with extreme care in a visitor with copy behavior, or some nodes may be shared between the original and the copy. - Do not erase a statement during the visit, as there might be annotations attached to it. Change it to Skip instead, the [generic_frama_c_visitor] will know what to do. - Be careful if you change the [vid] or [sid]: this must be done before anything has been attached to the corresponding variable or statement in the new project, which means - for statements, in [vstmt], for the current statement only - for variables, at their declaration point. *) class type frama_c_visitor = object inherit Cil.cilVisitor method frama_c_plain_copy: frama_c_visitor (** same as plain_copy_visitor but for frama-c specific methods *) method vstmt_aux: stmt -> stmt Cil.visitAction (** Replacement of vstmt. @plugin development guide*) method vglob_aux: global -> global list Cil.visitAction (** Replacement of vglob. @plugin development guide*) method current_kf: kernel_function option (** link to the kernel function currently being visited. {b NB:} for copy visitors, the link is to the original kf (anyway, the new kf is created only after the visit is over). @plugin development guide *) method set_current_kf: kernel_function -> unit (** Internal use only. *) method reset_current_kf: unit -> unit (** Internal use only. *) end class frama_c_inplace: frama_c_visitor (** in-place visitor; always act in the current project. @plugin development guide *) class frama_c_copy: Project.t -> frama_c_visitor (** Copying visitor. The [Project.t] argument specifies in which project the visitor creates the new values. (Technically, the method [fill_global_tables] is called inside this project.) See {!File.init_project_from_visitor} and [create_project_from_visitor] for possible uses. *) class generic_frama_c_visitor: Cil.visitor_behavior -> frama_c_visitor (** Generic class that abstracts over [frama_c_inplace] and [frama_c_copy]. @plugin development guide *) (** Visit a file. This will will re-cons all globals TWICE (so that it is tail-recursive). Use {!Cil.visitCilFileSameGlobals} if your visitor will not change the list of globals. *) val visitFramacFileCopy: frama_c_visitor -> file -> file (** Same thing, but the result is ignored. The given visitor must thus be an inplace visitor. Nothing is done if the visitor is a copy visitor. *) val visitFramacFile: frama_c_visitor -> file -> unit (** A visitor for the whole file that does not change the globals (but maybe changes things inside the globals). Use this function instead of {!Visitor.visitFramacFile} whenever appropriate because it is more efficient for long files. @plugin development guide *) val visitFramacFileSameGlobals: frama_c_visitor -> file -> unit (** Visit a global. *) val visitFramacGlobal: frama_c_visitor -> global -> global list (** Visit a function definition. @plugin development guide *) val visitFramacFunction: frama_c_visitor -> fundec -> fundec (** Visit an expression *) val visitFramacExpr: frama_c_visitor -> exp -> exp (** Visit an lvalue *) val visitFramacLval: frama_c_visitor -> lval -> lval (** Visit an lvalue or recursive offset *) val visitFramacOffset: frama_c_visitor -> offset -> offset (** Visit an initializer offset *) val visitFramacInitOffset: frama_c_visitor -> offset -> offset (** Visit an instruction *) val visitFramacInstr: frama_c_visitor -> instr -> instr list (** Visit a statement *) val visitFramacStmt: frama_c_visitor -> stmt -> stmt (** Visit a block *) val visitFramacBlock: frama_c_visitor -> block -> block (** Visit a type *) val visitFramacType: frama_c_visitor -> typ -> typ (** Visit a variable declaration *) val visitFramacVarDecl: frama_c_visitor -> varinfo -> varinfo (** Visit an initializer, pass also the global to which this belongs and the * offset. *) val visitFramacInit: frama_c_visitor -> varinfo -> offset -> init -> init (** Visit a list of attributes *) val visitFramacAttributes: frama_c_visitor -> attribute list -> attribute list val visitFramacAnnotation: frama_c_visitor -> global_annotation -> global_annotation val visitFramacCodeAnnotation: frama_c_visitor -> code_annotation -> code_annotation val visitFramacAssigns: frama_c_visitor -> identified_term assigns -> identified_term assigns val visitFramacFrom: frama_c_visitor -> identified_term from -> identified_term from val visitFramacDeps: frama_c_visitor -> identified_term deps -> identified_term deps val visitFramacFunspec: frama_c_visitor -> funspec -> funspec val visitFramacLogicType: frama_c_visitor -> logic_type -> logic_type val visitFramacPredicate: frama_c_visitor -> predicate -> predicate val visitFramacPredicateNamed: frama_c_visitor -> predicate named -> predicate named val visitFramacIdPredicate: frama_c_visitor -> identified_predicate -> identified_predicate val visitFramacPredicates: frama_c_visitor -> identified_predicate list -> identified_predicate list (** visit identified_term. @since Oxygen-20120901 *) val visitFramacIdTerm: frama_c_visitor -> identified_term -> identified_term val visitFramacTerm: frama_c_visitor -> term -> term val visitFramacTermLval: frama_c_visitor -> term_lval -> term_lval val visitFramacTermLhost: frama_c_visitor -> term_lhost -> term_lhost val visitFramacTermOffset: frama_c_visitor -> term_offset -> term_offset val visitFramacLogicInfo: frama_c_visitor -> logic_info -> logic_info val visitFramacBehavior: frama_c_visitor -> funbehavior -> funbehavior val visitFramacBehaviors: frama_c_visitor -> funbehavior list -> funbehavior list val visitFramacModelInfo: frama_c_visitor -> model_info -> model_info (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/special_hooks.ml0000644000175000017500000001065012155630171021224 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let version () = if Kernel.PrintVersion.get () then begin Log.print_on_output (fun fmt -> Format.fprintf fmt "Version: %s@\n\ Compilation date: %s@\n\ Share path: %s (may be overridden with FRAMAC_SHARE variable)@\n\ Library path: %s (may be overridden with FRAMAC_LIB variable)@\n\ Plug-in paths: %t(may be overridden with FRAMAC_PLUGIN variable)@." Config.version Config.date Config.datadir Config.libdir (fun fmt -> List.iter (fun s -> Format.fprintf fmt "%s " s) (Dynamic.default_path ())) ); raise Cmdline.Exit end let () = Cmdline.run_after_early_stage version let print_path get dir () = if get () then begin Log.print_on_output (fun fmt -> Format.fprintf fmt "%s%!" dir) ; raise Cmdline.Exit end let print_sharepath = print_path Kernel.PrintShare.get Config.datadir let () = Cmdline.run_after_early_stage print_sharepath let print_libpath = print_path Kernel.PrintLib.get Config.libdir let () = Cmdline.run_after_early_stage print_libpath let print_pluginpath = print_path Kernel.PrintPluginPath.get Config.plugin_dir let () = Cmdline.run_after_early_stage print_pluginpath (* Time *) let time () = let filename = Kernel.Time.get () in if filename <> "" then let oc = open_out_gen [ Open_append; Open_creat; Open_binary] 0b111100100 filename in let {Unix.tms_utime = time } = Unix.times () in let now = Unix.localtime (Unix.time ()) in Printf.fprintf oc "%02d/%02d/%02d %02d:%02d:%02d %f\n" now.Unix.tm_mday (now.Unix.tm_mon+1) (now.Unix.tm_year - 100) now.Unix.tm_hour now.Unix.tm_min now.Unix.tm_sec time; flush oc; close_out oc let () = at_exit time (* Save Frama-c on disk if required *) let save_binary () = let filename = Kernel.SaveState.get () in if filename <> "" then begin Kernel.SaveState.clear (); try Project.save_all filename with Project.IOError s -> Kernel.error "problem while saving to file %s (%s)." filename s end let () = at_exit save_binary (* Load Frama-c from disk if required *) let load_binary () = let filename = Kernel.LoadState.get () in if filename <> "" then begin try Project.load_all filename with Project.IOError s -> Kernel.abort "problem while loading file %s (%s)" filename s end let () = Cmdline.run_after_loading_stage load_binary (* This hook cannot be registered directly in Kernel or Cabs2cil, as it depends on Ast_info *) let warn_for_call_to_undeclared_function vi = let name = vi.Cil_types.vname in if Kernel.WarnUndeclared.get () && not (Ast_info.is_frama_c_builtin name) then Kernel.warning ~current:true ~once:true "Calling undeclared function %s. Old style K&R code?" name let () = Cabs2cil.register_implicit_prototype_hook warn_for_call_to_undeclared_function (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/cmdline.ml0000644000175000017500000007253412155630171020025 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** This file implements how the command line is parsed. The parsing of the Frama-C command line is done in several stages. The first one is done when this module is loaded by caml (that is very early). At each stage [s], each option [o] put on the command line are checked again the recognized options at stage [s]. If [o] is recognized, then its associated action is performed. Otherwise [o] will be proceed by the next stage. Complexity of this algorithm is [O(2*s*o)] where [s] is the number of stages and [o] is the number of options puts on the command line options. That is quite bad and that could be improved. However it should be good enough in practice because there are not so many options put on the command line and others Frama-C algorithms take much more time. Parsing the command line option is not the more difficult/longer stuff for Frama-C ;-). *) (* ************************************************************************* *) (** {2 Global declarations} *) (* ************************************************************************* *) module type Level = sig val value_if_set: int option ref val get: unit -> int val set: int -> unit end module Make_level(X: sig val default: int end) = struct let value_if_set = ref None let get () = match !value_if_set with None -> X.default | Some x -> x let set n = value_if_set := Some n end module Debug_level = Make_level(struct let default = 0 end) module Verbose_level = Make_level(struct let default = 1 end) module Kernel_debug_level = Make_level(struct let default = 0 end) module Kernel_verbose_level = Make_level(struct let default = 1 end) let kernel_debug_atleast_ref = ref (fun n -> Kernel_debug_level.get () >= n) let kernel_verbose_atleast_ref = ref (fun n -> Kernel_verbose_level.get () >= n) let quiet_ref = ref false let journal_enable_ref = ref !Config.is_gui let journal_isset_ref = ref false let journal_name_ref = ref "frama_c_journal" let use_obj_ref = ref true let use_type_ref = ref true module L = Log.Register (struct let channel = Log.kernel_channel_name let label = Log.kernel_label_name (* eta-expansion required below *) let verbose_atleast n = !kernel_verbose_atleast_ref n let debug_atleast n = !kernel_debug_atleast_ref n end) include L (* ************************************************************************* *) (** {2 Handling errors} *) (* ************************************************************************* *) let long_plugin_name s = if s = Log.kernel_label_name then "Frama-C" else "Plug-in " ^ s let additional_info () = if !Config.is_gui then "\nReverting to previous state.\n\ Look at the console for additional information (if any)." else "" let get_backtrace () = let current_src_string = try let src = Log.get_current_source() in "Current source was: " ^ (Printf.sprintf "%s:%d" src.Lexing.pos_fname src.Lexing.pos_lnum) ^ "\n" with Not_found -> "Current source was not set\n" in current_src_string ^ "The full backtrace is:\n" ^ Printexc.get_backtrace () let request_crash_report = Format.sprintf "Please report as 'crash' at http://bts.frama-c.com/.\n\ Your Frama-C version is %s.\n\ Note that a version and a backtrace alone often do not contain enough\n\ information to understand the bug. Guidelines for reporting bugs are at:\n\ http://bts.frama-c.com/dokuwiki/doku.php?id=mantis:frama-c:bug_reporting_guidelines\n" Config.version let protect = function | Sys.Break -> "User Interruption (Ctrl-C)" ^ if Kernel_debug_level.get () > 0 then "\n" ^ get_backtrace () else "" | Sys_error s -> Printf.sprintf "System error: %s" s | Unix.Unix_error(err, a, b) -> let error = Printf.sprintf "System error: %s" (Unix.error_message err) in (match a, b with | "", "" -> error | "", t | t, "" -> Printf.sprintf "%s (%s)" error t | f, x -> Printf.sprintf "%s (%s %S)" error f x) | Log.AbortError p -> Printf.sprintf "%s aborted: invalid user input.%s" (long_plugin_name p) (additional_info ()) | Log.AbortFatal p -> Printf.sprintf "%s\n%s aborted: internal error.%s\n%s" (get_backtrace ()) (long_plugin_name p) (additional_info ()) request_crash_report | Log.FeatureRequest(p, m) -> let name = long_plugin_name p in Printf.sprintf "%s aborted: unimplemented feature.%s\n\ You may send a feature request at http://bts.frama-c.com with:\n\ '[%s] %s'." name (additional_info ()) name m | e -> Printf.sprintf "%s\nUnexpected error (%s).\n%s" (get_backtrace ()) (Printexc.to_string e) request_crash_report (* ************************************************************************* *) (** {2 Exiting Frama-C} *) (* ************************************************************************* *) module NormalExit = Hook.Make(struct end) let at_normal_exit = NormalExit.extend let run_normal_exit_hook = NormalExit.apply module ErrorExit = Hook.Make(struct end) let at_error_exit = ErrorExit.extend let run_error_exit_hook = ErrorExit.apply let error_occured_ref = ref false let error_occured () = error_occured_ref := true type exit = unit exception Exit let nop = () let catch_at_toplevel = function | Log.AbortError _ -> true | Log.FeatureRequest _ -> true | _ -> Kernel_debug_level.get () = 0 let exit_code = function | Log.AbortError _ -> 1 | Sys.Break -> 2 | Log.FeatureRequest _ -> 3 | Log.AbortFatal _ -> 4 | _ -> 125 let bail_out_ref = ref (fun _ -> assert false) let bail_out () = !bail_out_ref (); (* bail_out_ref must call exit 0 *) assert false let catch_toplevel_run ~f ~quit ~at_normal_exit ~on_error = (* both functions below handle errors at exit hooks *) let run_at_normal_exit () = try at_normal_exit () with exn -> L.feedback ~level:0 "error occurring when exiting Frama-C: stopping exit procedure.\n%s@." (protect exn); exit 5 in let run_on_error () = try on_error () with exn -> L.feedback ~level:0 "error occurring when handling error: stopping error handling \ procedure.\n%s@." (protect exn); exit 6 in let bail_out () = (if !error_occured_ref then run_on_error else run_at_normal_exit) (); (* even if an error occured somewhere, Frama-C stops normally. *) exit 0 in bail_out_ref := bail_out; try f (); (* write again on stdout *) Log.set_output (Pervasives.output stdout) (fun () -> Pervasives.flush stdout); (if quit then bail_out else run_at_normal_exit) () with | Exit -> bail_out () | exn when catch_at_toplevel exn -> L.feedback ~level:0 "%s" (protect exn); run_on_error (); exit (exit_code exn) | exn -> run_on_error (); raise exn (* ************************************************************************* *) (** {2 Generic parsing way} *) (* ************************************************************************* *) type option_setting = | Unit of (unit -> unit) | Int of (int -> unit) | String of (string -> unit) | String_list of (string list -> unit) exception Cannot_parse of string * string let raise_error name because = raise (Cannot_parse(name, because)) let error name msg = let bin_name = Sys.argv.(0) in L.abort "option `%s' %s.@\nuse `%s -help' for more information." name msg bin_name let all_options = match Array.to_list Sys.argv with | [] -> assert false | _binary :: l -> l let get_option_and_arg option arg = try let k = String.index option '=' in let p = succ k in String.sub option 0 k , String.sub option p (String.length option - p) , true with Not_found -> option, arg, false let parse known_options_list then_expected options_list = let known_options = Hashtbl.create 17 in List.iter (fun (n, s) -> Hashtbl.add known_options n s) known_options_list; let parse_one_option unknown_options option arg = let option, arg, explicit = get_option_and_arg option arg in let check_string_argname () = if not explicit && (arg = "" || arg.[0] = '-') then raise_error option "requires a string as argument"; in try let setting = Hashtbl.find known_options option in let use_arg = match setting with | Unit f -> if explicit then raise_error option "does not accept any argument"; f (); false | Int f -> let n = try int_of_string arg with Failure _ -> raise_error option "requires an integer as argument" in f n; true | String f -> check_string_argname (); f arg; true | String_list f -> check_string_argname (); f (Str.split (Str.regexp "[ \t]*,[ \t]*") arg); true in unknown_options, use_arg && not explicit, true with Not_found -> let o = if explicit then option ^ "=" ^ arg else option in o :: unknown_options, false, false in let rec go unknown_options nb_used = function | [] -> unknown_options, nb_used, None | [ "-then" ] when then_expected -> L.warning "ignoring last option `-then'"; unknown_options, nb_used, None | [ "-then-on" ] when then_expected -> raise_error "-then-on" "requires a string as argument" | [ option ] -> let unknown, use_arg, is_used = parse_one_option unknown_options option "" in assert (not use_arg); unknown, (if is_used then succ nb_used else nb_used), None | "-then" :: then_options when then_expected -> unknown_options, nb_used, Some (then_options, None) | "-then-on" :: project_name :: then_options when then_expected -> unknown_options, nb_used, Some (then_options, Some project_name) | option :: (arg :: next_options as arg_next) -> let unknown, use_arg, is_used = parse_one_option unknown_options option arg in let next = if use_arg then next_options else arg_next in go unknown (if is_used then succ nb_used else nb_used) next in try let unknown_options, nb_used, then_options = go [] 0 options_list in List.rev unknown_options, nb_used, then_options with Cannot_parse(name, msg) -> error name msg (* ************************************************************************* *) (** {2 First parsing stage at the very beginning of the initialization step} *) (* ************************************************************************* *) let non_initial_options_ref = ref [] let () = let set_journal b = journal_enable_ref := b; journal_isset_ref := true in let first_parsing_stage () = parse [ "-journal-enable", Unit (fun () -> set_journal true); "-journal-disable", Unit (fun () -> set_journal false); "-journal-name", String (fun s -> journal_name_ref := s); "-no-obj", Unit (fun () -> use_obj_ref := false); "-no-type", Unit (fun () -> use_type_ref := false); "-quiet", Unit (fun () -> quiet_ref := true; Verbose_level.set 0; Debug_level.set 0); "-verbose", Int (fun n -> Verbose_level.set n); "-debug", Int (fun n -> Debug_level.set n); "-kernel-verbose", Int (fun n -> Kernel_verbose_level.set n); "-kernel-debug", Int (fun n -> Kernel_debug_level.set n) ] false all_options in catch_toplevel_run ~f:(fun () -> let remaining_options, _, _ = first_parsing_stage () in non_initial_options_ref := remaining_options) ~quit:false ~at_normal_exit:(fun () -> ()) ~on_error:run_error_exit_hook let () = if not !use_obj_ref then use_type_ref := false; if not !use_type_ref then begin Type.no_obj (); if !journal_enable_ref then begin warning "disabling journal in the 'no obj' mode"; journal_enable_ref := false end end let quiet = !quiet_ref let journal_enable = !journal_enable_ref let journal_isset = !journal_isset_ref let journal_name = !journal_name_ref let use_obj = !use_obj_ref let use_type = !use_type_ref (* ************************************************************************* *) (** {2 Plugin} *) (* ************************************************************************* *) type cmdline_option = { oname: string; argname: string; ohelp: string; ovisible: bool; ext_help: (unit,Format.formatter,unit) format; setting: option_setting } module Plugin: sig type t = private { name: string; help: string; short: string; groups: (string, cmdline_option list ref) Hashtbl.t } val all_plugins: unit -> t list val add: ?short:string -> string -> help:string -> unit val add_group: ?memo:bool -> plugin:string -> string -> string * bool val add_option: string -> group:string -> cmdline_option -> unit val add_aliases: orig:string -> string -> group:string -> string list -> cmdline_option list val find: string -> t val find_option_aliases: cmdline_option -> cmdline_option list val is_option_alias: cmdline_option -> bool end = struct type t = { name: string; help: string; short: string; groups: (string, cmdline_option list ref) Hashtbl.t } (* all the registered plug-ins indexed by their shortnames *) let plugins : (string, t) Hashtbl.t = Hashtbl.create 17 let all_plugins () = Hashtbl.fold (fun _ p acc -> p :: acc) plugins [] let add ?short name ~help = let short = match short with None -> name | Some s -> s in if Hashtbl.mem plugins short then invalid_arg ("a plug-in " ^ short ^ " is already registered."); let groups = Hashtbl.create 7 in Hashtbl.add groups "" (ref []); Hashtbl.add plugins short { name = name; short = short; help = help; groups = groups } let find p = try Hashtbl.find plugins p with Not_found -> fatal "Plug-in %s not found" p let add_group ?(memo=false) ~plugin name = let groups = (find plugin).groups in name, if Hashtbl.mem groups name then begin if not memo then abort "A group of name %s already exists for plug-in %s" name plugin; false end else begin Hashtbl.add groups name (ref []); true end let find_group p g = try Hashtbl.find (find p).groups g with Not_found -> fatal "Group %s not found for plug-in %s" g p module Option_names : sig val add: string -> bool -> unit val is_option_alias: string -> bool end = struct let tbl = Hashtbl.create 7 let check s = if Hashtbl.mem tbl s then invalid_arg (Format.sprintf "an option with the name %S is already registered." s) let add s b = check s; Hashtbl.add tbl s b let is_option_alias s = try Hashtbl.find tbl s with Not_found -> assert false end let add_option shortname ~group option = assert (option.oname <> ""); Option_names.add option.oname false; let g = find_group shortname group in g := option :: !g (* table name_of_the_original_option --> aliases *) let aliases_tbl = Hashtbl.create 7 let add_aliases ~orig shortname ~group names = (* mostly inline [add_option] and perform additional actions *) let options_group = find_group shortname group in let option = List.find (fun o -> o.oname = orig) !options_group in let get_one name = if name = "" then invalid_arg "empty alias name"; Option_names.add name true; let alias = { option with oname = name } in options_group := alias :: !options_group; alias in let aliases = List.map get_one names in (try let l = Hashtbl.find aliases_tbl orig in l := aliases @ !l; with Not_found -> Hashtbl.add aliases_tbl orig (ref aliases)); aliases let find_option_aliases o = try !(Hashtbl.find aliases_tbl o.oname) with Not_found -> [] let is_option_alias o = Option_names.is_option_alias o.oname end let add_plugin = Plugin.add module Group = struct type t = string let add = Plugin.add_group let default = "" let name x = x end (* ************************************************************************* *) (** {2 Parsing} *) (* ************************************************************************* *) module Make_Stage (S: sig val exclusive: bool val name: string val then_expected: bool end) = struct let nb_actions = ref 0 let is_going_to_run () = incr nb_actions module H = Hook.Make(struct end) let options : (string, cmdline_option) Hashtbl.t = Hashtbl.create 17 let add_for_parsing option = Hashtbl.add options option.oname option let add name plugin ?(argname="") help visible ext_help setting = L.debug ~level:4 "Cmdline: [%s] registers %S for stage %s." plugin name S.name; let help = if help = "" then "undocumented" else help in let o = { oname = name; argname = argname; ohelp = help; ext_help = ext_help; ovisible = visible; setting = setting } in add_for_parsing o; Plugin.add_option plugin o let parse options_list = L.feedback ~level:3 "parsing command line options of stage %S." S.name ; let options, nb_used, then_options = parse (Hashtbl.fold (fun _ o acc -> (o.oname, o.setting) :: acc) options []) S.then_expected options_list in let nb_used = nb_used + !nb_actions in if S.exclusive && nb_used > 1 then begin L.abort "at most one %s action must be specified." S.name; end; H.apply (); options, nb_used, then_options end module Early_Stage = Make_Stage (struct let exclusive = false let name = "early" let then_expected = false end) module Extending_Stage = Make_Stage (struct let exclusive = false let name = "extending" let then_expected = false end) module Extended_Stage = Make_Stage (struct let exclusive = false let name = "extended" let then_expected = true end) module Exiting_Stage = Make_Stage (struct let exclusive = true let name = "exiting" let then_expected = false end) module Loading_Stage = Make_Stage (struct let exclusive = true let name = "loading" let then_expected = false end) let is_going_to_load = Loading_Stage.is_going_to_run module Configuring_Stage = Make_Stage (struct let exclusive = false let name = "configuring" let then_expected = false end) let run_after_early_stage = Early_Stage.H.extend let run_during_extending_stage = Extending_Stage.H.extend let run_after_extended_stage = Extended_Stage.H.extend let run_after_exiting_stage = Exiting_Stage.H.extend let run_after_loading_stage = Loading_Stage.H.extend let run_after_configuring_stage = Configuring_Stage.H.extend module After_setting = Hook.Build(struct type t = string list end) let run_after_setting_files = After_setting.extend type stage = Early | Extending | Extended | Exiting | Loading | Configuring let add_option name ~plugin ~group stage ?argname ~help ~visible ~ext_help setting = if name <> "" then let add = match stage with | Early -> Early_Stage.add | Extending -> Extending_Stage.add | Extended -> Extended_Stage.add | Exiting -> Exiting_Stage.add | Loading -> Loading_Stage.add | Configuring -> Configuring_Stage.add in add name plugin ~group ?argname help visible ext_help setting let add_option_without_action name ~plugin ~group ?(argname="") ~help ~visible ~ext_help () = Plugin.add_option plugin ~group { oname = name; argname = argname; ohelp = help; ext_help = ext_help; ovisible = visible; setting = Unit (fun () -> assert false) } let add_aliases orig ~plugin ~group stage aliases = let l = Plugin.add_aliases ~orig plugin ~group aliases in let add = match stage with | Early -> Early_Stage.add_for_parsing | Extending -> Extending_Stage.add_for_parsing | Extended -> Extended_Stage.add_for_parsing | Exiting -> Exiting_Stage.add_for_parsing | Loading -> Loading_Stage.add_for_parsing | Configuring -> Configuring_Stage.add_for_parsing in List.iter add l module On_Files = Hook.Build(struct type t = string list end) let use_cmdline_files = On_Files.extend let set_files used_loading l = L.feedback ~level:3 "setting files from command lines."; List.iter (fun s -> if s = "" then error "" "has no name. What do you exactly have in mind?"; if s.[0] = '-' then error s "is unknown") l; assert (L.verify (not (On_Files.is_empty ())) "no function uses the files provided on the command line"); if List.length l > 0 then if used_loading then warning "ignoring source files specified on the command line \ while loading a global initial context." else begin On_Files.apply l; After_setting.apply l end let nb_used_ref = ref 0 let nb_used_relevant = ref false let nb_given_options () = assert (L.verify !nb_used_relevant "function `nb_given_options' called too early"); !nb_used_ref let rec play_in_toplevel on_from_name nb_used play options = let options, nb_used_extended, then_options_extended = Extended_Stage.parse options in let options, nb_used_exiting, then_options_exiting = Exiting_Stage.parse options in assert (then_options_exiting = None); if nb_used_exiting > 0 then fatal "setting an option at the exiting stage must stop Frama-C"; let options, nb_used_loading, then_options_loading = Loading_Stage.parse options in assert (then_options_loading = None); let files, nb_used_config, then_options_configuring = Configuring_Stage.parse options in assert (then_options_configuring = None); nb_used_relevant := true; nb_used_ref := nb_used + nb_used_extended + nb_used_exiting + nb_used_loading + nb_used_config ; set_files (nb_used_loading > 0) files; L.feedback ~level:3 "running plug-in mains."; play (); match then_options_extended with | None -> () | Some(options, project_name) -> on_from_name project_name (fun () -> play_in_toplevel on_from_name nb_used play options) let parse_and_boot on_from_name get_toplevel play = let options, nb_used_early, then_options_early = Early_Stage.parse !non_initial_options_ref in assert (then_options_early = None); let options, nb_used_extending, then_options_extending = Extending_Stage.parse options in assert (then_options_extending = None); get_toplevel () (* the extending stage may change the toplevel: applying [get_toplevel] provides the good one. *) (fun () -> play_in_toplevel on_from_name (nb_used_early + nb_used_extending) play options) (* ************************************************************************* *) (** {2 Help} Implement a not very efficient algorithm but it is enough for displaying help and exiting. *) (* ************************************************************************* *) let print_helpline fmt head help ext_help = let n = max 1 (19 - String.length head) in Format.fprintf fmt "@[%s%s %t%t@]@\n" head (* let enough spaces *) (String.make n ' ') (* the description *) (fun fmt -> (* add a cutting point at each space *) let cut_space fmt s = let rec cut_list fmt = function | [] -> () | [ s ] -> Format.fprintf fmt "%s" s | s :: tl -> Format.fprintf fmt "%s@ %a" s cut_list tl in cut_list fmt (Str.split (Str.regexp_string " ") s) in (* replace each '\n' by '@\n' (except for the last one) *) let rec cut_newline fmt = function | [] -> () | [ s ] -> Format.fprintf fmt "%a" cut_space s | s :: tl -> Format.fprintf fmt "%a@\n%a" cut_space s cut_newline tl in cut_newline fmt (Str.split (Str.regexp_string "\n") help)) (* the extended description *) (fun fmt -> Format.fprintf fmt ext_help) let low_print_option_help fmt print_invisible o = if Plugin.is_option_alias o then begin false end else let ty = let s = o.argname in if s = "" then match o.setting with | Unit _ -> "" | Int _ -> " " | String _ -> " " | String_list _ -> " " else " <" ^ s ^ ">" in let name = o.oname in if print_invisible || o.ovisible then begin print_helpline fmt (name ^ ty) o.ohelp o.ext_help; List.iter (fun o -> print_helpline fmt (o.oname ^ ty) (" alias for option " ^ name) "") (Plugin.find_option_aliases o) end; true let print_option_help fmt ~plugin ~group name = let p = Plugin.find plugin in let options = try Hashtbl.find p.Plugin.groups group with Not_found -> fatal "[Cmdline.print_option_help] no group %s" group in (* linear search... *) let rec find_then_print = function | [] -> fatal "[Cmdline.print_option_help] no option %s" name | o :: tl -> if o.oname = name then ignore (low_print_option_help fmt true o) else find_then_print tl in find_then_print !options let option_intro short = let first = if short <> "" then begin let short = "-" ^ short in Format.sprintf "Most options of the form '%s-option-name'@ and without any \ parameter@ have an opposite with the name '%s-no-option-name'.@\n@\n" short short end else "" in Format.sprintf "%sMost options of the form '-option-name' and without any parameter@ \ have an opposite with the name '-no-option-name'.@\n@\n\ Options taking a string as argument should preferably be written@ \ -option-name=\"argument\"." first let plugin_help shortname = let p = Plugin.find shortname in if p.Plugin.name <> "" then begin assert (p.Plugin.short <> ""); Log.print_on_output (fun fmt -> Format.fprintf fmt "@[%s:@ %s@]@\n@[%s:@ %s@]@\n" "Plug-in name" p.Plugin.name "Plug-in shortname" shortname) end; Log.print_on_output (fun fmt -> Format.fprintf fmt "@[@[%s:@ %s@]@\n@\n%s@\n@\n%s:@\n@\n@[%t@]@]@?" "Description" p.Plugin.help (option_intro shortname) "***** LIST OF AVAILABLE OPTIONS" (fun fmt -> let print_options l = List.fold_left (fun b o -> let b' = low_print_option_help fmt false o in b || b') false (List.sort (fun o1 o2 -> String.compare o1.oname o2.oname) l) in let printed = print_options !(Hashtbl.find p.Plugin.groups "") in if printed then Format.pp_print_newline fmt (); let sorted_groups = List.sort (fun (s1, _) (s2, _) -> String.compare s1 s2) (Hashtbl.fold (fun s l acc -> if s = "" then acc else (s, l) :: acc) p.Plugin.groups []) in match sorted_groups with | [] -> () | g :: l -> let print_group newline (s, o) = if newline then Format.pp_print_newline fmt (); Format.fprintf fmt "@[*** %s@]@\n@\n" (String.uppercase s); ignore (print_options !o) in print_group false g; List.iter (print_group true) l)); raise Exit let help () = let iter_on_plugins f = List.iter (fun p -> if p.Plugin.name <> "" then f p) (List.sort (fun p1 p2 -> String.compare (String.lowercase p1.Plugin.name) (String.lowercase p2.Plugin.name)) (Plugin.all_plugins ())) in Log.print_on_output (fun fmt -> Format.fprintf fmt "@[%t@\n%t@\n@\n%s@\n@\n@[%t@]@]@?" (fun fmt -> Format.fprintf fmt "@[Usage: %s [options and files...]@]" Sys.argv.(0)) (fun fmt -> Format.fprintf fmt "@[`%s -kernel-help' provides a description of the general \ options of frama-c@]" Sys.argv.(0)) "***** LIST OF AVAILABLE PLUG-INS" (fun fmt -> iter_on_plugins (fun p -> print_helpline fmt p.Plugin.name (p.Plugin.help ^ ";\n use -" ^ p.Plugin.short ^ "-help for specific options.") ""))); raise Exit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/kernel_function.ml0000644000175000017500000003276412155630171021600 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (* ************************************************************************* *) (** {2 Getters} *) (* ************************************************************************* *) let dummy () = { fundec = Definition (Cil.emptyFunction "@dummy@", Location.unknown); return_stmt = None; spec = List.hd Funspec.reprs } let get_vi kf = Ast_info.Function.get_vi kf.fundec let get_id kf = (get_vi kf).vid let get_name kf = (get_vi kf).vname let get_location kf = match kf.fundec with | Definition (_, loc) -> loc | Declaration (_,vi,_, _) -> vi.vdecl let get_type kf = (get_vi kf).vtype let get_return_type kf = Cil.getReturnType (get_type kf) let get_global f = match f.fundec with | Definition (d, loc) -> GFun(d,loc) | Declaration (spec, vi, _, loc) -> GVarDecl(spec, vi,loc) let get_formals f = match f.fundec with | Definition(d, _) -> d.sformals | Declaration(_, _, None, _) -> [] | Declaration(_,_,Some args,_) -> args let get_locals f = match f.fundec with | Definition(d, _) -> d.slocals | Declaration(_, _, _, _) -> [] exception No_Definition let get_definition kf = match kf.fundec with | Definition (f,_) -> f | Declaration _ -> raise No_Definition (* ************************************************************************* *) (** {2 Kernel functions are comparable} *) (* ************************************************************************* *) include Cil_datatype.Kf (* ************************************************************************* *) (** {2 Searching} *) (* ************************************************************************* *) module Kf = State_builder.Option_ref (Datatype.Int.Hashtbl.Make(Datatype.Triple(Kf)(Stmt)(Datatype.List(Block)))) (struct let name = "KF" let dependencies = [ Ast.self ] end) let auxiliary_kf_stmt_state = Kf.self let clear_sid_info () = Kf.clear () let () = Cfg.clear_sid_info_ref := clear_sid_info let compute () = Kf.memo (fun () -> let p = Ast.get () in let h = Datatype.Int.Hashtbl.create 97 in let visitor = object(self) inherit Cil.nopCilVisitor val mutable current_kf = None val mutable opened_blocks = [] method kf = match current_kf with None -> assert false | Some kf -> kf method vblock b = opened_blocks <- b :: opened_blocks; Cil.ChangeDoChildrenPost (b,fun b -> opened_blocks <- List.tl opened_blocks; b) method vstmt s = Datatype.Int.Hashtbl.add h s.sid (self#kf, s, opened_blocks); Cil.DoChildren method vglob g = begin match g with | GFun (fd, _) -> (try let kf = Globals.Functions.get fd.svar in current_kf <- Some kf; with Not_found -> Kernel.fatal "No kernel function for function %a" Cil_datatype.Varinfo.pretty fd.svar) | _ -> () end; Cil.DoChildren end in Cil.visitCilFile (visitor :> Cil.cilVisitor) p; h) let find_from_sid sid = let table = compute () in let kf, s, _ = Datatype.Int.Hashtbl.find table sid in s, kf let find_englobing_kf stmt = snd (find_from_sid stmt.sid) let blocks_closed_by_edge s1 s2 = if not (List.exists (Stmt.equal s2) s1.succs) then raise (Invalid_argument "Kernel_function.edge_exits_block"); let table = compute () in try let _,_,b1 = Datatype.Int.Hashtbl.find table s1.sid in let _,_,b2 = Datatype.Int.Hashtbl.find table s2.sid in (* Kernel.debug ~level:2 "Blocks opened for stmt %a@\n%a@\nblocks opened for stmt %a@\n%a" Printer.pp_stmt s1 (Pretty_utils.pp_list ~sep:Pretty_utils.nl_sep Printer.pp_block) b1 Printer.pp_stmt s2 (Pretty_utils.pp_list ~sep:Pretty_utils.nl_sep Printer.pp_block) b2;*) let rec aux acc = function [] -> acc | inner_block::others -> if List.memq inner_block b2 then acc else aux (inner_block::acc) others in aux [] b1 with Not_found -> Format.eprintf "Unknown statements:@\n%d: %a@\n%d: %a@." s1.sid Cil_printer.pp_stmt s1 s2.sid Cil_printer.pp_stmt s2; raise Not_found let find_enclosing_block s = let table = compute () in let (_,_,b) = Datatype.Int.Hashtbl.find table s.sid in List.hd b let () = Globals.find_enclosing_block:= find_enclosing_block let find_all_enclosing_blocks s = let table = compute () in let (_,_,b) = Datatype.Int.Hashtbl.find table s.sid in b let stmt_in_loop kf stmt = let blocks = find_all_enclosing_blocks stmt in let vis = object inherit Cil.nopCilVisitor method vstmt s = match s.skind with | Loop (_,b,_,_,_) -> if List.memq b blocks then raise Exit; Cil.SkipChildren (* Don't need to inspect nested loops if it's already outside the outermost one. *) | _ -> Cil.DoChildren end in try ignore (Cil.visitCilFunction vis (get_definition kf)); false with | Exit -> true | No_Definition -> false (* Not the good kf obviously. *) let find_enclosing_loop kf stmt = let blocks = find_all_enclosing_blocks stmt in let innermost = ref None in let vis = object inherit Cil.nopCilVisitor method vstmt s = match s.skind with | Loop (_,b,_,_,_) -> if List.memq b blocks then begin innermost:= Some s; Cil.DoChildren end else Cil.SkipChildren (* Don't need to inspect nested loops if it's already outside the outermost one. *) | _ -> Cil.DoChildren end in try (match stmt.skind with | Loop _ -> stmt | _ -> ignore (Cil.visitCilFunction vis (get_definition kf)); (match !innermost with | Some s -> s | None -> raise Not_found)) with | No_Definition -> raise Not_found (* Not the good kf obviously. *) exception Got_return of stmt exception No_Statement let find_return kf = match kf.return_stmt with | None -> let find_return fd = let visitor = object inherit Cil.nopCilVisitor method vstmt s = match s.skind with | Return _ -> raise (Got_return s) | _ -> Cil.DoChildren end in try ignore (Cil.visitCilFunction (visitor :> Cil.cilVisitor) fd); assert false with Got_return s -> s in (try let ki = find_return (get_definition kf) in kf.return_stmt <- Some ki; ki with No_Definition -> raise No_Statement) | Some ki -> ki let get_stmts kf = try (get_definition kf).sbody.bstmts with No_Definition | Not_found -> [] let find_first_stmt kf = match get_stmts kf with | [] -> raise No_Statement | s :: _ -> s let () = Globals.find_first_stmt := find_first_stmt exception Found_label of stmt ref let find_label kf label = match kf.fundec with | Declaration _ -> raise Not_found | Definition (fundec,_) -> let label_finder = object inherit Cil.nopCilVisitor method vstmt s = begin if List.exists (fun lbl -> match lbl with | Label (s,_,_) -> s = label | Case _ -> false | Default _ -> label="default") s.labels then raise (Found_label (ref s)); Cil.DoChildren end method vexpr _ = Cil.SkipChildren method vtype _ = Cil.SkipChildren method vinst _ = Cil.SkipChildren end in try ignore (Cil.visitCilFunction label_finder fundec); (* Ok: this is not a code label *) raise Not_found with Found_label s -> s let get_called fct = match fct.enode with | Lval (Var vkf, NoOffset) -> (try Some (Globals.Functions.get vkf) with Not_found -> None) | _ -> None (* ************************************************************************* *) (** {2 CallSites} *) (* ************************************************************************* *) module CallSite = Datatype.Pair(Cil_datatype.Kf)(Stmt) module CallSites = Cil_datatype.Kf.Hashtbl module KfCallers = State_builder.Option_ref(CallSites.Make(Datatype.List(CallSite))) (struct let name = "Kf.CallSites" let dependencies = [ Ast.self ] end) let called_kernel_function fct = match fct.enode with | Lval (Var vinfo,NoOffset) -> (try Some(Globals.Functions.get vinfo) with Not_found -> None) | _ -> None class callsite_visitor hmap = object (self) inherit Cil.nopCilVisitor val mutable current_kf = None method private kf = match current_kf with None -> assert false | Some kf -> kf (* Go into functions *) method vglob = function | GFun(fd,_) -> current_kf <- Some(Globals.Functions.get fd.svar) ; Cil.DoChildren | _ -> Cil.SkipChildren (* Inspect stmt calls *) method vstmt stmt = match stmt.skind with | Instr(Call(_,fct,_,_)) -> begin match called_kernel_function fct with | None -> Cil.SkipChildren | Some ckf -> let sites = try CallSites.find hmap ckf with Not_found -> [] in CallSites.replace hmap ckf ((self#kf,stmt)::sites) ; Cil.SkipChildren end | Instr _ -> Cil.SkipChildren | _ -> Cil.DoChildren (* Skip many other things ... *) method vexpr _ = Cil.SkipChildren method vtype _ = Cil.SkipChildren end let compute_callsites () = let ast = Ast.get () in let hmap = CallSites.create 97 in let visitor = new callsite_visitor hmap in Cil.visitCilFile (visitor :> Cil.cilVisitor) ast ; hmap let find_syntactic_callsites kf = let table = KfCallers.memo compute_callsites in try CallSites.find table kf with Not_found -> [] (* ************************************************************************* *) (** {2 Checkers} *) (* ************************************************************************* *) let is_definition kf = match kf.fundec with | Definition _ -> true | Declaration _ -> false let returns_void kf = let result_type,_,_,_ = Cil.splitFunctionType (get_type kf) in match Cil.unrollType result_type with | TVoid _ -> true | _ -> false (* ************************************************************************* *) (** {2 Membership of variables} *) (* ************************************************************************* *) let is_formal v kf = List.exists (fun vv -> v.vid = vv.vid) (get_formals kf) let get_formal_position v kf = Extlib.find_index (fun vv -> v.vid = vv.vid) (get_formals kf) let is_local v kf = match kf.fundec with | Definition(fd, _) -> Ast_info.Function.is_local v fd | Declaration _ -> false let is_formal_or_local v kf = (not v.vglob) && (is_formal v kf || is_local v kf) (* ************************************************************************* *) (** {2 Pretty printer} *) (* ************************************************************************* *) let pretty_name = Kernel.deprecated "Kernel_function.pretty" ~now:"Kernel_function.pretty" pretty (* ************************************************************************* *) (** {2 Collections} *) (* ************************************************************************* *) module Make_Table = State_builder.Hashtbl(Cil_datatype.Kf.Hashtbl) module Hptset = struct let pretty_kf = pretty include Hptset.Make (Cil_datatype.Kf) (struct let v = [ [ ] ] end) (struct let l = [ Ast.self ] end) let () = Ast.add_monotonic_state self let () = Ast.add_hook_on_update clear_caches let pretty fmt = Pretty_utils.pp_iter iter pretty_kf fmt end (* ************************************************************************* *) (** {2 Setters} *) (* ************************************************************************* *) let register_stmt kf s b = let tbl = try Kf.get () with Not_found -> assert false in Datatype.Int.Hashtbl.add tbl s.sid (kf,s,b) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/journal.ml0000644000175000017500000004151112155630171020053 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ****************************************************************************) (* ****************************************************************************) (* ****************************************************************************) (* Disclaimer ---------- This module uses very unsafe caml features (module Obj). Modify it at your own risk. Sometimes the caml type system does not help you here. Introducing a bug here may introduce some "segmentation faults" in Frama-C *) (* ****************************************************************************) (* ****************************************************************************) (* ****************************************************************************) include Log.Register (struct let channel = Log.kernel_channel_name let label = Log.kernel_label_name let verbose_atleast n = !Cmdline.kernel_verbose_atleast_ref n let debug_atleast n = !Cmdline.kernel_debug_atleast_ref n end) (** Journalization of functions *) (* ****************************************************************************) (** {2 Journal management} *) (* ****************************************************************************) (* [started] prevents journalization of function call inside another one. It is [true] iff a journalized function is being applied. *) let started = ref false module Sentences = struct type t = { sentence: Format.formatter -> unit; raise_exn: bool } let sentences : t Queue.t = Queue.create () let add print exn = Queue.add { sentence = print; raise_exn = exn } sentences let write fmt = let finally_raised = ref false in (* printing the sentences *) Queue.iter (fun s -> s.sentence fmt; finally_raised := s.raise_exn) sentences; (* if any, re-raised the exception raised by the last sentence *) Format.fprintf fmt "@[%s@]" (if !finally_raised then "raise (Exception (Printexc.to_string exn))" else "()"); (* closing the box opened when catching exception *) Queue.iter (fun s -> if s.raise_exn then Format.fprintf fmt "@]@]@]@;end") sentences let journal_copy = ref (Queue.create ()) let save () = journal_copy := Queue.copy sentences let restore () = Queue.clear sentences; Queue.transfer !journal_copy sentences end module Abstract_modules = struct let tbl: (string, string) Hashtbl.t = Hashtbl.create 7 let () = Type.add_abstract_types := Hashtbl.replace tbl let write fmt = Hashtbl.iter (fun k v -> Format.fprintf fmt "@[let module %s=@;@[Type.Abstract\ (struct let name = %S end) in@]@]@;" k v) tbl let tbl_copy = ref (Hashtbl.create 7) let save () = tbl_copy := Hashtbl.copy tbl let restore () = Hashtbl.clear tbl; Hashtbl.iter (fun k v -> Hashtbl.add tbl k v) !tbl_copy end let save () = Sentences.save (); Abstract_modules.save () let restore () = Sentences.restore (); Abstract_modules.restore () let now () = Unix.localtime (Unix.time ()) let filename = ref Cmdline.journal_name let get_name () = !filename let set_name s = filename := s let print_header fmt = let time = now () in Format.pp_open_hvbox fmt 0; (* the outermost box *) Format.fprintf fmt "@[(* Frama-C journal generated at %02d:%02d the %02d/%02d/%d *)@]@;@;" time.Unix.tm_hour time.Unix.tm_min time.Unix.tm_mday (time.Unix.tm_mon+1) (time.Unix.tm_year + 1900); Format.fprintf fmt "@[exception Unreachable@]@;"; Format.fprintf fmt "@[exception Exception of string@]@;@;"; Format.fprintf fmt (* open two boxes for start *) "(* Run the user commands *)@;@[let run () =@;@[" let print_trailer fmt = Format.fprintf fmt "@[(* Main *)@]@\n"; Format.fprintf fmt "@[let main () =@;"; Format.fprintf fmt "@[@[Journal.keep_file@;\"%s.ml\";@]@;" !filename; Format.fprintf fmt "try run ()@;"; Format.fprintf fmt "@[with@;@[| Unreachable ->@ "; Format.fprintf fmt "@[Kernel.fatal@;\"Journal reachs an assumed dead code\"@;@]@]@;"; Format.fprintf fmt "@[| Exception s ->@ "; Format.fprintf fmt "@[Kernel.log@;\"Journal re-raised the exception %%S\"@;s@]@]@;"; Format.fprintf fmt "@[| exn ->@ "; Format.fprintf fmt "@[Kernel.fatal@;\"Journal raised an unexpected exception: %%s\"@;"; Format.fprintf fmt "(Printexc.to_string exn)@]@]@]@]@]@\n@\n"; Format.fprintf fmt "@[(* Registering *)@]@\n"; Format.fprintf fmt "@[let main : unit -> unit =@;@[Dynamic.register@;~plugin:%S@;\"main\"@;" (String.capitalize (Filename.basename (get_name ()))); Format.fprintf fmt "@[(Datatype.func@;Datatype.unit@;Datatype.unit)@]@;"; Format.fprintf fmt "~journalize:false@;main@]@]@\n@\n"; Format.fprintf fmt "@[(* Hooking *)@]@\n"; Format.fprintf fmt "@[let () =@;"; Format.fprintf fmt "@[Cmdline.run_after_loading_stage@;main;@]@;"; Format.fprintf fmt "@[Cmdline.is_going_to_load@;()@]@]@."; (* close the outermost box *) Format.pp_close_box fmt () let preserved_files = ref [] let keep_file s = preserved_files := s :: !preserved_files let get_filename = let cpt = ref 0 in let rec get_filename first = let name = !filename ^ ".ml" in if (not first && Sys.file_exists name) || List.mem name !preserved_files then begin incr cpt; let suf = "_" ^ string_of_int !cpt in (try let n = Str.search_backward (Str.regexp "_[0-9]+") !filename (String.length !filename - 1) in filename := Str.string_before !filename n ^ suf with Not_found -> filename := !filename ^ suf); get_filename false end else name in fun () -> get_filename true let write () = let write fmt = print_header fmt; Abstract_modules.write fmt; Sentences.write fmt; Format.fprintf fmt "@]@]@;@;"; print_trailer fmt; Format.pp_print_flush fmt () in let error msg s = error "cannot %s journal (%s)." msg s in let filename = get_filename () in feedback ~level:2 "writing journal in file \"%s\"" filename; try let cout = open_out filename in let fmt = Format.formatter_of_out_channel cout in Format.pp_set_margin fmt 78 (* line length *); (try write fmt with Sys_error s -> error "write into" s); try close_out cout with Sys_error s -> error "close" s with Sys_error s -> error "create" s let () = (* write the journal iff it is enable and - either an error occurs; - or the user explicitly wanted it. *) if Cmdline.journal_enable then begin Cmdline.at_error_exit write; if Cmdline.journal_isset then Cmdline.at_normal_exit write end (* ****************************************************************************) (** {2 Journalization} *) (* ****************************************************************************) module Binding: sig val add: 'a Type.t -> 'a -> string -> unit (** [add ty v var] binds the value [v] to the variable name [var]. Thus, [pp ty v] prints [var] and not use the standard pretty printer. Very useful to pretty print values with no associated pretty printer. *) exception Name_already_exists of string val add_once: 'a Type.t -> 'a -> string -> unit (** Same as function [add] above but raise the exception [Already_exists] if the binding previously exists *) val find: 'a Type.t -> 'a -> string val iter: ('a Type.t -> 'a -> string -> unit) -> unit end = struct let bindings : string Type.Obj_tbl.t = Type.Obj_tbl.create () let add ty v var = Type.Obj_tbl.add bindings ty v var (* eta-expansion required *) (* add bindings for [Format.std_formatter] and [Format.err_formatter] *) let () = add Datatype.formatter Format.std_formatter "Format.std_formatter"; add Datatype.formatter Format.err_formatter "Format.err_formatter" exception Name_already_exists of string let check_name s = let error () = Format.eprintf "[Type] A value of name %s already exists@." s; raise (Name_already_exists s) in Type.Obj_tbl.iter bindings (fun _ _ s' -> if s = s' then error ()) let add_once ty x s = check_name s; add ty x s let find ty v = Type.Obj_tbl.find bindings ty v (* eta-expansion required *) let iter f = Type.Obj_tbl.iter bindings f (* eta-expansion required *) (* predefined bindings *) let () = add Datatype.formatter Format.std_formatter "Format.std_formatter"; add Datatype.formatter Format.err_formatter "Format.err_formatter" end (* JS 2012/02/07: useful only for BM introspection testing ;-) *) module Reverse_binding = struct module Tbl = Type.String_tbl(struct type 'a t = 'a end) exception Unbound_value = Tbl.Unbound_value exception Incompatible_type = Tbl.Incompatible_type let tbl = Tbl.create 97 let fill () = Binding.iter (fun ty v name -> Tbl.add tbl name ty v) let find name ty = Tbl.find tbl name ty let iter f = Tbl.iter f tbl let pretty fmt () = iter (fun name ty v -> Format.fprintf fmt "%s --> %a@." name (Datatype.pretty ty) v) end exception Not_writable of string let never_write name f = if Cmdline.journal_enable && Cmdline.use_type then if Obj.tag (Obj.repr f) = Obj.closure_tag then Obj.magic (fun y -> if !started then Obj.magic f y else raise (Not_writable name)) else invalid_arg ("[Journal.never_write] " ^ name ^ " is not a closure") else f let pp ty fmt (o:Obj.t) = assert Cmdline.use_type; let x = Obj.obj o in try Format.fprintf fmt "%s" (Binding.find ty x); with Not_found -> let pp_error msg = Format.fprintf fmt "@[(failwith @[\"%s:@ running the journal will fail.\"@])@;@]" msg in let pp = Datatype.internal_pretty_code ty in if pp == Datatype.undefined then pp_error (Pretty_utils.sfprintf "no printer registered for value of type %s" (Type.name ty)) else if pp == Datatype.pp_fail then pp_error (Pretty_utils.sfprintf "no code for pretty printer of type %s" (Type.name ty)) else pp Type.Call fmt x let gen_binding = let ids = Hashtbl.create 7 in let rec gen s = try let n = succ (Hashtbl.find ids s) in Hashtbl.replace ids s n; gen (s ^ "_" ^ string_of_int n) with Not_found -> Hashtbl.add ids s 1; s in gen let extend_continuation f_acc pp_arg opt_label opt_arg arg fmt = f_acc fmt; match opt_label, opt_arg with | None, None (* no label *) -> Format.fprintf fmt "@;%a" pp_arg arg; | None, Some _ -> assert false | Some _, Some f when f () == arg -> (* [arg] is the default value of the optional label *) () | Some l, _ (* other label *) -> Format.fprintf fmt "@;~%s:%a" l pp_arg arg (* print any comment *) let print_comment fmt pp = match pp with | None -> () | Some pp -> Format.fprintf fmt "(* %t *)@;" pp let print_sentence f_acc is_dyn comment ?value ty fmt = assert Cmdline.use_type; print_comment fmt comment; (* open a new box for the sentence *) Format.fprintf fmt "@["; (* add a let binding whenever the return type is not unit *) let is_unit = Type.equal ty Datatype.unit in if not is_unit then Format.fprintf fmt "let %t=@;" (fun fmt -> let binding = let varname = Datatype.varname ty in match varname == Datatype.undefined, value with | true, _ | _, None -> "__" (* no binding nor value: ignore the result *) | false, Some value -> (* bind to a fresh variable name *) let v = Obj.obj value in let b = gen_binding (varname v) in Binding.add ty v b; b in Format.fprintf fmt "%s" binding; (* add the return type for dynamic application *) if is_dyn then Format.fprintf fmt "@;: %s " (Type.name ty) else Format.fprintf fmt " "); (* pretty print the sentence itself in a box *) Format.fprintf fmt "@[%t@]" f_acc; (* close the sentence *) if is_unit then Format.fprintf fmt ";@]@;" else Format.fprintf fmt "@;<1 -2>in@]@;" let add_sentence f_acc is_dyn comment ?value ty = Sentences.add (print_sentence f_acc is_dyn comment ?value ty) false let catch_exn f_acc is_dyn comment ret_ty exn = let s_exn = Printexc.to_string exn in (* [s_exn] is not necessarily a valid OCaml exception. So don't use it in OCaml code. *) let comment fmt = Format.fprintf fmt "@[exception %s@;raised on: @]%t" s_exn (fun fmt -> Extlib.may (fun f -> f fmt) comment) in let print fmt = (* open a new box for the sentence *) Format.fprintf fmt "@[begin try@;@[%t@[raise Unreachable@]@]@]@;" (print_sentence f_acc is_dyn (Some comment) ret_ty); (* two opened boxes closed at end *) Format.fprintf fmt "@[with@;@[| Unreachable as exn -> raise exn@]@;"; Format.fprintf fmt "@[| exn (* %s *) ->@;@[@[(* continuing: *)@]@;" s_exn in Sentences.add print true let rec journalize_function f_acc ty is_dyn comment (x:Obj.t) = assert Cmdline.use_type; if Type.Function.is_instance_of ty then begin (* [ty] is a function type value: there exists [a] and [b] such than [ty = a -> b] *) let ty : ('a,'b) Type.Function.poly Type.t = Obj.magic (ty:'ty Type.t) in let (a:'a Type.t), (b:'b Type.t), opt_label = Type.Function.get_instance ty in let opt_arg = Type.Function.get_optional_argument ty in Obj.repr (fun (y:'a) -> if !started then (* prevent journalisation if you're journalizing another function *) Obj.repr (Obj.obj x y) else begin let old_started = !started in try (* [started] prevents journalization of function call inside another one *) started := true; (* apply the closure [x] to its argument [y] *) let xy = Obj.obj x y in started := old_started; (* extend the continuation and continue *) let f_acc = extend_continuation f_acc (pp a) opt_label opt_arg y in journalize_function f_acc b is_dyn comment xy with | Not_writable name -> started := old_started; fatal "a call to the function %S cannot be written in the journal" name | exn as e -> let f_acc = extend_continuation f_acc (pp a) opt_label opt_arg y in catch_exn f_acc is_dyn comment b exn; started := old_started; raise e end) end else begin if not !started then add_sentence f_acc is_dyn comment ~value:x ty; x end let register s ty ?comment ?(is_dyn=false) x = if Cmdline.journal_enable then begin assert Cmdline.use_type; if s = "" then abort "[Journal.register] the given name should not be \"\""; Binding.add_once ty x s; if Type.Function.is_instance_of ty then begin let x' = Obj.repr x in let f_acc fmt = pp ty fmt x' in let res : Obj.t = journalize_function f_acc ty is_dyn comment x' in Obj.obj res end else x end else x let prevent f x = let old = !started in started := true; let res = try f x with exn -> started := old; raise exn in started := old; res (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/dynamic.mli0000644000175000017500000001751512155630171020205 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Dynamic plug-ins: registration and use. @plugin development guide *) val default_path: unit -> string list (* ************************************************************************* *) (** {2 Registration} *) (* ************************************************************************* *) val register: ?comment:string -> plugin:string -> string -> 'a Type.t -> journalize:bool -> 'a -> 'a (** [register ~plugin name ty v] registers [v] with the name [name], the type [ty] and the plug-in [plugin]. @raise Type.AlreadyExists if [name] already exists. In other words you cannot register a value with the same name twice. @modify Boron-20100401 add the labeled argument "plugin" @modify Oxygen-20120901 add the optional labeled argument "comment" @plugin development guide *) (* ************************************************************************* *) (** {2 Access} *) (* ************************************************************************* *) exception Incompatible_type of string exception Unbound_value of string exception Unloadable of string (** Exception that a plug-in can throw if it detects that it can't be loaded. It is caught by {!Dynamic.load_module} and {!Dynamic.load_script} @since Oxygen-20120901 *) val get: plugin:string -> string -> 'a Type.t -> 'a (** [get ~plugin name ty] returns the value registered with the name [name], the type [ty] and the plug-in [plugin]. This plug-in will be loaded if required. @raise Unbound_value if the name is not registered @raise Incompatible_type if the name is not registered with a compatible type @raise Failure _ in the -no-obj mode @plugin development guide *) val iter: (string -> 'a Type.t -> 'a -> unit) -> unit val iter_comment : (string -> string -> unit) -> unit (** @since Oxygen-20120901 *) val is_plugin_present: string -> bool (** @return true iff the given plug-in is loaded and usable. @since Nitrogen-20111001 *) (* ************************************************************************* *) (** {2 Dedicated access to plug-in parameters} *) (* ************************************************************************* *) (** Module to use for accessing parameters of plug-ins. Assume that the plug-in is already loaded. @plugin development guide *) module Parameter : sig (** Set of common operations on parameters. *) module type Common = sig type t val get: string -> unit -> t val set: string -> t -> unit val clear: string -> unit -> unit val is_set: string -> unit -> bool val is_default: string -> unit -> bool end (** retrieve the representation of the corresponding parameter. *) val get_parameter: string -> Parameter.t (** retrieve the state related to the corresponding parameter. @raise Not_found if the option does not correspond to an actual parameter @since Oxygen-20120901 *) val get_state: string -> State.t (**/**) val get_name: string -> string -> string -> string (** Not for casual users *) (**/**) (** Boolean parameters. @plugin development guide *) module Bool: sig include Common with type t = bool val on: string -> unit -> unit (** Set the parameter to [true]. *) val off : string -> unit -> unit (** Set the parameter to [false]. *) end (** Integer parameters. *) module Int : sig include Common with type t = int val incr : string -> unit -> unit end (** String parameters. *) module String : Common with type t = string (** Set of string parameters. *) module StringSet : sig include Common with type t = Datatype.String.Set.t val add: string -> string -> unit val remove: string -> string -> unit val is_empty: string -> unit -> bool val iter: string -> (string -> unit) -> unit end (** List of string parameters. *) module StringList : sig include Common with type t = string list val add: string -> string -> unit val remove: string -> string -> unit val is_empty: string -> unit -> bool val iter: string -> (string -> unit) -> unit end (* module IndexedVal(X: sig val ty_name: string end) : sig include Common with type t = string type value val add_choice: string -> string -> value -> unit val get_val: string -> value end *) end (* ************************************************************************* *) (** {2 Kernel materials} *) (* ************************************************************************* *) val object_file_extension: string (** Object file extension used when loading a module. See function {!load_module}. @since Boron-20100401 *) val add_path: string -> bool (** Add a path into the search paths, if it is not already in the list. @return true iff the path is really added to the list. *) val load_module: string -> unit (** Load the module with the given name. The module is searched in search paths if the name is implicit (that is if the file name is relative and does not start with an explicit reference to the current directory (./ or ../ in Unix). Do nothing if dynamic loading is not available. @modify Nitrogen-20111001 better strategy for searching modules *) val load_script: string -> unit (** Compile then load the OCaml script with the given name. The file is searched in the current directory, next in search paths if the name is implicit (that is if the file name is relative and does not start with an explicit reference to the current directory (./ or ../ in Unix). Do nothing if dynamic loading is not available. @since Beryllium-20090601-beta1 @modify Nitrogen-20111001 better strategy for searching modules *) val set_default: bool -> unit (** Search in all the default directories iff the parameter is [true]. @since Boron-20100401 *) module Main : sig val extend : (unit -> unit) -> unit (** Register a function to be called by the Frama-C main entry point. @deprecated since Lithium-20081201. Replaced by {!Db.Main.extend}. @deprecated Since Beryllium-20090601-beta1. Replaced by {!Db.Main}. *) val apply: unit -> unit (** Apply entry points previously registered . *) end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/gui_init.ml0000644000175000017500000000341712155630171020213 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Frama-C GUI early initialization. *) let () = Config.is_gui := true let () = Unix.putenv "UBUNTU_MENUPROXY" "0" (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/kernel_function.mli0000644000175000017500000002101412155630171021733 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Operations to get info from a kernel function. This module does not give access to information about the set of all the registered kernel functions (like iterators over kernel functions). This kind of operations is stored in module {!Globals.Functions}. @plugin development guide *) open Cil_types (* ************************************************************************* *) (** {2 Kernel functions are comparable and hashable} *) (* ************************************************************************* *) include Datatype.S_with_collections with type t = kernel_function val id: t -> int val auxiliary_kf_stmt_state: State.t (* ************************************************************************* *) (** {2 Searching} *) (* ************************************************************************* *) exception No_Statement val find_first_stmt : t -> stmt (** Find the first statement in a kernel function. @raise No_Statement if there is no first statement for the given function. *) val find_return : t -> stmt (** Find the return statement of a kernel function. @raise No_Statement is there is no return statement for the given function. @modify Nitrogen-20111001 may raise No_Statement*) val find_label : t -> string -> stmt ref (** Find a given label in a kernel function. @raise Not_found if the label does not exist in the given function. *) val clear_sid_info: unit -> unit (** removes any information related to statements in kernel functions. ({i.e.} the table used by the function below). - Must be called when the Ast has silently changed (e.g. with an in-place visitor) before calling one of the functions below - Use with caution, as it is very expensive to re-populate the table. *) val find_from_sid : int -> stmt * t (** @return the stmt and its kernel function from its identifier. Complexity: the first call to this function is linear in the size of the cil file. @raise Not_found if there is no statement with such an identifier. *) val find_englobing_kf : stmt -> t (** @return the function to which the statement belongs. Same complexity as [find_from_sid] @raise Not_found if the given statement is not correctly registered *) val find_enclosing_block: stmt -> block (** @return the innermost block to which the given statement belongs. *) val find_all_enclosing_blocks: stmt -> block list (** same as above, but returns all enclosing blocks, starting with the innermost one. *) val blocks_closed_by_edge: stmt -> stmt -> block list (** [blocks_closed_by_edge s1 s2] returns the (possibly empty) list of blocks that are closed when going from [s1] to [s2]. @raise Invalid_argument if the statements do not belong to the same function or [s2] is not a successor of [s1] in the cfg. @since Carbon-20101201 *) val stmt_in_loop: t -> stmt -> bool (** [stmt_in_loop kf stmt] is [true] iff [stmt] strictly occurs in a loop of [kf]. @since Oxygen-20120901 *) val find_enclosing_loop: t -> stmt -> stmt (** [find_enclosing_loop kf stmt] returns the statement corresponding to the innermost loop containing [stmt] in [kf]. If [stmt] itself is a loop, returns [stmt] @raise Not_found if [stmt] is not part of a loop of [kf] @since Oxygen-20120901 *) val find_syntactic_callsites : t -> (t * stmt) list (** [callsites f] collect the statements where [f] is called. Same complexity as [find_from_sid]. @return a list of [f',s] where function [f'] calls [f] at statement [stmt]. @since Carbon-20110201 *) (* ************************************************************************* *) (** {2 Checkers} *) (* ************************************************************************* *) val is_definition : t -> bool val returns_void : t -> bool (* ************************************************************************* *) (** {2 Getters} *) (* ************************************************************************* *) val dummy: unit -> t (** @plugin development guide *) val get_vi : t -> varinfo val get_id: t -> int val get_name : t -> string val get_type : t -> typ val get_return_type : t -> typ val get_location: t -> Cil_types.location val get_global : t -> global val get_formals : t -> varinfo list val get_locals : t -> varinfo list exception No_Definition val get_definition : t -> fundec (** @raise No_Definition if the given function is not a definition. @plugin development guide *) (* ************************************************************************* *) (** {2 Membership of variables} *) (* ************************************************************************* *) val is_formal: varinfo -> t -> bool (** @return [true] if the given varinfo is a formal parameter of the given function. If possible, use this function instead of {!Ast_info.Function.is_formal}. *) val get_formal_position: varinfo -> t -> int (** [get_formal_position v kf] is the position of [v] as parameter of [kf]. @raise Not_found if [v] is not a formal of [kf]. *) val is_local : varinfo -> t -> bool (** @return [true] if the given varinfo is a local variable of the given function. If possible, use this function instead of {!Ast_info.Function.is_local}. *) val is_formal_or_local: varinfo -> t -> bool (** @return [true] if the given varinfo is a formal parameter or a local variable of the given function. If possible, use this function instead of {!Ast_info.Function.is_formal_or_local}. *) val get_called : exp -> t option (** Returns the static call to function [expr], if any. [None] means a dynamic call through function pointer. *) (* ************************************************************************* *) (** {2 Collections} *) (* ************************************************************************* *) (** Hashtable indexed by kernel functions and dealing with project. @plugin development guide *) module Make_Table(Data: Datatype.S)(Info: State_builder.Info_with_size): State_builder.Hashtbl with type key = t and type data = Data.t (** Set of kernel functions. *) module Hptset : Hptset.S with type elt = t (* ************************************************************************* *) (** {2 Setters} Use carefully the following functions. *) (* ************************************************************************* *) val register_stmt: t -> stmt -> block list -> unit (** Register a new statement in a kernel function, with the list of blocks that contain the statement (innermost first). *) (* ************************************************************************* *) (** {2 Pretty printer} *) (* ************************************************************************* *) val pretty_name : Format.formatter -> t -> unit (** Print the name of a kernel function. @deprecated since Nitrogen-20111001 Use {!pretty} instead. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/ast_info.ml0000644000175000017500000003560512155630171020212 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (* ************************************************************************** *) (** {2 Expressions} *) (* ************************************************************************** *) let is_integral_const = function | CInt64 _ | CEnum _ | CChr _ -> true | CStr _ | CWStr _ | CReal _ -> false let rec possible_value_of_integral_const = function | CInt64 (i,_,_) -> Some i | CEnum {eival = e} -> possible_value_of_integral_expr e | CChr c -> Some (Integer.of_int (Char.code c)) (* This is against the ISO C norm! See Cil.charConstToInt *) | _ -> None and possible_value_of_integral_expr e = match (stripInfo e).enode with | Const c -> possible_value_of_integral_const c | _ -> None let value_of_integral_const c = match possible_value_of_integral_const c with | None -> assert false | Some i -> i let value_of_integral_expr e = match possible_value_of_integral_expr e with | None -> assert false | Some i -> i let constant_expr ~loc i = new_exp ~loc (Const(CInt64(i,IInt,None))) let rec is_null_expr e = match (stripInfo e).enode with | Const c when is_integral_const c -> Integer.equal (value_of_integral_const c) Integer.zero | CastE(_,e) -> is_null_expr e | _ -> false let rec is_non_null_expr e = match (stripInfo e).enode with | Const c when is_integral_const c -> not (Integer.equal (value_of_integral_const c) Integer.zero) | CastE(_,e) -> is_non_null_expr e | _ -> false (* ************************************************************************** *) (** {2 Logical terms} *) (* ************************************************************************** *) let is_integral_logic_const = function | Integer _ | LEnum _ | LChr _ -> true | LStr _ | LWStr _ | LReal _ -> false let possible_value_of_integral_logic_const = function | Integer(i,_) -> Some i | LEnum {eival = e} -> possible_value_of_integral_expr e | LChr c -> Some (Integer.of_int (Char.code c)) (* This is against the ISO C norm! See Cil.charConstToInt *) | _ -> None let value_of_integral_logic_const c = match possible_value_of_integral_logic_const c with | None -> assert false | Some i -> i let possible_value_of_integral_term t = match t.term_node with | TConst c -> possible_value_of_integral_logic_const c | _ -> None let term_lvals_of_term t = let l = ref [] in ignore (Cil.visitCilTerm (object inherit nopCilVisitor method vterm_lval lv = l := lv :: !l; DoChildren end) t); !l let is_trivial_predicate = function Ptrue -> true | _ -> false let is_trivial_named_predicate p = is_trivial_predicate p.content let is_trivial_annotation a = match a.annot_content with | AAssert (_,a) -> is_trivial_named_predicate a | APragma _ | AStmtSpec _ | AInvariant _ | AVariant _ | AAssigns _| AAllocation _ -> false let behavior_assumes b = Logic_const.pands (List.map Logic_const.pred_of_id_pred b.b_assumes) let behavior_postcondition b k = let assumes = Logic_const.pold (behavior_assumes b) in let postcondition = Logic_const.pands (Extlib.filter_map (fun (x,_) -> x = k) (Extlib.($) Logic_const.pred_of_id_pred snd) b.b_post_cond) in Logic_const.pimplies (assumes,postcondition) let behavior_precondition b = let assumes = behavior_assumes b in let requires = Logic_const.pands (List.rev_map Logic_const.pred_of_id_pred b.b_requires) in Logic_const.pimplies (assumes,requires) let precondition spec = Logic_const.pands (List.map behavior_precondition spec.spec_behavior) (** find the behavior named [name] in the list *) let get_named_bhv bhv_list name = try Some (List.find (fun b -> b.b_name = name) bhv_list) with Not_found -> None let get_named_bhv_assumes spec bhv_names = let bhvs = match bhv_names with | [] -> (* no names ==> all named behaviors *) List.filter (fun b -> not (is_default_behavior b)) spec.spec_behavior | _ -> let rec get l = match l with [] -> [] | name::tl -> match get_named_bhv spec.spec_behavior name with | None -> (* TODO: warn ? *) get tl | Some b -> b::(get tl) in get bhv_names in List.map behavior_assumes bhvs let complete_behaviors spec bhv_names = let bhv_assumes = get_named_bhv_assumes spec bhv_names in Logic_const.pors bhv_assumes let disjoint_behaviors spec bhv_names = let bhv_assumes = get_named_bhv_assumes spec bhv_names in let mk_disj_bhv b1 b2 = (* ~ (b1 /\ b2) *) let p = Logic_const.pands [b1; b2] in Logic_const.pnot p in let do_one_with_list prop b lb = let lp = List.map (mk_disj_bhv b) lb in Logic_const.pands (prop::lp) in let rec do_list prop l = match l with [] -> prop | b::tl -> let prop = do_one_with_list prop b tl in do_list prop tl in do_list Logic_const.ptrue bhv_assumes let merge_assigns_internal (get:'b -> 'c assigns) (origin:'b -> string list) (acc:(('a*(bool * string list))*int) option) (bhvs: 'b list) = let cmp_assigns acc b = let a' = get b in match acc,a' with | _, WritesAny -> acc | None, Writes l -> (* use the number of assigned terms as measure *) Some ((a',(false,origin b)),List.length l) | (Some((a,(w,orig)),n)), Writes l -> let w = (* warning is needed? *) w || (a != a' && a <> WritesAny) in (* use the number of assigned terms as measure *) let m = List.length l in if n<0 || m (* All behaviors should be taken except the default behavior *) List.filter (fun b -> not (Cil.is_default_behavior b)) bhvs | _ -> (* Finds the corresponding behaviors from the set *) List.map (fun b_name -> List.find (fun b -> b.b_name = b_name) bhvs) bhv_names in (* Merges the assigns of the complete behaviors. Once one of them as no assumes, that means the merge of the ungarded behavior did already the job *) Writes (List.fold_left (fun acc b -> match b.b_assigns with | Writes l when b.b_assumes <> [] -> l @ acc | _ -> raise Not_found) [] behaviors) with Not_found -> (* One of these behaviors is not found or has no assumes *) WritesAny in let acc = if ungarded then (* Looks first at unguarded behaviors. *) let unguarded_bhvs = List.filter (fun b -> b.b_assumes = []) bhvs in merge_assigns_internal (* Chooses the smalest one *) (fun b -> b.b_assigns) (fun b -> [b.b_name]) None unguarded_bhvs else None in let acc = match acc with | Some (((Writes _),_),_) -> (* Does not look further since one has been found *) acc | _ -> (* Look at complete behaviors *) merge_assigns_internal (* Chooses the smalest one *) merge_assigns_from_complete_bhvs (fun bhvnames -> bhvnames) acc complete_bhvs in match acc with | None -> WritesAny (* No unguarded behavior -> assigns everything *) | Some ((a,(w,orig)),_) -> (* The smallest one *) let warn = match warn with | None -> w | Some warn -> warn in if warn then begin let orig = if orig = [] then List.map (fun b -> b.b_name) bhvs else orig in Kernel.warning ~once:true ~current:true "keeping only assigns from behaviors: %a" (Pretty_utils.pp_list ~sep:",@ " Format.pp_print_string) orig end; a (** Returns the assigns from complete behaviors and ungarded behaviors. *) let merge_assigns_from_spec ?warn (spec :funspec) = merge_assigns_from_complete_bhvs ?warn spec.spec_behavior spec.spec_complete_behaviors (** Returns the assigns of an unguarded behavior. *) let merge_assigns ?warn (bhvs : funbehavior list) = let unguarded_bhvs = List.filter (fun b -> b.b_assumes = []) bhvs in let acc = merge_assigns_internal (fun b -> b.b_assigns) (fun b -> [b.b_name]) None unguarded_bhvs in match acc with | None -> WritesAny (* No unguarded behavior -> assigns everything *) | Some((a,(w,orig)),_) -> (* The smallest one *) let warn = match warn with | None -> w | Some warn -> warn in if warn then Kernel.warning ~once:true ~current:true "keeping only assigns from behaviors: %a" (Pretty_utils.pp_list ~sep:",@ " Format.pp_print_string) orig; a let variable_term loc v = { term_node = TLval(TVar v,TNoOffset); term_loc = loc; term_type = v.lv_type; term_name = []; } let constant_term loc i = { term_node = TConst(Integer(i,None)); term_loc = loc; term_type = Ctype intType; term_name = []; } let rec is_null_term t = match t.term_node with | TConst c when is_integral_logic_const c -> Integer.equal (value_of_integral_logic_const c) Integer.zero | TCastE(_,t) -> is_null_term t | _ -> false (* ************************************************************************** *) (** {2 Predicates} *) (* ************************************************************************** *) let predicate loc p = { name = []; loc = loc; content = p; } (* ************************************************************************** *) (** {2 Statements} *) (* ************************************************************************** *) let is_loop_statement s = match s.skind with Loop _ -> true | _ -> false let get_sid s = match s with | Kglobal -> assert false | Kstmt s -> s.sid let mkassign lv e loc = Set(lv,e,loc) let mkassign_statement lv e loc = mkStmt (Instr(mkassign lv e loc)) let is_block_local v b = List.exists (fun vv -> v.vid = vv.vid) b.blocals (* ************************************************************************** *) (** {2 Functions} *) (* ************************************************************************** *) let is_function_type vi = isFunctionType vi.vtype module Function = struct let formal_args called_vinfo = match called_vinfo.vtype with | TFun (_,Some argl,_,_) -> argl | TFun _ -> [] | _ -> assert false let is_formal v fundec = List.exists (fun vv -> v.vid = vv.vid) fundec.sformals let is_local v fundec = List.exists (fun vv -> v.vid = vv.vid) fundec.slocals let is_formal_or_local v fundec = (not v.vglob) && ((is_formal v fundec) || (is_local v fundec)) let is_formal_of_prototype v vi = let formals = try getFormalsDecl vi with Not_found -> [] in List.exists (fun x -> x.vid = v.vid) formals let is_definition = function | Definition _ -> true | Declaration _ -> false let get_vi = function | Definition (d, _) -> d.svar | Declaration (_,vi,_, _) -> vi let get_name f = (get_vi f).vname let get_id f = (get_vi f).vid end (* ************************************************************************** *) (** {2 Types} *) (* ************************************************************************** *) let array_type ?length ?(attr=[]) ty = TArray(ty,length,empty_size_cache (),attr) let direct_array_size ty = match unrollType ty with | TArray(_ty,Some size,_,_) -> value_of_integral_expr size | TArray(_ty,None,_,_) -> Integer.zero | _ -> assert false let rec array_size ty = match unrollType ty with | TArray(elemty,Some _,_,_) -> if isArrayType elemty then Integer.mul (direct_array_size ty) (array_size elemty) else direct_array_size ty | TArray(_,None,_,_) -> Integer.zero | _ -> assert false let direct_element_type ty = match unrollType ty with | TArray(eltyp,_,_,_) -> eltyp | _ -> assert false let element_type ty = let rec elem_type ty = match unrollType ty with | TArray(eltyp,_,_,_) -> elem_type eltyp | _ -> ty in match unrollType ty with | TArray(eltyp,_,_,_) -> elem_type eltyp | _ -> assert false let direct_pointed_type ty = match unrollType ty with | TPtr(elemty,_) -> elemty | _ -> assert false let pointed_type ty = match unrollType (direct_pointed_type ty) with | TArray _ as arrty -> element_type arrty | ty -> ty (* ************************************************************************** *) (** {2 Predefined} *) (* ************************************************************************** *) let can_be_cea_function name = (String.length name >= 4 && name.[0] = 'C' && name.[1] = 'E' && name.[2] = 'A' && name.[3] = '_') || (String.length name >= 6 && name.[0] = 'F' && name.[1] = 'r' && name.[2] = 'a' && name.[3] = 'm' && name.[4] = 'a' && name.[5] = '_') let is_cea_function name = (String.length name >= 4 && (String.sub name 0 4 = "CEA_" )) || (String.length name >= 17 && (String.sub name 0 17 = "Frama_C_show_each" )) let is_cea_dump_function name = name = "CEA_DUMP" || name = "Frama_C_dump_each" let is_cea_dump_file_function name = (String.length name >= 22 && (String.sub name 0 22 = "Frama_C_dump_each_file" )) let is_frama_c_builtin n = can_be_cea_function n && (is_cea_dump_function n || is_cea_function n || is_cea_dump_file_function n) let () = Cil.add_special_builtin_family is_frama_c_builtin (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/command.ml0000644000175000017500000002202612155630171020017 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let safe_close_out outc = try close_out outc with _ -> () (* -------------------------------------------------------------------------- *) (* --- File Utilities --- *) (* -------------------------------------------------------------------------- *) let filename parent child = Filename.concat parent child let pp_to_file f pp = let cout = open_out f in let fout = Format.formatter_of_out_channel cout in try pp fout ; Format.pp_print_newline fout () ; Format.pp_print_flush fout () ; safe_close_out cout with err -> Format.pp_print_newline fout () ; Format.pp_print_flush fout () ; safe_close_out cout ; raise err let pp_from_file fmt file = let cin = open_in file in try while true do !Db.progress () ; let line = input_line cin in Format.pp_print_string fmt line ; Format.pp_print_newline fmt () ; done with | End_of_file -> close_in cin | err -> close_in cin ; raise err let rec bincopy buffer cin cout = let s = String.length buffer in let n = Pervasives.input cin buffer 0 s in if n > 0 then ( Pervasives.output cout buffer 0 n ; bincopy buffer cin cout ) else ( flush cout ) let on_inc file job = let inc = open_in file in try job inc ; close_in inc with e -> close_in inc ; raise e let on_out file job = let out = open_out file in try job out ; safe_close_out out with e -> safe_close_out out ; raise e let copy src tgt = on_inc src (fun inc -> on_out tgt (fun out -> bincopy (String.create 2048) inc out)) let read_file file job = let inc = open_in file in try let r = job inc in close_in inc ; r with err -> close_in inc ; raise err let read_lines file job = read_file file (fun inc -> try while true do job (input_line inc) ; done with End_of_file -> ()) let write_file file job = assert (file <> ""); let out = open_out file in try let r = job out in flush out ; close_out out ; r with err -> close_out out ; raise err let print_file file job = write_file file (fun out -> let fmt = Format.formatter_of_out_channel out in try let r = job fmt in Format.pp_print_flush fmt () ; r with err -> Format.pp_print_flush fmt () ; raise err) (* -------------------------------------------------------------------------- *) (* --- Timing --- *) (* -------------------------------------------------------------------------- *) type timer = float ref type 'a result = Result of 'a | Error of exn let dt_max tm dt = match tm with Some r when dt > !r -> r := dt | _ -> () let dt_add tm dt = match tm with Some r -> r := !r +. dt | _ -> () let return = function Result x -> x | Error e -> raise e let catch f x = try Result(f x) with e -> Error e let time ?rmax ?radd job data = begin let t0 = Sys.time () in let re = catch job data in let t1 = Sys.time () in let dt = t1 -. t0 in dt_max rmax dt ; dt_add radd dt ; return re ; end (* -------------------------------------------------------------------------- *) (* --- Process --- *) (* -------------------------------------------------------------------------- *) type process_result = Not_ready of (unit -> unit) | Result of Unix.process_status let full_command cmd args ~stdin ~stdout ~stderr = let pid = Unix.create_process cmd (Array.concat [[|cmd|];args]) stdin stdout stderr in let _,status = Unix.waitpid [Unix.WUNTRACED] pid in status let full_command_async cmd args ~stdin ~stdout ~stderr = let pid = Unix.create_process cmd (Array.concat [[|cmd|];args]) stdin stdout stderr in let last_result= ref(Not_ready (fun () -> Extlib.terminate_process pid)) in (fun () -> match !last_result with | Result _ as r -> r | Not_ready _ as r -> let child_id,status = Unix.waitpid [Unix.WNOHANG; Unix.WUNTRACED] pid in if child_id = 0 then r else (last_result := Result status; !last_result)) let cleanup_and_fill b f = match b with | None -> Extlib.safe_remove f | Some b -> try let cin = open_in_bin f in (try while true do Buffer.add_string b (input_line cin); Buffer.add_char b '\n' done with _ -> ()); close_in cin with _ -> Extlib.safe_remove f let command_generic ~async ?stdout ?stderr cmd args = let inf,inc = Filename.open_temp_file ~mode:[Open_binary;Open_rdonly; Open_trunc; Open_creat; Open_nonblock ] "in_" ".tmp" in let outf,outc = Filename.open_temp_file ~mode:[Open_binary;Open_wronly; Open_trunc; Open_creat] "out_" ".tmp" in let errf,errc = Filename.open_temp_file ~mode:[Open_binary;Open_wronly; Open_trunc; Open_creat] "out_" ".tmp" in let to_terminate = ref None in let do_terminate () = begin match !to_terminate with | None -> () | Some pid -> Extlib.terminate_process pid end; Extlib.safe_remove inf; Extlib.safe_remove outf; Extlib.safe_remove errf in at_exit do_terminate; (* small memory leak : pending list of ref None ... *) let pid = Unix.create_process cmd (Array.concat [[|cmd|];args]) (Unix.descr_of_out_channel inc) (Unix.descr_of_out_channel outc) (Unix.descr_of_out_channel errc) in to_terminate:= Some pid; safe_close_out inc; safe_close_out outc; safe_close_out errc; (*Format.printf "Generic run: %s " cmd; Array.iter (fun s -> Format.printf "%s " s) args; Format.printf "@.";*) let last_result= ref (Not_ready do_terminate) in let wait_flags = if async then [Unix.WNOHANG; Unix.WUNTRACED] else [Unix.WUNTRACED] in (fun () -> match !last_result with | Result _p as r -> (*Format.printf "Got result %d@." (match _p with Unix.WEXITED x -> x | _ -> 99);*) r | Not_ready _ as r -> let child_id,status = Unix.waitpid wait_flags pid in if child_id = 0 then (assert async;r) else ( to_terminate := None; (*Format.printf "Got (%s) result after wait %d@." cmd (match status with Unix.WEXITED x -> x | _ -> 99);*) last_result := Result status; cleanup_and_fill stdout outf; cleanup_and_fill stderr errf; Extlib.safe_remove inf; !last_result)) let command_async ?stdout ?stderr cmd args = command_generic ~async:true ?stdout ?stderr cmd args let command ?(timeout=0) ?stdout ?stderr cmd args = if !Config.is_gui || timeout > 0 then let f = command_generic ~async:true ?stdout ?stderr cmd args in let res = ref(Unix.WEXITED 99) in let elapsed = ref 0 in let running () = match f () with | Not_ready terminate -> begin try !Db.progress () ; if timeout > 0 && !elapsed > timeout then raise Db.Cancel ; true with Db.Cancel as e -> terminate (); raise e end | Result r -> res := r; false in while running () do Unix.sleep 1 done ; !res else let f = command_generic ~async:false ?stdout ?stderr cmd args in match f () with | Result r -> r | Not_ready _ -> assert false (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/loop.ml0000644000175000017500000001316612155630171017357 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Cil let name = "natural_loops" module Natural_Loops = Kernel_function.Make_Table (Datatype.List (Datatype.Pair(Stmt)(Datatype.List(Stmt)))) (struct let name = name let size = 97 let dependencies = [ Ast.self ] end) let pretty_natural_loops fmt loops = List.iter (fun (start,members) -> Format.fprintf fmt "Loop start: %d ( " start.sid; List.iter (fun d -> Format.fprintf fmt "%d " d.sid) members; Format.fprintf fmt ")@\n";) loops let get_naturals kf = let loops = Natural_Loops.memo (fun kf -> match kf.fundec with | Declaration _ -> [] | Definition (cilfundec,_) -> Kernel.debug "Compute natural loops for '%a'" Kernel_function.pretty kf; let dominators = Dominators.computeIDom cilfundec in (*if dbg then Format.printf "DONE COMPUTE NATURAL LOOPS IDOM FOR %S@." (Kernel_function.get_name kf);*) let naturals = Dominators.findNaturalLoops cilfundec dominators in Kernel.debug "Done computing natural loops for '%a':@.%a" Kernel_function.pretty kf pretty_natural_loops naturals; naturals ) kf in loops let is_natural kf = let natural_loops = List.fold_left (fun acc (n, _) -> Stmt.Set.add n acc) Stmt.Set.empty (get_naturals kf) in (* non natural loop over-approximation try: let can_reach = !stmt_can_reach kf in *) fun stmt -> let nat_loop = Stmt.Set.mem stmt natural_loops in nat_loop (* if nat_loop then nat_loop else if can_reach stmt stmt then true (* this is non natural loop or an imbricated loop... *) else false *) let back_edges kf stmt = if is_natural kf stmt then let rec lookup = function | [] -> assert false | (s, pred_s) :: sl -> if s.sid = stmt.sid then pred_s else lookup sl in lookup (get_naturals kf) else [] let while_for_natural_loop kf stmt = match stmt.skind with | Loop _ -> stmt | _ -> (* the while stmt is probably the non looping predecessor *) let be = back_edges kf stmt in Format.printf "Stmt:%d " stmt.sid; List.iter (fun x -> Format.printf "B_edge:%d " x.sid) be; List.iter (fun x -> Format.printf "Preds:%d " x.sid) stmt.preds; let non_looping_pred = List.filter (fun pred -> not (List.mem pred be)) stmt.preds in match non_looping_pred with | [x] -> x | _ -> Format.eprintf "@.Lexical non natural loop detected !@."; assert false let compute_allstmt_block block = let visitor = object val mutable allstmts = Stmt.Set.empty method allstmts = allstmts inherit nopCilVisitor method vstmt s = allstmts <- Stmt.Set.add s allstmts; DoChildren end in ignore (visitCilBlock (visitor:>cilVisitor) block); visitor#allstmts module Result = Kinstr.Hashtbl let compute_loops_stmts kf = let tbl = Result.create 17 in let visitor = object inherit nopCilVisitor method vstmt s = (match s.skind with | Loop (_,block,_,_,_) -> Result.add tbl (Kstmt s) (compute_allstmt_block block) | _ -> ()); DoChildren end in (try ignore (visitCilFunction (visitor :> cilVisitor) (Kernel_function.get_definition kf)); with Kernel_function.No_Definition -> ()); tbl exception No_such_while (** @raise No_such_while if [stmt.skind] is not a [While]. *) let get_loop_stmts = let module S = Kernel_function.Make_Table (Result.Make(Stmt.Set)) (struct let name = "LoopStmts" let size = 97 let dependencies = [ Ast.self ] end) in fun kf loop_stmt -> (match loop_stmt.skind with | Loop _ -> () | _ -> raise No_such_while); let tbl = S.memo compute_loops_stmts kf in try Result.find tbl (Kstmt loop_stmt) with Not_found -> assert false (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/alarms.mli0000644000175000017500000001177112155630171020036 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Alarms Database. @modify Fluorine-20130401 fully re-implemented. @plugin development guide *) open Cil_types (** Only signed overflows int are really RTEs. The other kinds may be meaningful nevertheless. *) type overflow_kind = Signed | Unsigned | Signed_downcast | Unsigned_downcast type access_kind = For_reading | For_writing type bound_kind = Lower_bound | Upper_bound (** @modify Fluorine-20130401 full re-implementation *) type alarm = | Division_by_zero of exp | Memory_access of lval * access_kind | Logic_memory_access (* temporary? *) of term * access_kind | Index_out_of_bound of exp (** index *) * exp option (** None = lower bound is zero; Some up = upper bound *) | Invalid_shift of exp * int option (* strict upper bound, if any *) | Pointer_comparison of exp option (** [None] when implicit comparison to NULL pointer *) * exp | Overflow of overflow_kind * exp * Integer.t (** the bound *) * bound_kind | Float_to_int of exp * Integer.t (** the bound for the integer type. The actual alarm is [exp < bound+1] or [bound-1 < exp]. *) * bound_kind | Not_separated of lval * lval (** the two lvalues must be separated *) | Overlap of lval * lval (** overlapping read/write: the two lvalues must be separated or equal *) | Uninitialized of lval | Is_nan_or_infinite of exp * fkind include Datatype.S_with_collections with type t = alarm val self: State.t val register: Emitter.t -> ?kf:kernel_function -> kinstr -> ?loc:location -> ?status:Property_status.emitted_status -> ?save:bool -> alarm -> code_annotation * bool (** Register the given alarm on the given statement. By default, no status is generated. If [save] is [false] (default is [true]), the annotation corresponding to the alarm is built, but neither it nor the alarm is registered. @return true if the given alarm has never been emitted before on the same kinstr (without taking into consideration the status or the emitter). @modify Oxygen-20120901 remove labeled argument ~deps @modify Fluorine-20130401 add the optional arguments [kf], [loc] and [save]; also returns the corresponding code_annotation *) val iter: (Emitter.t -> kernel_function -> stmt -> rank:int -> alarm -> code_annotation -> unit) -> unit (** Iterator over all alarms and the associated annotations at some program point. @since Fluorine-20130401 *) val fold: (Emitter.t -> kernel_function -> stmt -> rank:int -> alarm -> code_annotation -> 'a -> 'a) -> 'a -> 'a (** Folder over all alarms and the associated annotations at some program point. @since Fluorine-20130401 *) val find: code_annotation -> alarm option (** @return the alarm corresponding to the given assertion, if any. @since Fluorine-20130401 *) val remove: ?filter:(alarm -> bool) -> ?kinstr:kinstr -> Emitter.t -> unit (** Remove the alarms and the associated annotations emitted by the given emitter. If [kinstr] is specified, remove only the ones associated with this kinstr. If [filter] is specified, remove only the alarms [a] such that [filter a] is [true]. @since Fluorine-20130401 *) val create_predicate: ?loc:location -> t -> predicate named (** Generate the predicate corresponding to a given alarm. @since Fluorine-20130401 *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/kernel.mli0000644000175000017500000002325712155630171020041 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Provided services for kernel developers. @plugin development guide *) (* ************************************************************************* *) (** {2 Log Machinery} *) (* ************************************************************************* *) include Plugin.S (* ************************************************************************* *) (** {2 Installation Information} *) (* ************************************************************************* *) module PrintVersion: Plugin.Bool (** Behavior of option "-version" *) module PrintShare: Plugin.Bool (** Behavior of option "-print-share-path" *) module PrintLib: Plugin.Bool (** Behavior of option "-print-lib-path" *) module PrintPluginPath: Plugin.Bool (** Behavior of option "-print-plugin-path" *) (* ************************************************************************* *) (** {2 Output Messages} *) (* ************************************************************************* *) module GeneralVerbose: Plugin.Int (** Behavior of option "-verbose" *) module GeneralDebug: Plugin.Int (** Behavior of option "-debug" *) module Quiet: Plugin.Bool (** Behavior of option "-quiet" *) (** @plugin development guide *) module Unicode: sig include Plugin.Bool val without_unicode: ('a -> 'b) -> 'a -> 'b (** Execute the given function as if the option [-unicode] was not set. *) end (** Behavior of option "-unicode". @plugin development guide *) module UseUnicode: Plugin.Bool (** Behavior of option "-unicode" @deprecated since Nitrogen-20111001 use module {!Unicode} instead. *) module Time: Plugin.String (** Behavior of option "-time" *) module Collect_messages: Plugin.Bool (** Behavior of option "-collect-messages" *) (* ************************************************************************* *) (** {2 Input / Output Source Code} *) (* ************************************************************************* *) module PrintCode : Plugin.Bool (** Behavior of option "-print" *) module PrintComments: Plugin.Bool (** Behavior of option "-keep-comments" *) (** Behavior of option "-ocode". @plugin development guide *) module CodeOutput : sig include Plugin.String val output: (Format.formatter -> unit) -> unit end module FloatNormal: Plugin.Bool (** Behavior of option "-float-normal" *) module FloatRelative: Plugin.Bool (** Behavior of option "-float-relative" *) module FloatHex: Plugin.Bool (** Behavior of option "-float-hex" *) module BigIntsHex: Plugin.Int (** Behavior of option "-hexadecimal-big-integers" *) (* ************************************************************************* *) (** {2 Save/Load} *) (* ************************************************************************* *) module SaveState: Plugin.String (** Behavior of option "-save" *) module LoadState: Plugin.String (** Behavior of option "-load" *) module AddPath: Plugin.String_list (** Behavior of option "-add-path" *) module LoadModule: Plugin.String_set (** Behavior of option "-load-module" *) module LoadScript: Plugin.String_set (** Behavior of option "-load-script" *) module Dynlink: Plugin.Bool (** Behavior of option "-dynlink" *) (** Kernel for journalization. *) module Journal: sig module Enable: Plugin.Bool (** Behavior of option "-journal-enable" *) module Name: Plugin.String (** Behavior of option "-journal-name" *) end (* ************************************************************************* *) (** {2 Customizing Normalization} *) (* ************************************************************************* *) module UnrollingLevel: Plugin.Int (** Behavior of option "-ulevel" *) (** Behavior of option "-machdep". If function [set] is called, then {!File.prepare_from_c_files} must be called for well preparing the AST. *) module Machdep: Plugin.String (** Behavior of option "-enums" *) module Enums: Plugin.String module CppCommand: Plugin.String (** Behavior of option "-cpp-command" *) module CppExtraArgs: Plugin.String_list (** Behavior of option "-cpp-extra-args" *) module ReadAnnot: Plugin.Bool (** Behavior of option "-read-annot" *) module PreprocessAnnot: Plugin.Bool (** Behavior of option "-pp-annot" *) module TypeCheck: Plugin.Bool (** Behavior of option "-type-check" *) module ContinueOnAnnotError: Plugin.Bool (** Behavior of option "-continue-annot-error" *) module SimplifyCfg: Plugin.Bool (** Behavior of option "-simplify-cfg" *) module KeepSwitch: Plugin.Bool (** Behavior of option "-keep-switch" *) module Keep_unused_specified_functions: Plugin.Bool (** Behavior of option -keep-unused-specified-function. *) module Constfold: Plugin.Bool (** Behavior of option "-constfold" *) module InitializedPaddingLocals: Plugin.Bool (** Behavior of option "-initialized-padding-locals" *) (** Analyzed files *) module Files: sig include Plugin.String_list (** List of files to analyse *) module Check: Plugin.Bool (** Behavior of option "-check" *) module Copy: Plugin.Bool (** Behavior of option "-copy" *) module Orig_name: Plugin.Bool (** Behavior of option "-orig-name" *) end val normalization_parameters: Parameter.t list (** All the normalization options that influence the AST (in particular, changing one will reset the AST entirely *) module WarnDecimalFloat: Plugin.String (** Behavior of option "-warn-decimal-float" *) module WarnUndeclared: Plugin.Bool (** Behavior of option "-warn-call-to-undeclared" *) (* ************************************************************************* *) (** {3 Customizing cabs2cil options} *) (* ************************************************************************* *) module AllowDuplication: Plugin.Bool (** Behavior of option "-allow-duplication". *) module DoCollapseCallCast: Plugin.Bool (** Behavior of option "-collapse-call-cast". If false, the destination of a Call instruction should always have the same type as the function's return type. Where needed, CIL will insert a temporary to make this happen. If true, the destination type may differ from the return type, so there is an implicit cast. This is useful for analyses involving [malloc], because the instruction "T* x = malloc(...);" won't be broken into two instructions, so it's easy to find the allocation type. This is false by default. Set to true to replicate the behavior of CIL 1.3.5 and earlier. *) module ForceRLArgEval: Plugin.Bool (** Behavior of option "-force-rl-arg-eval". *) (* ************************************************************************* *) (** {2 Analysis Behavior of options} *) (* ************************************************************************* *) (** Behavior of option "-main". You should usually use {!Globals.entry_point} instead of {!MainFunction.get} since the first one handles the case where the entry point is invalid in the right way. *) module MainFunction: sig include Plugin.String (** {2 Internal functions} Not for casual users. *) val unsafe_set: t -> unit end (** Behavior of option "-lib-entry". You should usually use {!Globals.entry_point} instead of {!LibEntry.get} since the first one handles the case where the entry point is invalid in the right way. *) module LibEntry: sig include Plugin.Bool val unsafe_set: t -> unit (** Not for casual users. *) end module UnspecifiedAccess: Plugin.Bool (** Behavior of option "-unspecified-access" *) module SafeArrays: Plugin.Bool (** Behavior of option "-safe-arrays". @plugin development guide *) module SignedOverflow: Plugin.Bool (** Behavior of option "-warn-signed-overflow" *) module UnsignedOverflow: Plugin.Bool (** Behavior of option "-warn-unsigned-overflow" *) module SignedDowncast: Plugin.Bool (** Behavior of option "-warn-signed-downcast" *) module UnsignedDowncast: Plugin.Bool (** Behavior of option "-warn-unsigned-downcast" *) module AbsoluteValidRange: Plugin.String (** Behavior of option "-absolute-valid-range" *) (* module FloatFlushToZero: Plugin.Bool (** Behavior of option "-float-flush-to-zero" *) *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/db.ml0000644000175000017500000012427012155630171016772 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Extlib type 'a how_to_journalize = | Journalize of string * 'a Type.t | Journalization_not_required | Journalization_must_not_happen of string let register how_to_journalize r f = match how_to_journalize with | Journalize (name, ty) -> r := Journal.register ("!Db." ^ name) ty f | Journalization_not_required -> r := f | Journalization_must_not_happen name -> r := Journal.never_write ("!Db." ^ name) f let register_compute name deps r f = let name = "!Db." ^ name in let f = Journal.register name (Datatype.func Datatype.unit Datatype.unit) f in let compute, self = State_builder.apply_once name deps f in r := compute; self let register_guarded_compute name is_computed r f = let name = "!Db." ^ name in let f = Journal.register name (Datatype.func Datatype.unit Datatype.unit) f in let compute () = if not (is_computed ()) then f () in r := compute module Main = struct include Hook.Make(struct end) let play = mk_fun "Main.play" end module Toplevel = struct let run = ref (fun f -> f ()) end (* ************************************************************************* *) (** {2 Inouts} *) (* ************************************************************************* *) module type INOUTKF = sig type t val self_internal: State.t ref val self_external: State.t ref val compute : (kernel_function -> unit) ref val get_internal : (kernel_function -> t) ref val get_external : (kernel_function -> t) ref val display : (Format.formatter -> kernel_function -> unit) ref val pretty : Format.formatter -> t -> unit end module type INOUT = sig include INOUTKF val statement : (stmt -> t) ref val kinstr : kinstr -> t option end (** State_builder.of outputs - over-approximation of zones written by each function. *) module Outputs = struct type t = Locations.Zone.t let self_internal = ref State.dummy let self_external = ref State.dummy let compute = mk_fun "Out.compute" let display = mk_fun "Out.display" let display_external = mk_fun "Out.display_external" let get_internal = mk_fun "Out.get_internal" let get_external = mk_fun "Out.get_external" let statement = mk_fun "Out.statement" let kinstr ki = match ki with | Kstmt s -> Some (!statement s) | Kglobal -> None let pretty = Locations.Zone.pretty end (** State_builder.of read inputs - over-approximation of locations read by each function. *) module Inputs = struct (* What about [Inputs.statement] ? *) type t = Locations.Zone.t let self_internal = ref State.dummy let self_external = ref State.dummy let self_with_formals = ref State.dummy let compute = mk_fun "Inputs.compute" let display = mk_fun "Inputs.display" let display_with_formals = mk_fun "Inputs.display_with_formals" let get_internal = mk_fun "Inputs.get_internal" let get_external = mk_fun "Inputs.get_external" let get_with_formals = mk_fun "Inputs.get_with_formals" let statement = mk_fun "Inputs.statement" let expr = mk_fun "Inputs.expr" let kinstr ki = match ki with | Kstmt s -> Some (!statement s) | Kglobal -> None let pretty = Locations.Zone.pretty end (** State_builder.of operational inputs - over-approximation of zones whose input values are read by each function, State_builder.of sure outputs - under-approximation of zones written by each function. *) module Operational_inputs = struct type t = Inout_type.t let self_internal = ref State.dummy let self_external = ref State.dummy let compute = mk_fun "Operational_inputs.compute" let display = mk_fun "Operational_inputs.display" let get_internal = mk_fun "Operational_inputs.get_internal" let get_internal_precise = ref (fun ?stmt:_ _ -> failwith ("Db.Operational_inputs.get_internal_precise not implemented")) let get_external = mk_fun "Operational_inputs.get_external" module Record_Inout_Callbacks = Hook.Build (struct type t = Value_types.callstack * Inout_type.t end) let pretty fmt x = Format.fprintf fmt "@["; Format.fprintf fmt "@[Operational inputs:@ @[%a@]@]@ " Locations.Zone.pretty (x.Inout_type.over_inputs); Format.fprintf fmt "@[Operational inputs on termination:@ @[%a@]@]@ " Locations.Zone.pretty (x.Inout_type.over_inputs_if_termination); Format.fprintf fmt "@[Sure outputs:@ @[%a@]@]" Locations.Zone.pretty (x.Inout_type.under_outputs_if_termination); Format.fprintf fmt "@]"; end (** Derefs computations *) module Derefs = struct type t = Locations.Zone.t let self_internal = ref State.dummy let self_external = ref State.dummy let compute = mk_fun "Derefs.compute" let display = mk_fun "Derefs.display" let get_internal = mk_fun "Derefs.get_internal" let get_external = mk_fun "Derefs.get_external" let statement = mk_fun "Derefs.statement" let kinstr ki = match ki with | Kstmt s -> Some (!statement s) | Kglobal -> None let pretty = Locations.Zone.pretty end (* ************************************************************************* *) (** {2 Values} *) (* ************************************************************************* *) module Value = struct type state = Cvalue.Model.t type t = Cvalue.V.t (* This function is responsible for clearing completely Value's state when the user-supplied initial state or main arguments are changed. It is set deep inside Value for technical reasons *) let initial_state_changed = mk_fun "Value.initial_state_changed" (* Arguments of the root function of the value analysis *) module ListArgs = Datatype.List(Cvalue.V) module FunArgs = State_builder.Option_ref (ListArgs) (struct let name = "Db.Value.fun_args" let dependencies = [ Ast.self; Kernel.LibEntry.self; Kernel.MainFunction.self] end) let () = Ast.add_monotonic_state FunArgs.self exception Incorrect_number_of_arguments let fun_get_args () = FunArgs.get_option () (* This function is *not* journalized *) let fun_set_args = let module L = Datatype.List(Cvalue.V) in Journal.register "(failwith \"Function cannot be journalized: \ Db.Value.fun_set_args\" : _ -> unit)" (Datatype.func L.ty Datatype.unit) (fun l -> if not (Extlib.opt_equal ListArgs.equal (Some l) (FunArgs.get_option ())) then begin !initial_state_changed (); FunArgs.set l end) let fun_use_default_args = Journal.register "Db.Value.fun_use_default_args" (Datatype.func Datatype.unit Datatype.unit) (fun () -> if FunArgs.get_option () <> None then (!initial_state_changed (); FunArgs.clear ())) (* Initial memory state of the value analysis *) module VGlobals = State_builder.Option_ref (Cvalue.Model) (struct let name = "Db.Value.Vglobals" let dependencies = [Ast.self] end) (* This function is *not* journalized *) let globals_set_initial_state = Journal.register "(failwith \"Function cannot be journalized: \ Db.Value.globals_set_initial_state\" : _ -> unit)" (Datatype.func Cvalue.Model.ty Datatype.unit) (fun state -> if not (Extlib.opt_equal Cvalue.Model.equal (Some state) (VGlobals.get_option ())) then begin !initial_state_changed (); VGlobals.set state end) let globals_use_default_initial_state = Journal.register "Db.Value.globals_use_default_initial_state" (Datatype.func Datatype.unit Datatype.unit) (fun () -> if VGlobals.get_option () <> None then (!initial_state_changed (); VGlobals.clear ())) let initial_state_only_globals = mk_fun "Value.initial_state_only_globals" let globals_state () = match VGlobals.get_option () with | Some v -> v | None -> !initial_state_only_globals () let globals_use_supplied_state () = not (VGlobals.get_option () = None) (* Do NOT add dependencies to Kernel parameters here, but at the top of Value/Value_parameters *) let dependencies = [ Ast.self; Alarms.self; Annotations.code_annot_state; FunArgs.self; VGlobals.self ] let size = 1789 module States_by_callstack = Value_types.Callstack.Hashtbl.Make(Cvalue.Model) module Table_By_Callstack = Cil_state_builder.Stmt_hashtbl(States_by_callstack) (struct let name = "Value analysis results by callstack" let size = size let dependencies = dependencies end) module Table = Cil_state_builder.Stmt_hashtbl(Cvalue.Model) (struct let name = "Value analysis results" let size = size let dependencies = dependencies end) (* Clear Value's various caches each time [Db.Value.is_computed] is updated, including when it is set, reset, or during project change. Some operations of Value depend on -ilevel, -plevel, etc, so clearing those caches when Value ends ensures that those options will have an effect between two runs of Value. *) let () = Table.add_hook_on_update (fun _ -> Cvalue.V_Offsetmap.clear_caches (); Cvalue.Model.clear_caches (); Locations.Location_Bytes.clear_caches (); Locations.Zone.clear_caches (); Lmap_bitwise.From_Model.clear_caches (); ) module AfterTable = Cil_state_builder.Stmt_hashtbl(Cvalue.Model) (struct let name = "Value analysis after states" let dependencies = [Table.self] let size = size end) module AfterTable_By_Callstack = Cil_state_builder.Stmt_hashtbl(States_by_callstack) (struct let name = "Value analysis results after states by callstack" let size = size let dependencies = dependencies end) let self = Table.self let only_self = [ self ] let mark_as_computed = Journal.register "Db.Value.mark_as_computed" (Datatype.func Datatype.unit Datatype.unit) Table.mark_as_computed let is_computed () = Table.is_computed () module Conditions_table = Cil_state_builder.Stmt_hashtbl (Datatype.Int) (struct let name = "Conditions statuses" let size = 101 let dependencies = only_self end) let merge_conditions h = Cil_datatype.Stmt.Hashtbl.iter (fun stmt v -> try let old = Conditions_table.find stmt in Conditions_table.replace stmt (old lor v) with Not_found -> Conditions_table.add stmt v) h let mask_then = 1 let mask_else = 2 let condition_truth_value s = try let i = Conditions_table.find s in ((i land mask_then) <> 0, (i land mask_else) <> 0) with Not_found -> false, false module RecursiveCallsFound = State_builder.Set_ref (Kernel_function.Set) (struct let name = "Db.Value.RecursiveCallsFound" let dependencies = only_self end) let ignored_recursive_call kf = RecursiveCallsFound.mem kf let recursive_call_occurred kf = RecursiveCallsFound.add kf module Called_Functions = Cil_state_builder.Varinfo_hashtbl (Cvalue.Model) (struct let name = "called_functions" let size = 11 let dependencies = only_self end) (* let pretty_table () = Table.iter (fun k v -> Kernel.log ~kind:Log.Debug "GLOBAL TABLE at %a: %a@\n" Kinstr.pretty k Cvalue.Model.pretty v) let pretty_table_raw () = Kinstr.Hashtbl.iter (fun k v -> Kernel.log ~kind:Log.Debug "GLOBAL TABLE at %a: %a@\n" Kinstr.pretty k Cvalue.Model.pretty v) *) type callstack = (kernel_function * kinstr) list module Record_Value_Callbacks = Hook.Build (struct type t = (kernel_function * kinstr) list * (state Stmt.Hashtbl.t) Lazy.t end) module Record_Value_Callbacks_New = Hook.Build (struct type t = (kernel_function * kinstr) list * (state Stmt.Hashtbl.t) Lazy.t Value_types.callback_result end) module Record_Value_After_Callbacks = Hook.Build (struct type t = (kernel_function * kinstr) list * (state Stmt.Hashtbl.t) Lazy.t end) module Record_Value_Superposition_Callbacks = Hook.Build (struct type t = (kernel_function * kinstr) list * (state list Stmt.Hashtbl.t) Lazy.t end) module Call_Value_Callbacks = Hook.Build (struct type t = state * (kernel_function * kinstr) list end) let no_results = mk_fun "Value.no_results" let update_callstack_table ~after stmt callstack v = let open Value_types in let find,add = if after then AfterTable_By_Callstack.find, AfterTable_By_Callstack.add else Table_By_Callstack.find, Table_By_Callstack.add in try let by_callstack = find stmt in begin try let o = Callstack.Hashtbl.find by_callstack callstack in Callstack.Hashtbl.replace by_callstack callstack(Cvalue.Model.join o v) with Not_found -> Callstack.Hashtbl.add by_callstack callstack v end; with Not_found -> let r = Callstack.Hashtbl.create 7 in Callstack.Hashtbl.add r callstack v; add stmt r let update_table stmt v = try let old = Table.find stmt in let joined_global = Cvalue.Model.join old v in Table.replace stmt joined_global; with Not_found -> Table.add stmt v let merge_initial_state kf state = let vi = Kernel_function.get_vi kf in try let old = Called_Functions.find vi in Called_Functions.replace vi (Cvalue.Model.join old state) with Not_found -> Called_Functions.add vi state let get_initial_state kf = try Called_Functions.find (Kernel_function.get_vi kf) with Not_found -> Cvalue.Model.bottom let valid_behaviors = mk_fun "Value.get_valid_behaviors" let add_formals_to_state = mk_fun "add_formals_to_state" let noassert_get_stmt_state s = try Table.find s with Not_found -> Cvalue.Model.bottom let noassert_get_state k = match k with | Kglobal -> globals_state () | Kstmt s -> noassert_get_stmt_state s let get_stmt_state s = assert (is_computed ()); (* this assertion fails during value analysis *) noassert_get_stmt_state s let get_state k = assert (is_computed ()); (* this assertion fails during value analysis *) noassert_get_state k let get_stmt_state_callstack ~after stmt = assert (is_computed ()); (* this assertion fails during value analysis *) try Some (if after then AfterTable_By_Callstack.find stmt else Table_By_Callstack.find stmt) with Not_found -> None let is_reachable = Cvalue.Model.is_reachable let is_accessible ki = let st = get_state ki in Cvalue.Model.is_reachable st let is_reachable_stmt stmt = Cvalue.Model.is_reachable (get_stmt_state stmt) let is_called = mk_fun "Value.is_called" let callers = mk_fun "Value.callers" let access_location = mk_fun "Value.access_location" let find = Cvalue.Model.find ~with_alarms:CilE.warn_none_mode ~conflate_bottom:true let access = mk_fun "Value.access" let access_expr = mk_fun "Value.access_expr" let access_after = mk_fun "Value.access_after" let lval_to_offsetmap_after = mk_fun "Value.lval_to_offsetmap_after" let access_location_after = mk_fun "Value.access_location_after" (** Type for a Value builtin function *) type builtin_sig = state -> (Cil_types.exp * Cvalue.V.t * Cvalue.V_Offsetmap.t) list -> Value_types.call_result exception Outside_builtin_possibilities let register_builtin = mk_fun "Value.record_builtin" let mem_builtin = mk_fun "Value.mem_builtin" let use_spec_instead_of_definition = mk_fun "Value.use_spec_instead_of_definition" let eval_lval = ref (fun ~with_alarms:_ _ -> mk_labeled_fun "Value.eval_lval") let eval_expr = ref (fun ~with_alarms:_ _ -> mk_labeled_fun "Value.eval_expr") let eval_expr_with_state = ref (fun ~with_alarms:_ _ -> mk_labeled_fun "Value.eval_expr_with_state") let find_lv_plus = ref (fun ~with_alarms:_ _ -> mk_labeled_fun "Value.find_lv_plus") let pretty_state = Cvalue.Model.pretty let pretty_state_without_null = Cvalue.Model.pretty_without_null let pretty = Cvalue.V.pretty let display fmt kf = let refilter base = match base with Base.Var (v, _) -> if v.vgenerated then v.vname = "__retres" else ((not (Kernel_function.is_local v kf)) || List.exists (fun x -> x.vid = v.vid) (Kernel_function.get_definition kf).sbody.blocals ) | _ -> true in try let values = get_stmt_state (Kernel_function.find_return kf) in let fst_values = get_stmt_state (Kernel_function.find_first_stmt kf) in if Cvalue.Model.is_reachable fst_values && not (Cvalue.Model.is_top fst_values) then begin Format.fprintf fmt "@[Values at end of function %a:@\n" Kernel_function.pretty kf; if Cvalue.Model.is_top values then Format.fprintf fmt "NO INFORMATION" else let outs = !Outputs.get_internal kf in Cvalue.Model.pretty_filter fmt values outs refilter; Format.fprintf fmt "@]@\n" end with Kernel_function.No_Statement -> () let display_globals fmt () = let values = globals_state () in if Cvalue.Model.is_reachable values then begin Format.fprintf fmt "@[Values of globals at initialization @\n"; Cvalue.Model.pretty_without_null fmt values; Format.fprintf fmt "@]@\n" end let compute = mk_fun "Value.compute" let memoize = mk_fun "Value.memoize" let expr_to_kernel_function = mk_fun "Value.expr_to_kernel_function" let expr_to_kernel_function_state = mk_fun "Value.expr_to_kernel_function_state" exception Not_a_call let call_to_kernel_function call_stmt = match call_stmt.skind with | Instr (Call (_, fexp, _, _)) -> let _, called_functions = !expr_to_kernel_function ~with_alarms:CilE.warn_none_mode ~deps:None (Kstmt call_stmt) fexp in called_functions | _ -> raise Not_a_call let lval_to_loc_with_deps = mk_fun "Value.lval_to_loc_with_deps" let lval_to_loc_with_deps_state = mk_fun "Value.lval_to_loc_with_deps_state" let lval_to_loc = mk_fun "Value.lval_to_loc" let lval_to_offsetmap = mk_fun "Value.lval_to_offsetmap" let lval_to_offsetmap_state = mk_fun "Value.lval_to_offsetmap_state" let lval_to_loc_state = mk_fun "Value.lval_to_loc_state" let lval_to_zone = mk_fun "Value.lval_to_zone" let lval_to_zone_state = mk_fun "Value.lval_to_zone_state" let assigns_inputs_to_zone = mk_fun "Value.assigns_inputs_to_zone" let assigns_outputs_to_zone = mk_fun "Value.assigns_outputs_to_zone" let assigns_outputs_to_locations = mk_fun "Value.assigns_outputs_to_locations" exception Void_Function let find_return_loc kf = try let ki = Kernel_function.find_return kf in let lval = match ki with | { skind = Return (Some ({enode = Lval ((_ , offset) as lval)}), _) } -> assert (offset = NoOffset) ; lval | { skind = Return (None, _) } -> raise Void_Function | _ -> assert false in !lval_to_loc (Kstmt ki) ~with_alarms:CilE.warn_none_mode lval with Kernel_function.No_Statement -> (* [JS 2011/05/17] should be better to have another name for this exception or another one since it is possible to have no return without returning void (the case when the kf corresponds to a declaration *) raise Void_Function exception Aborted let degeneration_occurred = ref (fun _kf _lv -> raise Aborted) end module From = struct let access = mk_fun "From.access" let update = mk_fun "From.update" let find_deps_no_transitivity = mk_fun "From.find_deps_no_transitivity" let find_deps_no_transitivity_state = mk_fun "From.find_deps_no_transitivity_state" let compute = mk_fun "From.compute" let compute_all = mk_fun "From.compute_all" let compute_all_calldeps = mk_fun "From.compute_all_calldeps" let is_computed = mk_fun "From.is_computed" let pretty = mk_fun "From.pretty" let get = mk_fun "From.get" let self = ref State.dummy let display = mk_fun "From.display" module Record_From_Callbacks = Hook.Build (struct type t = (Kernel_function.t Stack.t) * Lmap_bitwise.From_Model.t Stmt.Hashtbl.t * (Kernel_function.t * Lmap_bitwise.From_Model.t) list Stmt.Hashtbl.t end) module Callwise = struct let iter = mk_fun "From.Callwise.iter" let find = mk_fun "From.Callwise.find" end end module Access_path = struct type t = (Locations.Zone.t * Locations.Location_Bits.t) Base.Map.t let compute = mk_fun "Access_path.compute" let filter = mk_fun "Access_path.filter" let pretty = mk_fun "Access_path.pretty" end module Users = struct let get = mk_fun "Users.get" end (* ************************************************************************* *) (** {2 PDG} *) (* ************************************************************************* *) module Pdg = struct type t = PdgTypes.Pdg.t type t_nodes_and_undef = ((PdgTypes.Node.t * Locations.Zone.t option) list * Locations.Zone.t option) exception Top = PdgTypes.Pdg.Top exception Bottom = PdgTypes.Pdg.Bottom let self = ref State.dummy let get = mk_fun "Pdg.get" let from_same_fun pdg1 pdg2 = let kf1 = PdgTypes.Pdg.get_kf pdg1 in let kf2 = PdgTypes.Pdg.get_kf pdg2 in Kernel_function.equal kf1 kf2 let node_key = mk_fun "Pdg.node_key" let find_decl_var_node = mk_fun "Pdg.find_decl_var_node" let find_input_node = mk_fun "Pdg.find_input_nodes" let find_ret_output_node = mk_fun "Pdg.find_ret_output_node" let find_output_nodes = mk_fun "Pdg.find_output_nodes" let find_all_inputs_nodes = mk_fun "Pdg.find_all_inputs_nodes" let find_stmt_and_blocks_nodes = mk_fun "Pdg.find_stmt_and_blocks_nodes" let find_simple_stmt_nodes = mk_fun "Pdg.find_simplestmt_nodes" let find_stmt_node = mk_fun "Pdg.find_stmt_node" let find_label_node = mk_fun "Pdg.find_label_node" let find_entry_point_node = mk_fun "Pdg.find_entry_point_node" let find_top_input_node = mk_fun "Pdg.find_top_input_node" let find_call_ctrl_node = mk_fun "Pdg.find_call_ctrl_node" let find_location_nodes_at_stmt = mk_fun "Pdg.find_location_nodes_at_stmt" let find_location_nodes_at_end = mk_fun "Pdg.find_location_nodes_at_end" let find_location_nodes_at_begin = mk_fun "Pdg.find_location_nodes_at_begin" let find_call_input_node = mk_fun "Pdg.find_call_input_node" let find_call_output_node = mk_fun "Pdg.find_call_output_node" let find_code_annot_nodes = mk_fun "Pdg.find_code_annot_nodes" let find_fun_precond_nodes = mk_fun "Pdg.find_fun_precond_nodes" let find_fun_postcond_nodes = mk_fun "Pdg.find_fun_postcond_nodes" let find_fun_variant_nodes = mk_fun "Pdg.find_fun_variant_nodes" let find_call_out_nodes_to_select = mk_fun "Pdg.find_call_out_nodes_to_select" let find_in_nodes_to_select_for_this_call = mk_fun "Pdg.find_in_nodes_to_select_for_this_call" let direct_dpds = mk_fun "Pdg.direct_dpds" let direct_ctrl_dpds = mk_fun "Pdg.direct_ctrl_dpds" let direct_data_dpds = mk_fun "Pdg.direct_data_dpds" let direct_addr_dpds = mk_fun "Pdg.direct_addr_dpds" let all_dpds = mk_fun "Pdg.all_dpds" let all_ctrl_dpds = mk_fun "Pdg.all_ctrl_dpds" let all_data_dpds = mk_fun "Pdg.all_data_dpds" let all_addr_dpds = mk_fun "Pdg.all_addr_dpds" let direct_uses = mk_fun "Pdg.direct_uses" let direct_ctrl_uses = mk_fun "Pdg.direct_ctrl_uses" let direct_data_uses = mk_fun "Pdg.direct_data_uses" let direct_addr_uses = mk_fun "Pdg.direct_addr_uses" let all_uses = mk_fun "Pdg.all_uses" let custom_related_nodes = mk_fun "Pdg.custom_related_nodes" let find_call_stmts = mk_fun "Pdg.find_call_stmts" let iter_nodes = mk_fun "Pdg.iter_nodes" let extract = mk_fun "Pdg.extract" let pretty = ref (fun ?bw:_ _ _ -> mk_labeled_fun "Pdg.pretty") let pretty_node = mk_fun "Pdg.pretty_node" let pretty_key = mk_fun "Pdg.pretty_key" (* module F_FctMarks = PdgMarks.F_Fct *) (* module F_ProjMarks = PdgMarks.F_Proj *) end (* ************************************************************************* *) (** {2 Scope} *) (* ************************************************************************* *) (** Interface for the Scope plugin *) module Scope = struct let get_data_scope_at_stmt = mk_fun "Datascope.get_data_scope_at_stmt" let get_prop_scope_at_stmt = mk_fun "Datascope.get_prop_scope_at_stmt" let check_asserts = mk_fun "Datascope.check_asserts" let rm_asserts = mk_fun "Datascope.rm_asserts" let get_defs = mk_fun "Datascope.get_defs" let get_defs_with_type = mk_fun "Datascope.get_defs_with_type" type t_zones = Locations.Zone.t Stmt.Hashtbl.t let build_zones = mk_fun "Pdg.build_zones" let pretty_zones = mk_fun "Pdg.pretty_zones" let get_zones = mk_fun "Pdg.get_zones" end (* ************************************************************************* *) (** {2 Spare Code} *) (* ************************************************************************* *) (** Detection of the unused code of an application. *) module Sparecode = struct let get = ref (fun ~select_annot:_ -> mk_labeled_fun "Sparecode.run") let rm_unused_globals = ref (fun ?new_proj_name:_ -> mk_labeled_fun "Sparecode.rm_unused_globals") end (* ************************************************************************* *) (** {2 Slicing} *) (* ************************************************************************* *) (** Interface for the slicing tool. *) module Slicing = struct exception No_Project exception Existing_Project let self = ref State.dummy let set_modes = ref (fun ?calls:_ ?callers:_ ?sliceUndef:_ ?keepAnnotations:_ ?print:_ _ -> mk_labeled_fun "Slicing.set_modes") (* TODO: merge with frama-c projects (?) *) module Project = struct type t = SlicingTypes.sl_project let dyn_t = SlicingTypes.Sl_project.ty let default_slice_names = mk_fun "Slicing.Project.default_slice_names" let extract = mk_fun "Slicing.Project.extract" let pretty = mk_fun "Slicing.Project.pretty" let print_extracted_project = ref (fun ?fmt:_ ~extracted_prj:_ -> mk_labeled_fun "Slicing.Project.print_extracted_project") let print_dot = ref (fun ~filename:_ ~title:_ _ -> mk_labeled_fun "Slicing.Project.print_dot") let get_all = mk_fun "Slicing.Project.get_all" let get_project = mk_fun "Slicing.Project.get_project" let set_project = mk_fun "Slicing.Project.set_project" let mk_project = mk_fun "Slicing.Project.mk_project" let from_unique_name = mk_fun "Slicing.Project.from_unique_name" let get_name = mk_fun "Slicing.Project.get_name" let is_directly_called_internal = mk_fun "Slicing.Project.is_directly_called_internal" let is_called = mk_fun "Slicing.Project.is_called" let has_persistent_selection = mk_fun "Slicing.Project.has_persistent_selection" let change_slicing_level = mk_fun "Slicing.Project.change_slicing_level" end module Mark = struct type t = SlicingTypes.sl_mark let dyn_t = SlicingTypes.dyn_sl_mark let compare = mk_fun "Slicing.Mark.compare" let pretty = mk_fun "Slicing.Mark.pretty" let make = ref (fun ~data:_ ~addr:_ ~ctrl:_ -> mk_labeled_fun "Slicing.Mark.make") let is_bottom = mk_fun "Slicing.Mark.is_bottom" let is_spare = mk_fun "Slicing.Mark.is_spare" let is_ctrl = mk_fun "Slicing.Mark.is_ctrl" let is_data = mk_fun "Slicing.Mark.is_data" let is_addr = mk_fun "Slicing.Mark.is_addr" let get_from_src_func = mk_fun "Slicing.Mark.get_from_src_func" end module Select = struct type t = SlicingTypes.sl_select let dyn_t = SlicingTypes.Sl_select.ty type set = SlicingTypes.Fct_user_crit.t Cil_datatype.Varinfo.Map.t module S = Cil_datatype.Varinfo.Map.Make(SlicingTypes.Fct_user_crit) let dyn_set = S.ty let get_function = mk_fun "Slicing.Select.get_function" let select_stmt = mk_fun "Slicing.Select.select_stmt" let select_stmt_ctrl = mk_fun "Slicing.Select.select_stmt_ctrl" let select_stmt_lval_rw = mk_fun "Slicing.Select.select_stmt_lval_rw" let select_stmt_lval = mk_fun "Slicing.Select.select_stmt_lval" let select_stmt_zone = mk_fun "Slicing.Select.select_stmt_zone" let select_stmt_annots = mk_fun "Slicing.Select.select_stmt_annots" let select_stmt_annot = mk_fun "Slicing.Select.select_stmt_annot" let select_stmt_pred = mk_fun "Slicing.Select.select_stmt_pred" let select_stmt_term = mk_fun "Slicing.Select.select_stmt_term" let select_func_return = mk_fun "Slicing.Select.select_func_return" let select_func_calls_to = mk_fun "Slicing.Select.select_func_calls_to" let select_func_calls_into = mk_fun "Slicing.Select.select_func_calls_into" let select_func_lval_rw = mk_fun "Slicing.Select.select_func_lval_rw" let select_func_lval = mk_fun "Slicing.Select.select_func_lval" let select_func_zone = mk_fun "Slicing.Select.select_func_zone" let select_func_annots = mk_fun "Slicing.Select.select_func_annots" let select_stmt_internal = mk_fun "Slicing.Select.select_stmt_internal" let select_label_internal = mk_fun "Slicing.Select.select_label_internal" let empty_selects = Journal.register "Db.Slicing.Select.empty_selects" dyn_set Cil_datatype.Varinfo.Map.empty let add_to_selects_internal = mk_fun "Slicing.Select.add_to_selects_internal" let iter_selects_internal = mk_fun "Slicing.Select.iter_selects_internal" (* didn't manage to put this polymorphic function as a ref... *) let fold_selects_internal f acc selections = let r = ref acc in let dof select = r := f !r select in !iter_selects_internal dof selections; !r let merge_internal = mk_fun "Slicing.Select.merge_internal" let select_min_call_internal = mk_fun "Slicing.Select.select_min_call_internal" let select_stmt_ctrl_internal = mk_fun "Slicing.Select.select_control_stmt_ctrl" let select_pdg_nodes = mk_fun "Slicing.Select.select_pdg_nodes" let select_entry_point_internal = mk_fun "Slicing.Select.select_entry_point_internal" let select_return_internal = mk_fun "Slicing.Select.select_return_internal" let select_decl_var_internal = mk_fun "Slicing.Select.select_decl_var_internal" let select_pdg_nodes_internal = mk_fun "Slicing.Select.select_pdg_nodes_internal" let select_stmt_zone_internal = mk_fun "Slicing.Select.select_stmt_zone_internal" let select_zone_at_entry_point_internal = mk_fun "Slicing.Select.select_zone_at_entry_point_internal" let select_modified_output_zone_internal = mk_fun "Slicing.Select.select_modified_output_zone_internal" let select_zone_at_end_internal = mk_fun "Slicing.Select.select_zone_at_end_internal" let pretty = mk_fun "Slicing.Select.pretty" end module Slice = struct type t = SlicingTypes.sl_fct_slice let dyn_t = SlicingTypes.dyn_sl_fct_slice let create = mk_fun "Slicing.Slice.create" let remove = mk_fun "Slicing.Slice.remove" let remove_uncalled = mk_fun "Slicing.Slice.remove_uncalled" let get_all = mk_fun "Slicing.Slice.get_all" let get_callers = mk_fun "Slicing.Slice.get_callers" let get_called_slice = mk_fun "Slicing.Slice.get_called_slice" let get_called_funcs = mk_fun "Slicing.Slice.get_called_funcs" let get_function = mk_fun "Slicing.Slice.get_function" let pretty = mk_fun "Slicing.Slice.pretty" let get_mark_from_stmt = mk_fun "Slicing.Slice.get_mark_from_stmt" let get_mark_from_local_var = mk_fun "Slicing.Slice.get_mark_from_local_var" let get_mark_from_formal = mk_fun "Slicing.Slice.get_mark_from_formal" let get_mark_from_label = mk_fun "Slicing.Slice.get_from_label" let get_user_mark_from_inputs = mk_fun "Slicing.Slice.get_user_mark_from_inputs" let get_num_id = mk_fun "Slicing.Slice.get_num_id" let from_num_id = mk_fun "Slicing.Slice.from_num_id" end module Request = struct let add_selection = mk_fun "Slicing.Request.add_selection" let add_persistent_selection = mk_fun "Slicing.Request.add_persistent_selection" let add_persistent_cmdline = mk_fun "Slicing.Request.add_persistent_cmdline" let is_already_selected_internal = mk_fun "Slicing.Request.is_already_selected_internal" let add_slice_selection_internal = mk_fun "Slicing.Request.add_slice_selection_internal" let add_selection_internal = mk_fun "Slicing.Request.add_selection_internal" let add_call_slice = mk_fun "Slicing.Request.add_call_slice" let add_call_fun = mk_fun "Slicing.Request.add_call_fun" let add_call_min_fun = mk_fun "Slicing.Request.add_call_min_fun" let merge_slices = mk_fun "Slicing.Request.merge_slices" let copy_slice = mk_fun "Slicing.Request.copy_slice" let split_slice = mk_fun "Slicing.Request.split_slice" let propagate_user_marks = mk_fun "Slicing.Request.propagate_user_marks" let apply_all = mk_fun "Slicing.Request.apply_all" let apply_all_internal = mk_fun "Slicing.Request.apply_all_internal" let apply_next_internal = mk_fun "Slicing.Request.apply_next_internal" let is_request_empty_internal = mk_fun "Slicing.Request.is_request_empty_internal" let pretty = mk_fun "Slicing.Request.pretty" end end (* ************************************************************************* *) (** {2 Properties} *) (* ************************************************************************* *) module Properties = struct let mk_resultfun s = ref (fun ~result:_ -> failwith (Printf.sprintf "Function '%s' not registered yet" s)) module Interp = struct (** Interpretation and conversions of of formulas *) let code_annot = mk_fun "Properties.Interp.code_annot" let lval = mk_fun "Properties.Interp.lval" let expr = mk_fun "Properties.Interp.expr" let term_lval_to_lval = mk_resultfun "Properties.Interp.term_lval_to_lval" let term_to_exp = mk_resultfun "Properties.Interp.term_to_exp" let term_to_lval = mk_resultfun "Properties.Interp.term_to_lval" let loc_to_lval = mk_resultfun "Properties.Interp.loc_to_lval" (* loc_to_loc and loc_to_locs are defined in Value/Eval_logic, not in Logic_interp *) let loc_to_loc = mk_resultfun "Properties.Interp.loc_to_loc" let loc_to_locs = mk_resultfun "Properties.Interp.loc_to_locs" let identified_term_zone_to_loc = mk_resultfun "Properties.Interp.identified_term_to_loc" let loc_to_offset = mk_resultfun "Properties.Interp.loc_to_offset" let loc_to_exp = mk_resultfun "Properties.Interp.loc_to_exp" let term_offset_to_offset = mk_resultfun "Properties.Interp.term_offset_to_offset" module To_zone = struct type t_ctx = { state_opt: bool option; ki_opt: (stmt * bool) option; kf:Kernel_function.t } let mk_ctx_func_contrat = mk_fun "Interp.To_zone.mk_ctx_func_contrat" let mk_ctx_stmt_contrat = mk_fun "Interp.To_zone.mk_ctx_stmt_contrat" let mk_ctx_stmt_annot = mk_fun "Interp.To_zone.mk_ctx_stmt_annot" type t = {before:bool ; ki:stmt ; zone:Locations.Zone.t} type t_zone_info = (t list) option type t_decl = { var: Varinfo.Set.t; lbl: Logic_label.Set.t } type t_pragmas = { ctrl: Stmt.Set.t; stmt: Stmt.Set.t } let from_term = mk_fun "Interp.To_zone.from_term" let from_terms= mk_fun "Interp.To_zone.from_terms" let from_pred = mk_fun "Interp.To_zone.from_pred" let from_preds= mk_fun "Interp.To_zone.from_preds" let from_zone = mk_fun "Interp.To_zone.from_zone" let from_zones= mk_fun "Interp.To_zone.from_zones" let from_stmt_annot= mk_fun "Interp.To_zone.from_stmt_annot" let from_stmt_annots= mk_fun "Interp.To_zone.from_stmt_annots" let from_func_annots= mk_fun "Interp.To_zone.from_func_annots" let code_annot_filter= mk_fun "Interp.To_zone.code_annot_filter" end let to_result_from_pred = mk_fun "Properties.Interp.to_result_from_pred" end let add_assert emitter kf kinstr prop = Kernel.deprecated "Db.Properties.add_assert" ~now:"ACSL_importer plug-in" (fun () -> let interp_prop = !Interp.code_annot kf kinstr prop in Annotations.add_code_annot emitter kinstr interp_prop) () end (* ************************************************************************* *) (** {2 Others plugins} *) (* ************************************************************************* *) module Impact = struct let compute_pragmas = mk_fun "Impact.compute_pragmas" let from_stmt = mk_fun "Impact.from_stmt" let slice = mk_fun "Impact.slice" end module Security = struct let run_whole_analysis = mk_fun "Security.run_whole_analysis" let run_ai_analysis = mk_fun "Security.run_ai_analysis" let run_slicing_analysis = mk_fun "Security.run_slicing_analysis" let self = ref State.dummy end module Occurrence = struct type t = (kernel_function option * kinstr * lval) list let get = mk_fun "Occurrence.get" let get_last_result = mk_fun "Occurrence.get_last_result" let print_all = mk_fun "Occurrence.print_all" let self = ref State.dummy end module RteGen = struct type status_accessor = string * (kernel_function -> bool -> unit) * (kernel_function -> bool) let compute = mk_fun "RteGen.compute" let annotate_kf = mk_fun "RteGen.annotate_kf" let self = ref State.dummy let do_precond = mk_fun "RteGen.do_precond" let do_all_rte = mk_fun "RteGen.do_all_rte" let do_rte = mk_fun "RteGen.do_rte" let get_all_status = mk_fun "RteGen.get_all_status" let get_precond_status = mk_fun "RteGen.get_precond_status" let get_signedOv_status = mk_fun "RteGen.get_signedOv_status" let get_divMod_status = mk_fun "RteGen.get_divMod_status" let get_downCast_status = mk_fun "RteGen.get_downCast_status" let get_memAccess_status = mk_fun "RteGen.get_memAccess_status" let get_unsignedOv_status = mk_fun "RteGen.get_unsignedOv_status" let get_unsignedDownCast_status = mk_fun "RteGen.get_unsignedDownCast_status" end module Report = struct let print = mk_fun "Report.print" end module Constant_Propagation = struct let get = mk_fun "Constant_Propagation.get" let compute = mk_fun "Constant_Propagation.compute" end module Syntactic_Callgraph = struct let dump = mk_fun "Syntactic_callgraph.dump" end module PostdominatorsTypes = struct exception Top module type Sig = sig val compute: (kernel_function -> unit) ref val stmt_postdominators: (kernel_function -> stmt -> Stmt.Hptset.t) ref val is_postdominator: (kernel_function -> opening:stmt -> closing:stmt -> bool) ref val display: (unit -> unit) ref val print_dot : (string -> kernel_function -> unit) ref end end module Postdominators = struct let compute = mk_fun "Postdominators.compute" let is_postdominator : (kernel_function -> opening:stmt -> closing:stmt -> bool) ref = mk_fun "Postdominators.is_postdominator" let stmt_postdominators = mk_fun "Postdominators.stmt_postdominators" let display = mk_fun "Postdominators.display" let print_dot = mk_fun "Postdominators.print_dot" end module PostdominatorsValue = struct let compute = mk_fun "PostdominatorsValue.compute" let is_postdominator : (kernel_function -> opening:stmt -> closing:stmt -> bool) ref = mk_fun "PostdominatorsValue.is_postdominator" let stmt_postdominators = mk_fun "PostdominatorsValue.stmt_postdominators" let display = mk_fun "PostdominatorsValue.display" let print_dot = mk_fun "PostdominatorsValue.print_dot" end module Dominators = struct let compute = mk_fun "Dominators.compute" let is_dominator : (kernel_function -> opening:stmt -> closing:stmt -> bool) ref = mk_fun "Dominators.is_dominator" exception Top let stmt_dominators = mk_fun "Dominators.stmt_dominators" let display = mk_fun "Dominators.display" let print_dot = mk_fun "Dominators.print_dot" end (* ************************************************************************* *) (** {2 Graphs} *) (* ************************************************************************* *) module Semantic_Callgraph = struct let dump = mk_fun "Semantic_Callgraph.dump" let topologically_iter_on_functions = mk_fun "Semantic_Callgraph.topologically_iter_on_functions" let iter_on_callers = mk_fun "Semantic_Callgraph.iter_on_callers" let accept_base = ref (fun ~with_formals:_ ~with_locals:_ _ _ -> raise (Extlib.Unregistered_function "Semantic_Callgraph.accept_base")) end (* ************************************************************************* *) (** {2 GUI} *) (* ************************************************************************* *) let progress = ref (fun () -> ()) exception Cancel (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/parameter.ml0000644000175000017500000001033612155630171020362 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) type kind = Correctness | Tuning | Other type ('a, 'b) gen_accessor = { get: unit -> 'a; set: 'a -> unit; add_set_hook: ('b -> 'b -> unit) -> unit; add_update_hook: ('b -> 'b -> unit) -> unit } type 'a accessor = ('a, 'a) gen_accessor type typed_accessor = | Bool of bool accessor * string option (** the negative option, if any *) | Int of int accessor * (unit -> int * int) (** getting range *) | String of string accessor * (unit -> string list) (** possible values *) | String_set of (string, Datatype.String.Set.t) gen_accessor | String_list of (string, string list) gen_accessor type parameter = { name: string; help: string; accessor: typed_accessor; is_set: unit -> bool } include Datatype.Make_with_collections (struct type t = parameter let name = "Parameter.t" let rehash = Datatype.identity let structural_descr = Structural_descr.Unknown let reprs = [ { name = "bool_opt"; help = "dummy bool option"; accessor = Bool ({ get = (fun () -> false); set = (fun _ -> ()); add_set_hook = (fun _ -> ()); add_update_hook = (fun _ -> ()) }, None); is_set = fun () -> false } ] let equal = (==) let compare x y = if x == y then 0 else String.compare x.name y.name let hash x = Datatype.String.hash x.name let copy x = x (* The representation of the parameter is immutable *) let pretty fmt x = Format.pp_print_string fmt x.name let internal_pretty_code = Datatype.undefined let varname _ = assert false (* unused if internal_pretty_code undefined *) let mem_project = Datatype.never_any_project end) let parameters = Datatype.String.Hashtbl.create 97 let create ~name ~help ~accessor ~is_set = let p = { name = name; help = help; accessor = accessor; is_set = is_set } in (* parameter name unicity already checks in [Plugin]. *) assert (not (Datatype.String.Hashtbl.mem parameters name)); Datatype.String.Hashtbl.add parameters name p; p let get = Datatype.String.Hashtbl.find parameters let pretty_value fmt p = match p.accessor with | Bool(a, _) -> Format.fprintf fmt "%b" (a.get ()) | Int(a, _) -> Format.fprintf fmt "%d" (a.get ()) (* factorisation requires GADT (OCaml 4.01) *) | String(a, _) -> Format.fprintf fmt "%s" (a.get ()) | String_set a -> Format.fprintf fmt "%s" (a.get ()) | String_list a -> Format.fprintf fmt "%s" (a.get ()) let get_value p = Pretty_utils.sfprintf "%a" pretty_value p (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/log.ml0000644000175000017500000007222612155630171017171 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) type kind = Result | Feedback | Debug | Warning | Error | Failure type event = { evt_kind : kind ; evt_plugin : string ; evt_source : Lexing.position option ; evt_message : string ; } let kernel_channel_name = "kernel" let kernel_label_name = "kernel" (* -------------------------------------------------------------------------- *) (* --- Exception Management --- *) (* -------------------------------------------------------------------------- *) exception FeatureRequest of string * string exception AbortError of string (* plug-in *) exception AbortFatal of string (* plug-in *) (* -------------------------------------------------------------------------- *) (* --- Terminal Management --- *) (* -------------------------------------------------------------------------- *) open Format let null = Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) let with_null k msg = Format.kfprintf (fun _ -> k ()) null msg let nullprintf msg = Format.ifprintf null msg let min_buffer = 128 (* initial size of buffer *) let max_buffer = 2097152 (* maximal size of buffer *) let tgr_buffer = 3145728 (* elasticity (internal overhead) *) type lock = | Ready | Locked | DelayedLock type terminal = { mutable lock : lock ; mutable delayed : (terminal -> unit) list ; mutable output : string -> int -> int -> unit ; (* Same as Format.make_formatter *) mutable flush : unit -> unit ; (* Same as Format.make_formatter *) } let delayed_echo t = match t.lock with | Locked -> true | Ready | DelayedLock -> false let is_locked t = match t.lock with | Locked | DelayedLock -> true | Ready -> false let is_ready t = match t.lock with | Locked | DelayedLock -> false | Ready -> true let set_terminal t output flush = begin assert (is_ready t) ; t.output <- output ; t.flush <- flush ; end let stdout = { lock = Ready ; delayed = [] ; output = Pervasives.output Pervasives.stdout ; flush = (fun () -> Pervasives.flush Pervasives.stdout); } let set_output = set_terminal stdout (* -------------------------------------------------------------------------- *) (* --- Locked Formatter --- *) (* -------------------------------------------------------------------------- *) type delayed = | Delayed of terminal | Formatter of (string -> int -> int -> unit) * (unit -> unit) let lock_terminal t = begin if is_locked t then failwith "Console is already locked" ; t.lock <- Locked ; Format.make_formatter t.output t.flush ; end let unlock_terminal t fmt = if is_ready t then failwith "Console can not be unlocked" ; begin Format.pp_print_flush fmt () ; t.lock <- Ready ; List.iter (fun job -> job t) (List.rev t.delayed) ; t.delayed <- [] ; end let print_on_output job = let fmt = lock_terminal stdout in try job fmt ; unlock_terminal stdout fmt with error -> unlock_terminal stdout fmt ; raise error (* -------------------------------------------------------------------------- *) (* --- Delayed Lock until first write --- *) (* -------------------------------------------------------------------------- *) let delayed_terminal terminal = if is_locked terminal then failwith "Console is already locked" ; terminal.lock <- DelayedLock ; let d = ref (Delayed terminal) in let d_output d text k n = match !d with | Delayed t -> t.lock <- Locked ; d := Formatter( t.output , t.flush ) ; t.output text k n | Formatter(out,_) -> out text k n in let d_flush d () = match !d with | Delayed _ -> () (* nothing to flush yet ! *) | Formatter(_,flush) -> flush () in Format.make_formatter (d_output d) (d_flush d) let print_delayed job = let fmt = delayed_terminal stdout in try job fmt ; unlock_terminal stdout fmt with error -> unlock_terminal stdout fmt ; raise error (* -------------------------------------------------------------------------- *) (* --- Buffering Output --- *) (* -------------------------------------------------------------------------- *) type buffer = { mutable formatter : Format.formatter ; (* formatter on self (recursive) *) mutable text : string ; mutable pos : int ; (* end of material *) } let rec size_up required size = let s = 2*size+1 in if required <= s then s else size_up required s let is_blank = function | ' ' | '\t' | '\r' | '\n' -> true | _ -> false let trim_begin buffer = let rec lookup_fwd text k n = if k < n && is_blank text.[k] then lookup_fwd text (succ k) n else k in lookup_fwd buffer.text 0 buffer.pos let trim_end buffer = let rec lookup_bwd text k = if k >= 0 && is_blank text.[k] then lookup_bwd text (pred k) else k in lookup_bwd buffer.text (pred buffer.pos) let reduce_buffer buffer = if String.length buffer.text > min_buffer then buffer.text <- String.create min_buffer let truncate_text buffer size = if buffer.pos > size then begin let p = trim_begin buffer in let q = trim_end buffer in let n = q+1-p in if n <= 0 then begin reduce_buffer buffer ; buffer.pos <- 0 ; end else if n <= size then begin String.blit buffer.text p buffer.text 0 n ; buffer.pos <- n ; end else begin let n_left = size / 2 - 3 in let n_right = size - n_left - 5 in if p > 0 then String.blit buffer.text p buffer.text 0 n_left ; String.blit "[...]" 0 buffer.text n_left 5 ; String.blit buffer.text (q-n_right+1) buffer.text (n_left + 5) n_right ; buffer.pos <- size ; end end let append_text buffer text k n = begin let req = buffer.pos + n in let avail = String.length buffer.text in if req > avail then begin let s = size_up req avail in let t = String.create s in String.blit buffer.text 0 t 0 buffer.pos ; buffer.text <- t ; end ; String.blit text k buffer.text buffer.pos n ; buffer.pos <- buffer.pos + n ; if buffer.pos > tgr_buffer then truncate_text buffer max_buffer ; end let append buffer text k n = if n > 0 then append_text buffer text k n let new_buffer () = let buffer = { formatter = null ; text = String.create min_buffer ; pos = 0 ; } in let fmt = Format.make_formatter (append buffer) (fun () -> ()) in buffer.formatter <- fmt ; buffer (* -------------------------------------------------------------------------- *) (* --- Echo Buffer --- *) (* -------------------------------------------------------------------------- *) type prefix = | Label of string | Prefix of string | Indent of int let next_line = function | Label t -> Indent (String.length t) | Prefix _ | Indent _ as p -> p let blank32 = String.make 32 ' ' let rec echo_indent output k = if k > 0 then if k <= 32 then output blank32 0 k else ( output blank32 0 32 ; echo_indent output (k-32) ) let echo_line output prefix text k n = match prefix with | Prefix t | Label t -> output t 0 (String.length t) ; output text k n | Indent m -> echo_indent output m ; output text k n let rec echo_lines output text prefix p q = if p <= q then let t = try String.index_from text p '\n' with Not_found -> (-1) in if t < 0 || t > q then begin (* incomplete, last line *) echo_line output prefix text p (q+1-p) ; output "\n" 0 1 ; end else begin (* complete line *) echo_line output prefix text p (t+1-p) ; echo_lines output text (next_line prefix) (t+1) q ; end let echo_source output = function | None -> () | Some src -> let s = Printf.sprintf "%s:%d:" src.Lexing.pos_fname src.Lexing.pos_lnum in output s 0 (String.length s) let do_echo terminal source prefix text p q = if p <= q then if delayed_echo terminal then begin let s = String.sub text p (q+1-p) in let job t = echo_source t.output source ; echo_lines t.output s prefix 0 (String.length s - 1) ; t.flush () in terminal.delayed <- job :: terminal.delayed end else begin echo_source terminal.output source ; echo_lines terminal.output text prefix p q ; terminal.flush () end (* -------------------------------------------------------------------------- *) (* --- Channels --- *) (* -------------------------------------------------------------------------- *) let current_loc = ref (fun () -> raise Not_found) let set_current_source fpos = current_loc := fpos let get_current_source () = !current_loc () type emitter = { mutable listeners : (event -> unit) list ; mutable echo : bool ; } type channel = { locked_buffer : buffer ; (* already allocated top-level buffer *) mutable stack : int ; (* number of 'stacked' buffers *) plugin : string ; emitters : emitter array ; terminal : terminal ; } type channelstate = | NotCreatedYet of emitter array | Created of channel let nth_kind = function | Result -> 0 | Feedback -> 1 | Debug -> 2 | Error -> 3 | Warning -> 4 | Failure -> 5 let all_kinds = [| Result ; Feedback ; Debug ; Error ; Warning ; Failure |] let () = Array.iteri (fun i k -> assert (i == nth_kind k)) all_kinds (* -------------------------------------------------------------------------- *) (* --- Channels --- *) (* -------------------------------------------------------------------------- *) let all_channels : (string,channelstate) Hashtbl.t = Hashtbl.create 31 let default_emitters = Array.map (fun _ -> { listeners=[] ; echo=true }) all_kinds let new_emitters () = Array.map (fun e -> { listeners = e.listeners ; echo = e.echo }) default_emitters let get_emitters plugin = try match Hashtbl.find all_channels plugin with | NotCreatedYet e -> e | Created c -> c.emitters with Not_found -> let e = new_emitters () in Hashtbl.replace all_channels plugin (NotCreatedYet e) ; e let new_channel plugin = let create_with_emitters plugin emitters = let c = { plugin = plugin ; stack = 0 ; locked_buffer = new_buffer () ; emitters = emitters ; terminal = stdout ; } in Hashtbl.replace all_channels plugin (Created c) ; c in try match Hashtbl.find all_channels plugin with | Created c -> c | NotCreatedYet ems -> create_with_emitters plugin ems with Not_found -> let ems = new_emitters () in create_with_emitters plugin ems (* -------------------------------------------------------------------------- *) (* --- Already emitted messages --- *) (* -------------------------------------------------------------------------- *) let check_not_yet = ref (fun _evt -> false) (* -------------------------------------------------------------------------- *) (* --- Listeners --- *) (* -------------------------------------------------------------------------- *) let do_fire e f = f e let iter_kind ?kind f ems = match kind with | None -> Array.iter f ems | Some ks -> List.iter (fun k -> f ems.(nth_kind k)) ks let iter_plugin ?plugin ?kind f = match plugin with | None -> Hashtbl.iter (fun _ s -> match s with | Created c -> iter_kind ?kind f c.emitters | NotCreatedYet ems -> iter_kind ?kind f ems) all_channels ; iter_kind ?kind f default_emitters | Some p -> iter_kind ?kind f (get_emitters p) let add_listener ?plugin ?kind demon = iter_plugin ?plugin ?kind (fun em -> em.listeners <- em.listeners @ [demon]) let set_echo ?plugin ?kind echo = iter_plugin ?plugin ?kind (fun em -> em.echo <- echo) let notify e = let es = get_emitters e.evt_plugin in List.iter (do_fire e) es.(nth_kind e.evt_kind).listeners (* -------------------------------------------------------------------------- *) (* --- Generic Log Routine --- *) (* -------------------------------------------------------------------------- *) let open_buffer c = if c.stack > 0 then ( c.stack <- succ c.stack ; new_buffer () ) else ( c.stack <- 1 ; c.locked_buffer.pos <- 0 ; c.locked_buffer ) let close_buffer c = if c.stack > 1 then c.stack <- pred c.stack else reduce_buffer c.locked_buffer let fire_listeners emitwith listeners event = match emitwith, listeners with | None , [] -> () | None , fs -> List.iter (do_fire (Lazy.force event)) fs | Some f , _ -> do_fire (Lazy.force event) f let logtext c ~kind ~once ~prefix ~source ~append ~emitwith ~echo text = let buffer = open_buffer c in Format.kfprintf (fun fmt -> try (match append with None -> () | Some k -> k fmt) ; Format.pp_print_newline fmt () ; Format.pp_print_flush fmt () ; truncate_text buffer max_buffer ; let p = trim_begin buffer in let q = trim_end buffer in if p <= q then begin let event = lazy { evt_kind = kind ; evt_plugin = c.plugin ; evt_message = String.sub buffer.text p (q+1-p) ; evt_source = source ; } in if not once || !check_not_yet (Lazy.force event) then begin let e = c.emitters.(nth_kind kind) in if echo && e.echo then do_echo c.terminal source prefix buffer.text p q ; fire_listeners emitwith e.listeners event end end ; close_buffer c with e -> close_buffer c ; raise e ) buffer.formatter text let logwith c ~kind ~prefix ~source ~append ~echo f text = let buffer = open_buffer c in Format.kfprintf (fun fmt -> try (match append with None -> () | Some k -> k fmt) ; Format.pp_print_flush fmt () ; truncate_text buffer max_buffer ; let p = trim_begin buffer in let q = trim_end buffer in let event = lazy { evt_kind = kind ; evt_plugin = c.plugin ; evt_message = if p<=q then String.sub buffer.text p (q+1-p) else "" ; evt_source = source ; } in let e = c.emitters.(nth_kind kind) in if echo && e.echo && p <= q then do_echo c.terminal source prefix buffer.text p q ; List.iter (do_fire (Lazy.force event)) e.listeners ; close_buffer c ; f event with e -> close_buffer c ; raise e ) buffer.formatter text let finally_raise e _ = raise e let finally_false _ = false let finally_do f e = f (Lazy.force e) (* -------------------------------------------------------------------------- *) (* --- Messages Interface --- *) (* -------------------------------------------------------------------------- *) type 'a pretty_printer = ?current:bool -> ?source:Lexing.position -> ?emitwith:(event -> unit) -> ?echo:bool -> ?once:bool -> ?append:(Format.formatter -> unit) -> ('a,formatter,unit) format -> 'a type ('a,'b) pretty_aborter = ?current:bool -> ?source:Lexing.position -> ?echo:bool -> ?append:(Format.formatter -> unit) -> ('a,formatter,unit,'b) format4 -> 'a let get_prefix kind text = function | Some p -> p | None -> Label begin match kind with | Result | Debug | Feedback -> Printf.sprintf "[%s] " text | Warning -> Printf.sprintf "[%s] warning: " text | Error -> Printf.sprintf "[%s] user error: " text | Failure -> Printf.sprintf "[%s] failure: " text end let get_source current = function | None -> if current then Some (!current_loc ()) else None | Some _ as s -> s let log_channel channel ?(kind=Result) ?prefix ?(current=false) ?source ?emitwith ?(echo=true) ?(once=false) ?append text = logtext channel ~kind ~prefix:(get_prefix kind channel.plugin prefix) ~source:(get_source current source) ~once ?emitwith ~echo ?append text let with_log_channel channel f ?(kind=Result) ?prefix ?(current=false) ?source ?(echo=true) ?append text = logwith channel ~kind ~prefix:(get_prefix kind channel.plugin prefix) ~source:(get_source current source) ~echo ?append (finally_do f) text let echo e = try match Hashtbl.find all_channels e.evt_plugin with | NotCreatedYet _ -> raise Not_found | Created c -> let n = String.length e.evt_message in let prefix = get_prefix e.evt_kind e.evt_plugin None in do_echo c.terminal e.evt_source prefix e.evt_message 0 (n-1) with Not_found -> let msg = Format.sprintf "[unknown channel %s]:%s" e.evt_plugin e.evt_message in failwith msg (* ------------------------------------------------------------------------- *) (* --- Plug-in Interface --- *) (* ------------------------------------------------------------------------- *) module type Messages = sig type category = private string val register_category: string -> category module Category_set: Set.S with type elt = category val get_category: string -> Category_set.t val get_all_categories: unit -> Category_set.t val verbose_atleast: int -> bool val debug_atleast: int -> bool val add_debug_keys: Category_set.t -> unit val del_debug_keys: Category_set.t -> unit val get_debug_keys: unit -> Category_set.t val is_debug_key_enabled: category -> bool val get_debug_keyset : unit -> category list val result : ?level:int -> ?dkey:category -> 'a pretty_printer val feedback: ?level:int -> ?dkey:category -> 'a pretty_printer val debug : ?level:int -> ?dkey:category -> 'a pretty_printer val warning : 'a pretty_printer val error : 'a pretty_printer val abort : ('a,'b) pretty_aborter val failure : 'a pretty_printer val fatal : ('a,'b) pretty_aborter val verify : bool -> ('a,bool) pretty_aborter val not_yet_implemented : ('a,formatter,unit,'b) format4 -> 'a val deprecated : string -> now:string -> ('a -> 'b) -> 'a -> 'b val with_result : (event -> 'b) -> ('a,'b) pretty_aborter val with_warning : (event -> 'b) -> ('a,'b) pretty_aborter val with_error : (event -> 'b) -> ('a,'b) pretty_aborter val with_failure : (event -> 'b) -> ('a,'b) pretty_aborter val log : ?kind:kind -> ?verbose:int -> ?debug:int -> 'a pretty_printer val with_log : (event -> 'b) -> ?kind:kind -> ('a,'b) pretty_aborter val register : kind -> (event -> unit) -> unit (** Very local listener. *) val register_tag_handlers : (string -> string) * (string -> string) -> unit end module Register (P : sig val channel : string val label : string val verbose_atleast : int -> bool val debug_atleast : int -> bool end) = struct include P type category = string module Category_set = (Set.Make(String): Set.S with type elt = category) let categories = Hashtbl.create 3 let () = Hashtbl.add categories "" (Category_set.add "" Category_set.empty) let register_category (s:string) = let res: category = s in (* empty string is already handled *) if s <> "" then begin let add s = let existing = try Hashtbl.find categories s with Not_found -> Category_set.empty in Hashtbl.replace categories s (Category_set.add res existing) in let rec aux super = add super; if String.contains super ':' then aux (String.sub super 0 (String.rindex super ':')) in add ""; aux s end; res let get_category s = let s = if s = "*" then "" else s in try Hashtbl.find categories s with Not_found -> Category_set.empty let get_all_categories () = get_category "" let debug_keys = ref Category_set.empty let add_debug_keys s = debug_keys:= Category_set.union s !debug_keys let del_debug_keys s = debug_keys:= Category_set.diff !debug_keys s let get_debug_keys () = !debug_keys let is_debug_key_enabled s = Category_set.mem s !debug_keys let has_debug_key = function | None -> true (* No key means to be displayed each time *) | Some k -> Category_set.mem k !debug_keys let channel = new_channel P.channel let prefix_first = Label (Printf.sprintf "[%s] " label) let prefix_all = Prefix (Printf.sprintf "[%s] " label) let prefix_error = Label (Printf.sprintf "[%s] user error: " label) let prefix_warning = Label (Printf.sprintf "[%s] warning: " label) let prefix_failure = Label (Printf.sprintf "[%s] failure: " label) let prefix_dkey = function | None -> if debug_atleast 1 then prefix_all else prefix_first | Some key -> let lab = (Printf.sprintf "[%s:%s] " label key) in if debug_atleast 1 then Prefix lab else Label lab let prefix_for = function | Result | Feedback | Debug -> if debug_atleast 1 then prefix_all else prefix_first | Error -> prefix_error | Warning -> prefix_warning | Failure -> prefix_failure let internal_register_tag_handlers _c (_ope,_close) = () (* BM->LOIC: I need to keep this code around to be able to handle marks ands tags correctly. Do you think we can emulate all other features of Log but without using c.buffer at all? Everything but ensure_unique_newline seems feasible. See Design.make_slash to see a usefull example. let start_of_line= Printf.sprintf "\n[%s] " P.label in let length= pred (String.length start_of_line) in Format.pp_set_all_formatter_output_functions c.formatter ~out:c.term.output ~flush:c.term.flush ~newline:(fun () -> c.term.output start_of_line 0 length) ~spaces:(fun _ -> ()(*TODO:correct margin*)) ; Format.pp_set_tags c.formatter true; Format.pp_set_mark_tags c.formatter true; Format.pp_set_print_tags c.formatter false; Format.pp_set_formatter_tag_functions c.formatter {(Format.pp_get_formatter_tag_functions c.formatter ()) with Format.mark_open_tag = ope; mark_close_tag = close} *) let register_tag_handlers h = internal_register_tag_handlers channel h let to_be_log verbose debug = match verbose , debug with | 0 , 0 -> verbose_atleast 1 | v , 0 -> verbose_atleast v | 0 , d -> debug_atleast d | v , d -> verbose_atleast v || debug_atleast d let log ?(kind=Result) ?(verbose=0) ?(debug=0) ?(current=false) ?source ?emitwith ?(echo=true) ?(once=false) ?append text = if to_be_log verbose debug then logtext channel ~kind ~prefix:(prefix_for kind) ~source:(get_source current source) ~once ?emitwith ~echo ?append text else nullprintf text let result ?(level=1) ?dkey ?(current=false) ?source ?emitwith ?(echo=true) ?(once=false) ?append text = if verbose_atleast level && has_debug_key dkey then logtext channel ~kind:Result ~prefix:(prefix_dkey dkey) ~source:(get_source current source) ~once ?emitwith ~echo ?append text else nullprintf text let feedback ?(level=1) ?dkey ?(current=false) ?source ?emitwith ?(echo=true) ?(once=false) ?append text = if verbose_atleast level && has_debug_key dkey then logtext channel ~kind:Feedback ~prefix:(prefix_dkey dkey) ~source:(get_source current source) ~once ?emitwith ~echo ?append text else nullprintf text let debug ?(level=1) ?dkey ?(current=false) ?source ?emitwith ?(echo=true) ?(once=false) ?append text = if debug_atleast level && has_debug_key dkey then logtext channel ~kind:Feedback ~prefix:(prefix_dkey dkey) ~source:(get_source current source) ~once ?emitwith ~echo ?append text else nullprintf text let warning ?(current=false) ?source ?emitwith ?(echo=true) ?(once=false) ?append text = logtext channel ~kind:Warning ~prefix:(Label (Printf.sprintf "[%s] warning: " label)) ~source:(get_source current source) ~once ?emitwith ~echo ?append text let error ?(current=false) ?source ?emitwith ?(echo=true) ?(once=false) ?append text = logtext channel ~kind:Error ~prefix:prefix_error ~source:(get_source current source) ~once ?emitwith ~echo ?append text let abort ?(current=false) ?source ?(echo=true) ?append text = logwith channel ~kind:Error ~prefix:prefix_error ~source:(get_source current source) ~echo ?append (finally_raise (AbortError P.channel)) text let failure ?(current=false) ?source ?emitwith ?(echo=true) ?(once=false) ?append text = logtext channel ~kind:Failure ~prefix:prefix_failure ~source:(get_source current source) ~once ?emitwith ~echo ?append text let fatal ?(current=false) ?source ?(echo=true) ?append text = logwith channel ~kind:Failure ~prefix:prefix_failure ~source:(get_source current source) ~echo ?append (finally_raise (AbortFatal P.channel)) text let verify assertion ?(current=false) ?source ?(echo=true) ?append text = if assertion then Format.kfprintf (fun _ -> true) null text else logwith channel ~kind:Failure ~prefix:prefix_failure ~source:(get_source current source) ~echo ?append finally_false text let with_result f ?(current=false) ?source ?(echo=true) ?append text = logwith channel ~kind:Result ~prefix:(if debug_atleast 1 then prefix_all else prefix_first) ~source:(get_source current source) ~echo ?append (finally_do f) text let with_warning f ?(current=false) ?source ?(echo=true) ?append text = logwith channel ~kind:Warning ~prefix:prefix_warning ~source:(get_source current source) ~echo ?append (finally_do f) text let with_error f ?(current=false) ?source ?(echo=true) ?append text = logwith channel ~kind:Error ~prefix:prefix_error ~source:(get_source current source) ~echo ?append (finally_do f) text let with_failure f ?(current=false) ?source ?(echo=true) ?append text = logwith channel ~kind:Failure ~prefix:prefix_failure ~source:(get_source current source) ~echo ?append (finally_do f) text let with_log f ?(kind=Result) ?(current=false) ?source ?(echo=true) ?append text = logwith channel ~kind ~prefix:(prefix_for kind) ~source:(get_source current source) ~echo ?append (finally_do f) text let register kd f = let em = channel.emitters.(nth_kind kd) in em.listeners <- em.listeners @ [f] let not_yet_implemented text = let buffer = Buffer.create 80 in let finally fmt = Format.pp_print_flush fmt (); let msg = Buffer.contents buffer in raise (FeatureRequest(channel.plugin,msg)) in let fmt = Format.formatter_of_buffer buffer in Format.kfprintf finally fmt text let deprecated name ~now f x = warning ~once:true "call to deprecated function '%s'.\nShould use '%s' instead." name now ; f x let get_debug_keyset = deprecated "Log.get_debug_key_set" ~now:"Log.get_all_categories (which returns a set instead of list)" (fun () -> Category_set.elements (get_debug_keys ())) end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/log.mli0000644000175000017500000003546712155630171017350 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Logging Services for Frama-C Kernel and Plugins. @since Beryllium-20090601-beta1 @plugin development guide *) open Format type kind = Result | Feedback | Debug | Warning | Error | Failure (** @since Beryllium-20090601-beta1 *) type event = { evt_kind : kind ; evt_plugin : string ; evt_source : Lexing.position option ; evt_message : string ; } (** @since Beryllium-20090601-beta1 *) type 'a pretty_printer = ?current:bool -> ?source:Lexing.position -> ?emitwith:(event -> unit) -> ?echo:bool -> ?once:bool -> ?append:(Format.formatter -> unit) -> ('a,formatter,unit) format -> 'a (** Generic type for the various logging channels which are not aborting Frama-C. - When [current] is [false] (default for most of the channels), no location is output. When it is [true], the last registred location is used as current (see {!Cil_const.CurrentLoc}). - [source] is the location to be output. If nil, [current] is used to determine if a location should be output - [emitwith] function which is called each time an event is processed - [echo] is [true] if the event should be output somewhere in addition to [stdout] - [append] adds some actions performed on the formatter after the event has been processed. @since Beryllium-20090601-beta1 *) type ('a,'b) pretty_aborter = ?current:bool -> ?source:Lexing.position -> ?echo:bool -> ?append:(Format.formatter -> unit) -> ('a,formatter,unit,'b) format4 -> 'a (** @since Beryllium-20090601-beta1 Same as {!Log.pretty_printer} except that channels having this type denote a fatal error aborting Frama-C. *) (* -------------------------------------------------------------------------- *) (** {2 Exception Registry} @plugin development guide @since Beryllium-20090601-beta1 *) (* -------------------------------------------------------------------------- *) exception AbortError of string (** Plug-in name *) (** User error that prevents a plugin to terminate. @since Beryllium-20090601-beta1 *) exception AbortFatal of string (** Plug-in name *) (** Internal error that prevents a plugin to terminate. @since Beryllium-20090601-beta1 *) exception FeatureRequest of string * string (** Raise by [not_yet_implemented]. You may catch [FeatureRequest(p,r)] to support degenerated behavior. The responsible plugin is 'p' and the feature request is 'r'. *) (* -------------------------------------------------------------------------- *) (** {2 Plugin Interface} @since Beryllium-20090601-beta1 *) (* -------------------------------------------------------------------------- *) (** @since Beryllium-20090601-beta1 @plugin development guide *) module type Messages = sig type category = private string (** category for debugging/verbose messages. Must be registered before any use. Each column in the string defines a sub-category, e.g. a:b:c defines a subcategory c of b, which is itself a subcategory of a. Enabling a category (via -plugin-msg-category) will enable all its subcategories. @since Fluorine-20130401 *) val register_category: string -> category (** register a new debugging/verbose category. @since Fluorine-20130401 *) module Category_set: Set.S with type elt = category val get_category: string -> Category_set.t (** returns all registered categories (including sub-categories) corresponding to a given string @since Fluorine-20130401 *) val get_all_categories: unit -> Category_set.t (** returns all registered categories. *) val verbose_atleast : int -> bool (** @since Beryllium-20090601-beta1 *) val debug_atleast : int -> bool (** @since Beryllium-20090601-beta1 *) val add_debug_keys : Category_set.t -> unit (** adds categories corresponding to string (including potential subcategories) to the set of categories for which messages are to be displayed. @since Fluorine-20130401 use categories instead of plain string *) val del_debug_keys: Category_set.t -> unit (** removes the given categories from the set for which messages are printed. @since Fluorine-20130401 *) val get_debug_keys: unit -> Category_set.t (** Returns currently active keys @since Fluorine-20130401 *) val is_debug_key_enabled: category -> bool (** Returns [true] if the given category is currently active @since Fluorine-20130401 *) val get_debug_keyset : unit -> category list (** Returns currently active keys @since Nitrogen-20111001 @deprecated Fluorine-20130401 use get_debug_keys instead *) val result : ?level:int -> ?dkey:category -> 'a pretty_printer (** Results of analysis. Default level is 1. @since Beryllium-20090601-beta1 @plugin development guide *) val feedback : ?level:int -> ?dkey:category -> 'a pretty_printer (** Progress and feedback. Level is tested against the verbosity level. @since Beryllium-20090601-beta1 @modify Fluorine-20130401 added dkey argument @plugin development guide *) val debug : ?level:int -> ?dkey:category -> 'a pretty_printer (** Debugging information dedicated to Plugin developpers. Default level is 1. The debugging key is used in message headers. See also [set_debug_keys] and [set_debug_keyset]. @since Beryllium-20090601-beta1 @modify Nitrogen-20111001 Optional parameter [dkey] @plugin development guide *) val warning : 'a pretty_printer (** Hypothesis and restrictions. @since Beryllium-20090601-beta1 @plugin development guide *) val error : 'a pretty_printer (** user error: syntax/typing error, bad expected input, etc. @since Beryllium-20090601-beta1 @plugin development guide *) val abort : ('a,'b) pretty_aborter (** user error stopping the plugin. @raise AbortError with the channel name. @since Beryllium-20090601-beta1 @plugin development guide *) val failure : 'a pretty_printer (** internal error of the plug-in. @plugin development guide *) val fatal : ('a,'b) pretty_aborter (** internal error of the plug-in. @raise AbortFatal with the channel name. @since Beryllium-20090601-beta1 @plugin development guide *) val verify : bool -> ('a,bool) pretty_aborter (** If the first argument is [true], return [true] and do nothing else, otherwise, send the message on the {i fatal} channel and return [false]. The intended usage is: [assert (verify e "Bla...") ;]. @since Beryllium-20090601-beta1 @plugin development guide *) val not_yet_implemented : ('a,formatter,unit,'b) format4 -> 'a (** raises [FeatureRequest] but {i does not} send any message. If the exception is not catched, Frama-C displays a feature-request message to the user. @since Beryllium-20090901 *) val deprecated: string -> now:string -> ('a -> 'b) -> ('a -> 'b) (** [deprecated s ~now f] indicates that the use of [f] of name [s] is now deprecated. It should be replaced by [now]. @return the given function itself @since Lithium-20081201 in Extlib @since Beryllium-20090902 *) val with_result : (event -> 'b) -> ('a,'b) pretty_aborter (** @since Beryllium-20090601-beta1 *) val with_warning : (event -> 'b) -> ('a,'b) pretty_aborter (** @since Beryllium-20090601-beta1 *) val with_error : (event -> 'b) -> ('a,'b) pretty_aborter (** @since Beryllium-20090601-beta1 *) val with_failure : (event -> 'b) -> ('a,'b) pretty_aborter (** @since Beryllium-20090601-beta1 *) val log : ?kind:kind -> ?verbose:int -> ?debug:int -> 'a pretty_printer (** Generic log routine. The default kind is [Result]. Use cases (with [n,m > 0]): - [log ~verbose:n]: emit the message only when verbosity level is at least [n]. - [log ~debug:n]: emit the message only when debugging level is at least [n]. - [log ~verbose:n ~debug:m]: any debugging or verbosity level is sufficient. @since Beryllium-20090901 @plugin development guide *) val with_log : (event -> 'b) -> ?kind:kind -> ('a,'b) pretty_aborter (** @since Beryllium-20090901 @plugin development guide *) val register : kind -> (event -> unit) -> unit (** Local registry for listeners. *) val register_tag_handlers : (string -> string) * (string -> string) -> unit end (** Each plugin has its own channel to output messages. This functor should not be directly applied by plug-in developer. They should apply {!Plugin.Register} instead. @since Beryllium-20090601-beta1 *) module Register (P : sig val channel : string val label : string val verbose_atleast : int -> bool val debug_atleast : int -> bool end) : Messages (* -------------------------------------------------------------------------- *) (** {2 Echo and Notification} *) (* -------------------------------------------------------------------------- *) val set_echo : ?plugin:string -> ?kind:kind list -> bool -> unit (** Turns echo on or off. Applies to all channel unless specified, and all kind of messages unless specified. @since Beryllium-20090601-beta1 @plugin development guide *) val add_listener : ?plugin:string -> ?kind:kind list -> (event -> unit) -> unit (** Register a hook that is called each time an event is emitted. Applies to all channel unless specified, and all kind of messages unless specified. @since Beryllium-20090601-beta1 @plugin development guide *) val echo : event -> unit (** Display an event of the terminal, unless echo has been turned off. @since Beryllium-20090601-beta1 *) val notify : event -> unit (** Send an event over the associated listeners. @since Beryllium-20090601-beta1 *) (* -------------------------------------------------------------------------- *) (** {2 Channel interface} This is the {i low-level} interface to logging services. Not to be used by casual users. *) (* -------------------------------------------------------------------------- *) type channel (** @since Beryllium-20090601-beta1 *) val new_channel : string -> channel (** @since Beryllium-20090901 @plugin development guide *) type prefix = | Label of string | Prefix of string | Indent of int val log_channel : channel -> ?kind:kind -> ?prefix:prefix -> 'a pretty_printer (** logging function to user-created channel. @since Beryllium-20090901 @plugin development guide *) val with_log_channel : channel -> (event -> 'b) -> ?kind:kind -> ?prefix:prefix -> ('a,'b) pretty_aborter (** logging function to user-created channel. @since Beryllium-20090901 @plugin development guide *) val kernel_channel_name: string (** the reserved channel name used by the Frama-C kernel. @since Beryllium-20090601-beta1 *) val kernel_label_name: string (** the reserved label name used by the Frama-C kernel. @since Beryllium-20090601-beta1 *) val get_current_source : unit -> Lexing.position (* -------------------------------------------------------------------------- *) (** {2 Terminal interface} This is the {i low-level} interface to logging services. Not to be used by casual users. *) (* -------------------------------------------------------------------------- *) val null : formatter (** Prints nothing. @since Beryllium-20090901 *) val nullprintf : ('a,formatter,unit) format -> 'a (** Discards the message and returns unit. @since Beryllium-20090901 *) val with_null : (unit -> 'b) -> ('a,formatter,unit,'b) format4 -> 'a (** Discards the message and call the continuation. @since Beryllium-20090901 *) val set_output : (string -> int -> int -> unit) -> (unit -> unit) -> unit (** This function has the same parameters as Format.make_formatter. @since Beryllium-20090901 @plugin development guide *) val print_on_output : (Format.formatter -> unit) -> unit (** Direct printing on output. Message echo is delayed until the output is finished. Then, the output is flushed and all pending message are echoed. Notification of listeners is not delayed, however. Can not be recursively invoked. @since Beryllium-20090901 @modify Nitrogen-20111001 signature changed @plugin development guide *) val print_delayed : (Format.formatter -> unit) -> unit (** Direct printing on output. Same as [print_on_output], except that message echo is not delayed until text material is actually written. This gives an chance for formatters to emit messages before actual pretty printing. Can not be recursively invoked. @since Beryllium-20090901 @modify Nitrogen-20111001 signature changed @plugin development guide *) (**/**) val set_current_source : (unit -> Lexing.position) -> unit (* Forward reference to the function returning the current location, used when [~current:true] is set on printers. Currently set in {Cil}. Not for the casual user. *) val check_not_yet: (event -> bool) ref (* Checks whether a message been emitted already, in which case it is not reprinted. Currently set in {Messages}. Not for the casual user. *) (**/**) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/file.ml0000644000175000017500000022477212155630171017334 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Visitor open Pretty_utils open Cil_datatype type file = | NeedCPP of string (* filename of the [.c] to preprocess *) * string (* Preprocessor command. [filename.c -o tempfilname.i] will be appended at the end.*) | NoCPP of string (** filename of a preprocessed [.c] *) | External of string * string (* file * name of plug-in that handles it *) module D = Datatype.Make (struct include Datatype.Serializable_undefined type t = file let name = "File" let reprs = [ NeedCPP("", ""); NoCPP ""; External("", "") ] let structural_descr = Structural_descr.Abstract let mem_project = Datatype.never_any_project let copy = Datatype.identity (* immutable strings *) let internal_pretty_code p_caller fmt t = let pp fmt = match t with | NoCPP s -> Format.fprintf fmt "@[File.NoCPP %S@]" s | External (f,p) -> Format.fprintf fmt "@[File.External (%S,%S)@]" f p | NeedCPP (a,b) -> Format.fprintf fmt "@[File.NeedCPP (%S,%S)@]" a b in Type.par p_caller Type.Call fmt pp end) include D let check_suffixes = Hashtbl.create 17 let new_file_type = Hashtbl.add check_suffixes let get_suffixes () = Hashtbl.fold (fun s _ acc -> s :: acc) check_suffixes [ ".c"; ".i"; ".h" ] let get_name = function NeedCPP (s,_) | NoCPP s | External (s,_) -> s (* ************************************************************************* *) (** {2 Preprocessor command} *) (* ************************************************************************* *) (* the preprocessor command is: If the program has an explicit argument -cpp-command "XX -Y" (quotes are required by the shell) then XX -Y else use the command in [Config.preprocessor].*) let get_preprocessor_command () = let cmdline = Kernel.CppCommand.get() in if cmdline <> "" then cmdline else Config.preprocessor let from_filename ?(cpp=get_preprocessor_command ()) f = if Filename.check_suffix f ".i" then begin NoCPP f end else let suf = try let suf_idx = String.rindex f '.' in String.sub f suf_idx (String.length f - suf_idx) with Not_found -> (* raised by String.rindex if '.' \notin f *) "" in if Hashtbl.mem check_suffixes suf then External (f, suf) else NeedCPP (f, cpp) (* ************************************************************************* *) (** {2 Internal states} *) (* ************************************************************************* *) module Files : sig val get: unit -> t list val register: t list -> unit val pre_register: t -> unit val is_computed: unit -> bool val reset: unit -> unit val pre_register_state: State.t end = struct module S = State_builder.List_ref (D) (struct let dependencies = [ Kernel.CppCommand.self; Kernel.CppExtraArgs.self; Kernel.Files.self ] let name = "Files for preprocessing" end) module Pre_files = State_builder.List_ref (D) (struct let dependencies = [] let name = "Built-ins headers and source" end) let () = State_dependency_graph.add_dependencies ~from:S.self [ Ast.self; Ast.UntypedFiles.self; Cabshelper.Comments.self ] let () = State_dependency_graph.add_dependencies ~from:Pre_files.self [ Ast.self; Ast.UntypedFiles.self; Cabshelper.Comments.self; Cil.Frama_c_builtins.self ] let pre_register_state = Pre_files.self (* Allow to register files in advance, e.g. prolog files for plugins *) let pre_register file = let prev_files = Pre_files.get () in Pre_files.set (prev_files @ [file]) let register files = if S.is_computed () then raise (Ast.Bad_Initialization "[File.register] Too many initializations"); let prev_files = S.get () in S.set (prev_files @ files); S.mark_as_computed () let get () = Pre_files.get () @ S.get () let is_computed () = S.is_computed () let reset () = let selection = State_selection.with_dependencies S.self in (* Keep built-in files set *) Project.clear ~selection () end let get_all = Files.get let pre_register = Files.pre_register let pre_register_in_share s = let real_s = Filename.concat Config.datadir s in if not (Sys.file_exists real_s) then Kernel.fatal "Cannot find file %s, needed for Frama-C initialization. \ Please check that %s is the correct share path for Frama-C." s Config.datadir; pre_register (from_filename real_s) (* Registers the initial builtins, for each new project. *) let () = Project.register_create_hook (fun p -> let selection = State_selection.singleton Files.pre_register_state in Project.on ~selection p pre_register_in_share (Filename.concat "libc" "__fc_builtin_for_normalization.i")) (*****************************************************************************) (** {2 AST Integrity check} *) (*****************************************************************************) let is_admissible_conversion e ot nt = let ot' = Cil.typeDeepDropAllAttributes ot in let nt' = Cil.typeDeepDropAllAttributes nt in not (Cil.need_cast ot' nt') || (match e.enode, Cil.unrollType nt with | Const(CEnum { eihost = ei }), TEnum(ei',_) -> ei.ename = ei'.ename | _ -> false) (* performs various consistency checks over a cil file. Code may vary depending on current development of the kernel and/or identified bugs. what is a short string indicating which AST is checked NB: some checks are performed on the CFG, so it must have been computed on the file that is checked. *) class check_file_aux is_normalized what: Visitor.frama_c_visitor = let check_abort fmt = Kernel.fatal ~current:true ("[AST Integrity Check]@ %s@ " ^^ fmt) what in let check_label s = let rec has_label = function Label _ :: _ -> () | [] -> check_abort "Statement is referenced by \\at or goto without having a label" | _ :: rest -> has_label rest in has_label s.labels in object(self) inherit Visitor.frama_c_inplace as plain val known_enuminfos = Enuminfo.Hashtbl.create 7 val known_enumitems = Enumitem.Hashtbl.create 7 val known_loop_annot_id = Hashtbl.create 7 val known_code_annot_id = Hashtbl.create 7 val known_fields = Fieldinfo.Hashtbl.create 7 val known_stmts = Stmt.Hashtbl.create 7 val known_vars = Varinfo.Hashtbl.create 7 val known_logic_info = Logic_var.Hashtbl.create 7 val mutable local_vars = Varinfo.Set.empty val known_logic_vars = Logic_var.Hashtbl.create 7 val switch_cases = Stmt.Hashtbl.create 7 val unspecified_sequence_calls = Stack.create () val mutable labelled_stmt = [] val mutable globals_functions = Varinfo.Set.empty val mutable globals_vars = Varinfo.Set.empty method private remove_globals_function vi = globals_functions <- Varinfo.Set.remove vi globals_functions method private remove_globals_var vi = globals_vars <- Varinfo.Set.remove vi globals_vars method venuminfo ei = Enuminfo.Hashtbl.add known_enuminfos ei ei; DoChildren method venumitem ei = let orig = try Enuminfo.Hashtbl.find known_enuminfos ei.eihost with Not_found -> check_abort "Unknown enuminfo %s" ei.eihost.ename in if orig != ei.eihost then check_abort "Item %s is not tied correctly to its enuminfo %s" ei.einame ei.eihost.ename; Enumitem.Hashtbl.add known_enumitems ei ei; DoChildren method private remove_unspecified_sequence_calls s = Stack.iter (fun calls -> calls:= Stmt.Set.remove s !calls) unspecified_sequence_calls method vvdec v = Kernel.debug "Declaration of %s(%d)" v.vname v.vid; if Varinfo.Hashtbl.mem known_vars v then (let v' = Varinfo.Hashtbl.find known_vars v in if v != v' then (* we can see the declaration twice (decl and def in fact) *) (check_abort "variables %s and %s have the same id (%d)" v.vname v'.vname v.vid)) else Varinfo.Hashtbl.add known_vars v v; match v.vlogic_var_assoc with None -> DoChildren | Some ({ lv_origin = Some v'} as lv) when v == v' -> Kernel.debug "var %s(%d) has an associated %s(%d)" v.vname v.vid lv.lv_name lv.lv_id; DoChildren | Some lv -> (check_abort "C variable %s is not properly referenced by its \ associated logic variable %s" v.vname lv.lv_name) method vvrbl v = let not_shared () = check_abort "variable %s is not shared between definition and use" v.vname in let unknown () = check_abort "variable %s is not declared" v.vname in (try if Varinfo.Hashtbl.find known_vars v != v then not_shared () with Not_found -> unknown () ); DoChildren method vquantifiers l = List.iter (fun lv -> if lv.lv_kind <> LVQuant then check_abort "logic variable %a is declared under a quantifier but is \ flagged with wrong origin" Printer.pp_logic_var lv) l; DoChildren method vlogic_var_decl lv = Logic_var.Hashtbl.add known_logic_vars lv lv; match lv.lv_origin with (* lvkind for purely logical variables is checked at the parent level. *) | None -> DoChildren | Some v when lv.lv_kind <> LVC -> check_abort "logic variable %a as an associated variable %a, but is not \ flagged as having a C origin" Printer.pp_logic_var lv Printer.pp_varinfo v | Some { vlogic_var_assoc = Some lv' } when lv == lv' -> DoChildren | Some v -> check_abort "logic variable %a is not properly referenced by the original \ C variable %a" Printer.pp_logic_var lv Printer.pp_varinfo v method vlogic_info_decl li = List.iter (fun lv -> if lv.lv_kind <> LVFormal then check_abort "Formal parameter %a of logic function/predicate is \ flagged with wrong origin" Printer.pp_logic_var lv) li.l_profile; DoChildren method vlogic_var_use v = if v.lv_name <> "\\exit_status" then begin if Logic_env.is_builtin_logic_function v.lv_name then begin if not (List.exists (fun x -> x.l_var_info == v) (Logic_env.find_all_logic_functions v.lv_name)) then check_abort "Built-in logic variable %s information is not shared \ between environment and use" v.lv_name end else begin let unknown () = check_abort "logic variable %s (%d) is not declared" v.lv_name v.lv_id in let not_shared () = check_abort "logic variable %s (%d) is not shared between definition and use" v.lv_name v.lv_id in try if Logic_var.Hashtbl.find known_logic_vars v != v then not_shared () with Not_found -> unknown () end end; DoChildren method vfunc f = (* Initial AST does not have kf *) if is_normalized then begin let kf = Extlib.the self#current_kf in if not (Kernel_function.is_definition kf) then check_abort "Kernel function %a is supposed to be a prototype, but it has a body" Kernel_function.pretty kf; if Kernel_function.get_definition kf != f then check_abort "Body of %a is not shared between kernel function and AST" Kernel_function.pretty kf; end; labelled_stmt <- []; Stmt.Hashtbl.clear known_stmts; Stmt.Hashtbl.clear switch_cases; local_vars <- Varinfo.Set.empty; List.iter (fun x -> local_vars <- Varinfo.Set.add x local_vars) f.slocals; let print_stmt fmt stmt = Format.fprintf fmt "@[%a (%d)@]" Printer.pp_stmt stmt stmt.sid in let check f = if Stmt.Hashtbl.length switch_cases <> 0 then begin Stmt.Hashtbl.iter (fun x _ -> check_abort "In function %a, statement %a \ does not appear in body of switch while porting a \ case or default label." Printer.pp_varinfo f.svar print_stmt x) switch_cases end; List.iter (fun stmt -> try let stmt' = Stmt.Hashtbl.find known_stmts stmt in if stmt' != stmt then check_abort "Label @[%a@]@ in function %a@ \ is not linked to the correct statement:@\n\ statement in AST is %a@\n\ statement referenced in goto or \\at is %a" Printer.pp_stmt {stmt with skind = Instr (Skip (Stmt.loc stmt)) } Printer.pp_varinfo f.svar print_stmt stmt' print_stmt stmt with Not_found -> check_abort "Label @[%a@]@ in function %a@ \ does not refer to an existing statement" Printer.pp_stmt {stmt with skind = Instr (Skip (Stmt.loc stmt)) } Printer.pp_varinfo f.svar) labelled_stmt; labelled_stmt <- []; let check_one_stmt stmt _ = let check_cfg_edge stmt' = try let ast_stmt = Stmt.Hashtbl.find known_stmts stmt' in if ast_stmt != stmt' then check_abort "cfg info of statement %a in function %a \ is not linked to correct statement:@\n\ statement in AST is %a@\n\ statement referenced in cfg info is %a" print_stmt stmt Printer.pp_varinfo f.svar print_stmt ast_stmt print_stmt stmt' with Not_found -> check_abort "cfg info of statement %a in function %a does not \ refer to an existing statement.@\n\ Referenced statement is %a" print_stmt stmt Printer.pp_varinfo f.svar print_stmt stmt' in List.iter check_cfg_edge stmt.succs; List.iter check_cfg_edge stmt.preds; match stmt.skind with | Return _ -> if stmt.succs <> [] then check_abort "return statement %a in function %a \ has successors:@\n%a" print_stmt stmt Printer.pp_varinfo f.svar (Pretty_utils.pp_list ~sep:"@\n" print_stmt) stmt.succs | Instr(Call (_, called, _, _)) when hasAttribute "noreturn" (typeAttrs (typeOf called)) -> if stmt.succs <> [] then check_abort "exit statement %a in function %a \ has successors:@\n%a" print_stmt stmt Printer.pp_varinfo f.svar (Pretty_utils.pp_list ~sep:"@\n" print_stmt) stmt.succs | Instr(Call (_, { enode = Lval(Var called,NoOffset)}, _, _)) when hasAttribute "noreturn" called.vattr -> if stmt.succs <> [] then check_abort "exit statement %a in function %a \ has successors:@\n%a" print_stmt stmt Printer.pp_varinfo f.svar (Pretty_utils.pp_list ~sep:"@\n" print_stmt) stmt.succs | _ -> (* unnormalized code may not contain return statement, leaving perfectly normal statements without succs. *) if is_normalized && stmt.succs = [] then check_abort "statement %a in function %a has no successor." print_stmt stmt Printer.pp_varinfo f.svar in Stmt.Hashtbl.iter check_one_stmt known_stmts; Stmt.Hashtbl.clear known_stmts; if not (Varinfo.Set.is_empty local_vars) then begin check_abort "Local variables %a of function %a are not part of any block" (pp_list ~sep:",@ " Printer.pp_varinfo) (Varinfo.Set.elements local_vars) Printer.pp_varinfo f.svar end; f in ChangeDoChildrenPost(f,check) method vstmt_aux s = Stmt.Hashtbl.add known_stmts s s; Stmt.Hashtbl.remove switch_cases s; self#remove_unspecified_sequence_calls s; (match s.skind with Goto (s,_) -> check_label !s; labelled_stmt <- !s :: labelled_stmt; DoChildren | Switch(_,_,cases,loc) -> List.iter (fun s -> Stmt.Hashtbl.add switch_cases s loc) cases; DoChildren | UnspecifiedSequence seq -> let calls = List.fold_left (fun acc (_,_,_,_,calls) -> List.fold_left (fun acc x -> Stmt.Set.add !x acc) acc calls) Stmt.Set.empty seq in Stack.push (ref calls) unspecified_sequence_calls; let f s = let calls = Stack.pop unspecified_sequence_calls in if Stmt.Set.is_empty !calls then s else check_abort "@[Calls referenced in unspecified sequence \ are not in the AST:@[%a@]@]" (Pretty_utils.pp_list ~sep:"@ " Printer.pp_stmt) (Stmt.Set.elements !calls) in ChangeDoChildrenPost(s,f) | _ -> DoChildren); method vblock b = (* ensures that the blocals are part of the locals of the function. *) List.iter (fun v -> if Varinfo.Set.mem v local_vars then begin local_vars <- Varinfo.Set.remove v local_vars; end else begin check_abort "In function %a, variable %a is supposed to be local to a block \ but not mentioned in the function's locals." Printer.pp_varinfo (Kernel_function.get_vi (Extlib.the self#current_kf)) Printer.pp_varinfo v end) b.blocals; DoChildren method vcode_annot ca = if Hashtbl.mem known_code_annot_id ca.annot_id then (check_abort "duplicated code annotation") else Hashtbl.add known_code_annot_id ca.annot_id (); DoChildren method voffs = function NoOffset -> SkipChildren | Index _ -> DoChildren | Field(fi,_) -> begin try if not (fi == Fieldinfo.Hashtbl.find known_fields fi) then (check_abort "field %s of type %s(%d) is not \ shared between declaration and use" fi.fname fi.fcomp.cname fi.fcomp.ckey) with Not_found -> (check_abort "field %s of type %s(%d) is unbound in the AST" fi.fname fi.fcomp.cname fi.fcomp.ckey) end; DoChildren method vterm_offset = function TNoOffset -> SkipChildren | TIndex _ -> DoChildren | TModel(mi,_) -> (try let mi' = Logic_env.find_model_field mi.mi_name mi.mi_base_type in if mi' != mi then begin check_abort "model field %s of type %a is not shared \ between declaration and use" mi.mi_name Printer.pp_typ mi.mi_base_type end with Not_found -> check_abort "unknown model field %s in type %a" mi.mi_name Printer.pp_typ mi.mi_base_type); DoChildren | TField(fi,_) -> begin try if not (fi == Fieldinfo.Hashtbl.find known_fields fi) then (check_abort "field %s of type %s is not \ shared between declaration and use" fi.fname fi.fcomp.cname) with Not_found -> (check_abort "field %s of type %s is unbound in the AST" fi.fname fi.fcomp.cname) end; DoChildren method private check_ei: 'a. enumitem -> 'a visitAction = fun ei -> try let ei' = Enumitem.Hashtbl.find known_enumitems ei in if ei != ei' then check_abort "enumitem %s is not shared between declaration and use" ei.einame; DoChildren with Not_found -> check_abort "enumitem %s is used but not declared" ei.einame method vterm t = match t.term_node with | TLval _ -> begin match t.term_type with | Ctype ty -> ignore (Kernel.verify (not (isVoidType ty)) "logic term with void type:%a" Printer.pp_term t); DoChildren | _ -> DoChildren end | Tat(_,StmtLabel l) -> check_label !l; labelled_stmt <- !l::labelled_stmt; DoChildren | TConst (LEnum ei) -> self#check_ei ei | Tif (_,t1,t2) -> if not (Cil_datatype.Logic_type.equal t1.term_type t2.term_type) then check_abort "Conditional operator %a@\nFirst branch has type %a@\n\ Second branch has type %a" Printer.pp_term t Printer.pp_logic_type t1.term_type Printer.pp_logic_type t2.term_type; DoChildren | Tlet(li,_) -> if li.l_var_info.lv_kind <> LVLocal then check_abort "Local logic variable %a is flagged with wrong origin" Printer.pp_logic_var li.l_var_info; DoChildren | _ -> DoChildren method vinitoffs = self#voffs (* In non-normalized mode, we can't rely on the Globals tables used by the normal Frama-C's vglob: jump directly to vglob_aux. *) method vglob g = if is_normalized then plain#vglob g else self#vglob_aux g method vglob_aux g = match g with GCompTag(c,_) -> Kernel.debug "Adding fields for type %s(%d)" c.cname c.ckey; List.iter (fun x -> Fieldinfo.Hashtbl.add known_fields x x) c.cfields; DoChildren | GVarDecl(_,v,_) when Cil.isFunctionType v.vtype -> self#remove_globals_function v; if is_normalized then begin if v.vdefined && not (Kernel_function.is_definition (Globals.Functions.get v)) then check_abort "Function %s is supposed to be defined, \ but not registered as such" v.vname; if not v.vdefined && Kernel_function.is_definition (Globals.Functions.get v) then check_abort "Function %s has a registered definition, \ but is supposed to be only declared" v.vname end; (match Cil.splitFunctionType v.vtype with (_,None,_,_) -> () | (_,Some l,_,_) -> if is_normalized then begin try let l' = Cil.getFormalsDecl v in if List.length l <> List.length l' then check_abort "prototype %s has %d arguments but is associated to \ %d formals in FormalsDecl" v.vname (List.length l) (List.length l') else let kf = Globals.Functions.get v in let l'' = Kernel_function.get_formals kf in if List.length l' <> List.length l'' then check_abort "mismatch between FormalsDecl and Globals.Functions \ on prototype %s." v.vname; if Kernel_function.is_definition kf then begin List.iter2 (fun v1 v2 -> if v1 != v2 then check_abort "formal parameters of %s are not shared \ between declaration and definition" v.vname) l' l'' end with Not_found -> check_abort "prototype %s (%d) has no associated \ parameters in FormalsDecl" v.vname v.vid end); DoChildren | GVarDecl(_,v,_) -> self#remove_globals_var v; DoChildren | GVar(v,_,_) -> self#remove_globals_var v; DoChildren | GFun (f,_) -> if not f.svar.vdefined then check_abort "Function %s has a definition, but is considered as not defined" f.svar.vname; self#remove_globals_function f.svar; DoChildren | _ -> DoChildren method vfile _ = let check_end f = if not (Cil_datatype.Varinfo.Set.is_empty globals_functions) || not (Cil_datatype.Varinfo.Set.is_empty globals_vars) then begin let print_var_vid fmt vi = Format.fprintf fmt "%a(%d)" Printer.pp_varinfo vi vi.vid in check_abort "Following functions and variables are present in global tables but \ not in AST:%a%a" (Pretty_utils.pp_list ~pre:"@\nFunctions:@\n" ~sep:"@ " print_var_vid) (Cil_datatype.Varinfo.Set.elements globals_functions) (Pretty_utils.pp_list ~pre:"@\nVariables:@\n" ~sep:"@ " print_var_vid) (Cil_datatype.Varinfo.Set.elements globals_vars) end; f in DoChildrenPost check_end method vannotation a = match a with Dfun_or_pred (li,_) | Dinvariant (li,_) | Dtype_annot (li,_) -> if not (List.memq li (Logic_env.find_all_logic_functions li.l_var_info.lv_name)) then check_abort "Global logic function %a information is not in the environment" Printer.pp_logic_var li.l_var_info; if li.l_var_info.lv_kind <> LVGlobal then check_abort "Global logic function %a is flagged with a wrong origin" Printer.pp_logic_var li.l_var_info; DoChildren | Dmodel_annot (mi, _) -> (try let mi' = Logic_env.find_model_field mi.mi_name mi.mi_base_type in if mi != mi' then check_abort "field %s of type %a is not shared between \ declaration and environment" mi.mi_name Printer.pp_typ mi.mi_base_type; with Not_found -> check_abort "field %s of type %a is not present in environment" mi.mi_name Printer.pp_typ mi.mi_base_type); DoChildren | _ -> DoChildren method vpredicate = function Pat(_,StmtLabel l) -> check_label !l; labelled_stmt <- !l::labelled_stmt; DoChildren | Plet(li,_) -> if li.l_var_info.lv_kind <> LVLocal then check_abort "Local logic variable %a is flagged with wrong origin" Printer.pp_logic_var li.l_var_info; DoChildren | _ -> DoChildren method vlogic_info_decl li = Logic_var.Hashtbl.add known_logic_info li.l_var_info li; DoChildren method vlogic_info_use li = let unknown () = check_abort "logic function %s has no information" li.l_var_info.lv_name in let not_shared () = check_abort "logic function %s information is not shared between declaration and \ use" li.l_var_info.lv_name in if Logic_env.is_builtin_logic_function li.l_var_info.lv_name then begin if not (List.memq li (Logic_env.find_all_logic_functions li.l_var_info.lv_name)) then check_abort "Built-in logic function %s information is not shared \ between environment and use" li.l_var_info.lv_name end else begin try if not (li == Logic_var.Hashtbl.find known_logic_info li.l_var_info) then not_shared () with Not_found -> unknown () end; DoChildren val accept_array = Stack.create () method private accept_array = function | SizeOfE _ | AlignOfE _ | CastE _ -> true | _ -> false method vexpr e = match e.enode with | Const (CEnum ei) -> self#check_ei ei | Lval lv when Cil.isArrayType (Cil.typeOfLval lv) && not (Stack.top accept_array) -> check_abort "%a is an array, but used as an lval" Printer.pp_lval lv | StartOf lv when not (Cil.isArrayType (Cil.typeOfLval lv)) -> check_abort "%a is supposed to be an array, but has type %a" Printer.pp_lval lv Printer.pp_typ (Cil.typeOfLval lv) | _ -> Stack.push (self#accept_array e.enode) accept_array; ChangeDoChildrenPost (e,fun e -> ignore (Stack.pop accept_array); e) method vinst i = match i with | Call(lvopt,{ enode = Lval(Var f, NoOffset)},args,_) -> let (treturn,targs,is_variadic,_) = Cil.splitFunctionTypeVI f in if Cil.isVoidType treturn && lvopt != None then check_abort "in call %a, assigning result of a function returning void" Printer.pp_instr i; (match lvopt with | None -> () | Some lv -> let tlv = Cil.typeOfLval lv in if not (Cabs2cil.allow_return_collapse ~tlv ~tf:treturn) then check_abort "in call %a, cannot implicitly cast from \ function return type %a to type of %a (%a)" Printer.pp_instr i Printer.pp_typ treturn Printer.pp_lval lv Printer.pp_typ tlv); let rec aux l1 l2 = match l1,l2 with [],[] -> DoChildren | _::_, [] -> check_abort "call %a has too few arguments" Printer.pp_instr i | [],e::_ -> if is_variadic then DoChildren else check_abort "call %a has too many arguments, starting from %a" Printer.pp_instr i Printer.pp_exp e | (_,ty1,_)::l1,arg::l2 -> let ty2 = Cil.typeOf arg in if not (is_admissible_conversion arg ty2 ty1) then check_abort "in call %a, arg %a has type %a instead of %a" Printer.pp_instr i Printer.pp_exp arg Printer.pp_typ ty2 Printer.pp_typ ty1; aux l1 l2 in (match targs with None -> DoChildren | Some targs -> aux targs args) | _ -> DoChildren method vtype ty = (match ty with | TArray (_, _, _, la) -> let elt, _ = Cil.splitArrayAttributes la in if elt != [] then Kernel.fatal "Element attribute on array type itself: %a" Printer.pp_attributes elt | _ -> () ); DoChildren initializer let add_func kf = let vi = Kernel_function.get_vi kf in if not vi.vlogic then globals_functions <- Cil_datatype.Varinfo.Set.add vi globals_functions in let add_var vi _ = if not vi.vlogic then globals_vars <- Cil_datatype.Varinfo.Set.add vi globals_vars in Globals.Functions.iter add_func; Globals.Vars.iter add_var end class check_file what = object inherit check_file_aux true what end (* ************************************************************************* *) (** {2 Initialisations} *) (* ************************************************************************* *) let safe_remove_file f = if Kernel.debug_atleast 3 then Kernel.debug ~level:3 "File %s generated" f else try Extlib.safe_remove f with Sys_error _ -> Kernel.warning "cannot remove temporary file %s" f let parse = function | NoCPP f -> if not (Sys.file_exists f) then Kernel.abort "preprocessed file %S does not exist" f; Frontc.parse f () | NeedCPP (f, cmdl) -> if not (Sys.file_exists f) then Kernel.abort "source file %S does not exist" f; let debug = Kernel.Debug_category.exists (fun x -> x = "parser") in let ppf = try Extlib.temp_file_cleanup_at_exit ~debug (Filename.basename f) ".i" with Extlib.Temp_file_error s -> Kernel.abort "cannot create temporary file: %s" s in let cmd supp_args in_file out_file = try (* Format.eprintf "-cpp-command=|%s|@\n" cmdl; *) (* look at the command line to find two "%s" or one "%1" and a "%2" *) let percent1 = String.index cmdl '%' in (* Format.eprintf "-cpp-command percent1=%d@\n" percent1; Format.eprintf "-cpp-command %%%c@\n" (String.get cmdl (percent1+1)); *) let percent2 = String.index_from cmdl (percent1+1) '%' in (* Format.eprintf "-cpp-command percent2=%d@\n" percent2; Format.eprintf "-cpp-command %%%c@\n" (String.get cmdl (percent2+1)); *) let file1, file2 = match String.get cmdl (percent1+1), String.get cmdl (percent2+1) with | '1', '2' -> in_file, out_file (* "%1" followed by "%2" is used to printf 'ppf' after 'f' *) | '2', '1' -> out_file, in_file | _, _ -> raise (Invalid_argument "maybe a bad cpp command") in let cmd1 = String.sub cmdl 0 percent1 in (* Format.eprintf "-cpp-command cmd1=|%s|@\n" cmd1; *) let cmd2 = String.sub cmdl (percent1 + 2) (percent2 - (percent1 + 2)) in (* Format.eprintf "-cpp-command cmd2=|%s|@\n" cmd2; *) let cmd3 = String.sub cmdl (percent2 + 2) (String.length cmdl - (percent2 + 2)) in (* Format.eprintf "-cpp-command cmd3=|%s|@\n" cmd3; *) Format.sprintf "%s%s %s %s%s%s" cmd1 (* using Filename.quote for filenames which contain space or shell metacharacters *) (Filename.quote file1) supp_args cmd2 (Filename.quote file2) cmd3 with | Invalid_argument _ | Not_found -> Format.sprintf "%s %s -o %s %s" cmdl supp_args (* using Filename.quote for filenames which contain space or shell metacharacters *) (Filename.quote out_file) (Filename.quote in_file) in let supp_args = (Kernel.CppExtraArgs.get_set ~sep:" " ()) ^ (if Kernel.ReadAnnot.get() && Kernel.PreprocessAnnot.get() then " -dD" else "") in Kernel.feedback "@{preprocessing@} with \"%s %s %s\"" cmdl supp_args f; if Sys.command (cmd supp_args f ppf) <> 0 then begin Extlib.safe_remove ppf; Kernel.abort "failed to run: %s@\n\ you may set the CPP environment variable to select the proper \ preprocessor command or use the option \"-cpp-command\"." (cmd supp_args f ppf); end; let ppf = if Kernel.ReadAnnot.get() && Kernel.PreprocessAnnot.get() then begin let ppf' = try Logic_preprocess.file ".c" (cmd "") ppf with Sys_error _ as e -> Extlib.safe_remove ppf; Kernel.abort "preprocessing of annotations failed (%s)" (Printexc.to_string e) in safe_remove_file ppf ; ppf' end else ppf in let (cil,(_,defs)) = Frontc.parse ppf () in cil.fileName <- f; safe_remove_file ppf; (cil,(f,defs)) | External (f,suf) -> if not (Sys.file_exists f) then Kernel.abort "file %S does not exist." f; try Hashtbl.find check_suffixes suf f with Not_found -> Kernel.abort "could not find a suitable plugin for parsing %s." f (** Keep defined entry point even if not defined, and possibly the functions with only specifications (according to parameter keep_unused_specified_function). This function is meant to be passed to {!Rmtmps.removeUnusedTemps}. *) let keep_entry_point ?(specs=Kernel.Keep_unused_specified_functions.get ()) g = Rmtmps.isDefaultRoot g || match g with | GVarDecl(spec,v,_) -> Kernel.MainFunction.get () = v.vname || (specs && not (is_empty_funspec spec)) | _ -> false let files_to_cil files = (* BY 2011-05-10 Deactivated this mark_as_computed. Does not seem to do anything useful anymore, and causes problem with the self-recovering gui (commit 13295) (* mark as computed early in case of a typing error occur: do not type check the erroneous program twice. *) Ast.mark_as_computed (); *) let debug_globals files = let level = 6 in if Kernel.debug_atleast level then begin List.iter (fun f -> (* NB: don't use frama-C printer here, as the annotations tables are not filled yet. *) List.iter (fun g -> Kernel.debug ~level "%a" Printer.pp_global g) f.globals) files end in (* Parsing and merging must occur in the very same order. Otherwise the order of files on the command line will not be consistantly handled. *) Kernel.feedback ~level:2 "parsing"; let files,cabs = List.fold_left (fun (acca,accc) f -> try let a,c = parse f in Kernel.debug "result of parsing %s:@\n%a" (get_name f) Printer.pp_file a; if Cilmsg.had_errors () then raise Exit; a::acca, c::accc with exn when Cilmsg.had_errors () -> if Kernel.Debug.get () >= 1 then raise exn else Kernel.abort "skipping file %S that has errors." (get_name f)) ([],[]) files in (* fold_left reverses the list order. This is an issue with pre-registered files. *) let files = List.rev files in let cabs = List.rev cabs in Ast.UntypedFiles.set cabs; debug_globals files; (* Clean up useless parts *) Kernel.feedback ~level:2 "cleaning unused parts"; Rmtmps.rmUnusedStatic := false; (* a command line option will be available*) (* remove unused functions. However, we keep declarations that have a spec, since they might be merged with another one which is used. If this is not the case, these declarations will be removed after Mergecil.merge. *) List.iter (Rmtmps.removeUnusedTemps ~isRoot:(keep_entry_point ~specs:true)) files; debug_globals files; Kernel.feedback ~level:2 "symbolic link"; let merged_file = Mergecil.merge files "whole_program" in (* dumpFile defaultCilPrinter stdout p; *) if Cilmsg.had_errors () then Kernel.abort "Target code cannot be parsed; aborting analysis."; debug_globals [merged_file]; Rmtmps.removeUnusedTemps ~isRoot:keep_entry_point merged_file; if Kernel.UnspecifiedAccess.get() then begin let rec not_separated_offset offs1 offs2 = match offs1, offs2 with NoOffset,_ | _, NoOffset -> true | Field (f1,offs1), Field(f2,offs2) -> f1.fname = f2.fname && f1.fcomp.ckey = f2.fcomp.ckey && not_separated_offset offs1 offs2 | Index(i1,offs1), Index(i2,offs2) -> (match Cil.isInteger (Cil.constFold true i1), Cil.isInteger (Cil.constFold true i2) with Some c1, Some c2 -> Integer.equal c1 c2 && not_separated_offset offs1 offs2 | None, _ | _, None -> true) | (Index _|Field _), (Index _|Field _) -> (* A bit strange, but we're not immune against some ugly cast. Let's play safe here. *) true in let not_separated (base1,offs1)(base2,offs2) = match (base1,offs1), (base2,offs2) with (Mem _,_),(Mem _,_) -> true | (Var v,_),(Mem _,_) | (Mem _,_), (Var v,_)-> v.vaddrof (* if the address of v is not taken, it cannot be aliased*) | (Var v1,offs1),(Var v2,offs2) -> v1.vid = v2.vid && not_separated_offset offs1 offs2 in let not_separated l1 l2 = Extlib.product_fold (fun f e1 e2 -> f || not_separated e1 e2) false l1 l2 in let check_unspec = object inherit Cil.nopCilVisitor method vstmt s = (match s.skind with UnspecifiedSequence [] | UnspecifiedSequence [ _ ] -> () | UnspecifiedSequence seq -> let my_stmt_print = object(self) inherit Cil_printer.extensible_printer () as super method stmt fmt = function | {skind = UnspecifiedSequence seq } -> Pretty_utils.pp_list ~sep:"@\n" (fun fmt (s,m,w,r,_) -> Format.fprintf fmt "/*@ %t%a@ <-@ %a@ */@\n%a" (fun fmt -> if (Kernel.debug_atleast 2) then Pretty_utils.pp_list ~pre:"@[(" ~suf:")@]" ~sep:"@ " self#lval fmt m) (Pretty_utils.pp_list ~sep:"@ " self#lval) w (Pretty_utils.pp_list ~sep:"@ " self#lval) r self#stmt s) fmt seq | s -> super#stmt fmt s end in let remove_mod m l = List.filter (fun x -> not (List.exists (Lval.equal x) m)) l in let not_separated_modified l1 l2 = List.fold_left (fun flag (m,r) -> flag || not_separated (remove_mod m l2) r) false l1 in let warn,_,_ = List.fold_left (fun ((warn,writes,reads) as res) (_,m,w,r,_) -> if warn then res else begin let new_writes = w @ writes in let new_reads = (m,r)::reads in let new_warn = warn || not_separated writes w || not_separated (remove_mod m writes) r || not_separated_modified reads w in new_warn,new_writes,new_reads end) (false, [], []) seq in if warn then Kernel.warning ~current:true ~once:true "Unspecified sequence with side effect:@\n%a@\n" (my_stmt_print#without_annot my_stmt_print#stmt) s | _ -> ()); DoChildren end in Cil.visitCilFileSameGlobals check_unspec merged_file end; merged_file let add_annotation kf st a = Annotations.add_code_annot Emitter.end_user ~kf st a; (* Now check if the annotation is valid by construction (provided normalization is correct). *) match a.annot_content with | AStmtSpec ([], ({ spec_behavior = [ { b_name = "Frama_C_implicit_init" } as bhv]})) -> let props = Property.ip_post_cond_of_behavior kf (Kstmt st) bhv in List.iter (fun p -> Property_status.emit Emitter.kernel ~hyps:[] p Property_status.True) props | _ -> () let synchronize_source_annot has_new_stmt kf = match kf.fundec with | Definition (fd,_) -> let (visitor:cilVisitor) = object inherit nopCilVisitor as super val block_with_user_annots = ref None val user_annots_for_next_stmt = ref [] method vstmt st = let stmt, father = match super#current_kinstr with | Kstmt stmt -> super#pop_stmt stmt; let father = super#current_stmt in super#push_stmt stmt; stmt, father | Kglobal -> assert false in let is_in_same_block () = match !block_with_user_annots,father with | None, None -> true | Some block, Some stmt_father when block == stmt_father -> true | _, _ -> false in let synchronize_user_annot a = add_annotation kf stmt a in let synchronize_previous_user_annots () = if !user_annots_for_next_stmt <> [] then begin if is_in_same_block () then begin let my_annots = !user_annots_for_next_stmt in let post_action st = let treat_annot (has_contract,st as acc) annot = if Logic_utils.is_contract annot then begin if has_contract then begin let new_stmt = Cil.mkStmt ~valid_sid:true (Block (Cil.mkBlock [st])) in has_new_stmt := true; Annotations.add_code_annot Emitter.end_user ~kf new_stmt annot; (true, new_stmt) end else begin add_annotation kf st annot; (true,st) end end else begin add_annotation kf st annot; acc end in let (_,st) = List.fold_left treat_annot (false,st) my_annots in st in block_with_user_annots:=None; user_annots_for_next_stmt:=[]; ChangeDoChildrenPost(st,post_action) end else begin Kernel.warning ~current:true ~once:true "Ignoring previous annotation relative \ to next statement effects" ; block_with_user_annots := None ; user_annots_for_next_stmt := []; DoChildren end end else begin block_with_user_annots := None ; user_annots_for_next_stmt := []; DoChildren; end in let add_user_annot_for_next_stmt annot = if !user_annots_for_next_stmt = [] then begin block_with_user_annots := father; user_annots_for_next_stmt := [annot] end else if is_in_same_block () then user_annots_for_next_stmt := annot::!user_annots_for_next_stmt else begin Kernel.warning ~current:true ~once:true "Ignoring previous annotation relative to next statement \ effects"; block_with_user_annots := father; user_annots_for_next_stmt := [annot] ; end in assert (stmt == st) ; assert (!block_with_user_annots = None || !user_annots_for_next_stmt <> []); match st.skind with | Instr (Code_annot (annot,_)) -> (* Code annotation isn't considered as a real stmt. So, previous annotations should be relative to the next stmt. Only this [annot] may be synchronised to that stmt *) (if match annot.annot_content with | AStmtSpec _ | APragma (Slice_pragma SPstmt | Impact_pragma IPstmt) -> (* Annotation relative to the effect of next statement *) true | APragma _ | AAssert _ | AAssigns _ | AAllocation _ | AInvariant _ | AVariant _ (* | ALoopBehavior _ *) -> (* Annotation relative to the current control point *) false then (* To synchronize on the next statement *) add_user_annot_for_next_stmt annot else (* Synchronize this annotation on that statement *) synchronize_user_annot annot); super#vstmt st | Loop (annot, _, _, _, _) -> (* Synchronize previous annotations on that statement *) let res = synchronize_previous_user_annots () in (* Synchronize loop annotations on that statement *) List.iter synchronize_user_annot (List.sort (fun x y -> x.annot_id - y.annot_id) annot); res | _ -> (* Synchronize previous annotations on that statement *) synchronize_previous_user_annots () ; end in ignore (visitCilFunction visitor fd) | Declaration _ -> () let register_global = function | GFun (fundec, loc) -> (* ensure there is only one return *) Oneret.oneret fundec; (* Build the Control Flow Graph for all functions *) if Kernel.SimplifyCfg.get () then begin Cfg.prepareCFG ~keepSwitch:(Kernel.KeepSwitch.get ()) fundec; Cfg.clearCFGinfo fundec; Cfg.cfgFun fundec; end; Globals.Functions.add (Definition(fundec,loc)); | GVarDecl (spec, ({vtype=typ } as f),loc) when isFunctionType typ -> (* global prototypes *) let args = try Some (Cil.getFormalsDecl f) with Not_found -> None in (* Use a copy of the spec, as the original one will be erased by AST cleanup. *) let spec = { spec with spec_variant = spec.spec_variant } in Globals.Functions.add (Declaration(spec,f,args,loc)) | GVarDecl (_spec(*TODO*), ({vstorage=Extern} as vi),_) -> (* global variables declaration with no definitions *) Globals.Vars.add_decl vi | GVar (varinfo,initinfo,_) -> (* global variables definitions *) Globals.Vars.add varinfo initinfo; | GAnnot (annot, _loc) -> Annotations.add_global Emitter.end_user annot | _ -> () let computeCFG ~clear_id file = Cfg.clearFileCFG ~clear_id file; Cfg.computeFileCFG file let cleanup file = let visitor = object(self) inherit Visitor.frama_c_inplace val mutable keep_stmt = Stmt.Set.empty val mutable changed = false method private remove_lexical_annotations stmt = match stmt.skind with | Instr(Code_annot(_,loc)) -> stmt.skind <- Instr(Skip(loc)) | Loop (_::_, b1,l1,s1,s2) -> stmt.skind <- Loop ([], b1, l1, s1, s2) | _ -> () method vstmt_aux st = self#remove_lexical_annotations st; let loc = Stmt.loc st in if Annotations.has_code_annot st || st.labels <> [] then keep_stmt <- Stmt.Set.add st keep_stmt; match st.skind with Block b -> (* queue is flushed afterwards*) let b' = Cil.visitCilBlock (self:>cilVisitor) b in (match b'.bstmts with [] -> changed <- true; st.skind <- (Instr (Skip loc)); SkipChildren | _ -> if b != b' then st.skind <- Block b'; SkipChildren) | Instr _ -> SkipChildren (* No annotation below that level *) | _ -> DoChildren method vblock b = let optim b = b.bstmts <- List.filter (fun x -> not (Cil.is_skip x.skind) || Stmt.Set.mem x keep_stmt || ( changed <- true; false) (* don't try this at home, kids...*) ) b.bstmts; (* Now that annotations are in the table, we do not need to retain the block anymore. *) b.battrs <- List.filter (function (Attr(l,[])) when l = Cabs2cil.frama_c_keep_block -> false | _ -> true) b.battrs; b in (* uncomment if you don't want to consider scope of locals (see below) *) (* b.blocals <- [];*) ChangeDoChildrenPost(b,optim) method vglob_aux = function | GFun (f,_) -> f.sspec <- Cil.empty_funspec (); (* uncomment if you dont want to treat scope of locals (see above)*) (* f.sbody.blocals <- f.slocals; *) DoChildren | GVarDecl(s,_,_) -> Logic_utils.clear_funspec s; DoChildren | GType _ | GCompTag _ | GCompTagDecl _ | GEnumTag _ | GEnumTagDecl _ | GVar _ | GAsm _ | GPragma _ | GText _ | GAnnot _ -> SkipChildren method vfile f = ChangeDoChildrenPost (f,fun f -> if changed then begin Cfg.clearFileCFG ~clear_id:false f; Cfg.computeFileCFG f; f end else f) end in visitFramacFileSameGlobals visitor file let print_renaming: Cil.cilVisitor = object inherit Cil.nopCilVisitor method vvdec v = if v.vname <> v.vorig_name then begin Kernel.result ~current:true "Variable %s has been renamed to %s" v.vorig_name v.vname end; DoChildren end let prepare_cil_file file = Kernel.feedback ~level:2 "preparing the AST"; computeCFG ~clear_id:true file; if Kernel.Files.Check.get () then begin Cil.visitCilFileSameGlobals (new check_file_aux false "initial AST" :> Cil.cilVisitor) file end; Kernel.feedback ~level:2 "First check done"; if Kernel.Files.Orig_name.get () then begin Cil.visitCilFileSameGlobals print_renaming file end; (* Compute the list of functions and their CFG *) (try List.iter register_global file.globals with Globals.Vars.AlreadyExists(vi,_) -> Kernel.fatal "Trying to add the same varinfo twice: %a (vid:%d)" Printer.pp_varinfo vi vi.vid); Kernel.feedback ~level:2 "register globals done"; Rmtmps.removeUnusedTemps ~isRoot:keep_entry_point file; (* NB: register_global also calls oneret, which might introduce new statements and new annotations tied to them. Since sid are set by cfg, we must compute it again before annotation synchronisation *) Cfg.clearFileCFG ~clear_id:false file; Cfg.computeFileCFG file; let recompute = ref false in Globals.Functions.iter (synchronize_source_annot recompute); (* We might also introduce new blocks for synchronization. *) if !recompute then begin Cfg.clearFileCFG ~clear_id:false file; Cfg.computeFileCFG file; end; cleanup file; (* Check that normalization is correct. *) if Kernel.Files.Check.get() then begin Cil.visitCilFileSameGlobals (new check_file "AST after normalization" :> Cil.cilVisitor) file; end; (* Unroll loops in file *) Unroll_loops.compute file; (* Annotate functions from declspec. *) Translate_lightweight.interprate file; Globals.Functions.iter Annotations.register_funspec; (* Check that we start with a correct file. *) if Kernel.Files.Check.get() then begin Cil.visitCilFileSameGlobals (new check_file "Ast as set in Frama-C's original state" :> Cil.cilVisitor) file; end; Ast.set_file file let default_machdeps = [ "x86_16", (module Machdep_x86_16: Cil.Machdeps); "x86_32", (module Machdep_x86_32: Cil.Machdeps); "x86_64", (module Machdep_x86_64: Cil.Machdeps); "ppc_32", (module Machdep_ppc_32: Cil.Machdeps); ] let machdeps = Datatype.String.Hashtbl.create 7 let () = List.iter (fun (s, c) -> Datatype.String.Hashtbl.add machdeps s c) default_machdeps let new_machdep s f = if Datatype.String.Hashtbl.mem machdeps s then invalid_arg (Format.sprintf "machdep `%s' already exists" s); Datatype.String.Hashtbl.add machdeps s f let pretty_machdeps fmt = Datatype.String.Hashtbl.iter (fun x _ -> Format.fprintf fmt "@ %s" x) machdeps let set_machdep () = let m = Kernel.Machdep.get () in if not (Datatype.String.Hashtbl.mem machdeps m) then if m = "help" then Kernel.feedback "supported machines are%t." pretty_machdeps else Kernel.abort "unsupported machine %s. Try one of%t." m pretty_machdeps (* Local to this module. Use Cil.theMachine.theMachine outside *) let get_machdep () = let m = Kernel.Machdep.get () in try Datatype.String.Hashtbl.find machdeps m with Not_found -> (* Should not happen given the checks above *) Kernel.fatal "Machdep %s not registered" m let () = Cmdline.run_after_configuring_stage set_machdep let fill_built_ins () = if Cil.selfMachine_is_computed () then begin Kernel.debug "Machine is computed, just fill the built-ins"; Cil.init_builtins (); end else begin Kernel.debug "Machine is not computed, initialize everything"; Cil.initCIL (Logic_builtin.init()) (get_machdep ()); end; (* Fill logic tables with builtins *) Logic_env.Builtins.apply (); Logic_env.prepare_tables () let init_project_from_cil_file prj file = let selection = State_selection.diff State_selection.full (State_selection.list_state_union ~deps:State_selection.with_dependencies [Cil.Builtin_functions.self; Ast.self; Files.pre_register_state]) in Project.copy ~selection prj; Project.on prj (fun file -> fill_built_ins (); prepare_cil_file file) file module Global_annotation_graph = struct module Base = Graph.Imperative.Digraph.Concrete(Cil_datatype.Global_annotation) include Base include Graph.Traverse.Dfs(Base) include Graph.Topological.Make(Base) end let find_typeinfo ty = let module F = struct exception Found of global end in let globs = (Ast.get()).globals in try List.iter (fun g -> match g with | GType (ty',_) when ty == ty' -> raise (F.Found g) | GType (ty',_) when ty.tname = ty'.tname -> Kernel.fatal "Lost sharing between definition and declaration of type %s" ty.tname | _ -> ()) globs; Kernel.fatal "Reordering AST: unknown typedef for %s" ty.tname with F.Found g -> g let extract_logic_infos g = let rec aux acc = function | Dfun_or_pred (li,_) | Dinvariant (li,_) | Dtype_annot (li,_) -> li :: acc | Dvolatile _ | Dtype _ | Dlemma _ | Dmodel_annot _ | Dcustom_annot _ -> acc | Daxiomatic(_,l,_) -> List.fold_left aux acc l in aux [] g let find_logic_info_decl li = let module F = struct exception Found of global_annotation end in let globs = (Ast.get()).globals in try List.iter (fun g -> match g with | GAnnot (g,_) -> if List.exists (fun li' -> Logic_info.equal li li') (extract_logic_infos g) then raise (F.Found g) | _ -> ()) globs; Kernel.fatal "Reordering AST: unknown declaration \ for logic function or predicate %s" li.l_var_info.lv_name with F.Found g -> g class reorder_ast: Visitor.frama_c_visitor = let unique_name_recursive_axiomatic = let i = ref 0 in fun () -> if !i = 0 then begin incr i; "__FC_recursive_axiomatic" end else begin let res = "__FC_recursive_axiomatic_" ^ (string_of_int !i) in incr i; res end in object(self) inherit Visitor.frama_c_inplace val mutable known_enuminfo = Enuminfo.Set.empty val mutable known_compinfo = Compinfo.Set.empty val mutable known_typeinfo = Typeinfo.Set.empty val mutable known_var = Varinfo.Set.empty val mutable known_logic_info = Logic_info.Set.empty val mutable local_logic_info = Logic_info.Set.empty (* globals that have to be declared before current declaration. *) val mutable needed_decls = [] (* global annotations are treated separately, as they need special care when revisiting their content *) val mutable needed_annots = [] val current_annot = Stack.create () val subvisit = Stack.create () val typedefs = Stack.create () val logic_info_deps = Global_annotation_graph.create () method private add_known_enuminfo ei = known_enuminfo <- Enuminfo.Set.add ei known_enuminfo method private add_known_compinfo ci = known_compinfo <- Compinfo.Set.add ci known_compinfo method private add_known_type ty = known_typeinfo <- Typeinfo.Set.add ty known_typeinfo method private add_known_var vi = known_var <- Varinfo.Set.add vi known_var method private add_known_logic_info li = known_logic_info <- Logic_info.Set.add li known_logic_info method private add_needed_decl g = needed_decls <- g :: needed_decls method private add_needed_annot g = needed_annots <- g :: needed_annots method private add_annot_depend g = try let g' = Stack.top current_annot in if g == g' then () else Global_annotation_graph.add_edge logic_info_deps g g' (* g' depends upon g *) with Stack.Empty -> Global_annotation_graph.add_vertex logic_info_deps g (* Otherwise, if we only have one annotation to take care of, the graph will be empty... *) method private add_known_annots g = let lis = extract_logic_infos g in List.iter self#add_known_logic_info lis method private clear_deps () = needed_decls <- []; needed_annots <- []; Stack.clear current_annot; Stack.clear typedefs; Global_annotation_graph.clear logic_info_deps method private make_annots g = let g = match g with | [ g ] -> g | _ -> (* We'll eventually add some globals, but the value returned by visitor itself is supposed to be a singleton. Everything is done in post-action. *) Kernel.fatal "unexpected result of visiting global when reordering" in let deps = if Global_annotation_graph.has_cycle logic_info_deps then begin let entries = Global_annotation_graph.fold (fun ga acc -> ga :: acc) logic_info_deps [] in [GAnnot (Daxiomatic (unique_name_recursive_axiomatic (), entries, Location.unknown), Location.unknown)] end else begin Global_annotation_graph.fold (fun ga acc -> GAnnot (ga, Global_annotation.loc ga) :: acc) logic_info_deps [] end in assert (List.length deps = List.length needed_annots); match g with | GAnnot _ -> List.rev deps (** g is already in the dependencies graph. *) | _ -> List.rev (g::deps) (* TODO: add methods for uses of undeclared identifiers. Use functions that maps an identifier to its decl. Don't forget to check for cycles for TNamed and logic_info. *) method vtype ty = (match ty with | TVoid _ | TInt _ | TFloat _ | TPtr _ | TFun _ | TBuiltin_va_list _ | TArray _ -> () | TNamed (ty,_) -> let g = find_typeinfo ty in if not (Typeinfo.Set.mem ty known_typeinfo) then begin self#add_needed_decl g; Stack.push g typedefs; Stack.push true subvisit; ignore (Visitor.visitFramacGlobal (self:>Visitor.frama_c_visitor) g); ignore (Stack.pop typedefs); ignore (Stack.pop subvisit); end else Stack.iter (fun g' -> if g == g' then Kernel.fatal "Globals' reordering failed: \ recursive definition of type %s" ty.tname) typedefs | TComp(ci,_,_) -> if not (Compinfo.Set.mem ci known_compinfo) then begin self#add_needed_decl (GCompTagDecl (ci,Location.unknown)); self#add_known_compinfo ci end | TEnum(ei,_) -> if not (Enuminfo.Set.mem ei known_enuminfo) then begin self#add_needed_decl (GEnumTagDecl (ei, Location.unknown)); self#add_known_enuminfo ei end); DoChildren method vvrbl vi = if vi.vglob && not (Varinfo.Set.mem vi known_var) then begin self#add_needed_decl (GVarDecl (Cil.empty_funspec(),vi,vi.vdecl)); self#add_known_var vi; end; DoChildren method private logic_info_occurrence lv = if not (Logic_env.is_builtin_logic_function lv.l_var_info.lv_name) then begin let g = find_logic_info_decl lv in if not (Logic_info.Set.mem lv known_logic_info) then begin self#add_annot_depend g; Stack.push true subvisit; (* visit will also push g in needed_annot. *) ignore (Visitor.visitFramacGlobal (self:>Visitor.frama_c_visitor) (GAnnot (g, Global_annotation.loc g))); ignore (Stack.pop subvisit) end else if List.memq g needed_annots then begin self#add_annot_depend g; end; end method private add_local_logic_info li = local_logic_info <- Logic_info.Set.add li local_logic_info method private remove_local_logic_info li = local_logic_info <- Logic_info.Set.remove li local_logic_info method private is_local_logic_info li = Logic_info.Set.mem li local_logic_info method vlogic_var_use lv = let logic_infos = Annotations.logic_info_of_global lv.lv_name in (try self#logic_info_occurrence (List.find (fun x -> Cil_datatype.Logic_var.equal x.l_var_info lv) logic_infos) with Not_found -> ()); DoChildren method vterm t = match t.term_node with | Tlet(li,_) -> self#add_local_logic_info li; DoChildrenPost (fun t -> self#remove_local_logic_info li; t) | _ -> DoChildren method vpredicate p = match p with | Plet(li,_) -> self#add_local_logic_info li; DoChildrenPost (fun t -> self#remove_local_logic_info li; t) | _ -> DoChildren method vlogic_info_use lv = if not (self#is_local_logic_info lv) then self#logic_info_occurrence lv; DoChildren method vglob_aux g = let is_subvisit = try Stack.top subvisit with Stack.Empty -> false in (match g with | GType (ty,_) -> self#add_known_type ty; self#add_needed_decl g | GCompTagDecl(ci,_) | GCompTag(ci,_) -> self#add_known_compinfo ci | GEnumTagDecl(ei,_) | GEnumTag(ei,_) -> self#add_known_enuminfo ei | GVarDecl(_,vi,_) | GVar (vi,_,_) -> self#add_known_var vi | GFun(f,_) -> self#add_known_var f.svar | GAsm _ | GPragma _ | GText _ -> () | GAnnot (g,_) -> Stack.push g current_annot; self#add_known_annots g; Global_annotation_graph.add_vertex logic_info_deps g; self#add_needed_annot g); let post_action g = (match g with | [GAnnot _] -> ignore (Stack.pop current_annot) | _ -> ()); if is_subvisit then g (* everything will be done at toplevel *) else begin let res = List.rev_append needed_decls (self#make_annots g) in self#clear_deps (); res end in DoChildrenPost post_action end module Remove_spurious = struct type env = { typeinfos: Typeinfo.Set.t; compinfos: Compinfo.Set.t; enuminfos: Enuminfo.Set.t; varinfos: Varinfo.Set.t; logic_infos: Logic_info.Set.t; typs: global list; others: global list } let treat_one_global acc g = match g with | GType (ty,_) when Typeinfo.Set.mem ty acc.typeinfos -> acc | GType (ty,_) -> { acc with typeinfos = Typeinfo.Set.add ty acc.typeinfos; typs = g :: acc.typs } | GCompTag _ -> { acc with typs = g :: acc.typs } | GCompTagDecl(ci,_) when Compinfo.Set.mem ci acc.compinfos -> acc | GCompTagDecl(ci,_) -> { acc with compinfos = Compinfo.Set.add ci acc.compinfos; typs = g :: acc.typs } | GEnumTag _ -> { acc with typs = g :: acc.typs } | GEnumTagDecl(ei,_) when Enuminfo.Set.mem ei acc.enuminfos -> acc | GEnumTagDecl(ei,_) -> { acc with enuminfos = Enuminfo.Set.add ei acc.enuminfos; typs = g :: acc.typs } | GVarDecl(_,vi,_) when Varinfo.Set.mem vi acc.varinfos -> acc | GVarDecl(_,vi,_) when Cil.isFunctionType vi.vtype -> { acc with others = g :: acc.others } | GVarDecl(_,vi,_) -> { acc with varinfos = Varinfo.Set.add vi acc.varinfos; others = g :: acc.others } | GVar _ | GFun _ -> { acc with others = g :: acc.others } | GAsm _ | GPragma _ | GText _ -> { acc with others = g :: acc.others } | GAnnot (a,_) -> let lis = extract_logic_infos a in if List.exists (fun x -> Logic_info.Set.mem x acc.logic_infos) lis then acc else begin let known_li = List.fold_left (Extlib.swap Logic_info.Set.add) acc.logic_infos lis in { acc with others = g::acc.others; logic_infos = known_li; } end let empty = { typeinfos = Typeinfo.Set.empty; compinfos = Compinfo.Set.empty; enuminfos = Enuminfo.Set.empty; varinfos = Varinfo.Set.empty; logic_infos = Logic_info.Set.empty; typs = []; others = []; } let process file = let env = List.fold_left treat_one_global empty file.globals in file.globals <- List.rev_append env.typs (List.rev env.others) end let reorder_ast () = Visitor.visitFramacFile (new reorder_ast) (Ast.get ()); Remove_spurious.process (Ast.get ()) let init_cil () = Cil.initCIL (Logic_builtin.init()) (get_machdep ()); Logic_env.Builtins.apply (); Logic_env.prepare_tables () (* Fill logic tables with builtins *) let prepare_from_c_files () = init_cil (); let files = Files.get () in (* Allow pre-registration of prolog files *) let cil = files_to_cil files in prepare_cil_file cil let init_project_from_visitor ?(reorder=false) prj (vis:Visitor.frama_c_visitor) = if not (Cil.is_copy_behavior vis#behavior) || not (Project.equal prj (Extlib.the vis#project)) then Kernel.fatal "Visitor does not copy or does not operate on correct project."; Project.on prj (fun () -> Cil.initCIL (fun () -> ()) (get_machdep ())) (); let file = Ast.get () in let file' = visitFramacFileCopy vis file in let finalize file' = computeCFG ~clear_id:false file'; Ast.set_file file' in let selection = State_selection.with_dependencies Ast.self in Project.on ~selection prj finalize file'; (* reorder _before_ check. *) if reorder then Project.on prj reorder_ast (); if Kernel.Files.Check.get() then begin Project.on prj (* eta-expansion required because of operations on the current project in the class construtor *) (fun f -> Cil.visitCilFile (new check_file ("AST of " ^ prj.Project.name) :> Cil.cilVisitor) f) file'; assert (Kernel.verify (file == Ast.get()) "Creation of project %s modifies original project" prj.Project.name); Cil.visitCilFile (new check_file ("Original AST after creation of " ^ prj.Project.name) :> Cil.cilVisitor) file end let prepare_from_visitor ?reorder prj visitor = let visitor = visitor prj in init_project_from_visitor ?reorder prj visitor let create_project_from_visitor ?reorder prj_name visitor = let selection = State_selection.list_state_union ~deps:State_selection.with_dependencies [ Kernel.Files.self; Files.pre_register_state ] in let selection = State_selection.diff State_selection.full selection in let prj = Project.create_by_copy ~selection prj_name in (* reset projectified parameters to their default values *) let temp = Project.create "File.temp" in Project.copy ~selection:(Plugin.get_selection ()) ~src:temp prj; Project.remove ~project:temp (); Project.on prj init_cil (); prepare_from_visitor ?reorder prj visitor; prj let init_from_c_files files = (match files with [] -> () | _ :: _ -> Files.register files); prepare_from_c_files () let init_from_cmdline () = let prj1 = Project.current () in if Kernel.Files.Copy.get () then begin let selection = State_selection.diff State_selection.full (State_selection.list_state_union ~deps:State_selection.with_dependencies [ Cil.Builtin_functions.self; Logic_env.Logic_info.self; Logic_env.Logic_type_info.self; Logic_env.Logic_ctor_info.self; Ast.self ]) in let prj2 = Project.create_by_copy ~selection "debug_copy_prj" in Project.set_current prj2; end; let files = Kernel.Files.get () in if files = [] && not !Config.is_gui then Kernel.warning "no input file."; let files = List.map (fun s -> from_filename s) files in try init_from_c_files files; if Kernel.Files.Check.get () then begin Cil.visitCilFile (new check_file "Copy of original AST" :> Cil.cilVisitor) (Ast.get()) end; if Kernel.Files.Copy.get () then begin Project.on prj1 fill_built_ins (); prepare_from_visitor prj1 (fun prj -> new Visitor.frama_c_copy prj); Project.set_current prj1; end; with Ast.Bad_Initialization s -> Kernel.fatal "@[Cannot initialize from C files@ \ Kernel raised Bad_Initialization %s@]" s let init_from_cmdline = Journal.register "File.init_from_cmdline" (Datatype.func Datatype.unit Datatype.unit) init_from_cmdline let init_from_c_files = Journal.register "File.init_from_c_files" (Datatype.func (Datatype.list ty) Datatype.unit) init_from_c_files let prepare_from_c_files = Journal.register "File.prepare_from_c_files" (Datatype.func Datatype.unit Datatype.unit) prepare_from_c_files let () = Ast.set_default_initialization (fun () -> if Files.is_computed () then prepare_from_c_files () else init_from_cmdline ()) let pp_file_to fmt_opt = let pp_ast = Printer.pp_file in let ast = Ast.get () in (match fmt_opt with | None -> Kernel.CodeOutput.output (fun fmt -> pp_ast fmt ast) | Some fmt -> pp_ast fmt ast) let unjournalized_pretty prj (fmt_opt:Format.formatter option) () = Project.on prj pp_file_to fmt_opt let journalized_pretty_ast = Journal.register "File.pretty_ast" (Datatype.func3 ~label1:("prj",Some Project.current) Project.ty ~label2:("fmt",Some (fun () -> None)) (let module O = Datatype.Option(Datatype.Formatter) in O.ty) Datatype.unit Datatype.unit) unjournalized_pretty let pretty_ast ?(prj=Project.current ()) ?fmt () = journalized_pretty_ast prj fmt () let create_rebuilt_project_from_visitor ?reorder ?(preprocess=false) prj_name visitor = let prj = create_project_from_visitor ?reorder prj_name visitor in try let f = let name = "frama_c_project_" ^ prj_name ^ "_" in let ext = if preprocess then ".c" else ".i" in let debug = Kernel.Debug.get () > 0 in Extlib.temp_file_cleanup_at_exit ~debug name ext in let cout = open_out f in let fmt = Format.formatter_of_out_channel cout in unjournalized_pretty prj (Some fmt) (); let redo () = (* Kernel.feedback "redoing initialization on file %s" f;*) Files.reset (); init_from_c_files [ if preprocess then from_filename f else NoCPP f ] in Project.on prj redo (); prj with Extlib.Temp_file_error s | Sys_error s -> Kernel.abort "cannot create temporary file: %s" s (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/dynamic.ml0000644000175000017500000004716512155630171020040 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ************************************************************************* *) (** {2 Global variables for paths} *) (* ************************************************************************* *) let no_default = ref false let set_default b = no_default := not b let default_path () = match !no_default, !Config.is_gui with | true, _ -> [] | false, true -> (* The order is relevant: plugins are loaded in reverse order of this list. *) [ Config.plugin_dir ; Filename.concat Config.plugin_dir "gui"] | false, false -> [ Config.plugin_dir ] let all_path = ref [] let bad_path : string list ref = ref [] (* ************************************************************************* *) (** {2 Debugging} *) (* ************************************************************************* *) include Log.Register (struct let channel = Log.kernel_channel_name let label = Log.kernel_label_name let verbose_atleast n = !Cmdline.kernel_verbose_atleast_ref n let debug_atleast n = !Cmdline.kernel_debug_atleast_ref n end) (* Try to display an error message from the argument of a [Sys_error] exception raised whenever a path is incorrect. Don't display any error for default path since it occurs whenever Frama-C is not installed. *) let catch_sysreaddir s = (* [Sys_error] messages for path get usually the form "%s: %s" *) let list_arg = Str.split (Str.regexp ": ") s in match list_arg with | [ dir; error ] -> if not (List.mem dir (default_path ())) then begin warning "cannot search dynamic plugins inside directory `%s' (%s)." dir error; bad_path := dir :: !bad_path; end | [] | [ _ ] | _ :: _ :: _ :: _ -> raise (Sys_error s) (* To determine if Dynlink works on this OCaml version *) let too_old_for_dynlink = try ignore (Dynlink_common_interface.init ()); false with Dynlink_common_interface.Unsupported_Feature _ -> true let is_dynlink_available = not (too_old_for_dynlink && Dynlink_common_interface.is_native) (* apply [f] to [x] iff dynlink is available *) let dynlink_available f x = if is_dynlink_available then f x (* ************************************************************************* *) (** {2 Paths} *) (* ************************************************************************* *) (** @return true iff [path] is a readable directory *) let check_path path = try ignore (Sys.readdir path); true with Sys_error s -> catch_sysreaddir s; false let rec init_paths = let todo = ref true in fun () -> if !todo then begin todo := false; List.iter (fun s -> ignore (add_path s)) (default_path ()) end (** Display debug message and add a path to list of search path *) and add_path_list path = feedback ~level:2 "dynamic plug-ins are now also searched inside directory `%s'" path; init_paths (); all_path := path :: !all_path and add_path path = (* the lazyness of && is used below *) if not (List.mem path !all_path) && not (List.mem path !bad_path) && check_path path then begin add_path_list path; true end else false let remove_last_path () = match !all_path with | [] -> invalid_arg "Dynamic.remove_last_path" | _ :: l -> all_path := l (* read_path is very similar to check_path but to check a path you must use Sys.readdir and use Sys.readdir after. To prevent two use of Sys.readdir, I introduce this function to check path and read path at the same time. *) (** @return read path and check error in the same times *) let read_path path= (* sorting ensures a deterministic results of listing directories *) try List.sort String.compare (Array.to_list (Sys.readdir path)) with Sys_error s -> catch_sysreaddir s; [] (* ************************************************************************* *) (** {2 Loaded files} *) (* ************************************************************************* *) module Loading_error_messages: sig val add: string (* name *) -> string (* message *) -> string (* detail *) -> unit val print: unit -> unit end = struct let tbl = Datatype.String.Hashtbl.create 7 let add name msg details = let t = try Datatype.String.Hashtbl.find tbl msg with Not_found -> let t = Datatype.String.Hashtbl.create 7 in Datatype.String.Hashtbl.add tbl msg t; t in Datatype.String.Hashtbl.replace t name details let print () = let once = true in Datatype.String.Hashtbl.iter (fun msg tbl -> let len = Datatype.String.Hashtbl.length tbl in assert (len > 0); if len = 1 then Datatype.String.Hashtbl.iter (fun name details -> let append fmt = if verbose_atleast 2 then Format.fprintf fmt " The exact failure is: %s." details in warning ~once ~append "cannot load plug-in `%s' (%s)." name msg) tbl else let append fmt = let first = ref true in let print (name, details) = if verbose_atleast 2 then Format.fprintf fmt "%s@;(%s)@\n" name details else begin if !first then Format.fprintf fmt "%s" name else Format.fprintf fmt ";@;%s" name; first := false end in let l = Datatype.String.Hashtbl.fold (fun n d acc -> (n, d) :: acc) tbl [] in List.iter print (List.sort Extlib.compare_basic l) in warning ~once ~append "cannot load %d plug-ins (%s).@\n" len msg) tbl; Datatype.String.Hashtbl.clear tbl end module Modules : sig val register_once: string -> bool val unregister: string -> unit val mem: string -> bool end = struct let module_names = ref Datatype.String.Set.empty let forbidden_names = ref Datatype.String.Set.empty let add s = module_names := Datatype.String.Set.add s !module_names let disable s = forbidden_names := Datatype.String.Set.add s !forbidden_names let () = List.iter add Config.static_plugins; List.iter (fun s -> add (s ^ "_gui")) Config.static_gui_plugins; List.iter disable Config.compilation_unit_names let register_once s = if Datatype.String.Set.mem s !module_names then false else begin if Datatype.String.Set.mem s !forbidden_names then begin Loading_error_messages.add (String.capitalize s) "forbidden plug-in name" "name already used by a Frama-C kernel file"; false end else begin add s; true end end let unregister s = module_names := Datatype.String.Set.remove s !module_names let mem s = Datatype.String.Set.mem s !module_names end let is_plugin_present = Modules.mem (* ************************************************************************* *) (** {2 Loading of dynamic modules} *) (* ************************************************************************* *) exception Unloadable of string (* Distinction between native and bytecode versions *) let object_file_extension = if Dynlink_common_interface.is_native then ".cmxs" else ".cm[oa]" let dynlink_file path module_name = let error msg details = Modules.unregister module_name; Loading_error_messages.add (String.capitalize module_name) msg details in let file = if Dynlink_common_interface.is_native then Filename.concat path (module_name ^ object_file_extension) else begin let cmo = Filename.concat path (module_name ^ ".cmo") in let cma = Filename.concat path (module_name ^ ".cma") in if Sys.file_exists cma then cma else cmo end in try feedback ~level:2 "loading plug-in %s" (String.capitalize module_name); Dynlink_common_interface.loadfile file with | Dynlink_common_interface.Error e -> (match e with | Dynlink_common_interface.Not_a_bytecode_file s -> error "not a bytecode file" s | Dynlink_common_interface.File_not_found s -> error "file not found" s | Dynlink_common_interface.Inconsistent_import _ | Dynlink_common_interface.Linking_error _ | Dynlink_common_interface.Corrupted_interface _ | Dynlink_common_interface.Cannot_open_dll _ | Dynlink_common_interface.Inconsistent_implementation _ | Dynlink_common_interface.Unavailable_unit _ -> error (Format.sprintf "incompatible with %s" Config.version) (Dynlink_common_interface.error_message e) | Dynlink_common_interface.Unsafe_file -> assert false) | Sys_error _ as e -> error "system error" (Printexc.to_string e) | Unloadable s -> error "incompatible with current set-up" s | Log.AbortError _ | Log.AbortFatal _ | Log.FeatureRequest _ as e -> raise e | e -> fatal "unexpected exception %S" (Printexc.to_string e) let load_module_from_unknown_path name = if Modules.register_once name then begin Modules.unregister name; let regexp = Str.regexp_case_fold (name ^ "\\" ^ object_file_extension ^ "$") in let check_path path = let files= read_path path in List.exists (fun file -> Str.string_match regexp file 0) files in let paths = !all_path in let tried = ref false in List.iter (fun p -> if check_path p then begin tried := true; if Modules.register_once name then dynlink_file p name end) paths; if not !tried then begin Modules.unregister name; Loading_error_messages.add name "plug-in not found" (match paths with | [] -> "no specified directory" | [ p ] -> Pretty_utils.sfprintf "plug-in not found in directory %s" p | _ :: _ -> Pretty_utils.sfprintf "plug-in not found in directories %a" (Pretty_utils.pp_list Format.pp_print_string) paths); end; Loading_error_messages.print (); end let extract_filename f = try Filename.chop_extension f with Invalid_argument _ -> f let load_module f = init_paths (); let load f = let name = String.capitalize (Filename.basename (extract_filename f)) in let dir = Filename.dirname f in if dir = Filename.current_dir_name && Filename.is_implicit f then load_module_from_unknown_path (String.capitalize f) else if Modules.register_once name then dynlink_file dir name; Loading_error_messages.print () in dynlink_available load f let load_script = let load f = let name = extract_filename f in let dir = Filename.dirname f in let ml_name = name ^ ".ml" in let mk_name ext = dir ^ "/" ^ String.capitalize (Filename.basename name) ^ ext in let gen_name = mk_name (if Dynlink_common_interface.is_native then ".cmxs" else ".cmo") in let cmd = Format.sprintf "%s -w Ly -warn-error A -I %s%s%t -I %s %s" (if Dynlink_common_interface.is_native then Config.ocamlopt ^ " -shared -o " ^ gen_name else Config.ocamlc ^ " -c -o " ^ gen_name) Config.libdir (if !Config.is_gui then " -I +lablgtk2" else "") (fun () -> List.fold_left (fun acc s -> " -I " ^ s ^ acc) "" !all_path) dir ml_name in feedback ~level:2 "executing command `%s'" cmd; let code = Sys.command cmd in if code <> 0 then abort "command `%s' failed" cmd else begin let extended = add_path "." in load_module name; if extended then remove_last_path (); let cleanup () = feedback ~level:2 "Removing files generated when compiling %S" ml_name; Extlib.safe_remove gen_name (* .cmo or .cmxs *); Extlib.safe_remove (mk_name ".cmi"); if Dynlink_common_interface.is_native then begin Extlib.safe_remove (mk_name ".o"); Extlib.safe_remove (mk_name ".cmx") end in at_exit cleanup end in dynlink_available load let load_all_modules = let filter f = Str.string_match (Str.regexp (".+\\" ^ object_file_extension ^ "$")) f 0 in let load_dir d = let files = read_path d in let files = List.filter filter files in let modules = List.map Filename.chop_extension files in let load f = if Modules.register_once f then dynlink_file d f in (* order of loading inside a directory remains system-independent *) List.iter load (List.sort String.compare modules) in let load_all () = init_paths (); (* order of directory matters for the GUI *) List.iter load_dir !all_path; Loading_error_messages.print () in dynlink_available load_all (* ************************************************************************* *) (** {2 Registering and accessing dynamic values} *) (* ************************************************************************* *) module Tbl = Type.String_tbl(struct type 'a t = 'a end) let dynamic_values = Tbl.create 97 let comments_fordoc = Hashtbl.create 97 let register ?(comment="") ~plugin name ty ~journalize f = if Cmdline.use_type then begin debug ~level:5 "registering dynamic function %s" name; let f = if journalize then let comment fmt = Format.fprintf fmt "@[Applying@;dynamic@;functions@;%S@;of@;type@;%s@]" name (Type.name ty) in let jname = Format.fprintf Format.str_formatter "@[Dynamic.get@;~plugin:%S@;%S@;%t@]" plugin name (Type.pp_ml_name ty Type.Call); Format.flush_str_formatter () in Journal.register jname ty ~is_dyn:true ~comment f else f in let key = plugin ^ "." ^ name in Tbl.add dynamic_values key ty f; if comment <> "" then Hashtbl.add comments_fordoc key comment ; f end else f exception Incompatible_type = Tbl.Incompatible_type exception Unbound_value = Tbl.Unbound_value let get ~plugin name ty = if Cmdline.use_type then begin if plugin <> "" then load_module_from_unknown_path plugin; Tbl.find dynamic_values (plugin ^ "." ^ name) ty end else failwith (Pretty_utils.sfprintf "cannot access value %s in the 'no obj' mode" name) let iter f = Tbl.iter f dynamic_values let iter_comment f = Hashtbl.iter f comments_fordoc (* ************************************************************************* *) (** {2 Specialised interface for parameters} *) (* ************************************************************************* *) module Parameter = struct module type Common = sig type t val get: string -> unit -> t val set: string -> t -> unit val clear: string -> unit -> unit val is_set: string -> unit -> bool val is_default: string -> unit -> bool end let get_name functor_name fct_name option_name = Format.sprintf "Dynamic.Parameter.%s.%s %S" functor_name fct_name option_name let get_parameter option_name = get ~plugin:"" option_name Parameter.ty let get_state option_name = let prm = get ~plugin:"" option_name Parameter.ty in State.get prm.Parameter.name let apply modname name s ty1 ty2 = get ~plugin:"" (get_name modname s name) (Datatype.func ty1 ty2) module Common(X: sig type t val modname:string val ty: t Type.t end ) = struct type t = X.t let ty = X.ty let get name = apply X.modname name "get" Datatype.unit ty let set name = apply X.modname name "set" ty Datatype.unit let clear name = apply X.modname name "clear" Datatype.unit Datatype.unit let is_set name = apply X.modname name "is_set" Datatype.unit Datatype.bool let is_default name = apply X.modname name "is_default" Datatype.unit Datatype.bool end module Bool = struct include Common (struct type t = bool let ty = Datatype.bool let modname = "Bool"end ) let on name = apply "Bool" name "on" Datatype.unit Datatype.unit let off name = apply "Bool" name "off" Datatype.unit Datatype.unit end module Int = struct include Common (struct type t = int let ty = Datatype.int let modname = "Int" end ) let incr name = apply "Int" name "incr" Datatype.unit Datatype.unit end module String = Common (struct type t = string let ty = Datatype.string let modname = "String" end) module StringSet = struct include Common (struct include Datatype.String.Set let modname = "StringSet" end) let add name = apply "StringSet" name "add" Datatype.string Datatype.unit let remove name = apply "StringSet" name "remove" Datatype.string Datatype.unit let is_empty name = apply "StringSet" name "is_empty" Datatype.unit Datatype.bool let iter name = apply "StringSet" name "iter" (Datatype.func Datatype.string Datatype.unit) Datatype.unit end module StringList = struct include Common (struct include Datatype.List(Datatype.String) let modname = "StringList" end) let add name = apply "StringList" name "add" Datatype.string Datatype.unit let remove name = apply "StringList" name "remove" Datatype.string Datatype.unit let is_empty name = apply "StringList" name "is_empty" Datatype.unit Datatype.bool let iter name = apply "StringList" name "iter" (Datatype.func Datatype.string Datatype.unit) Datatype.unit end (* module IndexedVal(X: sig val ty_name: string end) = struct include Common(struct type t = string let ty = string end) type value = Type.ty let ty = Type.get_abstract X.ty_name let add_choice name = StringTbl.find tbl (name ^ ".add_choice") (func string (func ty unit)) let get_val name = StringTbl.find tbl (name ^ ".get_val") (func unit ty) () end *) end (* ************************************************************************* *) (** {2 Initialisation} *) (* ************************************************************************* *) let () = if is_dynlink_available then begin Dynlink_common_interface.init (); Dynlink_common_interface.allow_unsafe_modules true; Cmdline.run_during_extending_stage load_all_modules end; module Main = struct module Old = Hook.Make(struct end) let extend = deprecated "Dynamic.Main.extend" ~now:"Db.Main.extend" Old.extend let apply = Old.apply end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/kernel/unicode.ml0000644000175000017500000000324312155630171020027 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let inset_string () = if Kernel.Unicode.get () then Utf8_logic.inset else "IN" frama-c-Fluorine-20130601/src/pdg/0000755000175000017500000000000012155634040015336 5ustar mehdimehdiframa-c-Fluorine-20130601/src/pdg/sets.mli0000644000175000017500000001011112155630237017015 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** PDG (program dependence graph) access functions. *) open PdgTypes open Cil_types type nodes_and_undef = (Node.t * Locations.Zone.t option) list * Locations.Zone.t option (** {2 PDG nodes for some elements} *) val find_stmt_node : Pdg.t -> stmt -> Node.t val find_simple_stmt_nodes : Pdg.t -> stmt -> Node.t list val find_stmt_and_blocks_nodes : Pdg.t -> stmt -> Node.t list val find_location_nodes_at_stmt : Pdg.t -> stmt -> before:bool -> Locations.Zone.t -> nodes_and_undef val find_location_nodes_at_end : Pdg.t -> Locations.Zone.t -> nodes_and_undef val find_location_nodes_at_begin : Pdg.t -> Locations.Zone.t -> nodes_and_undef val find_label_node : Pdg.t -> stmt -> label -> Node.t val find_decl_var_node : Pdg.t -> 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 : Pdg.t -> PdgIndex.Signature.out_key -> nodes_and_undef val find_call_ctrl_node : Pdg.t -> stmt -> Node.t val find_call_num_input_node : Pdg.t -> stmt -> int -> Node.t val find_call_input_nodes : Pdg.t -> stmt -> PdgIndex.Signature.in_key -> nodes_and_undef val find_call_output_node : Pdg.t -> stmt -> Node.t val find_call_stmts: kernel_function -> caller:kernel_function -> stmt list val find_call_out_nodes_to_select : Pdg.t -> NodeSet.t -> Pdg.t -> stmt -> Node.t list val find_in_nodes_to_select_for_this_call : Pdg.t -> NodeSet.t -> stmt -> Pdg.t -> Node.t list (** direct dependencies only : * This means the nodes that have an edge to the given node. *) 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 : 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 : 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 : Pdg.t -> Node.t list -> Node.t list (** others *) val custom_related_nodes : (Node.t -> Node.t list) -> Node.t list -> Node.t list frama-c-Fluorine-20130601/src/pdg/pdg_parameters.ml0000644000175000017500000000507112155630237020674 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.Register (struct let name = "pdg" let shortname = "pdg" let help = "Program Dependence Graph" end) let output = add_group "Output" module BuildAll = WithOutput (struct let option_name = "-pdg" let help = "build the dependence graph of each function" let output_by_default = false end) module BuildFct = StringSet (struct let option_name = "-fct-pdg" let arg_name = "" let help = "build the dependence graph for the specified function" end) let () = Plugin.set_group output module PrintBw = False(struct let option_name = "-codpds" let help = "force option -pdg-print to show the co-dependencies rather than the dependencies" end) let () = Plugin.set_group output module DotBasename = EmptyString (struct let option_name = "-pdg-dot" let arg_name = "basename" let help = "put the PDG of function in basename.f.dot" end) frama-c-Fluorine-20130601/src/pdg/Pdg.mli0000644000175000017500000000704512155630237016565 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Program Dependences Graph. *) (** Functions are registered through the [Db] module, or the dynamic API. *) (* OCaml 3.12: module type of Marks.F_proj *) 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. * [in_marks_to_caller] translate this [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 : PdgTypes.Pdg.t -> Cil_types.stmt -> ('mark PdgMarks.m2m) -> ?rqs:('mark PdgMarks.select) -> 'mark PdgMarks.info_caller_inputs -> 'mark PdgMarks.select (** similar to [in_marks_to_caller] except that it is done * for every callers of the function. *) val translate_in_marks : PdgTypes.Pdg.t -> 'mark PdgMarks.info_caller_inputs -> ?m2m:'mark PdgMarks.call_m2m -> 'mark PdgMarks.pdg_select -> 'mark PdgMarks.pdg_select (** similar to [in_marks_to_caller] except that it is for the outputs * of a function propagated into its calls *) val call_out_marks_to_called : PdgTypes.Pdg.t -> 'mark PdgMarks.m2m -> ?rqs:('mark PdgMarks.select) -> (PdgIndex.Signature.out_key * 'mark) list -> 'mark PdgMarks.select (** translate all the interprocedural information returned by a propagation in * a function the (node, mark) list of both callers and called function. *) val translate_marks_to_prop : Db.Pdg.t -> 'mark PdgMarks.info_inter -> ?in_m2m:'mark PdgMarks.call_m2m -> ?out_m2m:'mark PdgMarks.call_m2m -> 'mark PdgMarks.pdg_select -> 'mark PdgMarks.pdg_select (** Full backward interprocedural propagation. * Can be configured using the funtor parameter. * Used for instance in [Sparecode]. *) module F_Proj (C : PdgMarks.Config) : PdgMarks.Proj with type mark = C.M.t and type call_info = C.M.call_info end frama-c-Fluorine-20130601/src/pdg/annot.mli0000644000175000017500000000545412155630237017174 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** All these functions find the nodes needed for various kind of annotations. * * @raise Kernel_function.No_Definition on annotations for function declarations. * * *) (** [data_info] is composed of [(node,z_part) list, undef_loc)] * and correspond to data dependencies nodes. * Can be None if we don't know how to compute them. *) type data_info = ((PdgTypes.Node.t * Locations.Zone.t option) list * Locations.Zone.t option) option (** [ctrl_info] correspond to control dependancies nodes *) type ctrl_info = PdgTypes.Node.t list (** [decl_info] correspond to the declarations nodes of the variables needed to * parse the annotation *) type decl_info = PdgTypes.Node.t list (** @raise Not_found when the statement is unreachable. *) val find_code_annot_nodes : 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 -> decl_info * data_info val find_fun_postcond_nodes : PdgTypes.Pdg.t -> Cil_types.predicate -> decl_info * data_info val find_fun_variant_nodes : PdgTypes.Pdg.t -> Cil_types.term -> decl_info * data_info (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/pdg/build.ml0000644000175000017500000013573712155630237017013 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Build graphs (PDG) for the function (see module {!module: Build.BuildPdg}) to represente the dependencies between instructions in order to use it for slicing purposes. A function is processed using a forward dataflow analysis (see module {{: ../html/Dataflow.html}Dataflow} which is instanciated with the module {!module: Build.Computer} below). *) let dkey = Pdg_parameters.register_category "build" let debug fmt = Pdg_parameters.debug ~dkey fmt let debug2 fmt = Pdg_parameters.debug ~dkey fmt ~level:2 open Cil_types open Cil_datatype open PdgTypes open PdgIndex (* exception Err_Top of string *) exception Err_Bot of string (** set of nodes of the graph *) module BoolNodeSet = Set.Make(Datatype.Pair(Datatype.Bool)(PdgTypes.Node)) 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 | _ -> 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 *) 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. *) module BuildPdg : sig open PdgTypes (* Export type data_state *) (** type of the whole PDG representation during its building process *) type t (** create an empty pdg for the function*) val create : kernel_function -> t val get_kf : t -> kernel_function type arg_nodes val get_states : t -> data_state Stmt.Hashtbl.t val print_state : Format.formatter -> PdgTypes.data_state -> unit val empty_state : data_state val bottom_state: data_state (** gives the first state of a function with declaration information * and begin to build the pdg. * [process_declarations pdg formals locals] *) val process_declarations : t -> formals:varinfo list -> locals:varinfo list -> data_state (** for assign statement. * @param l_loc assigned location(s) * @param l_dpds dependencies of the left hand side of the statement, * @param r_dpds dependencies of the right hand side of the statement, * @param exact true if the location is surely modified. *) val process_asgn : t -> data_state -> Cil_types.stmt -> l_loc:Locations.Zone.t -> exact:bool -> l_dpds:Locations.Zone.t -> l_decl: Varinfo.Set.t -> r_dpds:Locations.Zone.t -> r_decl: Varinfo.Set.t -> data_state (** 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 -> data_state -> Cil_types.stmt -> data_state option (** similar to [process_skip], except that we emit a warning *) val process_asm : t -> data_state -> Cil_types.stmt -> data_state option (** similar to [process_skip] but returns an empty state (bottom)*) val process_unreachable : t -> data_state -> Cil_types.stmt -> data_state option (** similar to [process_unreachable] but for call stmt *) val process_unreachable_call : t -> data_state -> Cil_types.stmt -> data_state option (** Add a node for the stmt which is a jump. Add control dependencies from this node to the nodes which correspond to the stmt list. Also add dependencies for the jump to the label. Don't use for jumps with data dependencies : use [process_jump_with_exp] instead ! *) val process_jump : t -> Cil_types.stmt -> bool * Cil_datatype.Stmt.Hptset.t -> unit val process_stmt_labels : t -> Cil_types.stmt -> unit val process_block : t -> Cil_types.stmt -> Cil_types.block -> unit val process_entry_point : t -> Cil_types.stmt list -> unit (** like [process_jump] but also add data dependencies on the datas and their declarations. For conditional jumps and returns. *) val process_jump_with_exp : t -> Cil_types.stmt -> (bool * Cil_datatype.Stmt.Hptset.t) -> data_state -> Locations.Zone.t -> Varinfo.Set.t -> unit (** 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. *) val test_and_merge_states : old:data_state -> data_state -> bool * data_state (** add a simple node for each call in order to have something in the PDG * for this statement even if there are no input/output *) val process_call_node : t -> Cil_types.stmt -> unit val process_call_args : t -> data_state -> Cil_types.stmt -> (Locations.Zone.t * Varinfo.Set.t) list -> arg_nodes val process_call_params : t -> data_state -> Cil_types.stmt -> kernel_function -> arg_nodes -> data_state val process_call_ouput : t -> data_state -> data_state -> Cil_types.stmt -> int -> Locations.Zone.t -> bool -> Locations.Zone.t -> Locations.Zone.t -> data_state val process_call_return : t -> data_state -> data_state -> Cil_types.stmt -> l_loc:Locations.Zone.t -> exact:bool -> l_dpds:Locations.Zone.t -> l_decl:Varinfo.Set.t -> r_dpds:Locations.Zone.t -> Locations.Zone.t -> data_state (** add a node corresponding to the returned value. *) val add_retres : t -> data_state -> Cil_types.stmt -> Locations.Zone.t -> Varinfo.Set.t -> data_state (** store the state as the final state. Will be used in finalize_pdg to add * the output nodes. *) val store_last_state : t -> data_state -> unit (** to call then the building process is over : add the control dependencies in the graph. @return the real PDG that will be used later on. *) val finalize_pdg : t -> Function_Froms.t option -> PdgTypes.Pdg.t end = struct type arg_nodes = Node.t list (** The PDG used during its computation. *) 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.states; index : PdgTypes.Pdg.fi; 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 : Node.t Varinfo.Hashtbl.t ; (** map between declaration nodes and the variables to build the dependencies. *) } let empty_state = Pdg_state.empty let bottom_state = Pdg_state.bottom let create kf = let nb_stmts = if !Db.Value.use_spec_instead_of_definition kf then 17 else List.length (Kernel_function.get_definition kf).sallstmts in let index = FctIndex.create nb_stmts in let states = Stmt.Hashtbl.create nb_stmts in let graph = G.create () in { fct = kf; graph = graph; states = states; index = index; topinput = None; other_inputs = []; ctrl_dpds = Stmt.Hashtbl.create nb_stmts ; decl_nodes = Varinfo.Hashtbl.create 10 ; } let get_kf pdg = pdg.fct let graph pdg = pdg.graph let nodes_index pdg = pdg.index let get_states pdg = pdg.states let add_to_inputs pdg n dk zone = pdg.other_inputs <- (n, dk, zone) :: pdg.other_inputs let _pretty fmt pdg = PdgTypes.Pdg.pretty_graph fmt pdg.graph (** add a node to the PDG, but if it is associated with a stmt, check before if it doesn't exist already (useful for loops). @return the (new or old) node. *) let add_elem pdg key = let add_new_node key = let new_node = G.add_elem (graph pdg) key in debug "add_new_node %a@." (pretty_node ~key:true) new_node; new_node in let index = nodes_index pdg in try match key with | Key.CallStmt _ -> assert false (*FctIndex.find_info_call index (Key.call_from_id call_id)*) | _ -> FctIndex.find_info index key with Not_found -> let new_node = add_new_node key in let _ = match key with | Key.CallStmt _call_id -> assert false (* FctIndex.add_info_call index (Key.call_from_id call_id) new_node ~replace:false *) | _ -> FctIndex.add index key new_node in new_node let decl_var pdg var = let new_node = add_elem pdg (Key.decl_var_key var) in Varinfo.Hashtbl.add pdg.decl_nodes var new_node; new_node let get_var_base zone = try let base, _ = Locations.Zone.find_lonely_key zone in match base with | Base.Var (var,_) -> Some var | _ -> None with Not_found -> None let add_z_dpd pdg n1 k z_part n2 = add_dpd_in_g (graph pdg) n1 k z_part n2 let add_ctrl_dpd pdg n1 n2 = add_dpd_in_g (graph pdg) n1 Dpd.Ctrl None n2 let add_decl_dpd pdg n1 k n2 = add_dpd_in_g (graph pdg) n1 k None n2 (** add a dependency on the variable declaration. The kind of the dependency is address if the variable appears in a lvalue, data otherwise. *) let add_decl_dpds pdg node dpd_kind varset = let add_dpd var = try 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 (** [add_dpds pdg v dpd_kind state loc] * add 'dpd_kind' dependencies from node n to each element * which are stored for loc in state *) let add_dpds pdg n dpd_kind state loc = let add (node,z_part) = (* we only use [z_part] for dependencies to OutCall. * Would it be interesting to have it on other cases ? *) let z_part = match PdgTypes.Node.elem_key node with | PdgIndex.Key.SigCallKey (_, PdgIndex.Signature.Out (PdgIndex.Signature.OutLoc _)) -> z_part | _ -> None in add_z_dpd pdg n dpd_kind z_part node in let nodes, undef_zone = Pdg_state.get_loc_nodes state loc in List.iter add nodes; 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. * 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_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 stmt_nodes = try FctIndex.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 @ FctIndex.find_all index (Key.label_key stmt label) with Not_found -> acc in 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 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 = let empty_state = Pdg_state.empty in (** 2 new nodes for each formal parameters : one for its declaration, and one for its values. This is because it might be the case that we only need the declaration whatever the value is. Might allow us to do a better slicing of the callers. TODO: normally, the value should depend on the the declaration, but because we don't know how to select a declaration without selecting the value at the moment, we do the dependence the other way round. *) let do_param (n, state) v = let decl_node = decl_var pdg v 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 = Pdg_state.add_loc_node state ~exact:true (Locations.zone_of_varinfo v) new_node in (n+1, new_state) in let _next_in_num, new_state = List.fold_left do_param (1, empty_state) formals in List.iter (fun v -> ignore (decl_var pdg v)) locals; new_state let process_call_node pdg call_stmt = ignore (add_elem pdg (Key.call_ctrl_key call_stmt)) let ctrl_call_node pdg call_stmt = try FctIndex.find_info (nodes_index pdg) (Key.call_ctrl_key call_stmt) 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 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 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. *) let process_call_params pdg d_state stmt called_kf arg_nodes = let ctrl_node = ctrl_call_node pdg stmt in let param_list = Kernel_function.get_formals called_kf in let process_param state param arg = let new_node = arg in let _ = add_ctrl_dpd pdg new_node ctrl_node in Pdg_state.add_loc_node state (Locations.zone_of_varinfo param) new_node ~exact:true in let rec do_param_arg state param_list arg_nodes = match param_list, arg_nodes with | [], [] -> state | p :: param_list, a :: arg_nodes -> let state = process_param state p a in do_param_arg state param_list arg_nodes | [], _ -> (* call to a variadic function *) (* warning already sent during 'from' computation. *) state | _, [] -> 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 = let new_node = add_elem pdg out_key in let _ = add_dpds pdg new_node Dpd.Data state out_from in let _ = add_dpds pdg new_node Dpd.Ctrl state fct_dpds in let ctrl_node = ctrl_call_node pdg stmt in let _ = add_ctrl_dpd pdg new_node ctrl_node in new_node (** creates a node for lval : caller has to add dpds about the right part *) let create_lval_node pdg state key ~l_loc ~exact ~l_dpds ~l_decl = let new_node = add_elem pdg key in let _ = add_dpds pdg new_node Dpd.Addr state l_dpds in let _ = add_decl_dpds pdg new_node Dpd.Addr l_decl in let new_state = Pdg_state.add_loc_node state exact l_loc new_node in (new_node, new_state) let add_from pdg state_before state lval (default, deps) = 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 state let process_call_ouput pdg state_before_call state stmt numout out default from_out fct_dpds = let exact = (* TODO : Check this with Pascal ! * (Locations.Zone.cardinal_zero_or_one out) && *) (not default) in 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 "); let key = Key.call_output_key stmt (* numout *) out in let new_node = create_call_output_node pdg state_before_call stmt key from_out fct_dpds in let state = Pdg_state.add_loc_node state exact out new_node in state (** mix between process_call_ouput and process_asgn *) let process_call_return pdg state_before_call state_with_inputs stmt ~l_loc ~exact ~l_dpds ~l_decl ~r_dpds fct_dpds = let out_key = Key.call_outret_key stmt in let new_node = create_call_output_node pdg state_with_inputs stmt out_key r_dpds fct_dpds 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 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 let new_node, new_state = create_lval_node pdg d_state key ~l_loc ~exact ~l_dpds ~l_decl in let _ = add_dpds pdg new_node Dpd.Data d_state r_dpds in let _ = add_decl_dpds pdg new_node Dpd.Data r_decl in new_state let process_skip pdg _state stmt = let _new_node = add_elem pdg (Key.stmt_key stmt) in None (* keep previous state *) (* Copied from [process_skip] above: we cannot treat asm for the moment *) let process_asm pdg _state stmt = Pdg_parameters.warning ~once:true ~current:true "Ignoring inline assembly code"; 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.bottom 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.bottom let add_label pdg label label_stmt = let key = Key.label_key label_stmt label in try FctIndex.find_info (nodes_index pdg) key with Not_found -> add_elem pdg key let process_stmt_labels pdg stmt = let add label = match label with | Label _ -> ignore (add_label pdg label stmt) | _ -> (* see [add_dpd_switch_cases] *) () in List.iter add stmt.labels let add_label_and_dpd pdg label label_stmt jump_node = let label_node = add_label pdg label label_stmt in add_ctrl_dpd pdg jump_node label_node let add_dpd_goto_label pdg goto_node dest_goto = let rec pickLabel = function | [] -> None | Label _ as lab :: _ -> Some lab | _ :: rest -> pickLabel rest in 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_and_dpd pdg label dest_goto goto_node let add_dpd_switch_cases pdg switch_node case_stmts = let add_case stmt = let rec pickLabel = function | [] -> None | Case _ as lab :: _ -> Some lab | Default _ as lab :: _ -> Some lab | _ :: rest -> pickLabel rest in match pickLabel stmt.labels with | Some label -> add_label_and_dpd pdg label stmt switch_node | 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 by [finalize_pdg] *) 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 new_dpds = try 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 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 new_node = add_elem pdg (Key.stmt_key stmt) in let _ = match stmt.skind with | 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 Stmt.Hptset.iter controled_stmts; new_node let process_jump pdg stmt controled_stmts = ignore (mk_jump_node pdg stmt controled_stmts) let process_jump_with_exp pdg stmt controled_stmts state loc_cond decls_cond = let jump_node = mk_jump_node pdg stmt controled_stmts in add_dpds pdg jump_node Dpd.Data state loc_cond; add_decl_dpds pdg jump_node Dpd.Data decls_cond let add_blk_ctrl_dpds pdg key bstmts = let new_node = add_elem pdg key in store_ctrl_dpds pdg new_node List.iter (true, bstmts) let process_block pdg stmt blk = add_blk_ctrl_dpds pdg (Key.stmt_key stmt) blk.bstmts let process_entry_point pdg bstmts = add_blk_ctrl_dpds pdg Key.entry_point bstmts let create_fun_output_node pdg state dpds = 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 *) () let add_retres pdg state ret_stmt retres_loc_dpds retres_decls = 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.enumerate_valid_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 let _ = create_fun_output_node pdg (Some new_state) retres in new_state let store_last_state pdg state = Pdg_state.store_last_state (get_states pdg) state let store_init_state pdg state = Pdg_state.store_init_state (get_states pdg) state (** part of [finalize_pdg] : add missing inputs * and build a state with the new nodes to find them back when searching for * undefined zones. * (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 = 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 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 state, [(z_or_top, nz)] | (zone, nz)::tl_zones -> match z_or_top, zone with | (Locations.Zone.Top (_,_), Locations.Zone.Top (_,_)) -> let _ = add_z_dpd pdg n dpd_kind None nz in (state, zones) | (z, _) when (Locations.Zone.equal zone z) -> let _ = add_z_dpd pdg n dpd_kind None nz in (* don't add z : already in *) (state, zones) | _ -> (* rec : look for z in tail *) let state, tl_zones = add n dpd_kind (state, tl_zones) z_or_top in state, (zone, nz)::tl_zones in let add_zone acc (n, dpd_kind, z) = let do_add = match get_var_base z with | Some v -> if Kernel_function.is_local v pdg.fct then false else true | None -> true in if do_add then let acc = match z with | Locations.Zone.Top (_,_) -> add n dpd_kind acc z | _ -> let aux b intervs acc = let z = Locations.Zone.inject b intervs in add n dpd_kind acc z in Locations.Zone.fold_i aux z acc in acc 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 in state (** @param from_opt for undefined functions (declarations) *) let finalize_pdg pdg from_opt = debug2 "try to finalize_pdg"; let last_state = try Some (Pdg_state.get_last_state (get_states pdg)) with Not_found -> 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 = if Lmap_bitwise.From_Model.is_bottom from_table then bottom_state else let new_state = try Lmap_bitwise.From_Model.fold_fuse_same 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; new_state in store_last_state pdg new_state); let init_state = process_other_inputs pdg in store_init_state pdg init_state; add_ctrl_dpds pdg ; debug2 "finalize_pdg ok"; let states = get_states pdg in PdgTypes.Pdg.make pdg.fct pdg.graph states pdg.index end (*-----------------------------------------------------------------------*) (** gives needed informations about [lval] : = 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 in let l_loc = Locations.enumerate_valid_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). *) let process_asgn pdg state stmt lval exp = 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 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 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 and [new_state] the state to modify. * Process call outputs (including returned value) *) let call_ouputs pdg state_before_call state_with_inputs stmt lvaloption froms fct_dpds = (* be carefull to get every inputs from state_with_inputs * to avoid mixing in and out *) let froms_deps_return = froms.Function_Froms.deps_return in let from_table = froms.Function_Froms.deps_table in let print_outputs fmt = Format.fprintf fmt "call outputs : %a" Lmap_bitwise.From_Model.pretty from_table; if not (lvaloption = None) then Format.fprintf fmt "\t and \\result %a@." Lmap_bitwise.From_Model.LOffset.pretty froms_deps_return 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 if Lmap_bitwise.From_Model.is_bottom from_table then BuildPdg.bottom_state else let (state_with_outputs, _num) = try Lmap_bitwise.From_Model.fold_fuse_same 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) (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} Use the state at ki (before the call) and returns the new state (after the call). *) let process_call pdg state stmt lvaloption funcexp argl = let state_before_call = state in let _ = BuildPdg.process_call_node pdg stmt 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 ~with_alarms:CilE.warn_none_mode (Kstmt stmt) ~deps:(Some Locations.Zone.bottom) funcexp in let mixed_froms = try let froms = !Db.From.Callwise.find (Kstmt stmt) in Some froms with Not_found -> None (* don't have callwise analysis (-calldeps option) *) in let process_simple_call called_kf acc = let state_with_inputs = BuildPdg.process_call_params pdg state_with_args stmt called_kf arg_nodes in let r = match mixed_froms with | Some _ -> state_with_inputs (* process outputs later *) | None -> (* don't have callwise analysis (-calldeps option) *) let froms = !Db.From.get called_kf in let state_for_this_call = call_ouputs pdg state_before_call state_with_inputs stmt lvaloption froms funcexp_dpds in state_for_this_call in r :: acc in let state_for_each_call = Kernel_function.Hptset.fold process_simple_call called_functions [] in let new_state = match state_for_each_call with | [] -> let stmt_str = Pretty_utils.sfprintf "%a" Printer.pp_stmt stmt in Pdg_parameters.not_yet_implemented "pdg with an unknown function call: %s" stmt_str | st :: [] -> st | st :: other_states -> let merge s1 s2 = let _,s = BuildPdg.test_and_merge_states ~old:s1 s2 in s in List.fold_left merge st other_states in let new_state = match mixed_froms with | None -> new_state | Some froms -> call_ouputs pdg state_before_call new_state stmt lvaloption froms funcexp_dpds in 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 = let loc_cond = !Db.From.find_deps_no_transitivity stmt condition in let decls_cond = Cil.extract_varinfos_from_exp condition in 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 (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. Returns are not handled here, but in {!Build.process_return}. *) let process_jump_stmt pdg ctrl_dpds_infos jump = let controled_stmts = CtrlDpds.get_jump_controled_stmts ctrl_dpds_infos jump in 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 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 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 = 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 if Db.Value.is_reachable_stmt stmt then BuildPdg.store_last_state pdg last_state (** Computer is a ForwardsTransfer to use [Datatflow.Forwards] *) module Computer (Param:sig val current_pdg : BuildPdg.t val ctrl_dpds_infos : CtrlDpds.t end) = struct let name = "slicingflow" let pdg_debug fmt = debug fmt let debug = ref false type t = PdgTypes.data_state let current_pdg = Param.current_pdg let current_function = BuildPdg.get_kf current_pdg 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 = PdgTypes.data_state let states = BuildPdg.get_states current_pdg let clear () = Stmt.Hashtbl.clear 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 length () = Stmt.Hashtbl.length states end let copy (d: t) = d let pretty fmt (v: t) = Format.fprintf fmt "@\n%a@\n<\\STATE>@." BuildPdg.print_state v (** Transforme the state before storing it at the point before 'stmt' when there is nothing stored yet. *) let computeFirstPredecessor _stmt state = state (** Combine an old state with a new one at the point before 's'. Simply 'join' the two states. Return None if the new state is already included in the old one to stop processing (fix point reached). *) let combinePredecessors stmt ~old (new_:t) = 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 (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 (); pdg_debug "doInstr sid:%d : %a" stmt.sid Printer.pp_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 _ -> BuildPdg.process_asm current_pdg state stmt 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) = pdg_debug "doStmt %d @." stmt.sid ; (* Notice that the stmt labels are processed while processing the jumps. *) BuildPdg.process_stmt_labels current_pdg stmt; match stmt.skind with | Instr _ -> Dataflow.SDefault | Block blk -> BuildPdg.process_block current_pdg stmt blk; Dataflow.SDefault | UnspecifiedSequence seq -> BuildPdg.process_block current_pdg stmt (Cil.block_from_unspecified_sequence seq); Dataflow.SDefault | Switch (exp,_,_,_) | If (exp,_,_,_) -> process_condition ctrl_dpds_infos current_pdg state stmt exp; Dataflow.SDefault | Return (exp,_) -> process_return current_function current_pdg state stmt exp; Dataflow.SDefault | Continue _ | Break _ | Goto _ -> process_jump_stmt current_pdg ctrl_dpds_infos stmt; Dataflow.SDefault | Loop _ -> process_loop_stmt current_pdg ctrl_dpds_infos stmt; Dataflow.SDefault | TryExcept (_, _, _, _) | TryFinally (_, _, _) -> Dataflow.SDefault (** Whether to put this statement in the worklist. *) 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 let doEdge _ _ d = d 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 = 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 let formals = Kernel_function.get_formals kf in BuildPdg.process_declarations pdg formals f_locals in let froms = match f_stmts with | [] -> let state = init_state in BuildPdg.store_last_state pdg state ; let froms = !Db.From.get kf in Some (froms) | start :: stmts -> let ctrl_dpds_infos = CtrlDpds.compute kf in let module Computer = Computer (struct let current_pdg = pdg let ctrl_dpds_infos = ctrl_dpds_infos end) in let module Compute = Dataflow.Forwards(Computer) in if Db.Value.is_reachable_stmt start then begin let init_state = Computer.computeFirstPredecessor start init_state in Computer.StmtStartData.add start init_state ; let rec add acc l = match l with [] -> acc | s::tl -> Computer.StmtStartData.add s 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))) in let pdg = BuildPdg.finalize_pdg pdg froms in pdg let degenerated top 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 (); Pdg_parameters.feedback "computing for function %a" Kernel_function.pretty kf; try if is_variadic kf then Pdg_parameters.not_yet_implemented "variadic function"; let pdg = compute_pdg_for_f kf in Pdg_parameters.feedback "done for function %a" Kernel_function.pretty kf; pdg with | Err_Bot what -> Pdg_parameters.warning "%s" what ; degenerated false kf | Log.AbortFatal what -> (* [JS 2012/08/24] nobody should catch this exception *) Pdg_parameters.warning "internal error: %s" what ; degenerated true kf | Log.AbortError what -> (* [JS 2012/08/24] nobody should catch this exception *) Pdg_parameters.warning "user error: %s" what ; degenerated true kf | Pdg_state.Cannot_fold -> Pdg_parameters.warning "too imprecise value analysis : abort" ; degenerated true kf | Log.FeatureRequest (who, what) -> (* [JS 2012/08/24] nobody should catch this exception *) Pdg_parameters.warning "not implemented by %s yet: %s" who what ; degenerated true kf (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/pdg/ctrlDpds.mli0000644000175000017500000000502512155630237017626 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Internal information about control dependencies *) type t (** Compute some information on the function in order to be able to compute * the control dependencies later on *) val compute : Kernel_function.t -> t (** 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_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, * but also a [break], a [continue], or even a loop because CIL transformations 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_datatype.Stmt.Hptset.t val get_loop_controled_stmts : t -> Cil_types.stmt -> Cil_datatype.Stmt.Hptset.t (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/pdg/annot.ml0000644000175000017500000002045712155630237017023 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open PdgTypes open PdgIndex type data_info = ((Node.t * Locations.Zone.t option) list * Locations.Zone.t option) option type ctrl_info = 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 = let stmt = info.Db.Properties.Interp.To_zone.ki in let before = info.Db.Properties.Interp.To_zone.before in let zone = info.Db.Properties.Interp.To_zone.zone in Pdg_parameters.debug ~level:2 "[pdg:annotation] need %a %s stmt %d@." 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 in let undef_acc = match undef_acc, undef_loc with | None, _ -> undef_loc | _, None -> undef_acc | Some z1, Some z2 -> Some (Locations.Zone.join z1 z2) in (nodes @ nodes_acc, undef_acc) in match data_info with | None -> None (* To_zone.xxx didn't manage to compute the zone *) | Some data_info -> let data_dpds = ([], None) in let data_dpds = List.fold_left (add_info_nodes pdg) data_dpds data_info in Some data_dpds let get_decl_nodes pdg decl_info = let add_decl_nodes decl_var nodes_acc = let node = Sets.find_decl_var_node pdg decl_var in node::nodes_acc in Varinfo.Set.fold add_decl_nodes decl_info [] let find_nodes_for_function_contract pdg f_interpret = let kf = Pdg.get_kf pdg in let (data_info, decl_label_info) = f_interpret kf in let data_dpds = zone_info_nodes pdg data_info in let decl_nodes = (* No way to get stmt from labels of at construct into function contracts *) get_decl_nodes pdg decl_label_info.Db.Properties.Interp.To_zone.var in decl_nodes, data_dpds 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 ~state_opt:(Some true) kf in !Db.Properties.Interp.To_zone.from_pred named_p f_ctx in find_nodes_for_function_contract pdg f_interpret let find_fun_postcond_nodes pdg 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 ~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] * to the returned list of nodes. *) if !Db.Properties.Interp.to_result_from_pred named_p then (Sets.find_output_node pdg)::nodes else nodes in nodes,deps let find_fun_variant_nodes pdg t = let f_interpret kf = let f_ctx = !Db.Properties.Interp.To_zone.mk_ctx_func_contrat ~state_opt:(Some true) kf in !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 stmt annot = Pdg_parameters.debug "[pdg:annotation] CodeAnnot-%d stmt %d : %a @." annot.annot_id stmt.sid Printer.pp_code_annotation annot; if Db.Value.is_reachable_stmt stmt then try begin let kf = Pdg.get_kf pdg in let (data_info, decl_label_info), pragmas = !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_label_info.Db.Properties.Interp.To_zone.var in let labels = decl_label_info.Db.Properties.Interp.To_zone.lbl in let stmt_key = Key.stmt_key stmt in let stmt_node = match stmt_key with | Key.Stmt _ -> !Db.Pdg.find_stmt_node pdg stmt | Key.CallStmt _ -> !Db.Pdg.find_call_ctrl_node pdg stmt | _ -> assert false in let ctrl_dpds = !Db.Pdg.direct_ctrl_dpds pdg stmt_node in let add_stmt_nodes s acc = (!Db.Pdg.find_stmt_and_blocks_nodes pdg s) @ acc in (* can safely ignore pragmas.ctrl * because we already have the ctrl dpds from the stmt node. *) let stmt_pragmas = pragmas.Db.Properties.Interp.To_zone.stmt in let ctrl_dpds = Stmt.Set.fold add_stmt_nodes stmt_pragmas ctrl_dpds in let add_label_nodes l acc = match l with | StmtLabel stmt -> (* TODO: we could be more precise here if we knew which label * is really useful... *) let add acc l = try (Sets.find_label_node pdg !stmt l)::acc with Not_found -> acc in List.fold_left add acc (!stmt).labels | LogicLabel (Some stmt, str) -> let add acc l = match l with | Label (sl, _, _) when sl = str -> (try (Sets.find_label_node pdg stmt l)::acc with Not_found -> acc) | _ -> acc in List.fold_left add acc stmt.labels | LogicLabel (None, _) -> acc in let ctrl_dpds = Logic_label.Set.fold add_label_nodes labels ctrl_dpds in if Pdg_parameters.debug_atleast 2 then begin let p fmt (n,z) = match z with | None -> Node.pretty fmt n | Some z -> Format.fprintf fmt "%a(%a)" 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" Node.pretty_list ctrl_dpds; Pdg_parameters.debug " decl nodes = %a" Node.pretty_list decl_nodes; match data_dpds with | None -> Pdg_parameters.debug " data nodes = None (failed to compute)" | Some (data_nodes, data_undef) -> begin Pdg_parameters.debug " data nodes = %a" pl data_nodes; match data_undef with | None -> () | Some data_undef -> Pdg_parameters.debug " data undef = %a" Locations.Zone.pretty data_undef; end end; ctrl_dpds, decl_nodes, data_dpds end with Logic_interp.To_zone.NYI msg -> raise (Logic_interp.To_zone.NYI ("[pdg:find_code_annot_nodes] to_zone : "^msg)) else begin Pdg_parameters.debug ~level:2 "[pdg:annotation] CodeAnnot-%d : unreachable stmt ! @." annot.annot_id; raise Not_found (* unreachable statement *) end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/pdg/pdg_parameters.mli0000644000175000017500000000335312155630237021046 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.S module BuildAll: Plugin.WithOutput module BuildFct: Plugin.String_set module PrintBw: Plugin.Bool module DotBasename: Plugin.String frama-c-Fluorine-20130601/src/pdg/ctrlDpds.ml0000644000175000017500000004114012155630237017453 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let dkey = Pdg_parameters.register_category "ctrl-dpds" open Cil_types open Cil_datatype (*============================================================================*) (** 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) *) module Lexical_successors : sig type t val compute : Cil_types.kernel_function -> t (** @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 let dkey = Pdg_parameters.register_category "lex-succs" (** 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 (** 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 (** @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 (*============================================================================*) (** 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 type t = State.t Stmt.Hashtbl.t let _pretty fmt infos = Stmt.Hashtbl.iter (fun k v -> Format.fprintf fmt "Stmt:%d\n%a\n======" k.sid State.pretty v) infos 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 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 end (*============================================================================*) (** Compute information needed for control dependencies *) (*============================================================================*) type t = Lexical_successors.t * PdgPostdom.t let compute kf = let lex_succ_graph = Lexical_successors.compute kf in let ctrl_dpds_infos = PdgPostdom.compute kf in (lex_succ_graph, ctrl_dpds_infos) (** 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. * As B is usually a successor of A, it means that S is reached if the B-branch * is chosen, but not necessary for the other branches. Then, S should depend * on A. (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 Stmt.Hptset.empty else begin 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 -> 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) *) Stmt.Hptset.empty (* because we don't want b postdoms to depend on the jump *) in 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} * (see the document to know more about the applied algorithm). *) let get_if_controled_stmts ctrl_dpds_infos stmt = let _, infos = ctrl_dpds_infos in 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) = {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 lex_suc = try Lexical_successors.find lex_succ_graph jump with Not_found -> assert false in 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 (** 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 ../.." End: *) frama-c-Fluorine-20130601/src/pdg/marks.mli0000644000175000017500000000645112155630237017170 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 PdgMarks (** [in_marks_to_caller] translate the input information part returned by [mark_and_propagate] into [(node, mark) list] related to a call. Example : if marks has been propagated in [f] and some input marks has changed, they have to be propagated into [f] callers. So this function takes one call to [f] and translate input keys into nodes. The function ([m2m]) is called for each element to translate. See {!m2m} for more information about how to use it. *) val in_marks_to_caller : PdgTypes.Pdg.t -> Cil_types.stmt -> 'mark m2m -> ?rqs:('mark select) -> 'mark info_caller_inputs -> 'mark select (** translate the input information part returned by [mark_and_propagate] using [in_marks_to_caller] for each call. (see above) *) val translate_in_marks : PdgTypes.Pdg.t-> 'mark info_caller_inputs-> ?m2m:('mark call_m2m) -> 'mark pdg_select -> 'mark pdg_select (** we have a list of a call output marks, and we want to translate it into a list of marks on the called function nodes. The pdg is the called_pdg. *) val call_out_marks_to_called : PdgTypes.Pdg.t -> 'mark m2m -> ?rqs:('mark select) -> (PdgIndex.Signature.out_key * 'mark) list -> 'mark select (** use both [translate_in_marks] and [call_out_marks_to_called] to translate the information provided by [mark_and_propagate] info selection on other functions. *) val translate_marks_to_prop : PdgTypes.Pdg.t -> 'mark info_inter -> ?in_m2m:('mark call_m2m) -> ?out_m2m:('mark call_m2m) -> 'mark pdg_select -> 'mark pdg_select module F_Proj (C : Config) : Proj with type mark = C.M.t and type call_info = C.M.call_info (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/pdg/build.mli0000644000175000017500000000331612155630237017147 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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_pdg : Cil_types.kernel_function -> PdgTypes.Pdg.t (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/pdg/register.ml0000644000175000017500000001564112155630237017527 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let compute = Build.compute_pdg let pretty ?(bw=false) fmt pdg = let kf = PdgTypes.Pdg.get_kf pdg in Format.fprintf fmt "@[RESULT for %s:@]@\n@[%a@]" (Kernel_function.get_name kf) (PdgTypes.Pdg.pretty_bw ~bw) pdg let pretty_node short = if short then PdgTypes.Node.pretty else PdgTypes.Node.pretty_node let print_dot pdg filename = PdgTypes.Pdg.build_dot filename pdg; Pdg_parameters.result "dot file generated in %s" filename module Tbl = Kernel_function.Make_Table (PdgTypes.Pdg) (struct let name = "Pdg.State" let dependencies = [] (* postponed because !Db.From.self may not exist yet *) let size = 17 end) let () = Cmdline.run_after_extended_stage (fun () -> State_dependency_graph.add_codependencies ~onto:Tbl.self [ !Db.From.self ]) (** Register external functions into Db. *) let () = Db.Pdg.self := Tbl.self; Db.Pdg.get := Tbl.memo compute; Db.Pdg.node_key := PdgTypes.Node.elem_key; Db.Pdg.find_decl_var_node := Sets.find_decl_var_node; Db.Pdg.find_entry_point_node := Sets.find_entry_point_node; Db.Pdg.find_top_input_node := Sets.find_top_input_node; Db.Pdg.find_simple_stmt_nodes := Sets.find_simple_stmt_nodes; Db.Pdg.find_stmt_and_blocks_nodes := Sets.find_stmt_and_blocks_nodes; Db.Pdg.find_stmt_node := Sets.find_stmt_node; Db.Pdg.find_label_node := Sets.find_label_node; Db.Pdg.find_location_nodes_at_stmt := Sets.find_location_nodes_at_stmt; Db.Pdg.find_location_nodes_at_begin := Sets.find_location_nodes_at_begin; Db.Pdg.find_location_nodes_at_end := Sets.find_location_nodes_at_end; Db.Pdg.find_call_ctrl_node := Sets.find_call_ctrl_node; Db.Pdg.find_call_input_node := Sets.find_call_num_input_node; Db.Pdg.find_call_output_node := Sets.find_call_output_node; Db.Pdg.find_input_node := Sets.find_input_node; Db.Pdg.find_ret_output_node := Sets.find_output_node; Db.Pdg.find_output_nodes := Sets.find_output_nodes; Db.Pdg.find_all_inputs_nodes := Sets.find_all_input_nodes; Db.Pdg.find_call_stmts := Sets.find_call_stmts; Db.Pdg.find_code_annot_nodes := Annot.find_code_annot_nodes; Db.Pdg.find_fun_precond_nodes := Annot.find_fun_precond_nodes; Db.Pdg.find_fun_postcond_nodes := Annot.find_fun_postcond_nodes; Db.Pdg.find_call_out_nodes_to_select := Sets.find_call_out_nodes_to_select; Db.Pdg.find_in_nodes_to_select_for_this_call := Sets.find_in_nodes_to_select_for_this_call; Db.Pdg.direct_dpds := Sets.direct_dpds; Db.Pdg.direct_ctrl_dpds := Sets.direct_ctrl_dpds; Db.Pdg.direct_data_dpds := Sets.direct_data_dpds; Db.Pdg.direct_addr_dpds := Sets.direct_addr_dpds; Db.Pdg.all_dpds := Sets.find_nodes_all_dpds; Db.Pdg.all_ctrl_dpds := Sets.find_nodes_all_ctrl_dpds; Db.Pdg.all_data_dpds := Sets.find_nodes_all_data_dpds; Db.Pdg.all_addr_dpds := Sets.find_nodes_all_addr_dpds; Db.Pdg.direct_uses := Sets.direct_uses; Db.Pdg.direct_ctrl_uses := Sets.direct_ctrl_uses; Db.Pdg.direct_data_uses := Sets.direct_data_uses; Db.Pdg.direct_addr_uses := Sets.direct_addr_uses; Db.Pdg.all_uses := Sets.all_uses; Db.Pdg.custom_related_nodes := Sets.custom_related_nodes; Db.Pdg.iter_nodes := PdgTypes.Pdg.iter_nodes; Db.Pdg.pretty := pretty ; Db.Pdg.pretty_node := pretty_node ; Db.Pdg.pretty_key := PdgIndex.Key.pretty; Db.Pdg.extract := print_dot (* Polymorphic functions : cannot be registered in Db. Can be used through Pdg.Register (see Pdg.mli) *) let translate_marks_to_prop = Marks.translate_marks_to_prop let call_out_marks_to_called = Marks.call_out_marks_to_called let in_marks_to_caller = Marks.in_marks_to_caller let translate_in_marks = Marks.translate_in_marks module F_Proj = Marks.F_Proj let deps = [!Db.Pdg.self; Pdg_parameters.BuildAll.self; Pdg_parameters.BuildFct.self] let () = Pdg_parameters.BuildAll.set_output_dependencies deps let compute () = let all = Pdg_parameters.BuildAll.get () in let do_kf_pdg kf = let fname = Kernel_function.get_name kf in if all || Datatype.String.Set.mem fname (Pdg_parameters.BuildFct.get ()) then let pdg = !Db.Pdg.get kf in 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; Pdg_parameters.debug "Logging keys : %s" (Pdg_parameters.Debug_category.get_set()) ; if Pdg_parameters.BuildAll.get () then Pdg_parameters.feedback "====== PDG GRAPH COMPUTED ======" let compute_once, _ = State_builder.apply_once "Pdg.Register.compute_once" deps compute let output () = let bw = Pdg_parameters.PrintBw.get () in let all = Pdg_parameters.BuildAll.get () in let do_kf_pdg kf = let fname = Kernel_function.get_name kf in if all || Datatype.String.Set.mem fname (Pdg_parameters.BuildFct.get ()) then let pdg = !Db.Pdg.get kf in Pdg_parameters.result "@[%a@]" (!Db.Pdg.pretty ~bw) pdg; in !Db.Semantic_Callgraph.topologically_iter_on_functions do_kf_pdg let something_to_do () = Pdg_parameters.BuildAll.get () || not (Datatype.String.Set.is_empty (Pdg_parameters.BuildFct.get ())) let main () = if something_to_do () then (compute_once (); Pdg_parameters.BuildAll.output output) let () = Db.Main.extend main (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/pdg/pdg_state.mli0000644000175000017500000000510312155630237020016 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) exception Cannot_fold open PdgTypes (** Types data_state and Node.t come froms this module *) val make : PdgTypes.LocInfo.t -> Locations.Zone.t -> data_state val empty : data_state val bottom: data_state val add_loc_node : data_state -> exact:bool -> Locations.Zone.t -> Node.t -> data_state val add_init_state_input : data_state -> Locations.Zone.t -> Node.t -> data_state val test_and_merge : old:data_state -> data_state -> bool * data_state (** @raise Cannot_fold if the state is Top *) val get_loc_nodes : data_state -> Locations.Zone.t -> (Node.t * Locations.Zone.t option) list * Locations.Zone.t option val pretty : Format.formatter -> data_state -> unit (* ~~~~~~~~~~~~~~~~~~~ *) type states = data_state Cil_datatype.Stmt.Hashtbl.t val store_init_state : states -> data_state -> unit val store_last_state : states -> data_state -> unit val get_init_state : states -> data_state val get_stmt_state : states -> Cil_types.stmt -> data_state val get_last_state : states -> data_state frama-c-Fluorine-20130601/src/pdg/sets.ml0000644000175000017500000003331112155630237016653 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Provides function to extract information from the PDG. *) open Cil_types open PdgTypes open PdgIndex type 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 (Pdg.get_states pdg) with Not_found -> assert false (** @raise Not_found when no last state (strange !) *) let get_last_state pdg = Pdg_state.get_last_state (Pdg.get_states pdg) (** @raise Not_found for unreachable stmt *) let get_stmt_state pdg stmt = Pdg_state.get_stmt_state (Pdg.get_states pdg) stmt 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 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 let nodes = s_nodes @ nodes in let add_block_stmts_nodes node_list blk = List.fold_left (add_stmt_nodes pdg) node_list blk.bstmts in match s.skind with | Switch (_,blk,_,_) | Loop (_, blk, _, _, _) | Block blk -> Pdg_parameters.debug ~level:2 " 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; add_block_stmts_nodes nodes (Cil.block_from_unspecified_sequence seq) | If (_,bthen,belse,_) -> let nodes = add_block_stmts_nodes nodes bthen in add_block_stmts_nodes nodes belse | _ -> nodes (** notice that there can be several nodes if the statement is a call. * If the stmt is a composed instruction (block, etc), all the nodes of the * enclosed statements are considered. *) let find_stmt_and_blocks_nodes pdg stmt = add_stmt_nodes pdg [] stmt let find_stmt_node pdg stmt = find_node pdg (Key.stmt_key stmt) let find_entry_point_node pdg = 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 let nodes, undef = match undef with | Some undef -> let state = get_init_state pdg in let init_nodes, init_undef = Pdg_state.get_loc_nodes state undef in let init_nodes = match loc with | Locations.Zone.Top(_,_) -> begin try (find_top_input_node pdg, None)::init_nodes with Not_found -> init_nodes end | _ -> init_nodes in let nodes = List.fold_left (fun acc n -> n::acc) nodes init_nodes in nodes, init_undef | None -> nodes, undef in nodes, undef let find_location_nodes_at_stmt pdg stmt ~before loc = let get_nodes state = find_loc_nodes pdg state loc in let get_stmt_nodes stmt = get_nodes (get_stmt_state pdg stmt) in let get_stmts_nodes stmts = let add (acc_nodes, acc_loc) stmt = let nodes, undef = get_stmt_nodes stmt in let acc_nodes = nodes @ acc_nodes in let acc_loc = match acc_loc, undef with | _, None -> acc_loc | None, _ -> undef | Some acc_loc, Some undef -> Some (Locations.Zone.join acc_loc undef) in (acc_nodes, acc_loc) in List.fold_left add ([], None) stmts in let nodes, undef_zone = if before then get_stmt_nodes stmt else match stmt.skind, stmt.succs with | Return _, [] -> get_nodes (get_last_state pdg) | _, [] -> (* no successors but not a return => unreachable *) raise Not_found | _, succs -> get_stmts_nodes succs in nodes, undef_zone let find_location_nodes_at_end pdg loc = find_loc_nodes pdg (get_last_state pdg) loc (* be carreful that begin is different from init because * init_state only contains implicit inputs * while begin contains only formal arguments *) let find_location_nodes_at_begin pdg loc = let kf = Pdg.get_kf pdg in let stmts = 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 | stmt :: _ -> get_stmt_state pdg stmt in find_loc_nodes pdg state loc let find_label_node pdg label_stmt label = find_node pdg (Key.label_key label_stmt label) let find_decl_var_node pdg v = find_node pdg (Key.decl_var_key v) let find_output_node pdg = find_node pdg Key.output_key let find_input_node pdg numin = let sgn = FctIndex.sgn (Pdg.get_index pdg) in PdgIndex.Signature.find_input sgn numin let find_all_input_nodes pdg = 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 let find_call_input_nodes pdg_caller call_stmt in_key = match in_key with | PdgIndex.Signature.InCtrl | PdgIndex.Signature.InNum _ -> 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 = 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 = Key.call_input_key call num_in in find_node pdg key let find_call_output_node pdg call = let key = Key.call_outret_key call in find_node pdg key let find_output_nodes called_pdg out_key = match out_key with | PdgIndex.Signature.OutRet -> [ find_output_node called_pdg, None ], None | PdgIndex.Signature.OutLoc out -> find_location_nodes_at_end called_pdg out let find_call_stmts kf ~caller = match List.filter (fun (f, _) -> Kernel_function.equal f caller) (!Db.Value.callers kf) with | [] -> [] | [ _, callsites ] -> assert (callsites <> []); callsites | _ -> assert false (** {2 Build sets of nodes} This parts groups the functions that build sets from the pdg. Made to answer user questions rather that to build slice marks, because efficient marking doesn't need to build this sets. However, it might be useful to prove that it is the same... *) (** 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 = (Node.compare node n) = 0 in try let _ = List.find is_node node_list in true with Not_found -> false in if is_node_in node node_list then node_list, false else (node :: node_list), true (** add the node to the list. It it wasn't already in the list, * recursively call the same function on the successors or/and predecessors * according to the flags. *) let rec add_node_and_custom_dpds get_dpds node_list node = let node_list, added = add_node_in_list node node_list in if added then 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) | _ -> false in if is_block 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) else node_list let add_nodes_and_custom_dpds get_dpds node_list nodes = List.fold_left (add_node_and_custom_dpds get_dpds) node_list nodes let custom_related_nodes get_dpds nodes = add_nodes_and_custom_dpds get_dpds [] nodes (** we ignore z_part for the moment. TODO ? *) let filter_nodes l = List.map (fun (n,_) -> n) l (** {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 (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 (Pdg.get_x_direct_dpds dpd_type pdg node) 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] *) let find_nodes_all_x_dpds dpd_type pdg nodes = let merge_dpds node_list node = let node_dpds = direct_x_dpds dpd_type pdg node in add_nodes_and_custom_dpds (direct_dpds pdg) node_list node_dpds in List.fold_left merge_dpds [] nodes let find_nodes_all_dpds pdg nodes = let merge_dpds node_list node = let node_dpds = direct_dpds pdg node in add_nodes_and_custom_dpds (direct_dpds pdg) node_list node_dpds in List.fold_left merge_dpds [] nodes 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 (Pdg.get_all_direct_codpds pdg node) let direct_x_uses dpd_type pdg node = filter_nodes (Pdg.get_x_direct_codpds dpd_type pdg node) 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 = Pdg.get_all_direct_codpds pdg node in let codpds = filter_nodes codpds 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} *) (* VP: unused function *) (* let node_set_of_list l = List.fold_left (fun acc n -> NodeSet.add n acc) NodeSet.empty l *) (** @return the call outputs nodes [out] such that [find_output_nodes pdg_called out_key] intersects [called_selected_nodes]. *) let find_call_out_nodes_to_select pdg_called called_selected_nodes pdg_caller call_stmt = Pdg_parameters.debug ~level:2 "[pdg:find_call_out_nodes_to_select] for call sid:%d@." call_stmt.sid; let _, call_sgn = FctIndex.find_call (Pdg.get_index pdg_caller) call_stmt 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) -> NodeSet.mem n called_selected_nodes) called_out_nodes in if intersect then begin Pdg_parameters.debug ~level:2 "\t+ %a@." Node.pretty call_out_node; call_out_node::acc end else acc in PdgIndex.Signature.fold_all_outputs test_out [] call_sgn let find_in_nodes_to_select_for_this_call pdg_caller caller_selected_nodes call_stmt pdg_called = Pdg_parameters.debug ~level:2 "[pdg:find_in_nodes_to_select_for_this_call] for call sid:%d@." call_stmt.sid; let sgn = FctIndex.sgn (Pdg.get_index pdg_called) in let test_in acc (in_key, in_node) = let caller_nodes, _undef = find_call_input_nodes pdg_caller call_stmt in_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) -> NodeSet.mem n caller_selected_nodes) caller_nodes in if intersect then begin Pdg_parameters.debug ~level:2 "\t+ %a@." Node.pretty in_node; in_node::acc end else acc in PdgIndex.Signature.fold_all_inputs test_in [] sgn frama-c-Fluorine-20130601/src/pdg/pdg_state.ml0000644000175000017500000001541712155630237017656 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** 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 was last defined. *) let dkey = Pdg_parameters.register_category "state" module P = Pdg_parameters open PdgTypes exception Cannot_fold let make loc_info under_outputs = { loc_info = loc_info; under_outputs = under_outputs } let empty = make LocInfo.empty Locations.Zone.bottom (* Convention: bottom is used for statements that are not reachable, and for calls that never terminate. In this case, the second field must be ignored *) let bottom = make LocInfo.bottom Locations.Zone.bottom let pretty fmt state = Format.fprintf fmt "state = %a@.with under_outputs = %a@." LocInfo.pretty state.loc_info Locations.Zone.pretty state.under_outputs let add_loc_node state ~exact loc node = 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 ; if LocInfo.is_bottom state.loc_info then (* Do not add anything to a bottom state (which comes from an unreachable statement *) state else let new_info = NodeSetLattice.inject_singleton node in let new_loc_info = LocInfo.add_binding exact state.loc_info loc new_info in let new_outputs = (* Zone.link in the under-approx version of Zone.join *) if exact then Locations.Zone.link state.under_outputs loc else state.under_outputs in 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 * we want to accumulate the nodes (exact = false) but nonetheless * define under_outputs like (exact = true) *) let add_init_state_input state loc node = match loc with | Locations.Zone.Top(_p,_o) -> (* don't add top because it loses everything*) state | _ -> let new_info = NodeSetLattice.inject_singleton node in let new_loc_info = LocInfo.add_binding false state.loc_info loc new_info in let new_outputs = Locations.Zone.link state.under_outputs loc in make new_loc_info new_outputs let test_and_merge ~old new_ = if LocInfo.is_included new_.loc_info old.loc_info && Locations.Zone.is_included old.under_outputs new_.under_outputs then (false, old) else (* Catch Bottom states, as under_outputs get a special value *) if LocInfo.is_bottom old.loc_info then true, new_ else if LocInfo.is_bottom new_.loc_info then true, old else let new_loc_info = LocInfo.join old.loc_info new_.loc_info in let new_outputs = Locations.Zone.meet old.under_outputs new_.under_outputs in let new_state = { loc_info = new_loc_info ; under_outputs = new_outputs } in true, new_state (** returns pairs of (n, z_opt) where n is a node that computes a part of [loc] * and z is the intersection between [loc] and the zone computed by the node. * @raise Cannot_fold if the state is top (TODO : something better ?) * *) let get_loc_nodes_and_part state loc = let process z (_default, nodes) acc = if Locations.Zone.intersects z loc then 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... *) else Some (Locations.Zone.narrow z loc) in let add n acc = P.debug ~dkey ~level:2 "get_loc_nodes -> %a@." PdgTypes.Node.pretty_with_part (n,z); (n,z)::acc in NodeSetLattice.fold add nodes acc else acc in try LocInfo.fold process state.loc_info [] with LocInfo.Cannot_fold -> raise Cannot_fold (** @raise Cannot_fold (see [get_loc_nodes_and_part]) *) let get_loc_nodes state loc = 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 ~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 else Some undef_zone in nodes, undef_zone open Cil_datatype type states = PdgTypes.data_state Stmt.Hashtbl.t (* Slightly ugly, but should not be a problem unless the sid counter wraps *) let stmt_init = List.hd Stmt.reprs let stmt_last = { stmt_init with Cil_types.sid = stmt_init.Cil_types.sid - 1 } let store_init_state states state = Stmt.Hashtbl.add states stmt_init state let store_last_state states state = Stmt.Hashtbl.add states stmt_last state let get_init_state states = Stmt.Hashtbl.find states stmt_init let get_last_state states = Stmt.Hashtbl.find states stmt_last let get_stmt_state states stmt = Stmt.Hashtbl.find states stmt frama-c-Fluorine-20130601/src/pdg/marks.ml0000644000175000017500000002055312155630237017016 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 PdgTypes open PdgIndex open Cil_datatype (** compute the marks to propagate in the caller nodes from the marks of * a function inputs [in_marks]. *) let in_marks_to_caller pdg call m2m ?(rqs=[]) in_marks = let add_n_m acc n z_opt m = let select = PdgMarks.mk_select_node ~z_opt n in match m2m select m with | None -> acc | Some m -> PdgMarks.add_to_select acc select m in let build rqs (in_key, m) = match in_key with | Signature.InCtrl -> add_n_m rqs (!Db.Pdg.find_call_ctrl_node pdg call) None m | Signature.InNum in_num -> add_n_m rqs (!Db.Pdg.find_call_input_node pdg call in_num) None m | Signature.InImpl zone -> let nodes, undef = !Db.Pdg.find_location_nodes_at_stmt pdg call ~before:true zone in let rqs = List.fold_left (fun acc (n,z) -> add_n_m acc n z m) rqs nodes in let rqs = match undef with None -> rqs | Some z -> match m2m (PdgMarks.mk_select_undef_zone z) m with None -> rqs | Some m -> PdgMarks.add_undef_in_to_select rqs undef m in rqs in List.fold_left build rqs in_marks (** some new input marks has been added in a called function. * Build the list of what is to be propagated in the callers. * Be careful that some Pdg can be top : in that case, a list of mark is * returned (Beware that m2m has NOT been called in that case). * *) let translate_in_marks pdg_called in_new_marks ?(m2m=fun _ _ _ m -> Some m) other_rqs = let kf_called = Pdg.get_kf pdg_called in let translate pdg rqs call = in_marks_to_caller pdg call (m2m (Some call) pdg) ~rqs in_new_marks in let build rqs (caller, _) = let pdg_caller = !Db.Pdg.get caller in let caller_rqs = try let call_stmts = !Db.Pdg.find_call_stmts ~caller kf_called in (* TODO : more intelligent merge ? *) let rqs = List.fold_left (translate pdg_caller) [] call_stmts in PdgMarks.SelList rqs with PdgTypes.Pdg.Top -> let marks = List.fold_left (fun acc (_, m) -> m::acc) [] in_new_marks in PdgMarks.SelTopMarks marks (* #345 *) in (pdg_caller, caller_rqs)::rqs in let res = List.fold_left build other_rqs (!Db.Value.callers kf_called) in res let call_out_marks_to_called called_pdg m2m ?(rqs=[]) out_marks = let build rqs (out_key, m) = let nodes, undef = Sets.find_output_nodes called_pdg out_key in let sel = List.map (fun (n, _z_opt) -> PdgMarks.mk_select_node ~z_opt:None n) nodes in let sel = match undef with None -> sel | Some undef -> (PdgMarks.mk_select_undef_zone undef)::sel in let add acc s = match m2m s m with | None -> acc | Some m -> (s, m)::acc in let rqs = List.fold_left add rqs sel in rqs in List.fold_left build rqs out_marks 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 node_marks = call_out_marks_to_called called_pdg m2m ~rqs:[] l_out_m in (called_pdg, PdgMarks.SelList node_marks)::rqs with PdgTypes.Pdg.Top -> (* no PDG for this function : forget the new marks * because anyway, the source function will be called. * *) rqs in let all_called = Db.Value.call_to_kernel_function call in Kernel_function.Hptset.fold (add_list l) all_called other_rqs (** [add_new_marks_to_rqs pdg new_marks other_rqs] translates [new_marks] * that were computed during intraprocedural propagation into requests, * and add them to [other_rqs]. * * The functions [in_m2m] and [out_m2m] can be used to modify the marks during * propagation : *- [in_m2m call_stmt call_in_node mark] : provide the mark to propagate to the [call_in_node] knowing that the mark of the called function has been modify to [mark] *- [out_m2m out_node mark] : provide the mark to propagate to the [out_node] knowing that a call output mark has been modify to [mark]. *) let translate_marks_to_prop pdg new_marks ?(in_m2m=fun _ _ _ m -> Some m) ?(out_m2m=fun _ _ _ m -> Some m) other_rqs = let in_marks, out_marks = new_marks in let other_rqs = translate_in_marks pdg in_marks ~m2m:in_m2m other_rqs in let rqs = List.fold_left (translate_out_mark pdg out_m2m) other_rqs out_marks in rqs (** To also use interprocedural propagation, the user can instantiate this * functor. This is, of course, not mandatory because one can want to use a more * complex propagation (like slicing for instance, that has more than one * version for a source function). *) module F_Proj (C : PdgMarks.Config) : PdgMarks.Proj with type mark = C.M.t and type call_info = C.M.call_info = struct module F = PdgMarks.F_Fct (C.M) type mark = C.M.t type call_info = C.M.call_info type fct = F.fi type fct_info = F.t type t = fct_info Varinfo.Hashtbl.t let empty () = Varinfo.Hashtbl.create 10 let find_marks proj fct_var = try let f = Varinfo.Hashtbl.find proj fct_var in Some (F.get_idx f) with Not_found -> None let get proj pdg = let kf = PdgTypes.Pdg.get_kf pdg in let fct_var = Kernel_function.get_vi kf in try Varinfo.Hashtbl.find proj fct_var with Not_found -> let pdg = !Db.Pdg.get kf in let info = F.create pdg in Varinfo.Hashtbl.add proj fct_var info; info (** Add the marks to the pdg nodes. * @return a merge between the input [other_rqs] and the new requests produced. * *) let apply_fct_rqs proj (pdg, mark_list) other_rqs = match mark_list with | PdgMarks.SelList [] | PdgMarks.SelTopMarks [] -> (* don't want to build the marks when calling [get] if there is nothing to do... *) other_rqs | PdgMarks.SelList mark_list -> let fm = get proj pdg in let to_prop = F.mark_and_propagate fm mark_list in let rqs = translate_marks_to_prop pdg to_prop ~in_m2m:C.mark_to_prop_to_caller_input ~out_m2m:C.mark_to_prop_to_called_output other_rqs in rqs | PdgMarks.SelTopMarks _marks -> (* TODO #345 *) Pdg_parameters.not_yet_implemented "mark propagation in Top PDG" (** Add the marks to the pdg nodes and also apply all the produced requests * to do the interprocedural propagation. *) let mark_and_propagate proj pdg node_marks = let rec apply_all rqs = match rqs with | [] -> () | rq :: tl_rqs -> let new_rqs = apply_fct_rqs proj rq tl_rqs in apply_all new_rqs in apply_all [(pdg, PdgMarks.SelList node_marks)] end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/dummy/0000755000175000017500000000000012155634040015717 5ustar mehdimehdiframa-c-Fluorine-20130601/src/dummy/hello_world/0000755000175000017500000000000012155634040020231 5ustar mehdimehdiframa-c-Fluorine-20130601/src/dummy/hello_world/hello_world.ml0000644000175000017500000000624612155630234023106 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** The traditional 'Hello world!' plugin. It contains one boolean state [Enabled] which can be set by the command line option "-hello". When this option is set it just pretty prints a message on the standard output. *) (** Register the new plug-in "Hello World" and provide access to some plug-in dedicated features. *) module Self = Plugin.Register (struct let name = "Hello world" let shortname = "hello" let help = "The famous 'Hello world' plugin" end) (** Register the new Frama-C option "-hello". *) module Enabled = Self.False (struct let option_name = "-hello" let help = "pretty print \"Hello world!\"" end) let print () = Self.result "Hello world!" (** The function [print] below is not mandatory: you can ignore it in a first reading. It provides an API for the plug-in, so that the function [run] is callable by another plug-in and journalized: first, each plug-in can call [Dynamic.get "Hello.run" (Datatype.func Datatype.unit Datatype.unit)] in order to call [print] and second, each call to [print] is written in the Frama-C journal. *) let print = Dynamic.register ~comment:"[Dynamic.get \"Hello.run\" (Datatype.func Datatype.unit \ Datatype.unit)] calls [run] and pretty prints \"Hello world!\"" ~plugin:"Hello" "run" ~journalize:true (Datatype.func Datatype.unit Datatype.unit) print (** Print 'Hello World!' whenever the option is set. *) let run () = if Enabled.get () then print () (** Register the function [run] as a main entry point. *) let () = Db.Main.extend run frama-c-Fluorine-20130601/src/dummy/hello_world/Makefile0000644000175000017500000000363312155630234021677 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## # Example of Makefile for dynamic plugins ######################################### # Frama-c should be properly installed with "make install" # before any use of this makefile FRAMAC_SHARE :=$(shell frama-c.byte -print-path) FRAMAC_LIBDIR :=$(shell frama-c.byte -print-libpath) PLUGIN_NAME = Hello PLUGIN_CMO = hello_world include $(FRAMAC_SHARE)/Makefile.dynamic frama-c-Fluorine-20130601/src/dummy/untyped_metrics/0000755000175000017500000000000012155634040021135 5ustar mehdimehdiframa-c-Fluorine-20130601/src/dummy/untyped_metrics/count_for.ml0000644000175000017500000000550212155630235023471 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Counting for loops on the untyped AST. *) module Self = Plugin.Register (struct let name = "For loops counter" let shortname = "for_counter" let module_name = "Untyped_metrics.Count_for.Self" let help = "For counter on untyped AST" let is_dynamic = true end) module Enabled = Self.False (struct let module_name = "Count_for.Enabled" let option_name = "-count-for" let help = "count the for loops" end) open Cabs class count_for = object inherit Cabsvisit.nopCabsVisitor as super val mutable counted_for = 0 method counted_for = counted_for method vstmt s = begin match s.stmt_node with | FOR _ -> counted_for <- counted_for + 1 | _ -> () end; super#vstmt s end let count_for (fname,_ as file) = let counter = new count_for in ignore (Cabsvisit.visitCabsFile (counter:>Cabsvisit.cabsVisitor) file); fname,counter#counted_for let print_stat (fname,n) = Format.printf "%s: %d@." fname n let startup _ = if Enabled.get () then begin let untyped_files = Ast.UntypedFiles.get () in let stats = List.map count_for untyped_files in List.iter print_stat stats end let () = Db.Main.extend startup frama-c-Fluorine-20130601/src/dummy/untyped_metrics/Makefile0000644000175000017500000000332712155630235022604 0ustar mehdimehdi########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## # Generic Makefile for bytecode plugins FRAMAC_SHARE=$(shell frama-c -print-path) PLUGIN_NAME=Untyped_metrics PLUGIN_CMO=count_for include $(FRAMAC_SHARE)/Makefile.dynamic frama-c-Fluorine-20130601/src/postdominators/0000755000175000017500000000000012155634040017651 5ustar mehdimehdiframa-c-Fluorine-20130601/src/postdominators/postdominators_parameters.mli0000644000175000017500000000334412155630171025671 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.General_services module DotPostdomBasename: Plugin.String (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/postdominators/postdominators_parameters.ml0000644000175000017500000000402312155630171025513 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.Register (struct let name = "postdominators" let shortname = "postdominators" 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 in basename.f.dot" end) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/postdominators/compute.ml0000644000175000017500000002731612155630171021671 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 module DomKernel = Plugin.Register (struct let name = "dominators" let shortname = "dominators" let help = "Compute dominators and postdominators of statements" end) module DomSet = struct 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.Hptset.inter v v') let add v d = match d with | Top -> Top | Value d -> Value (Stmt.Hptset.add v d) let mem v = function | Top -> true | Value d -> Stmt.Hptset.mem v d let map f = function | Top -> Top | Value set -> Value (f set) include Datatype.Make (struct 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 (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) module Dom = Cil_state_builder.Stmt_hashtbl (DomSet) (struct let name = "dominator" let dependencies = [ Ast.self ] let size = 503 end) module DomComputer = struct let name = "dominators" let debug = ref false type t = DomSet.t module StmtStartData = Dom let pretty = DomSet.pretty let copy (s:t) = s let computeFirstPredecessor _stmt _set = assert false let combinePredecessors stmt ~old new_ = let new_ = DomSet.add stmt new_ in let set = DomSet.inter old new_ in if DomSet.equal set old then None else Some set let doStmt _stmt _set = Dataflow.SDefault let doInstr stmt _instr set = Dataflow.Done (DomSet.add stmt set) let stmt_can_reach _ _ = true let filterStmt _stmt = true let doGuard _ _ _ = Dataflow.GDefault, Dataflow.GDefault let doEdge _ _ d = d end module DomCompute = Dataflow.Forwards(DomComputer) let compute_dom kf = let start = Kernel_function.find_first_stmt kf in try let _ = Dom.find start in DomKernel.feedback ~level:2 "computed for function %a" Kernel_function.pretty kf; with Not_found -> 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 _ -> DomKernel.fatal "cannot compute for a leaf function %a" Kernel_function.pretty kf in List.iter (fun s -> Dom.add s DomSet.Top) stmts; Dom.replace start (DomSet.Value (Stmt.Hptset.singleton start)); DomCompute.compute [start]; DomKernel.feedback ~level:2 "done for function %a" Kernel_function.pretty kf let get_stmt_dominators f stmt = let do_it () = Dom.find stmt in try do_it () with Not_found -> compute_dom f; do_it () let stmt_dominators f stmt = match get_stmt_dominators f stmt with | DomSet.Value s -> s | DomSet.Top -> raise Db.Dominators.Top let is_dominator f ~opening ~closing = let dominators = get_stmt_dominators f closing in DomSet.mem opening dominators let display_dom () = Dom.iter (fun k v -> DomKernel.result "Stmt:%d@\n%a@\n======" k.sid DomSet.pretty v) (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) 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 val dependencies: State.t list val name: string end module MakePostDom(X: MakePostDomArg) = struct module PostDom = Cil_state_builder.Stmt_hashtbl (DomSet) (struct let name = "postdominator." ^ X.name let dependencies = Ast.self :: X.dependencies let size = 503 end) module PostComputer = struct let name = "postdominator" let debug = ref false type t = DomSet.t module StmtStartData = PostDom let pretty = DomSet.pretty 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 combineSuccessors = DomSet.inter 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) 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 let stmt_can_reach _ _ = true 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 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 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) 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 end) (Db.PostdominatorsValue) 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 (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/postdominators/print.ml0000644000175000017500000001302612155630171021342 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 let pretty_stmt fmt s = let key = PdgIndex.Key.stmt_key s in !Db.Pdg.pretty_key fmt key module Printer = struct 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 end module E = struct type t = (V.t * V.t) let src e = fst e let dst e = snd e end let iter_vertex f (_, graph) = let do_s ki postdom = let s = match ki with Kstmt s -> s | _ -> assert false in Postdominators_parameters.debug "iter_vertex %d : %a\n" s.sid V.pretty s; let has_postdom = match postdom with None -> false | _ -> true in f (s, has_postdom) in Kinstr.Hashtbl.iter do_s graph let iter_edges_e f (_, graph) = let do_s ki postdom = let s = match ki with Kstmt s -> s | _ -> assert false in match postdom with None -> () | Some postdom -> let do_edge p = f ((s, true), (p, true)) in Stmt.Hptset.iter do_edge postdom in Kinstr.Hashtbl.iter do_s graph let vertex_name (s, _) = string_of_int s.sid let graph_attributes (title, _) = [`Label title] let default_vertex_attributes _g = [`Style `Filled] let default_edge_attributes _g = [] let vertex_attributes (s, has_postdom) = let attrib = [] in let txt = Pretty_utils.sfprintf "%a" V.pretty s in let attrib = (`Label txt) :: attrib in let color = if has_postdom then 0x7FFFD4 else 0xFF0000 in let attrib = (`Shape `Box) :: attrib in let attrib = (`Fillcolor color) :: attrib in attrib let edge_attributes _s = [] let get_subgraph _v = None end module PostdomGraph = Graph.Graphviz.Dot(Printer) let get_postdom kf graph s = try match Kinstr.Hashtbl.find graph (Kstmt s) with | None -> Stmt.Hptset.empty | Some l -> l with Not_found -> try let postdom = !Db.Postdominators.stmt_postdominators kf s in let postdom = Stmt.Hptset.remove s postdom in Postdominators_parameters.debug "postdom for %d:%a = %a\n" s.sid pretty_stmt s Stmt.Hptset.pretty postdom; Kinstr.Hashtbl.add graph (Kstmt s) (Some postdom); postdom with Db.PostdominatorsTypes.Top -> Kinstr.Hashtbl.add graph (Kstmt s) None; raise Db.PostdominatorsTypes.Top (** [s_postdom] are [s] postdominators, including [s]. * We don't have to represent the relation between s and s. * And because the postdom relation is transitive, if [p] is in [s_postdom], * we can remove [p_postdom] from [s_postdom] in order to have a clearer graph. *) let reduce kf graph s = let remove 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.Hptset.diff s_postdom p_postdom in s_postdom 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.Hptset.fold remove postdom postdom in Postdominators_parameters.debug "new postdom for %d:%a = %a\n" s.sid pretty_stmt s Stmt.Hptset.pretty postdom; Kinstr.Hashtbl.replace graph (Kstmt s) (Some postdom) with Db.PostdominatorsTypes.Top -> () let build_reduced_graph kf graph stmts = List.iter (reduce kf graph) stmts let build_dot filename kf = 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 let name = Kernel_function.get_name kf in let title = "Postdominators for function " ^ name in let file = open_out filename in PostdomGraph.output_graph file (title, graph); close_out file (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/postdominators/Postdominators.mli0000644000175000017500000000342312155630171023404 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* $Id: Postdominators.mli,v 1.5 2008-04-01 09:25:21 uid568 Exp $ *) (** Postdominators analysis. *) (** No function is directly exported: they are registered in {!Db.Postdominators}. *) frama-c-Fluorine-20130601/src/wp/0000755000175000017500000000000012155634043015215 5ustar mehdimehdiframa-c-Fluorine-20130601/src/wp/normAtLabels.ml0000644000175000017500000002252512155630215020135 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 (Cil.copy_visit (Project.current ())) 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 frama-c-Fluorine-20130601/src/wp/Cfloat.ml0000644000175000017500000001475712155630215016772 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Floats Arithmetic Model --- *) (* -------------------------------------------------------------------------- *) open Qed open Lang open Lang.F (* -------------------------------------------------------------------------- *) (* --- Library --- *) (* -------------------------------------------------------------------------- *) let theory = "cfloat" let result = Logic.Sreal let params = [Logic.Sreal] let binop = [Logic.Sreal;Logic.Sreal] let make_fun_float name = Ctypes.fmemo (fun f -> extern_f ~theory ~result ~params "%s_%a" name Ctypes.pp_float f) let make_pred_float name = Ctypes.fmemo (fun f -> extern_f ~theory ~result ~params "%s_%a" name Ctypes.pp_float f) let f_of_int = extern_f ~theory:"qed" ~result "real_of_int" let r_opp = extern_f ~theory ~result ~params "ropp" let r_add = extern_f ~theory ~result ~params:binop "radd" let r_sub = extern_f ~theory ~result ~params:binop "rsub" let r_mul = extern_f ~theory ~result ~params:binop "rmul" let r_div = extern_f ~theory ~result ~params:binop "rdiv" let apply2 f x y = e_fun f [x;y] (* -------------------------------------------------------------------------- *) (* --- Model Setting --- *) (* -------------------------------------------------------------------------- *) type model = Real | Float let model = Context.create ~default:Real "Cfloat.model" (* -------------------------------------------------------------------------- *) (* --- Litterals --- *) (* -------------------------------------------------------------------------- *) let code_lit f = match Context.get model with | Real -> e_mthfloat f | Float -> e_hexfloat f let acsl_lit = let open Cil_types in function { r_literal ; r_nearest } -> match Context.get model with | Float -> let n = String.length r_literal in let suffixed = n > 0 && match r_literal.[n-1] with 'f' | 'F' | 'd' | 'D' | 'l' | 'L' -> true | _ -> false in if suffixed then e_hexfloat r_nearest else e_real (R.of_string r_literal) | Real -> e_mthfloat r_nearest (* -------------------------------------------------------------------------- *) (* --- Conversion Symbols --- *) (* -------------------------------------------------------------------------- *) let fconvert f a = match Context.get model with | Real -> a | Float -> e_fun (make_fun_float "to" f) [a] let real_of_int a = e_fun f_of_int [a] let float_of_int f a = fconvert f (real_of_int a) let frange f a = p_call (make_pred_float "is" f) [a] let runop op f x = match Context.get model with | Real -> op x | Float -> e_fun f [x] let rbinop op f x y = match Context.get model with | Real -> op x y | Float -> e_fun f [x;y] let funop op f x = fconvert f (op x) let fbinop op name f x y = match Context.get model with | Real -> op x y | Float -> e_fun (make_fun_float name f) [x;y] (* -------------------------------------------------------------------------- *) (* --- Real Arithmetics --- *) (* -------------------------------------------------------------------------- *) let ropp = runop e_opp r_opp let radd = rbinop e_add r_add let rsub = rbinop e_sub r_sub let rmul = rbinop e_mul r_mul let rdiv = rbinop e_div r_div (* -------------------------------------------------------------------------- *) (* --- Float Arithmetics --- *) (* -------------------------------------------------------------------------- *) let fopp = funop e_opp let fadd = fbinop e_add "add" let fsub = fbinop e_sub "sub" let fmul = fbinop e_mul "mul" let fdiv = fbinop e_div "div" (* -------------------------------------------------------------------------- *) (* --- Float Simplifiers --- *) (* -------------------------------------------------------------------------- *) let compute_f_of_int = function | [e] -> begin match F.repr e with | Qed.Logic.Kint k -> let m = Z.to_string k in let r = R.of_string (m ^ ".0") in F.e_real r | _ -> raise Not_found end | _ -> raise Not_found let compute_r_opp = function | [e] -> begin match F.repr e with | Qed.Logic.Kreal r -> let r = R.to_string r in let s = if r.[0] = '-' then String.sub r 1 (String.length r -1) else "-" ^ r in e_real (R.of_string s) | _ -> raise Not_found end | _ -> raise Not_found let () = begin F.add_builtin f_of_int compute_f_of_int ; F.add_builtin r_opp compute_r_opp ; end (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/wpReport.mli0000644000175000017500000000466112155630215017546 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 fcstat val fcstat : unit -> fcstat val export : fcstat -> string -> unit (** Export Statistics. Patterns for formatting: - ["%{cmd:arg}"] or "%cmd:arg" - ["%{cmd}"] or ["%cmd"] Patterns in [fct]: - ["%kf"] or ["%kf:name"] the name of the function. - ["%kf:"] the stats in format [] for the function. - ["%

    :"] the stats in format [] for prover [

    ]. Patterns in [main]: - "%" the global statistics with format []. Prover strings are ["wp"], ["ergo"], ["coq"] , ["z3"] and ["simplify"]. Format strings are "100" (percents of valid upon total, default), ["total"], ["valid"] and ["failed"] for respective number of verification conditions. Zero is printed as [zero]. Percentages are printed in decimal ["dd.d"]. *) frama-c-Fluorine-20130601/src/wp/wpStrategy.mli0000644000175000017500000002521612155630215020074 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 -> LogicUsage.logic_lemma -> 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 is_default_behavior : strategy -> bool val cfg_of_strategy : strategy -> Cil2cfg.t val get_kf : strategy -> kernel_function val get_bhv : strategy -> string option 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 (** 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) (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/GuiList.mli0000644000175000017500000000456512155630215017307 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- PO List View --- *) (* -------------------------------------------------------------------------- *) class pane : GuiConfig.provers -> object method show : Wpo.t -> unit method on_click : (Wpo.t -> VCS.prover option -> unit) -> unit method on_double_click : (Wpo.t -> VCS.prover option -> unit) -> unit method reload : unit method update : Wpo.t -> unit method update_all : unit method count_selected : int method on_selection : (int -> unit) -> unit method iter_selected : (Wpo.t -> unit) -> unit method add : Wpo.t -> unit method size : int method index : Wpo.t -> int method get : int -> Wpo.t method coerce : GObj.widget end frama-c-Fluorine-20130601/src/wp/LogicAssigns.ml0000644000175000017500000000765712155630215020150 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Ctypes open Lang open Lang.F open Memory module type Code = sig type loc val equal_obj : c_object -> loc value -> loc value -> F.pred end module type Logic = sig type loc val vars : loc Memory.sloc list -> Vars.t val pp_logic : Format.formatter -> loc Memory.logic -> unit val pp_sloc : Format.formatter -> loc Memory.sloc -> unit val pp_region : Format.formatter -> loc Memory.sloc list -> unit end module Make ( M : Memory.Model ) ( C : Code with type loc = M.loc ) ( L : Logic with type loc = M.loc ) = struct open M module Hmap = Heap.Map module Dom = Heap.Set type region = (c_object * loc sloc list) list (* -------------------------------------------------------------------------- *) (* --- Domain --- *) (* -------------------------------------------------------------------------- *) let vars (r:region) = List.fold_left (fun xs (_,s) -> Vars.union xs (L.vars s)) Vars.empty r let dsloc obj = function | Sloc l | Sdescr(_,l,_) -> M.domain obj l | Srange(l,obj,_,_) | Sarray(l,obj,_) -> M.domain obj l let domain (r:region) = List.fold_left (fun d (obj,slocs) -> List.fold_left (fun d sloc -> Dom.union d (dsloc obj sloc)) d slocs ) Dom.empty r (* -------------------------------------------------------------------------- *) (* --- Assignation --- *) (* -------------------------------------------------------------------------- *) let rec assigned_seq hs s = function | [] -> Bag.concat (M.Sigma.assigned s.pre s.post Dom.empty) hs | [obj,sloc] -> let hs_sloc = Bag.list (M.assigned s obj sloc) in let hs_sdom = M.Sigma.assigned s.pre s.post (dsloc obj sloc) in Bag.concat (Bag.concat hs_sloc hs_sdom) hs | (obj,sloc)::tail -> let sigma = M.Sigma.havoc s.post (dsloc obj sloc) in let s_local = { pre = sigma ; post = s.post } in let s_other = { pre = s.pre ; post = sigma } in let hs_sloc = Bag.list (M.assigned s_local obj sloc) in assigned_seq (Bag.concat hs_sloc hs) s_other tail let assigned (s:sigma sequence) (r:region) = let hs = assigned_seq Bag.empty s begin List.fold_left (fun w (obj,slocs) -> List.fold_left (fun w sloc -> (obj,sloc) :: w) w slocs ) [] r end in Bag.elements hs end frama-c-Fluorine-20130601/src/wp/rformat.mll0000644000175000017500000001425312155630215017377 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Fast Report for WP --- *) (* -------------------------------------------------------------------------- *) { (* -------------------------------------------------------------------------- *) (* --- Time Utilities --- *) (* -------------------------------------------------------------------------- *) let epsilon = 0.0005 let get_time ladder t = let rec dicho ladder t i j = let k = (i+j)/2 in if i=k then j else let d = ladder.(k) in if t < d then dicho ladder t i k else if t > d then dicho ladder t k j else k in if t <= ladder.(0) then 0 else let n = Array.length ladder in if t > ladder.(n-1) then n else dicho ladder t 0 (n-1) let rdiv t n = let d = floor (t /. n) in let r = t -. d *. n in d , r let pp_time fmt t = if t < 1.0 then Format.fprintf fmt "%dms" (truncate (t *. 1000.0 +. 0.5)) else if t < 60.0 then let dt = t -. floor t in if dt < 0.1 then Format.fprintf fmt "%.0fs" t else Format.fprintf fmt "%.1fs" t else if t < 3600.0 then let minutes,seconds = rdiv t 60.0 in if seconds < 1.0 then Format.fprintf fmt "%d'" (truncate minutes) else Format.fprintf fmt "%d'%ds" (truncate minutes) (truncate seconds) else let hours,seconds = rdiv t 3600.0 in let minutes,_ = rdiv seconds 60.0 in if minutes < 1.0 then Format.fprintf fmt "%dh" (truncate hours) else Format.fprintf fmt "%dh%d'" (truncate hours) (truncate minutes) let pp_time_range ladder fmt t = let k = get_time ladder t in let n = Array.length ladder in if k > n then Format.fprintf fmt ">%a" pp_time ladder.(n-1) else pp_time fmt ladder.(k) (* -------------------------------------------------------------------------- *) (* --- Formatters Syntax --- *) (* -------------------------------------------------------------------------- *) type command = | CMD of string | ARG of string * string | TEXT type console = { env : (Format.formatter -> string -> string -> unit) ; line : Buffer.t ; mutable spaces : int ; fline : Format.formatter ; foutput : Format.formatter ; } let spaces = String.make 80 ' ' let rec add_spaces buffer n = if n > 0 then if n < 80 then Buffer.add_substring buffer spaces 0 n else ( Buffer.add_string buffer spaces ; add_spaces buffer (n-80) ) let spaces console = begin Format.pp_print_flush console.fline () ; if console.spaces > 0 then ( add_spaces console.line console.spaces ; console.spaces <- 0 ) ; end let flush console = begin spaces console ; Format.pp_print_string console.foutput (Buffer.contents console.line) ; Buffer.clear console.line ; end let write console text = spaces console ; Buffer.add_string console.line text let env console cmd arg = spaces console ; console.env console.fline cmd arg } let blank = [ ' ' '\t' ] let number = [ '0'-'9' ]+ let ident = [ 'a'-'z' 'A'-'Z' '-' '0'-'9' ]+ rule word console = parse eof { flush console } | '\n' { flush console ; Format.pp_print_newline console.foutput () ; word console lexbuf } | ' ' { console.spaces <- succ console.spaces ; word console lexbuf } | "&&" { write console "&" ; word console lexbuf } | "%%" { write console "%" ; word console lexbuf } | '&' (number as arg) ':' { Format.pp_print_flush console.fline () ; add_spaces console.line (int_of_string arg - Buffer.length console.line) ; console.spaces <- 0 ; word console lexbuf } | "%{" (ident as cmd) ':' (ident as arg) '}' | '%' (ident as cmd) ':' (ident as arg) { env console cmd arg ; word console lexbuf } | "%{" (ident as cmd) "}" | '%' (ident as cmd) { env console cmd "" ; word console lexbuf } | _ { write console (Lexing.lexeme lexbuf) ; word console lexbuf } and command = parse | blank* '@' (ident as cmd) blank* { CMD cmd } | blank* '@' (ident as cmd) blank+ '"' ([^ '"']* as arg) '"' blank* { ARG(cmd,arg) } | _ { TEXT } { let pretty env fmt msg = let lexbuf = Lexing.from_string msg in let line = Buffer.create 80 in word { line = line ; fline = Format.formatter_of_buffer line ; foutput = fmt ; env = env ; spaces = 0 ; } lexbuf let command msg = let lexbuf = Lexing.from_string msg in command lexbuf } frama-c-Fluorine-20130601/src/wp/Warning.ml0000644000175000017500000001302012155630215017145 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Warning Manager --- *) (* -------------------------------------------------------------------------- *) module SELF = struct type t = { loc : Lexing.position ; severe : bool ; source : string ; reason : string ; effect : string ; } let compare w1 w2 = if w1 == w2 then 0 else let f1 = w1.loc.Lexing.pos_fname in let f2 = w2.loc.Lexing.pos_fname in let fc = String.compare f1 f2 in if fc <> 0 then fc else let l1 = w1.loc.Lexing.pos_lnum in let l2 = w2.loc.Lexing.pos_lnum in let lc = l1 - l2 in if lc <> 0 then lc else match w1.severe , w2.severe with | true , false -> (-1) | false , true -> 1 | _ -> Pervasives.compare w1 w2 end include SELF module Map = Map.Make(SELF) module Set = Set.Make(SELF) let severe s = Set.exists (fun w -> w.severe) s let pretty fmt w = begin Format.fprintf fmt "@[%s:%d: warning from %s:@\n" w.loc.Lexing.pos_fname w.loc.Lexing.pos_lnum w.source ; if w.severe then Format.fprintf fmt " - Warning: %s, looking for context inconsistency" w.effect else Format.fprintf fmt " - Warning: %s" w.effect ; Format.fprintf fmt "@\n Reason: %s@]" w.reason ; end type collector = { default : string ; mutable warnings : Set.t ; } let collector : collector Context.value = Context.create "Warning" let default () = (Context.get collector).default (* -------------------------------------------------------------------------- *) (* --- Contextual Errors --- *) (* -------------------------------------------------------------------------- *) exception Error of string * string (* source , reason *) let error ?(source="wp") text = let buffer = Buffer.create 120 in Format.kfprintf (fun fmt -> Format.pp_print_flush fmt () ; let text = Buffer.contents buffer in if Context.defined collector then raise (Error (source,text)) else Wp_parameters.abort ~current:true "%s" text ) (Format.formatter_of_buffer buffer) text (* -------------------------------------------------------------------------- *) (* --- Contextual Errors --- *) (* -------------------------------------------------------------------------- *) type context = collector option let context ?(source="wp") () = Context.push collector { default = source ; warnings = Set.empty } let flush old = let c = Context.get collector in Context.pop collector old ; c.warnings let add w = Wp_parameters.warning ~source:w.loc "%s" w.reason ~once:true ; let c = Context.get collector in c.warnings <- Set.add w c.warnings let emit ?(severe=false) ?source ~effect message = let source = match source with Some s -> s | None -> default () in let buffer = Buffer.create 80 in Format.kfprintf (fun fmt -> Format.pp_print_flush fmt () ; let text = Buffer.contents buffer in let loc = Cil_const.CurrentLoc.get () in add { loc = fst loc ; severe = severe ; source = source ; effect = effect ; reason = text ; }) (Format.formatter_of_buffer buffer) message let handle ?(severe=false) ~effect ~handler cc x = try cc x with Error(source,reason) -> if Context.defined collector then ( emit ~severe ~source ~effect "%s" reason ; handler x ) else if source <> "wp" then Wp_parameters.fatal ~current:true "[%s] %s" source reason else Wp_parameters.fatal ~current:true "%s" reason type 'a outcome = | Result of Set.t * 'a | Failed of Set.t let catch ?source ?(severe=true) ~effect cc x = let wrn = context ?source () in try let y = cc x in Result(flush wrn,y) (* DO NOT inline this let *) with Error(source,reason) -> emit ~severe ~source ~effect "%s" reason ; Failed (flush wrn) frama-c-Fluorine-20130601/src/wp/LogicCompiler.ml0000644000175000017500000006427412155630215020311 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Compilation of ACSL Logic-Info --- *) (* -------------------------------------------------------------------------- *) open LogicUsage open LogicBuiltins open Cil_types open Cil_datatype open Clabels open Ctypes open Lang open Lang.F open Memory open Definitions module Make( M : Memory.Model ) = struct (* -------------------------------------------------------------------------- *) (* --- Definitions --- *) (* -------------------------------------------------------------------------- *) open M type value = M.loc Memory.value type logic = M.loc Memory.logic type sigma = M.Sigma.t type chunk = M.Chunk.t type signature = | CST of Qed.Z.t | SIG of sig_param list and sig_param = | Sig_value of logic_var (* to be replaced by the value *) | Sig_chunk of chunk * c_label (* to be replaced by the chunk variable *) (* -------------------------------------------------------------------------- *) (* --- Utilities --- *) (* -------------------------------------------------------------------------- *) let rec wrap_lvar xs vs = match xs , vs with | x::xs , v::vs -> Logic_var.Map.add x v (wrap_lvar xs vs) | _ -> Logic_var.Map.empty let rec wrap_var xs vs = match xs , vs with | x::xs , v::vs -> Varinfo.Map.add x v (wrap_var xs vs) | _ -> Varinfo.Map.empty let rec wrap_mem = function | (label,mem) :: m -> LabelMap.add label mem (wrap_mem m) | [] -> LabelMap.empty let fresh_lvar ?basename ltyp = let tau = Lang.tau_of_ltype ltyp in let x = Lang.freshvar ?basename tau in let p = Cvalues.has_ltype ltyp (e_var x) in Lang.assume p ; x let fresh_cvar ?basename typ = fresh_lvar ?basename (Ctype typ) (* -------------------------------------------------------------------------- *) (* --- Logic Frame --- *) (* -------------------------------------------------------------------------- *) type frame = { name : string ; pool : pool ; gamma : gamma ; kf : kernel_function option ; formals : value Varinfo.Map.t ; types : string list ; mutable triggers : trigger list ; mutable labels : sigma LabelMap.t ; mutable result : var option ; mutable status : var option ; } let pp_frame fmt f = begin Format.fprintf fmt "Frame '%s':@\n" f.name ; LabelMap.iter (fun l m -> Format.fprintf fmt "@[Label '%a': %a@]@\n" Clabels.pretty l Sigma.pretty m ) f.labels ; end (* -------------------------------------------------------------------------- *) (* --- Frames Builders --- *) (* -------------------------------------------------------------------------- *) let logic_frame a types = { name = a ; pool = Lang.new_pool () ; gamma = Lang.new_gamma () ; formals = Varinfo.Map.empty ; types = types ; triggers = [] ; kf = None ; result = None ; status = None ; labels = LabelMap.empty ; } let frame kf = { name = Kernel_function.get_name kf ; types = [] ; pool = Lang.new_pool () ; gamma = Lang.new_gamma () ; formals = Varinfo.Map.empty ; triggers = [] ; kf = Some kf ; result = None ; status = None ; labels = LabelMap.empty ; } let call_pre kf vs mem = { name = "Pre " ^ Kernel_function.get_name kf ; types = [] ; pool = Lang.get_pool () ; gamma = Lang.get_gamma () ; formals = wrap_var (Kernel_function.get_formals kf) vs ; triggers = [] ; kf = None ; result = None ; status = None ; labels = wrap_mem [ Clabels.Pre , mem ] ; } let call_post kf vs seq = { name = "Post " ^ Kernel_function.get_name kf ; types = [] ; pool = Lang.get_pool () ; gamma = Lang.get_gamma () ; formals = wrap_var (Kernel_function.get_formals kf) vs ; triggers = [] ; kf = Some kf ; result = None ; status = None ; labels = wrap_mem [ Clabels.Pre , seq.pre ; Clabels.Post , seq.post ] ; } let frame_copy f = { f with pool = Lang.new_pool ~copy:f.pool () ; gamma = Lang.new_gamma ~copy:f.gamma () ; labels = LabelMap.map Sigma.copy f.labels ; } (* -------------------------------------------------------------------------- *) (* --- Current Frame --- *) (* -------------------------------------------------------------------------- *) let cframe : frame Context.value = Context.create "LogicSemantics.frame" let get_frame () = Context.get cframe let in_frame f cc = Context.bind Lang.poly f.types (Context.bind cframe f (Lang.local ~pool:f.pool ~gamma:f.gamma cc)) let mem_at_frame frame label = assert (label <> Clabels.Here) ; try LabelMap.find label frame.labels with Not_found -> let s = M.Sigma.create () in frame.labels <- LabelMap.add label s frame.labels ; s let mem_frame label = mem_at_frame (Context.get cframe) label let formal x = let f = Context.get cframe in try Some (Varinfo.Map.find x f.formals) with Not_found -> None let return () = let f = Context.get cframe in match f.kf with | None -> Wp_parameters.fatal "No function in frame '%s'" f.name | Some kf -> if Kernel_function.returns_void kf then Wp_parameters.fatal "No result in frame '%s'" f.name ; Kernel_function.get_return_type kf let result () = let f = Context.get cframe in match f.result with | Some x -> x | None -> match f.kf with | None -> Wp_parameters.fatal "No function in frame '%s'" f.name | Some kf -> if Kernel_function.returns_void kf then Wp_parameters.fatal "No result in frame '%s'" f.name ; let tr = Kernel_function.get_return_type kf in let basename = Kernel_function.get_name kf in let x = fresh_cvar ~basename tr in f.result <- Some x ; x let status () = let f = Context.get cframe in match f.status with | Some x -> x | None -> let x = fresh_cvar ~basename:"status" Cil.intType in f.status <- Some x ; x let trigger tg = if tg <> Qed.Engine.TgAny then let f = Context.get cframe in f.triggers <- tg :: f.triggers let guards f = Lang.hypotheses f.gamma (* -------------------------------------------------------------------------- *) (* --- Environments --- *) (* -------------------------------------------------------------------------- *) type env = { vars : logic Logic_var.Map.t ; (* pure : not cvar *) lhere : sigma option ; current : sigma option ; } let plain_of_exp lt e = if Logic_typing.is_set_type lt then let te = Logic_typing.type_of_set_elem lt in Vset [Vset.Set(tau_of_ltype te,e)] else Vexp e let new_env lvars = let lvars = List.fold_left (fun lvars lv -> let x = fresh_lvar ~basename:lv.lv_name lv.lv_type in let v = Vexp(e_var x) in Logic_var.Map.add lv v lvars) Logic_var.Map.empty lvars in { lhere = None ; current = None ; vars = lvars } let sigma e = match e.current with Some s -> s | None -> Warning.error "No current memory (missing \\at)" let move env s = { env with lhere = Some s ; current = Some s } let env_at env label = let s = match label with | Clabels.Here -> env.lhere | label -> Some(mem_frame label) in { env with current = s } let mem_at env label = match label with | Clabels.Here -> sigma env | _ -> mem_frame label let env_let env x v = { env with vars = Logic_var.Map.add x v env.vars } let env_letval env x = function | Loc l -> env_let env x (Vloc l) | Val e -> env_let env x (plain_of_exp x.lv_type e) (* -------------------------------------------------------------------------- *) (* --- Generic Compiler --- *) (* -------------------------------------------------------------------------- *) let param_of_lv lv = let t = Lang.tau_of_ltype lv.lv_type in freshvar ~basename:lv.lv_name t let rec profile_env vars sigv = function | [] -> { vars=vars ; lhere=None ; current=None } , List.rev sigv | lv :: profile -> let x = param_of_lv lv in let v = plain_of_exp lv.lv_type (e_var x) in profile_env (Logic_var.Map.add lv v vars) ((lv,x)::sigv) profile let default_label env = function | [l] -> move env (mem_frame (Clabels.c_label l)) | _ -> env let compile_step (name:string) (types:string list) (profile:logic_var list) (labels:logic_label list) (cc : env -> 'a -> 'b) (filter : 'b -> var -> bool) (data : 'a) : var list * trigger list * 'b * sig_param list = let frame = logic_frame name types in in_frame frame begin fun () -> let env,sigv = profile_env Logic_var.Map.empty [] profile in let env = default_label env labels in let result = cc env data in let used = List.filter (fun (_,x) -> filter result x) sigv in let parp = List.map snd used in let sigp = List.map (fun (lv,_) -> Sig_value lv) used in let (parm,sigm) = LabelMap.fold (fun label sigma -> Heap.Set.fold (fun chunk acc -> if filter result (Sigma.get sigma chunk) then let (parm,sigm) = acc in let x = Sigma.get sigma chunk in let s = Sig_chunk(chunk,label) in ( x::parm , s::sigm ) else acc) (Sigma.domain sigma)) frame.labels (parp,sigp) in parm , frame.triggers , result , sigm end () let cc_term : (env -> Cil_types.term -> term) ref = ref (fun _ _ -> assert false) let cc_pred : (bool -> env -> predicate named -> pred) ref = ref (fun _ _ -> assert false) let cc_logic : (env -> Cil_types.term -> logic) ref = ref (fun _ _ -> assert false) let cc_region : (env -> Cil_types.term -> loc sloc list) ref = ref (fun _ _ -> assert false) let term env t = !cc_term env t let pred positive env t = !cc_pred positive env t let logic env t = !cc_logic env t let region env t = !cc_region env t let reads env ts = List.iter (fun t -> ignore (logic env t.it_content)) ts let bootstrap_term cc = cc_term := cc let bootstrap_pred cc = cc_pred := cc let bootstrap_logic cc = cc_logic := cc let bootstrap_region cc = cc_region := cc let in_term t x = F.occurs x t let in_pred p x = F.occursp x p let in_reads _ _ = true let is_recursive l = if LogicUsage.is_recursive l then Rec else Def (* -------------------------------------------------------------------------- *) (* --- Registering User-Defined Signatures --- *) (* -------------------------------------------------------------------------- *) module Axiomatic = Model.Index (struct type key = string type data = unit let name = "LogicCompiler." ^ M.datatype ^ ".Axiomatic" let compare = String.compare let pretty = Format.pp_print_string end) module Signature = Model.Index (struct type key = logic_info type data = signature let name = "LogicCompiler." ^ M.datatype ^ ".Signature" let compare = Logic_info.compare let pretty fmt l = Logic_var.pretty fmt l.l_var_info end) (* -------------------------------------------------------------------------- *) (* --- Compiling Lemmas --- *) (* -------------------------------------------------------------------------- *) let compile_lemma cluster name ~assumed types labels lemma = let xs,tgs,prop,_ = compile_step name types [] labels (pred true) in_pred lemma in let xs,prop = Definitions.Trigger.plug [tgs] (p_forall xs prop) in { l_name = name ; l_types = List.length types ; l_assumed = assumed ; l_triggers = [tgs] ; l_forall = xs ; l_cluster = cluster ; l_lemma = prop ; } (* -------------------------------------------------------------------------- *) (* --- Type Signature of Logic Function --- *) (* -------------------------------------------------------------------------- *) let type_for_signature l ldef sigp = match l.l_type with | None -> () | Some tr -> match Cvalues.ldomain tr with | None -> () | Some p -> let name = "T" ^ Lang.logic_id l in let vs = List.map e_var ldef.d_params in let rec conditions vs sigp = match vs , sigp with | v::vs , Sig_value lv :: sigp -> let cond = Cvalues.has_ltype lv.lv_type v in cond :: conditions vs sigp | _ -> [] in let result = F.e_fun ldef.d_lfun vs in let lemma = p_hyps (conditions vs sigp) (p result) in let trigger = Trigger.of_term result in Definitions.define_lemma { l_name = name ; l_assumed = true ; l_types = ldef.d_types ; l_forall = ldef.d_params ; l_triggers = [[trigger]] ; l_cluster = ldef.d_cluster ; l_lemma = lemma ; } (* -------------------------------------------------------------------------- *) (* --- Compiling Pure Logic Function --- *) (* -------------------------------------------------------------------------- *) let compile_lbpure cluster l = let lfun = ACSL l in let tau = Lang.tau_of_return l in let parp = Lang.local (List.map param_of_lv) l.l_profile in let sigp = List.map (fun lv -> Sig_value lv) l.l_profile in let ldef = { d_lfun = lfun ; d_types = List.length l.l_tparams ; d_params = parp ; d_cluster = cluster ; d_definition = Logic tau ; } in Definitions.update_symbol ldef ; Signature.update l (SIG sigp) ; parp,sigp (* -------------------------------------------------------------------------- *) (* --- Compiling Abstract Logic Function (in axiomatic with no reads) --- *) (* -------------------------------------------------------------------------- *) let compile_lbnone cluster l vars = let lfun = ACSL l in let tau = Lang.tau_of_return l in let parp = Lang.local (List.map param_of_lv) l.l_profile in let sigp = List.map (fun lv -> Sig_value lv) l.l_profile in let (parm,sigm) = if vars = [] then (parp,sigp) else let heap = List.fold_left (fun m x -> let obj = object_of x.vtype in Heap.Set.union m (M.domain obj (M.cvar x)) ) Heap.Set.empty vars in List.fold_left (fun acc l -> let label = Clabels.c_label l in let sigma = Sigma.create () in Heap.Set.fold (fun chunk (parm,sigm) -> let x = Sigma.get sigma chunk in let s = Sig_chunk (chunk,label) in ( x::parm , s :: sigm ) ) heap acc ) (parp,sigp) l.l_labels in let ldef = { d_lfun = lfun ; d_types = List.length l.l_tparams ; d_params = parm ; d_cluster = cluster ; d_definition = Logic tau ; } in Definitions.define_symbol ldef ; type_for_signature l ldef sigp ; SIG sigm (* -------------------------------------------------------------------------- *) (* --- Compiling Logic Function with Reads --- *) (* -------------------------------------------------------------------------- *) let compile_lbreads cluster l ts = let lfun = ACSL l in let name = l.l_var_info.lv_name in let tau = Lang.tau_of_return l in let xs,_,(),s = compile_step name l.l_tparams l.l_profile l.l_labels reads in_reads ts in let ldef = { d_lfun = lfun ; d_types = List.length l.l_tparams ; d_params = xs ; d_cluster = cluster ; d_definition = Logic tau ; } in Definitions.define_symbol ldef ; type_for_signature l ldef s ; SIG s (* -------------------------------------------------------------------------- *) (* --- Compiling Recursive Logic Body --- *) (* -------------------------------------------------------------------------- *) let compile_rec name l cc filter data = let types = l.l_tparams in let profile = l.l_profile in let labels = l.l_labels in let result = compile_step name types profile labels cc filter data in if LogicUsage.is_recursive l then begin let (_,_,_,s) = result in Signature.update l (SIG s) ; compile_step name types profile labels cc filter data end else result (* -------------------------------------------------------------------------- *) (* --- Compiling Logic Function with Definition --- *) (* -------------------------------------------------------------------------- *) let compile_lbterm cluster l t = let name = l.l_var_info.lv_name in let tau = Lang.tau_of_return l in let xs,_,r,s = compile_rec name l term in_term t in match F.repr r with | Qed.Logic.Kint c -> CST c | _ -> let ldef = { d_lfun = ACSL l ; d_types = List.length l.l_tparams ; d_params = xs ; d_cluster = cluster ; d_definition = Value(tau,is_recursive l,r) ; } in Definitions.define_symbol ldef ; type_for_signature l ldef s ; SIG s (* -------------------------------------------------------------------------- *) (* --- Compiling Logic Predicate with Definition --- *) (* -------------------------------------------------------------------------- *) let compile_lbpred cluster l p = let lfun = ACSL l in let name = l.l_var_info.lv_name in let xs,_,r,s = compile_rec name l (pred true) in_pred p in let ldef = { d_lfun = lfun ; d_types = List.length l.l_tparams ; d_params = xs ; d_cluster = cluster ; d_definition = Predicate(is_recursive l,r) ; } in Definitions.define_symbol ldef ; SIG s let heap_case labels_used support = function | Sig_value _ -> support | Sig_chunk(chk,l_case) -> let l_ind = try LabelMap.find l_case labels_used with Not_found -> LabelSet.empty in let l_chk = try Heap.Map.find chk support with Not_found -> LabelSet.empty in Heap.Map.add chk (LabelSet.union l_chk l_ind) support (* -------------------------------------------------------------------------- *) (* --- Compiling Inductive Logic --- *) (* -------------------------------------------------------------------------- *) let compile_lbinduction cluster l cases = (* unused *) (* Temporarily defines l to reads only its formals *) let parp,sigp = compile_lbpure cluster l in (* Compile cases with default definition and collect used chunks *) let support = List.fold_left (fun support (case,labels,types,lemma) -> let _,_,_,s = compile_step case types [] labels (pred true) in_pred lemma in let labels_used = LogicUsage.get_induction_labels l case in List.fold_left (heap_case labels_used) support s) Heap.Map.empty cases in (* Make signature with collected chunks *) let (parm,sigm) = Heap.Map.fold (fun chunk labels acc -> let basename = Chunk.basename_of_chunk chunk in let tau = Chunk.tau_of_chunk chunk in LabelSet.fold (fun label (parm,sigm) -> let x = Lang.freshvar ~basename tau in x :: parm , Sig_chunk(chunk,label) :: sigm ) labels acc) support (parp,sigp) in (* Set global Signature *) let lfun = ACSL l in let ldef = { d_lfun = lfun ; d_types = List.length l.l_tparams ; d_params = parm ; d_cluster = cluster ; d_definition = Logic Qed.Logic.Prop ; } in Definitions.update_symbol ldef ; (* Re-compile final cases *) let cases = List.map (fun (case,labels,types,lemma) -> compile_lemma cluster ~assumed:true case types labels lemma) cases in Definitions.update_symbol { ldef with d_definition = Inductive cases } ; type_for_signature l ldef sigp (* sufficient *) ; SIG sigm let compile_logic cluster section l = let s_rec = List.map (fun x -> Sig_value x) l.l_profile in Signature.update l (SIG s_rec) ; match l.l_body with | LBnone -> let vars = match section with | Toplevel _ -> if l.l_labels <> [] then Wp_parameters.warning ~once:true ~current:false "No definition for '%s' interpreted as reads nothing" l.l_var_info.lv_name ; [] | Axiomatic a -> Varinfo.Set.elements a.ax_reads in compile_lbnone cluster l vars | LBterm t -> compile_lbterm cluster l t | LBpred p -> compile_lbpred cluster l p | LBreads ts -> compile_lbreads cluster l ts | LBinductive cases -> compile_lbinduction cluster l cases (* -------------------------------------------------------------------------- *) (* --- Retrieving Signature --- *) (* -------------------------------------------------------------------------- *) let define_type = Definitions.define_type let define_logic c a = Signature.compile (compile_logic c a) let define_lemma c l = if l.lem_labels <> [] && Wp_parameters.has_dkey "lemma" then Wp_parameters.warning ~source:l.lem_position "Lemma '%s' has labels, consider using global invariant instead." l.lem_name ; Definitions.define_lemma (compile_lemma c ~assumed:l.lem_axiom l.lem_name l.lem_types l.lem_labels l.lem_property) let define_axiomatic cluster ax = begin List.iter (define_type cluster) ax.ax_types ; List.iter (define_logic cluster (Axiomatic ax)) ax.ax_logics ; List.iter (define_lemma cluster) ax.ax_lemmas ; end let lemma l = try Definitions.find_lemma l with Not_found -> let section = LogicUsage.section_of_lemma l.lem_name in let cluster = Definitions.section section in begin match section with | Toplevel _ -> define_lemma cluster l | Axiomatic ax -> define_axiomatic cluster ax end ; Definitions.find_lemma l let signature phi = try Signature.find phi with Not_found -> let section = LogicUsage.section_of_logic phi in let cluster = Definitions.section section in match section with | Toplevel _ -> Signature.memoize (compile_logic cluster section) phi | Axiomatic ax -> (* force compilation of entire axiomatics *) define_axiomatic cluster ax ; try Signature.find phi with Not_found -> Wp_parameters.fatal ~current:true "Axiomatic '%s' compiled, but '%a' not" ax.ax_name Printer.pp_logic_var phi.l_var_info (* -------------------------------------------------------------------------- *) (* --- Binding Formal with Actual w.r.t Signature --- *) (* -------------------------------------------------------------------------- *) let rec bind_labels env labels : M.Sigma.t LabelMap.t = match labels with | [] -> LabelMap.empty | (l1,l2) :: labels -> let l1 = Clabels.c_label l1 in let l2 = Clabels.c_label l2 in LabelMap.add l1 (mem_at env l2) (bind_labels env labels) let call_params env (phi:logic_info) (labels:(logic_label * logic_label) list) (sparam : sig_param list) (parameters:F.term list) : F.term list = let mparams = wrap_lvar phi.l_profile parameters in let mlabels = bind_labels env labels in List.map (function | Sig_value lv -> Logic_var.Map.find lv mparams | Sig_chunk(c,l) -> M.Sigma.value (LabelMap.find l mlabels) c ) sparam let call_fun env (phi:logic_info) (labels:(logic_label * logic_label) list) (parameters:F.term list) : F.term = match signature phi with | CST c -> e_zint c | SIG sparam -> let es = call_params env phi labels sparam parameters in F.e_fun (ACSL phi) es let call_pred env (phi:logic_info) (labels:(logic_label * logic_label) list) (parameters:F.term list) : F.pred = match signature phi with | CST _ -> assert false | SIG sparam -> let es = call_params env phi labels sparam parameters in F.p_call (ACSL phi) es (* -------------------------------------------------------------------------- *) (* --- Variable Bindings --- *) (* -------------------------------------------------------------------------- *) let logic_var env x = try Logic_var.Map.find x env.vars with Not_found -> try let cst = Logic_env.find_logic_cons x in let v = match LogicBuiltins.logic cst with | ACSLDEF -> call_fun env cst [] [] | LFUN phi -> e_fun phi [] | CONST e -> e in plain_of_exp x.lv_type v with Not_found -> Wp_parameters.fatal "Unbound logic variable '%a'" Printer.pp_logic_var x end frama-c-Fluorine-20130601/src/wp/why3_session.mli0000644000175000017500000000651612155630215020362 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2013 -- INRIA - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** From the original file we kept only the reading of a session. We also discard all the information about how that have been proved (metas, transformation, proof_attempts) or the order of the goals *) (** {2 Proof attempts} *) type goal = private { goal_name : string; goal_parent : theory; mutable goal_verified : bool; } and theory = private { theory_name : string; theory_parent : file; theory_goals : goal Datatype.String.Hashtbl.t; mutable theory_verified : bool; } and file = private { file_name : string; file_format : string option; file_parent : session; file_theories: theory Datatype.String.Hashtbl.t; (** Not mutated after the creation *) mutable file_verified : bool; } and session = private { session_files : file Datatype.String.Hashtbl.t; session_dir : string; } (** {2 Read/Write} *) exception LoadError val read_session : string -> session (** Read a session stored on the disk. It returns a session without any task attached to goals *) frama-c-Fluorine-20130601/src/wp/wpFroms.mli0000644000175000017500000000366112155630215017360 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 * *) frama-c-Fluorine-20130601/src/wp/VarUsage.ml0000644000175000017500000007026612155630215017274 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Variable Analysis --- *) (* -------------------------------------------------------------------------- *) open Ctypes open Cil open Cil_types open Cil_datatype module WpMain = Wp_parameters let dkey = Wp_parameters.register_category "vardebug" (* -------------------------------------------------------------------------- *) (* --- Dimension Utilities --- *) (* -------------------------------------------------------------------------- *) exception NoSize let pp_box fmt = function | [] -> () | k::ks -> Format.fprintf fmt "%d" k ; List.iter (fun k -> Format.fprintf fmt ":%d" k) ks let pp_dim fmt ks = List.iter (fun k -> Format.fprintf fmt "[%d]" k) ks let size_of_char c = match Cil.charConstToInt c with | CInt64(k,_,_) -> k | _ -> raise NoSize let size e = match (Cil.constFold true e).enode with | Const(CInt64(k,_,_)) -> k | Const(CChr c) -> size_of_char c | _ -> raise NoSize let size_int e = Integer.to_int (size e) let _merge_dim ds1 ds2 = (* Unused *) if ds1=[] then ds2 else if ds2=[] then ds1 else try let rec verify ds1 ds2 rs1 rs2 = match rs1 , rs2 with | [] , _ -> ds2 | _ , [] -> ds1 | d1::rs1 , d2::rs2 -> if d1=d2 then verify ds1 ds2 rs1 rs2 else raise Exit in verify ds1 ds2 (List.rev ds1) (List.rev ds2) with Exit -> [] (* boxes are dimensions in reverse order *) let merge_box box1 box2 = try let rec verify ds1 ds2 rs1 rs2 = match rs1 , rs2 with | [] , _ -> ds2 | _ , [] -> ds1 | d1::rs1 , d2::rs2 -> if d1=d2 then verify ds1 ds2 rs1 rs2 else raise Exit in verify box1 box2 box1 box2 with Exit -> [] let rec leq_box box1 box2 = (* merge box1 box2 = box2 *) match box1 , box2 with | [] , _ -> true | _::_ , [] -> false | d1::rs1 , d2::rs2 -> d1 = d2 && leq_box rs1 rs2 let rec addbox_of_type box typ = match Cil.unrollType typ with | TArray(te,Some d,_,_) -> addbox_of_type (size_int d::box) te | _ -> box let box_of_type typ = addbox_of_type [] typ let rec dim_of_type typ = match Cil.unrollType typ with | TArray(te,Some d,_,_) -> size_int d :: dim_of_type te | TArray(_,None,_,_) -> raise NoSize | _ -> [] let rec cells_in_type typ = match Cil.unrollType typ with | TArray(te,Some d,_,_) -> Integer.mul (size d) (cells_in_type te) | TArray(_,None,_,_) -> raise NoSize | _ -> Integer.one let rec type_of_cells typ = match Cil.unrollType typ with | TArray(te,_,_,_) -> type_of_cells te | te -> te let alloc_for_type typ = match Cil.unrollType typ with | TArray(te,Some d,_,_) -> size_int d :: dim_of_type te | TArray(te,None,_,_) -> 0 :: dim_of_type te | _ -> [] let rec degree_of_type typ = match Cil.unrollType typ with | TArray(te,_,_,_) -> succ (degree_of_type te) | _ -> 0 let shape typ = let rec destruct box typ = match Cil.unrollType typ with | TArray(te,Some d,_,_) -> destruct (size_int d :: box) te | te -> te , box in match Cil.unrollType typ with | TArray(te,_,_,_) -> Some (destruct [] te) | TPtr(te,_) -> Some(destruct [] te) | _ -> None let rec compatible s t = match Ctypes.object_of s , Ctypes.object_of t with | C_int i1 , C_int i2 -> i1 = i2 | C_float f1 , C_float f2 -> f1 = f2 | C_pointer t1 , C_pointer t2 -> compatible t1 t2 | C_comp s1 , C_comp s2 -> Compinfo.equal s1 s2 | _ -> false (* arrays are already destructured by shape *) let reshape ty_src ty_tgt = match shape ty_src , shape ty_tgt with | None , _ | _ , None -> None | Some (s,ds) , Some (t,dt) -> if compatible s t then Some (merge_box ds dt) else None (* -------------------------------------------------------------------------- *) (* --- Root Variables --- *) (* -------------------------------------------------------------------------- *) module Root = struct type t = Cvar of varinfo | Lvar of logic_var let compare x y = match x,y with | Cvar x , Cvar y -> Varinfo.compare x y | Lvar x , Lvar y -> Logic_var.compare x y | Cvar _ , Lvar _ -> (-1) | Lvar _ , Cvar _ -> 1 let pretty fmt = function | Cvar x -> Format.fprintf fmt "'%s'(C%d)" x.vname x.vid (* user's pretty print *) | Lvar x -> Format.fprintf fmt "'%s'(L%d)" x.lv_name x.lv_id (* user's pretty print *) end (* -------------------------------------------------------------------------- *) (* --- Abstract Access Model --- *) (* -------------------------------------------------------------------------- *) module Model = struct type value = | BASE (* base-address *) | VALUE (* load of base-address *) | REFERENCE (* load of load of base-address *) | INDEX of int list (* shift on base-address *) | ARRAY of int list (* load of shift on base-address *) | REF_INDEX of int list (* shift on value *) | REF_ARRAY of int list (* load of shift on value *) | TERM of value (* an arbitrary term build upon the given value *) (* all dimensions are in reverse order (boxes) *) let field = function | (TERM _) as t -> t | u -> TERM u let shift tbox = function | BASE -> INDEX tbox | VALUE -> REF_INDEX tbox | INDEX box -> INDEX(merge_box box tbox) | REF_INDEX box -> REF_INDEX(merge_box box tbox) | (REFERENCE|ARRAY _|REF_ARRAY _) as loc -> TERM loc | (TERM _) as t -> t let load = function | BASE -> VALUE | VALUE -> REFERENCE | INDEX box -> ARRAY box | REF_INDEX box -> REF_ARRAY box | (REFERENCE|ARRAY _|REF_ARRAY _) as loc -> TERM loc | (TERM _) as t -> t end module Context = struct type delta = | Dload | Dfield (* BY: unused constructor: always filtered, never created *) | Dshift of int list (* box *) let _ = Dfield (* VP: silence Ocaml's 4 warning, see BY remark above *) let apply loc = function | Dload -> Model.load loc | Dfield -> Model.field loc | Dshift box -> Model.shift box loc let eval : delta list -> Model.value = List.fold_left apply Model.BASE type target = | Memory | Validity | Fcall of kernel_function * varinfo | Logic of logic_info * logic_var type t = target * delta list (* first operation to apply at head *) let epsilon : t = (Memory,[]) let assigned : t = (Memory,[Dload]) let validity : t = (Validity,[]) let load (target,delta) = target , Dload :: delta let shift ty (target,delta) = target , Dshift (box_of_type ty) :: delta let cast ty_src ty_tgt (target,delta) = match reshape ty_src ty_tgt with | Some ds -> (target,Dshift ds :: delta) | None -> (target,[]) let function_param kf x = (Fcall(kf,x),[]) let logic_param phi x = (Logic(phi,x),[]) let in_spec = ref false let on_spec e = in_spec := true ; ChangeDoChildrenPost(e,fun e -> in_spec := false ; e) let pp_target fmt = function | Memory -> Format.fprintf fmt "memory" | Validity -> Format.fprintf fmt "valid" | Fcall(kf,x) -> Format.fprintf fmt "call %a:%a" Kernel_function.pretty kf Varinfo.pretty x | Logic(phi,x) -> Format.fprintf fmt "logic %a:%a" Logic_var.pretty phi.l_var_info Logic_var.pretty x let pp_access fmt ds = List.iter (function | Dload -> Format.fprintf fmt "L" | Dfield -> Format.fprintf fmt "F" | Dshift box -> Format.fprintf fmt "{%a}" pp_box box ) ds (*let pretty fmt (target,access) = Format.fprintf fmt "[%a] %a" pp_target target pp_access access *) end module Usage = struct type domain = | Bot (* value if never used *) | Top (* value must be allocated in heap *) | Value (* always accessed by [load(base)] *) | RefValue (* always accessed by [load(load(base))] *) | Array of int list (* always accessed by [load(shift(base))] *) | RefArray of int list (* always accessed by [load(shift(load(base)))] *) (* for arrays : empty list means flatten array *) (* for arrays : non-empty list may start with [0] for unknown size *) (* dimensions are given in reverse order (boxes) *) (* Usage Lattice Diagram Top | Array Justification comes from: | (b) Value (a) For any operation (f), f(u) <= u | (a) RefArray (b) 0-shift of any dimension is identity | (b) RefValue | Bot *) (* never used *) (* let print fmt = function | Bot -> Format.pp_print_string fmt "-" | Top -> Format.pp_print_string fmt "&" | Value -> Format.pp_print_string fmt "(=)" | RefValue -> Format.pp_print_string fmt "(*)" | Array box -> Format.fprintf fmt "@{%a}" pp_box box | RefArray box -> Format.fprintf fmt "(*){%a}" pp_box box *) let pretty ~name fmt = function | Bot -> Format.fprintf fmt "%s not used" name | Top -> Format.fprintf fmt "&%s" name | Value -> Format.fprintf fmt "%s" name | RefValue -> Format.fprintf fmt "*%s" name | Array box -> Format.fprintf fmt "%s[]%a" name pp_dim (List.rev box) | RefArray box -> Format.fprintf fmt "(%s[])%a" name pp_dim (List.rev box) let rec of_value = function | Model.BASE -> Top | Model.VALUE -> Value | Model.REFERENCE -> RefValue | Model.INDEX _ -> Top | Model.ARRAY box -> Array box | Model.REF_INDEX _ -> Value | Model.REF_ARRAY box -> RefArray box | Model.TERM t -> of_value t let of_context context = of_value (Context.eval context) let merge u v = match u , v with | Bot , w | w , Bot -> w | Top , _ | _ , Top -> Top (* same levels *) | Value , Value -> Value | RefValue , RefValue -> RefValue | Array a , Array b -> Array(merge_box a b) | RefArray a , RefArray b -> RefArray(merge_box a b) (* Array level *) | (Array _ as w) , _ | _ , (Array _ as w) -> w (* Value level *) | Value , _ | _ , Value -> Value (* RefArray level *) | (RefArray _ as w) , _ | _ , (RefArray _ as w) -> w (* RefValue level *) let leq u v = (* merge u v = v *) match u,v with | Bot,_ -> true | _,Bot -> false | _,Top -> true | Top,_ -> false (* RefValue level and upper *) | RefValue,_ -> true | _,RefValue -> false (* RefArray level and upper *) | RefArray a,RefArray b -> leq_box a b | RefArray _,_ -> true | _,RefArray _ -> false (* Value level and upper *) | Value,_ -> true | _,Value -> false (* Array level and upper *) | Array a,Array b -> leq_box a b let call formal ds = match formal with | Bot -> Bot | Top -> of_context ds | Value -> of_context ds | RefValue -> of_context (ds @ [Context.Dload]) | RefArray box -> of_context (ds @ [Context.Dshift box;Context.Dload]) | Array _ -> WpMain.fatal "Usage of formal as an array" end (* -------------------------------------------------------------------------- *) (* --- Occurences Collecting --- *) (* -------------------------------------------------------------------------- *) module Occur = struct type t = { mutable valid : bool ; (* address used for validity and separation *) mutable value : Usage.domain ; (* in scope of definition *) mutable param : Usage.domain ; (* in specification for formal parameter *) mutable calls : (bool * Root.t * Context.delta list) list ; (* calls *) } let empty () = { valid = false ; value = Usage.Bot ; param = Usage.Bot ; calls = [] ; } let merge_with usage context = Usage.merge usage (Usage.of_context context) open Context open Root let update occur inspec target context = match target with | Memory -> if inspec then occur.param <- merge_with occur.param context ; occur.value <- merge_with occur.value context | Validity -> occur.valid <- true | Fcall(_,x) -> occur.calls <- (inspec,Cvar x,context)::occur.calls | Logic(_,x) -> occur.calls <- (inspec,Lvar x,context)::occur.calls let propagate modified occur (phi : Root.t -> Usage.domain) = List.iter (fun (inspec,x,w) -> let u = Usage.call (phi x) w in if not (Usage.leq u occur.value) then begin occur.value <- Usage.merge occur.value u ; modified := true ; end ; if inspec && not (Usage.leq u occur.param) then begin occur.param <- Usage.merge occur.param u ; modified := true ; end ) occur.calls end (* -------------------------------------------------------------------------- *) (* --- Fixpoint Computation --- *) (* -------------------------------------------------------------------------- *) module Omap = Map.Make(Root) module Domain = Datatype.Make (struct type t = Occur.t Omap.t include Datatype.Serializable_undefined let reprs = [Omap.empty] let name = "Wp.VarUsage.Domain" end) module U = State_builder.Ref(Domain) (struct let name = "Wp.VarUsage.Analysis" let dependencies = [ Ast.self; (* [JS 2012/02/08] put all annotations state, but unsure that this state actually depends on all of them. *) Annotations.code_annot_state; Annotations.funspec_state; Annotations.global_state ] let default () = Omap.empty end) let occur r = let omap = U.get () in try Omap.find r omap with Not_found -> let occ = Occur.empty () in U.set (Omap.add r occ omap) ; occ let get_formal r = try let occ = Omap.find r (U.get()) in match r with | Root.Cvar _ -> occ.Occur.param | Root.Lvar _ -> occ.Occur.value with Not_found -> Usage.Bot let occurrence (target,access) root = let in_spec = match root with | Root.Cvar x -> x.vformal && !Context.in_spec | Root.Lvar _ -> false in WpMain.debug ~dkey ~current:true "%s %a : %a <- %a" (if in_spec then "Spec" else "Code") Root.pretty root Context.pp_target target Context.pp_access access ; Occur.update (occur root) in_spec target access let fixpoint () = let modified = ref true in let omap = U.get () in while !modified do modified := false ; Omap.iter (fun _ occ -> Occur.propagate modified occ get_formal) omap ; done (* -------------------------------------------------------------------------- *) (* --- C-Expressions Visitor --- *) (* -------------------------------------------------------------------------- *) let rec expr (context:Context.t) (e:Cil_types.exp) = match e.enode with | Const _ | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> () | UnOp((Neg|BNot|LNot),e,_) -> expr Context.epsilon e | BinOp((PlusPI|IndexPI|MinusPI),a,b,_) -> let ty = Cil.typeOf_pointed (Cil.typeOf a) in expr (Context.shift ty context) a ; expr Context.epsilon b | BinOp( (MinusPP|PlusA|MinusA|Mult|Div|Mod |Shiftlt|Shiftrt|BAnd|BXor|BOr|LAnd|LOr |Lt|Gt|Le|Ge|Eq|Ne), a,b,_ ) -> expr Context.epsilon a ; expr Context.epsilon b | CastE(ty_tgt,e) -> let ty_src = Cil.typeOf e in expr (Context.cast ty_src ty_tgt context) e | AddrOf lval -> lvalue context lval | StartOf lval -> lvalue context lval | Lval lval -> lvalue (Context.load context) lval | Info(e,_) -> expr context e and lvalue context (host,offset) = let ty_host = match host with | Var x -> x.vtype | Mem e -> Cil.typeOf_pointed (Cil.typeOf e) in let context = lval_offset context ty_host offset in lval_host context host and lval_option context = function None -> () | Some lv -> lvalue context lv and lval_host context = function | Var x -> occurrence context (Root.Cvar x) | Mem e -> expr context e and lval_offset context ty = function | NoOffset -> context | Field(f,offset) -> lval_offset Context.epsilon f.ftype offset | Index(e,offset) -> expr Context.epsilon e ; let telt = Cil.typeOf_array_elem ty in Context.shift telt (lval_offset context telt offset) let rec funcall_params kf xs es = match xs , es with | _ , [] | [] , _ -> () | x::xs , e::es -> expr (Context.function_param kf x) e ; funcall_params kf xs es let funcall (ef:Cil_types.exp) (es:Cil_types.exp list) = match Kernel_function.get_called ef with | None -> expr Context.epsilon ef ; List.iter (expr Context.epsilon) es | Some kf -> funcall_params kf (Kernel_function.get_formals kf) es (* -------------------------------------------------------------------------- *) (* --- Term Visitor --- *) (* -------------------------------------------------------------------------- *) let rec term (context:Context.t) (t:term) = match t.term_node with | TConst _ | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ -> () | TUnOp((Neg|BNot|LNot),t) -> term Context.epsilon t | TBinOp((PlusPI|IndexPI|MinusPI),a,b) -> let ty = Logic_typing.ctype_of_pointed a.term_type in term (Context.shift ty context) a ; term Context.epsilon b | TBinOp( (MinusPP|PlusA|MinusA|Mult|Div|Mod |Shiftlt|Shiftrt|BAnd|BXor|BOr|LAnd|LOr |Lt|Gt|Le|Ge|Eq|Ne), a,b ) -> term Context.epsilon a ; term Context.epsilon b | TCastE(ty_tgt,t) -> begin match Logic_utils.unroll_type t.term_type with | Ctype ty_src -> term (Context.cast ty_src ty_tgt context) t | _ -> term Context.epsilon t end | TAddrOf tlv -> term_lval context tlv | TStartOf tlv -> term_lval context tlv | TLval tlv -> term_lval (Context.load context) tlv | Tapp(phi,_,ts) -> logic_call phi phi.l_profile ts | Tlambda(_,t) -> term Context.epsilon t | TDataCons(_,ts) -> List.iter (term Context.epsilon) ts | Tif(e,a,b) -> term Context.epsilon e ; term context a ; term context b | Tat(t,_) -> term context t | Tbase_addr (_,t) -> term Context.epsilon t | Toffset (_,t) -> term Context.epsilon t | Tblock_length (_,t) -> term Context.validity t | Tnull -> () | TCoerce _ | TCoerceE _ -> WpMain.fatal "Jessie Coercions" | TUpdate(s,offset,t) -> term Context.epsilon s ; term Context.epsilon t ; term_indices offset | Ttypeof _ | Ttype _ -> () | Tempty_set -> () | Tunion ts | Tinter ts -> List.iter (term context) ts | Tcomprehension( t , _ , None ) -> term context t | Tcomprehension( t , _ , Some p ) -> term context t ; named_predicate p | Trange( a , b ) -> term_option Context.epsilon a ; term_option Context.epsilon b | Tlet( phi , a ) -> logic_body phi.l_body ; term context a | TLogic_coerce (_,t) -> term context t and term_option context = function None -> () | Some e -> term context e and term_lval context (host,offset) = match host with (* Logic value + field/array-index offset *) | TVar ({lv_origin=None} as x) -> occurrence context (Root.Lvar x) ; term_indices offset (* Cases where host has a C-type *) | TResult typ | TVar {lv_origin=Some {vtype=typ}} -> term_host (term_coffset context typ offset) host (* Case where host is a pointer *) | TMem e -> let te = Logic_typing.ctype_of_pointed e.term_type in term_host (term_coffset context te offset) host and term_coffset context ty = function | TNoOffset -> context | TField(f,offset) -> term_coffset Context.epsilon f.ftype offset | TModel _ -> Wp_parameters.not_yet_implemented "Model field" | TIndex(e,offset) -> term Context.epsilon e ; let telt = Cil.typeOf_array_elem ty in Context.shift telt (term_coffset context telt offset) and term_indices = function | TNoOffset -> () | TField(_,offset) | TModel(_,offset) -> term_indices offset | TIndex(k,offset) -> term Context.epsilon k ; term_indices offset and term_host context = function | TResult _ -> () | TVar {lv_origin=Some x} -> occurrence context (Root.Cvar x) | TVar x -> occurrence context (Root.Lvar x) | TMem t -> term context t and logic_call phi xs ts = match xs , ts with | [] , _ | _ , [] -> () | x::xs , t::ts -> term (Context.logic_param phi x) t ; logic_call phi xs ts and identified_term context t = term context t.it_content (* -------------------------------------------------------------------------- *) (* --- Pred Visitor --- *) (* -------------------------------------------------------------------------- *) and named_predicate p = predicate p.content and predicate = function | Psubtype _ | Pfalse | Ptrue -> () | Papp(phi,_,ts) -> logic_call phi phi.l_profile ts | Pseparated ts -> List.iter (term Context.validity) ts | Pvalid (_,t) | Pvalid_read (_,t) | Pallocable (_,t) | Pfreeable (_,t) -> term Context.validity t | Pinitialized (_,t) -> term Context.validity t | Pfresh (_,_,t,n) -> term Context.validity t ; term Context.validity n | Prel(_,a,b) -> term Context.epsilon a ; term Context.epsilon b | Pand(p,q) | Por(p,q) | Pxor(p,q) | Pimplies(p,q) | Piff(p,q) -> named_predicate p ; named_predicate q | Pnot p -> named_predicate p | Pif(t,p,q) -> term Context.epsilon t ; named_predicate p ; named_predicate q | Plet(phi,p) -> logic_body phi.l_body ; named_predicate p | Pforall(_,p) | Pexists(_,p) -> named_predicate p | Pat(p,_) -> named_predicate p (* -------------------------------------------------------------------------- *) (* --- Logic Visitor --- *) (* -------------------------------------------------------------------------- *) and logic_body = function | LBnone -> () | LBreads its -> List.iter (identified_term Context.epsilon) its | LBterm t -> term Context.epsilon t | LBpred p -> predicate p.content | LBinductive cases -> List.iter (fun (_,_,_,p) -> named_predicate p) cases (* -------------------------------------------------------------------------- *) (* --- CIL Visitor --- *) (* -------------------------------------------------------------------------- *) class visitor = object inherit Visitor.frama_c_inplace initializer Context.in_spec := false method vexpr e = expr Context.epsilon e ; SkipChildren method vinst = function | Call( result , e , es , _ ) -> lval_option Context.assigned result ; funcall e es ; SkipChildren | Set( lv , e , _ ) -> lvalue Context.assigned lv ; expr Context.epsilon e ; SkipChildren | Code_annot _ -> DoChildren | Skip _ -> DoChildren | Asm _ -> DoChildren method vterm t = term Context.epsilon t ; SkipChildren method vpredicate p = predicate p ; SkipChildren method vspec = Context.on_spec end let compute () = WpMain.feedback "Collecting variable usage" ; Visitor.visitFramacFile (new visitor) (Ast.get()) ; fixpoint () (* -------------------------------------------------------------------------- *) (* --- External API --- *) (* -------------------------------------------------------------------------- *) let (compute,_) = State_builder.apply_once "VarUsage.compute" (* [JS 2012/02/08] looks to be redundant with the definition of module [U]. *) [ Ast.self; (* [JS 2012/02/08] put all annotations state, but unsure that this state actually depends on all of them. *) Annotations.code_annot_state; Annotations.funspec_state; Annotations.global_state ] compute let of_cvar x = (occur (Root.Cvar x)).Occur.value let of_formal x = (occur (Root.Cvar x)).Occur.param let of_lvar x = (occur (Root.Lvar x)).Occur.value let validated_cvar x = (occur (Root.Cvar x)).Occur.valid let validated_lvar x = (occur (Root.Lvar x)).Occur.valid let dump_lvar fmt x = Usage.pretty ~name:x.lv_name fmt (of_lvar x) ; if validated_lvar x then Format.pp_print_string fmt " (validated)" let dump () = Log.print_on_output begin fun fmt -> Format.fprintf fmt "-------------------------------------------------@\n" ; Format.fprintf fmt "--- Roots Usage@\n" ; Format.fprintf fmt "-------------------------------------------------@\n" ; Globals.Vars.iter (fun x _ -> Format.fprintf fmt "Global %a@." (Usage.pretty ~name:x.vname) (of_cvar x) ) ; Globals.Functions.iter (fun kf -> let xs = Kernel_function.get_formals kf in let ys = Kernel_function.get_locals kf in Format.fprintf fmt "Function '%s':@\n" (Kernel_function.get_name kf) ; List.iter (fun x -> let occ = occur (Root.Cvar x) in let value = occ.Occur.value in let param = occ.Occur.param in if Usage.leq value param then Format.fprintf fmt " - formal %a" (Usage.pretty ~name:x.vname) value else Format.fprintf fmt " - formal %a (called: %a)" (Usage.pretty ~name:x.vname) value (Usage.pretty ~name:x.vname) param ; if occ.Occur.valid then Format.fprintf fmt " (validated)@\n" else Format.fprintf fmt "@\n" ) xs ; List.iter (fun y -> Format.fprintf fmt " - local %a@\n" (Usage.pretty ~name:y.vname) (of_cvar y) ) ys ; Format.pp_print_flush fmt () ) ; Annotations.iter_global (fun _ logic -> match logic with | Dfun_or_pred(linfo,_) -> let name = linfo.l_var_info.lv_name in let kind = if linfo.l_type = None then "Predicate" else "Logic" in if linfo.l_profile = [] then Format.fprintf fmt "%s '%s': %a@\n" kind name dump_lvar linfo.l_var_info else begin Format.fprintf fmt "%s '%s':@\n" kind name ; let xs = linfo.l_profile in List.iter (fun x -> Format.fprintf fmt " - parameter %a@\n" dump_lvar x) xs end | _ -> ()); Format.fprintf fmt "-------------------------------------------------@." ; end type usage = | NotUsed | ByValue | ByAddress | ByReference | ByArray of int list | ByRefArray of int list let usage = function | Usage.Bot -> NotUsed | Usage.Top -> ByAddress | Usage.Value -> ByValue | Usage.Array box -> ByArray (List.rev box) | Usage.RefValue -> ByReference | Usage.RefArray box -> ByRefArray (List.rev box) let of_cvar x = compute () ; usage (of_cvar x) let of_formal x = compute () ; usage (of_formal x) let of_lvar x = compute () ; usage (of_lvar x) let validated_cvar x = compute () ; validated_cvar x let validated_lvar x = compute () ; validated_lvar x let pretty ~name fmt = function | NotUsed -> Format.fprintf fmt "%s not used" name | ByAddress -> Format.fprintf fmt "&%s" name | ByValue -> Format.fprintf fmt "%s" name | ByReference -> Format.fprintf fmt "*%s" name | ByArray dim -> Format.fprintf fmt "%s[]%a" name pp_dim dim | ByRefArray dim -> Format.fprintf fmt "(%s[])%a" name pp_dim dim frama-c-Fluorine-20130601/src/wp/LogicUsage.ml0000644000175000017500000004216012155630215017571 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Dependencies of Logic Definitions --- *) (* -------------------------------------------------------------------------- *) open Cil open Cil_types open Cil_datatype open Clabels open Visitor (* -------------------------------------------------------------------------- *) (* --- Name Utilities --- *) (* -------------------------------------------------------------------------- *) let trim name = let rec first s k n = if k < n && s.[k]='_' then first s (succ k) n else k in let rec last s k = if k >= 0 && s.[k]='_' then last s (pred k) else k in let n = String.length name in if n > 0 then if ( name.[0]='_' || name.[n-1]='_' ) then let p = first name 0 n in let q = last name (pred n) in if p <= q then let name = String.sub name p (q+1-p) in match name.[0] with | '0' .. '9' -> "_" ^ name | _ -> name else "_" else name else "_" (* -------------------------------------------------------------------------- *) (* --- Definition Blocks --- *) (* -------------------------------------------------------------------------- *) type logic_lemma = { lem_name : string ; lem_position : Lexing.position ; lem_axiom : bool ; lem_types : string list ; lem_labels : logic_label list ; lem_property : predicate named ; lem_depends : logic_lemma list ; (* global lemmas declared before in AST order (in reverse order) *) } type axiomatic = { ax_name : string ; ax_position : Lexing.position ; ax_property : Property.t ; mutable ax_types : logic_type_info list ; mutable ax_logics : logic_info list ; mutable ax_lemmas : logic_lemma list ; mutable ax_reads : Varinfo.Set.t ; (* read-only *) } type logic_section = | Toplevel of int | Axiomatic of axiomatic let is_global_axiomatic ax = ax.ax_types = [] && ax.ax_logics = [] && ax.ax_lemmas <> [] module SMap = Datatype.String.Map module TMap = Logic_type_info.Map module LMap = Logic_info.Map module LSet = Logic_info.Set (* -------------------------------------------------------------------------- *) (* --- Usage and Dependencies --- *) (* -------------------------------------------------------------------------- *) type inductive_case = { ind_logic : logic_info ; ind_case : string ; mutable ind_call : LabelSet.t LabelMap.t ; } type database = { mutable cases : inductive_case list LMap.t ; mutable clash : LSet.t SMap.t ; mutable names : string LMap.t ; mutable types : logic_section TMap.t ; mutable logics : logic_section LMap.t ; mutable lemmas : (logic_lemma * logic_section) SMap.t ; mutable recursives : LSet.t ; mutable axiomatics : axiomatic SMap.t ; mutable proofcontext : logic_lemma list ; } let empty_database () = { cases = LMap.empty ; names = LMap.empty ; clash = SMap.empty ; types = TMap.empty ; logics = LMap.empty ; lemmas = SMap.empty ; recursives = LSet.empty ; axiomatics = SMap.empty ; proofcontext = [] ; } module DatabaseType = Datatype.Make (struct type t = database include Datatype.Serializable_undefined let reprs = [empty_database ()] let name = "Wp.LogicUsage.DatabaseType" end) module Database = State_builder.Ref(DatabaseType) (struct let name = "Wp.LogicUsage.Database" let dependencies = [Ast.self;Annotations.code_annot_state] let default = empty_database end) let pp_logic fmt l = Printer.pp_logic_var fmt l.l_var_info (* -------------------------------------------------------------------------- *) (* --- Overloading --- *) (* -------------------------------------------------------------------------- *) let basename x = trim x.vorig_name let compute_logicname l = let d = Database.get () in try LMap.find l d.names with Not_found -> let base = l.l_var_info.lv_name in let over = try SMap.find base d.clash with Not_found -> LSet.empty (*TODO: Undected usage -> overloading issue *) in match LSet.elements over with | [] | [_] -> d.names <- LMap.add l base d.names ; base | symbols -> let rec register k = function | l::ls -> let name = Printf.sprintf "%s_%d_" base k in d.names <- LMap.add l name d.names ; register (succ k) ls | [] -> () in register 1 symbols ; LMap.find l d.names let is_overloaded l = let d = Database.get () in try LSet.cardinal (SMap.find l.l_var_info.lv_name d.clash) > 1 with Not_found -> false let pp_profile fmt l = Format.fprintf fmt "%s" l.l_var_info.lv_name ; match l.l_profile with | [] -> () | x::xs -> Format.fprintf fmt "@[(%a" Printer.pp_logic_type x.lv_type ; List.iter (fun y -> Format.fprintf fmt ",@,%a" Printer.pp_logic_type y.lv_type) xs ; Format.fprintf fmt ")@]" (* -------------------------------------------------------------------------- *) (* --- Utilities --- *) (* -------------------------------------------------------------------------- *) let ip_lemma l = (if l.lem_axiom then Property.ip_axiom else Property.ip_lemma) (l.lem_name,l.lem_labels,l.lem_types, l.lem_property,(l.lem_position,l.lem_position)) let lemma_of_global proof = function | Dlemma(name,axiom,labels,types,pred,loc) -> { lem_name = name ; lem_position = fst loc ; lem_types = types ; lem_labels = labels ; lem_axiom = axiom ; lem_property = pred ; lem_depends = proof ; } | _ -> assert false let populate a proof = function | Dfun_or_pred(l,_) -> a.ax_logics <- l :: a.ax_logics | Dtype(t,_) -> a.ax_types <- t :: a.ax_types | Dlemma _ as g -> a.ax_lemmas <- lemma_of_global proof g :: a.ax_lemmas | _ -> () let ip_of_axiomatic g = match Property.ip_of_global_annotation_single g with | None -> assert false | Some ip -> ip let axiomatic_of_global proof = function | Daxiomatic(name,globals,loc) as g -> let a = { ax_name = name ; ax_position = fst loc ; ax_property = ip_of_axiomatic g ; ax_reads = Varinfo.Set.empty ; ax_types = [] ; ax_lemmas = [] ; ax_logics = [] ; } in List.iter (populate a proof) globals ; a.ax_types <- List.rev a.ax_types ; a.ax_logics <- List.rev a.ax_logics ; a.ax_lemmas <- List.rev a.ax_lemmas ; a | _ -> assert false let register_logic d section l = let name = l.l_var_info.lv_name in let over = try LSet.add l (SMap.find name d.clash) with Not_found -> LSet.singleton l in begin d.clash <- SMap.add name over d.clash ; d.logics <- LMap.add l section d.logics ; end let register_lemma d section l = begin d.lemmas <- SMap.add l.lem_name (l,section) d.lemmas ; end let register_type d section t = begin d.types <- TMap.add t section d.types ; end let register_axiomatic d a = begin d.axiomatics <- SMap.add a.ax_name a d.axiomatics ; end let register_cases l inds = let d = Database.get () in d.cases <- LMap.add l inds d.cases (* -------------------------------------------------------------------------- *) (* --- Adding a label called in an inductive case --- *) (* -------------------------------------------------------------------------- *) (* calls : LabelSet.t LabelMap.t Given an inductive phi{...A...} In case H{...B...}, have a call to phi{...B...} Then: ( A \in calls[B] ). *) let add_call calls (l_a,l_b) = let a = Clabels.c_label l_a in let b = Clabels.c_label l_b in let s = try LabelSet.add a (LabelMap.find b calls) with Not_found -> LabelSet.singleton a in LabelMap.add b s calls (* -------------------------------------------------------------------------- *) (* --- Visitor --- *) (* -------------------------------------------------------------------------- *) class visitor = object(self) inherit Visitor.frama_c_inplace val database = Database.get () val mutable caller : logic_info option = None val mutable axiomatic : axiomatic option = None val mutable inductive : inductive_case option = None val mutable toplevel = 0 method private section = match axiomatic with | None -> Toplevel toplevel | Some a -> Axiomatic a method private do_var x = match axiomatic with | None -> () | Some a -> a.ax_reads <- Varinfo.Set.add x a.ax_reads method private do_lvar x = try self#do_call (Logic_env.find_logic_cons x) [] with Not_found -> () method private do_call l labels = match inductive with | Some case -> if Logic_info.equal l case.ind_logic then case.ind_call <- List.fold_left add_call case.ind_call labels | None -> match caller with | None -> () | Some f -> if Logic_info.equal f l then database.recursives <- LSet.add f database.recursives method private do_case l (case,_labels,_types,pnamed) = begin let indcase = { ind_logic = l ; ind_case = case ; ind_call = LabelMap.empty ; } in inductive <- Some indcase ; ignore (visitFramacPredicateNamed (self :> frama_c_visitor) pnamed) ; inductive <- None ; indcase end (* --- LVALUES --- *) method vlval = function | (Var x,_) -> self#do_var x ; DoChildren | _ -> DoChildren method vterm_lval = function | (TVar { lv_origin=Some x } , _ ) -> self#do_var x ; DoChildren | (TVar x , _ ) -> self#do_lvar x ; DoChildren | _ -> DoChildren (* --- TERMS --- *) method vterm_node = function | Tapp(l,labels,_) -> self#do_call l labels ; DoChildren | _ -> DoChildren (* --- PREDICATE --- *) method vpredicate = function | Papp(l,labels,_) -> self#do_call l labels ; DoChildren | _ -> DoChildren method vannotation global = match global with (* --- AXIOMATICS --- *) | Daxiomatic _ -> begin let pf = database.proofcontext in let ax = axiomatic_of_global pf global in register_axiomatic database ax ; axiomatic <- Some ax ; DoChildrenPost (fun g -> if not (is_global_axiomatic ax) then database.proofcontext <- pf ; axiomatic <- None ; toplevel <- succ toplevel ; g) end (* --- LOGIC INFO --- *) | Dfun_or_pred(l,_) -> begin register_logic database self#section l ; match l.l_body with | LBnone when axiomatic = None -> SkipChildren | LBnone | LBreads _ | LBterm _ | LBpred _ -> caller <- Some l ; DoChildrenPost (fun g -> caller <- None ; g) | LBinductive cases -> register_cases l (List.map (self#do_case l) cases) ; SkipChildren end (* --- LEMMAS --- *) | Dlemma _ -> let lem = lemma_of_global database.proofcontext global in register_lemma database self#section lem ; database.proofcontext <- lem :: database.proofcontext ; SkipChildren | Dtype(t,_) -> register_type database self#section t ; SkipChildren (* --- OTHERS --- *) | Dvolatile _ | Dinvariant _ | Dtype_annot _ | Dmodel_annot _ | Dcustom_annot _ -> SkipChildren method vfunc _ = SkipChildren end let compute () = Wp_parameters.feedback "Collecting axiomatic usage" ; Visitor.visitFramacFile (new visitor) (Ast.get ()) (* -------------------------------------------------------------------------- *) (* --- External API --- *) (* -------------------------------------------------------------------------- *) let (compute,_) = State_builder.apply_once "LogicUsage.compute" [Ast.self;Annotations.code_annot_state] compute let is_recursive l = compute () ; let d = Database.get () in LSet.mem l d.recursives let get_induction_labels l case = compute () ; try let d = Database.get () in let cases = LMap.find l d.cases in try (List.find (fun i -> i.ind_case = case) cases).ind_call with Not_found -> Wp_parameters.fatal "No case '%s' for inductive '%s'" case l.l_var_info.lv_name with Not_found -> Wp_parameters.fatal "Non-inductive '%s'" l.l_var_info.lv_name let axiomatic a = compute () ; try let d = Database.get () in SMap.find a d.axiomatics with Not_found -> Wp_parameters.fatal "Axiomatic '%s' undefined" a let section_of_type t = compute () ; try let d = Database.get () in TMap.find t d.types with Not_found -> Wp_parameters.fatal "Logic type '%s' undefined" t.lt_name let section_of_logic l = compute () ; try let d = Database.get () in LMap.find l d.logics with Not_found -> Wp_parameters.fatal "Logic '%a' undefined" pp_logic l let get_lemma l = compute () ; try let d = Database.get () in SMap.find l d.lemmas with Not_found -> Wp_parameters.fatal "Lemma '%s' undefined" l let iter_lemmas f = compute () ; let d = Database.get () in SMap.iter (fun _name (lem,_) -> f lem) d.lemmas let logic_lemma l = fst (get_lemma l) let section_of_lemma l = snd (get_lemma l) let proof_context () = (* No need for compute: if no lemma, database is empty ! *) let d = Database.get () in d.proofcontext (* -------------------------------------------------------------------------- *) (* --- Dump API --- *) (* -------------------------------------------------------------------------- *) let dump_type fmt t = Format.fprintf fmt " * type '%s'@\n" t.lt_name let dump_profile fmt kind l = begin Format.fprintf fmt " * %s '%s'@\n" kind (compute_logicname l) ; if is_overloaded l then Format.fprintf fmt " profile %a@\n" pp_profile l ; if is_recursive l then Format.fprintf fmt " recursive@\n" ; end let dump_logic fmt d l = begin try let cases = LMap.find l d.cases in dump_profile fmt "inductive" l ; List.iter (fun ind -> Format.fprintf fmt " @[case %s:" ind.ind_case ; LabelMap.iter (fun l s -> Format.fprintf fmt "@ @[{%a:" Clabels.pretty l ; LabelSet.iter (fun l -> Format.fprintf fmt "@ %a" Clabels.pretty l) s ; Format.fprintf fmt "}@]" ) ind.ind_call ; Format.fprintf fmt "@]@\n" ) cases ; with Not_found -> let kind = if l.l_type = None then "predicate" else "function" in dump_profile fmt kind l ; end let dump_lemma fmt l = if l.lem_axiom then Format.fprintf fmt " * axiom '%s'@\n" l.lem_name else Format.fprintf fmt " * lemma '%s'@\n" l.lem_name let get_name l = compute () ; compute_logicname l let pp_section fmt = function | Toplevel 0 -> Format.fprintf fmt "Toplevel" | Toplevel n -> Format.fprintf fmt "Toplevel(%d)" n | Axiomatic a -> Format.fprintf fmt "Axiomatic '%s'" a.ax_name let dump () = compute () ; Log.print_on_output begin fun fmt -> let d = Database.get () in SMap.iter (fun _ a -> Format.fprintf fmt "Axiomatic %s {@\n" a.ax_name ; List.iter (dump_type fmt) a.ax_types ; List.iter (dump_logic fmt d) a.ax_logics ; List.iter (dump_lemma fmt) a.ax_lemmas ; Format.fprintf fmt "}@\n" ) d.axiomatics ; TMap.iter (fun t s -> Format.fprintf fmt " * type '%s' in %a@\n" t.lt_name pp_section s) d.types ; LMap.iter (fun l s -> Format.fprintf fmt " * logic '%a' in %a@\n" pp_logic l pp_section s) d.logics ; SMap.iter (fun l (lem,s) -> Format.fprintf fmt " * %s '%s' in %a@\n" (if lem.lem_axiom then "axiom" else "lemma") l pp_section s) d.lemmas ; Format.fprintf fmt "-------------------------------------------------@." ; end frama-c-Fluorine-20130601/src/wp/ProverCoq.ml0000644000175000017500000004333012155630215017467 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Coq Interface --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Qed open Lang open Definitions let dkey = Wp_parameters.register_category "prover" let cluster_file c = let dir = Model.directory () in let base = cluster_id c in Printf.sprintf "%s/%s.v" dir base (* -------------------------------------------------------------------------- *) (* --- Exporting Formulae to Coq --- *) (* -------------------------------------------------------------------------- *) type depend = | D_module of string (* D_module A : /A.v copied in /wp/A.v *) | D_cluster of cluster (* D_cluster A : Generated in //A.v *) | D_file of string * string (* D_file(F,A) : File F copied in //A.v *) let engine = let module E = Qed.Export_coq.Make(Lang.F) in object inherit E.engine method datatype = ADT.id method field = Field.id method link = Lang.link end class visitor fmt c = object(self) inherit Definitions.visitor c inherit ProverTask.printer fmt (cluster_title c) val mutable deps = [] (* --- Managing Formatter --- *) method flush = begin Format.pp_print_newline fmt () ; List.rev deps end (* --- Files, Theories and Clusters --- *) method add_module f = let dm = D_module f in if not (List.mem dm deps) then begin self#lines ; Format.fprintf fmt "Require Import %s.@\n" f ; deps <- dm :: deps end method add_library file lib = self#lines ; Format.fprintf fmt "Require Import %s.@\n" lib ; deps <- (D_file(file,lib)) :: deps method add_extlib name = let file = Wp_parameters.find_lib name in let lib = Filename.chop_extension (Filename.basename file) in self#add_library file lib method on_cluster c = self#lines ; Format.fprintf fmt "Require Import %s.@\n" (cluster_id c) ; deps <- (D_cluster c) :: deps method on_theory = function | "qed" | "driver" -> () | "cint" -> self#add_module "Cint" | "cbits" -> List.iter self#add_module [ "Cint" ; "Bits" ; "Cbits" ] | "cfloat" -> self#add_module "Cfloat" | "vset" -> self#add_module "Vset" | "memory" -> self#add_module "Memory" | "cmath" -> self#add_module "Cmath" | thy -> Wp_parameters.fatal ~current:false "No builtin theory '%s' for Coq" thy method on_library thy = let lib = String.capitalize thy in let file = Wp_parameters.find_lib (lib ^ ".v") in self#add_library file lib method on_type lt def = begin self#lines ; engine#declare_type fmt (Lang.atype lt) (List.length lt.lt_params) def ; end method on_comp c fts = begin (*TODO:NUPW: manage UNIONS *) self#paragraph ; engine#declare_type fmt (Lang.comp c) 0 (Qed.Engine.Trec fts) ; end method on_dlemma l = begin self#paragraph ; engine#declare_axiom fmt (Lang.lemma_id l.l_name) l.l_forall l.l_triggers (F.e_prop l.l_lemma) end method on_dfun d = begin self#paragraph ; match d.d_definition with | Logic t -> engine#declare_signature fmt d.d_lfun (List.map F.tau_of_var d.d_params) t ; | Value(t,mu,v) -> let pp = match mu with | Rec -> engine#declare_fixpoint ~prefix:"Fix" | Def -> engine#declare_definition in pp fmt d.d_lfun d.d_params t v | Predicate(mu,p) -> let pp = match mu with | Rec -> engine#declare_fixpoint ~prefix:"Fix" | Def -> engine#declare_definition in pp fmt d.d_lfun d.d_params Logic.Prop (F.e_prop p) | Inductive _ -> engine#declare_signature fmt d.d_lfun (List.map F.tau_of_var d.d_params) Logic.Prop end end let write_cluster c = let f = cluster_file c in Wp_parameters.debug ~dkey "Generate '%s'" f ; Command.print_file f begin fun fmt -> let v = new visitor fmt c in v#lines ; v#printf "Require Import ZArith.@\n" ; v#printf "Require Import Reals.@\n" ; v#add_module "Qedlib" ; v#vself ; v#flush ; end let need_recompile ~source ~target = try let t_src = (Unix.stat source).Unix.st_mtime in let t_tgt = (Unix.stat target).Unix.st_mtime in t_src >= t_tgt with Unix.Unix_error _ -> true (* -------------------------------------------------------------------------- *) (* --- Assembling Goal --- *) (* -------------------------------------------------------------------------- *) (** theories -> needed directory to include *) let compiled_theories : string option Datatype.String.Hashtbl.t = Datatype.String.Hashtbl.create 10 (*[LC] Shared : not projectified. *) module CLUSTERS = Model.Index (struct type key = cluster type data = int * depend list let name = "ProverCoq.FILES" let compare = cluster_compare let pretty = pp_cluster end) type coqcc = { (* in reverse order: *) mutable includes : string list ; (* directories where .vo are found *) mutable sources : string list ; (* file .v to recompile *) } let add_include coqcc dir = if not (List.mem dir coqcc.includes) then coqcc.includes <- dir :: coqcc.includes let add_source coqcc file = if not (List.mem file coqcc.sources) then coqcc.sources <- file :: coqcc.sources let rec assemble coqcc = function | D_module thy -> assemble_theory coqcc thy | D_cluster c -> assemble_cluster coqcc c | D_file(path,_) -> assemble_userlib coqcc path and assemble_cluster coqcc c = let (age,deps) = try CLUSTERS.find c with Not_found -> (-1,[]) in let deps = if age < cluster_age c then let deps = write_cluster c in CLUSTERS.update c (cluster_age c , deps) ; deps else deps in List.iter (assemble coqcc) deps ; add_source coqcc (cluster_file c) and assemble_theory coqcc thy = try let dirinclude = Datatype.String.Hashtbl.find compiled_theories thy in match dirinclude with | None -> () | Some dirinclude -> add_include coqcc dirinclude with Not_found -> let source = Wp_parameters.Share.file ~error:true (thy ^ ".v") in if Sys.file_exists (source ^ "o") then begin let dirinclude = (Filename.dirname source) in add_include coqcc dirinclude; Datatype.String.Hashtbl.add compiled_theories thy (Some dirinclude) end else begin let tgtdir = Wp_parameters.get_output_dir "wp" in let target = Printf.sprintf "%s/%s.v" tgtdir thy in Command.copy source target ; add_source coqcc target; Datatype.String.Hashtbl.add compiled_theories thy None end and assemble_userlib coqcc source = if Sys.file_exists (source ^ "o") then add_include coqcc (Filename.dirname source) else begin let tgtdir = Model.directory () in let coqsrc = Filename.basename source in let target = Printf.sprintf "%s/%s" tgtdir coqsrc in if need_recompile ~source ~target then Command.copy source target ; add_source coqcc target end (* -------------------------------------------------------------------------- *) (* --- Assembling Goal --- *) (* -------------------------------------------------------------------------- *) let assemble_goal ~pid axioms prop = let title = Pretty_utils.to_string WpPropId.pretty pid in let wpd = Wp_parameters.get_output_dir "wp" in let dir = Model.directory () in let id = WpPropId.get_propid pid in let file = Printf.sprintf "%s/%s.coq" dir id in let goal = cluster ~id ~title () in let deps = Command.print_file file begin fun fmt -> let v = new visitor fmt goal in v#printf "Require Import ZArith.@\n" ; v#printf "Require Import Reals.@\n" ; v#add_module "Qedlib" ; v#vgoal axioms prop ; let libs = Wp_parameters.CoqLibs.get () in if libs <> [] then begin v#section "Additional Libraries" ; List.iter v#add_extlib libs ; v#hline ; end ; v#paragraph ; engine#global begin fun () -> v#printf "@[Goal@ %a.@]@." engine#pp_prop (F.e_prop prop) ; end ; v#flush end in let coqcc = { includes = [] ; sources = [] } in List.iter (assemble coqcc) deps ; let includes = wpd :: List.rev (dir :: coqcc.includes) in let sources = List.rev coqcc.sources in includes , sources , file (* -------------------------------------------------------------------------- *) (* --- Running Coq --- *) (* -------------------------------------------------------------------------- *) open Task open VCS let coq_timeout () = let coqtimeout = Wp_parameters.CoqTimeout.get () in let gentimeout = Wp_parameters.Timeout.get () in max coqtimeout gentimeout let coqidelock = Task.mutex () class runcoq includes source = let base = Filename.chop_extension source in let logout = base ^ "_Coq.out" in let logerr = base ^ "_Coq.err" in object(coq) inherit ProverTask.command "coq" initializer begin coq#add_list ~name:"-I" includes ; coq#add [ "-noglob" ] ; end method failed : 'a. 'a task = begin let name = Filename.basename source in Wp_parameters.feedback "[Coq] '%s' compilation failed." name ; if Sys.file_exists logout then Log.print_on_output (fun fmt -> Command.pp_from_file fmt logout) ; if Sys.file_exists logerr then Log.print_on_output (fun fmt -> Command.pp_from_file fmt logerr) ; Task.failed "Compilation of '%s' failed." name ; end method compile = coq#set_command "coqc" ; coq#add [ source ] ; coq#timeout (coq_timeout ()) ; Task.call (fun () -> if not (Wp_parameters.wpcheck ()) then let name = Filename.basename source in Wp_parameters.feedback "[Coq] Compiling '%s'." name) () >>= coq#run ~logout ~logerr >>= fun r -> if r <> 0 then coq#failed else Task.return () method check = coq#set_command "coqc" ; coq#add [ source ] ; coq#timeout (coq_timeout ()) ; coq#run ~logout ~logerr () >>= function | 0 -> Task.return true | 1 -> Task.return false | _ -> coq#failed method coqide headers = coq#set_command "coqide" ; coq#add [ source ] ; let script = Wp_parameters.Script.get () in if Sys.file_exists script then coq#add [ script ] ; coq#add headers ; Task.sync coqidelock (coq#run ~logout ~logerr) end (* -------------------------------------------------------------------------- *) (* --- Compilation Helpers --- *) (* -------------------------------------------------------------------------- *) let shared_demon = ref true let shared_headers : (string,unit Task.shared) Hashtbl.t = Hashtbl.create 120 let shared includes source = try Hashtbl.find shared_headers source with Not_found -> if !shared_demon then begin shared_demon := false ; let server = ProverTask.server () in Task.on_server_stop server (fun () -> Hashtbl.clear shared_headers) ; end ; let descr = Printf.sprintf "Coqc '%s'" source in let shared = Task.shared ~descr ~retry:true (fun () -> (new runcoq includes source)#compile) in Hashtbl.add shared_headers source shared ; shared let rec compile_headers includes forced = function | [] -> Task.nop | source::headers -> let target = source ^ "o" in if forced || need_recompile ~source ~target then begin let cc = shared includes source in Task.share cc >>= fun () -> compile_headers includes true headers end else compile_headers includes forced headers (* -------------------------------------------------------------------------- *) (* --- Coq Prover --- *) (* -------------------------------------------------------------------------- *) open Wpo type coq_wpo = { cw_pid : WpPropId.prop_id ; cw_gid : string ; cw_goal : string ; (* filename for goal without proof *) cw_script : string ; (* filename for goal with proof script *) cw_headers : string list ; (* filename for libraries *) cw_includes : string list ; (* -I ... *) } let make_script ?(admitted=false) w script = Command.print_file w.cw_script begin fun fmt -> Command.pp_from_file fmt w.cw_goal ; if admitted then Format.fprintf fmt "Proof.@\nAdmitted.@\n@." else Format.fprintf fmt "Proof.@\n%sQed.@\n@." script ; end let try_script ?admitted w script = make_script ?admitted w script ; (new runcoq w.cw_includes w.cw_script)#check let rec try_hints w = function | [] -> Task.return false | (kind,script) :: hints -> Wp_parameters.feedback "[Coq] Goal %s : %s" w.cw_gid kind ; try_script w script >>= fun succeed -> if succeed then let required,hints = WpPropId.prop_id_keys w.cw_pid in let keys = List.merge String.compare required hints in Proof.add_script w.cw_gid keys script ; Task.return true else try_hints w hints let try_prove w () = begin match Proof.script_for ~pid:w.cw_pid ~gid:w.cw_gid with | Some script -> Wp_parameters.feedback "[Coq] Goal %s : Saved script" w.cw_gid ; try_script w script | None -> Task.return false end >>= fun succeed -> if succeed then Task.return true else try_hints w (Proof.hints_for ~pid:w.cw_pid) let try_coqide w = let script = Proof.script_for_ide ~pid:w.cw_pid ~gid:w.cw_gid in make_script w script ; (new runcoq w.cw_includes w.cw_script)#coqide w.cw_headers >>= fun st -> if st = 0 then match Proof.parse_coqproof w.cw_script with | None -> Wp_parameters.feedback "[Coq] No proof found" ; Task.return false | Some script -> if Proof.is_empty script then begin Proof.delete_script w.cw_gid ; Task.canceled () ; end else begin let req,hs = WpPropId.prop_id_keys w.cw_pid in let hints = List.merge String.compare req hs in Proof.add_script w.cw_gid hints script ; Wp_parameters.feedback "[Coq] Goal %s : Script" w.cw_gid ; try_script w script end else Task.failed "[Coq] coqide exit with status %d" st let prove_session ~interactive w = begin compile_headers w.cw_includes false w.cw_headers >>= try_prove w >>> function | Task.Result true -> Task.return true | Task.Failed e -> Task.raised e | Task.Canceled | Task.Timeout | Task.Result false -> if interactive then try_coqide w else Task.return false end >>= Task.call (fun r -> if r then VCS.valid else VCS.unknown) exception Admitted_not_proved let check_session w = compile_headers w.cw_includes false w.cw_headers >>= (fun () -> try_script ~admitted:true w "") >>> function | Task.Result true -> Task.return VCS.unknown | Task.Failed e -> Task.raised e | Task.Canceled | Task.Timeout | Task.Result false -> Task.raised Admitted_not_proved let prove_session ~interactive w = if Wp_parameters.wpcheck () then check_session w else prove_session ~interactive w let prove_prop wpo ~interactive ~axioms ~prop = let pid = wpo.po_pid in let gid = wpo.po_gid in let model = wpo.po_model in let script = DISK.file_goal ~pid ~model ~prover:Coq in let includes , headers , goal = Model.with_model model (assemble_goal ~pid axioms) prop in if Wp_parameters.Generate.get () then Task.return VCS.no_result else prove_session ~interactive { cw_pid = pid ; cw_gid = gid ; cw_goal = goal ; cw_script = script ; cw_headers = headers ; cw_includes = includes ; } let prove_annot wpo vcq ~interactive = Task.todo begin fun () -> let prop = GOAL.compute_proof vcq.VC_Annot.goal in prove_prop wpo ~interactive ~axioms:None ~prop end let prove_lemma wpo vca ~interactive = Task.todo begin fun () -> let lemma = vca.VC_Lemma.lemma in let depends = vca.VC_Lemma.depends in let prop = F.p_forall lemma.l_forall lemma.l_lemma in let axioms = Some(lemma.l_cluster,depends) in prove_prop wpo ~interactive ~axioms ~prop end let prove wpo ~interactive = match wpo.Wpo.po_formula with | GoalAnnot vcq -> prove_annot wpo vcq ~interactive | GoalLemma vca -> prove_lemma wpo vca ~interactive frama-c-Fluorine-20130601/src/wp/RefUsage.mli0000644000175000017500000000377612155630215017433 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Variable Analysis --- *) (* -------------------------------------------------------------------------- *) open Ctypes open Cil_types open Cil_datatype type var = Result | Cvar of varinfo | Lvar of logic_var module Var : sig type t = var val pretty : Format.formatter -> t -> unit end frama-c-Fluorine-20130601/src/wp/wp_error.ml0000644000175000017500000001140412155630215017403 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 "" | _ -> Format.fprintf fmt "@[%a@]" (Printer.pp_full_assigns "") asgns let pp_string_list ?(sep=format_of_string "@ ") ~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 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 frama-c-Fluorine-20130601/src/wp/driver.mli0000644000175000017500000000360012155630215017207 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Driver for External Files --- *) (* -------------------------------------------------------------------------- *) val load : string -> unit val load_drivers : unit -> unit frama-c-Fluorine-20130601/src/wp/Model.ml0000644000175000017500000001752212155630215016613 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Registry --- *) (* -------------------------------------------------------------------------- *) type model = { id : string ; (* Identifier Basename for Model (unique) *) descr : string ; (* Title of the Model (for pretty) *) emitter : Emitter.t ; mutable params : tuning list ; } and tuning = unit -> unit let repr = { id = "?model" ; descr = "?model" ; emitter = Emitter.kernel ; params = [] ; } module D = Datatype.Make_with_collections(struct type t = model let name = "WP.Model" let rehash = Datatype.identity (** TODO: register and find below? *) let structural_descr = let open Structural_descr in let parameter_descr = t_record [| p_string; p_string; (pack Unknown) |] in t_record [| p_string; p_string; pack (t_option t_string) ; Emitter.packed_descr; pack (t_list parameter_descr) |] let reprs = [repr] let equal x y = Datatype.String.equal x.id y.id let compare x y = Datatype.String.compare x.id y.id let hash x = Datatype.String.hash x.id let copy = Datatype.identity let internal_pretty_code _ fmt x = Format.pp_print_string fmt x.id let pretty fmt x = Format.pp_print_string fmt x.descr let mem_project = Datatype.never_any_project let varname _ = "m" end) module MODELS = struct module H = Datatype.String.Map let h = ref H.empty (* NOT PROJECTIFIED : Models are defined at Plugin load-time, for all projects *) let mem id = H.mem id !h let add m = h := H.add m.id m !h let find id = H.find id !h let iter f = H.iter (fun _ m -> f m) !h end let find ~id = MODELS.find id let iter f = MODELS.iter f let register ~id ?(descr=id) ?(tuning=[]) () = if MODELS.mem id then Wp_parameters.fatal "Duplicate model '%s'" id ; let emitter = let e_name = "Wp." ^ id in let correctness = [ ] in let tuning = [ Wp_parameters.Provers.parameter ] in Emitter.create e_name [ Emitter.Property_status ] ~correctness ~tuning in let model = { id = id ; descr = descr ; emitter = emitter ; params = tuning ; } in MODELS.add model ; model let get_id m = m.id let get_descr m = m.descr let model = Context.create "Wp.Model" let rec bind = function [] -> () | f::fs -> f () ; bind fs let back = function None -> () | Some c -> bind c.params let with_model m f x = let current = Context.push model m in try bind m.params ; let result = f x in Context.pop model current ; back current ; result with err -> Context.pop model current ; back current ; raise err let on_model m f = with_model m f () let get_model () = Context.get model let get_emitter model = model.emitter let directory () = Wp_parameters.get_output_dir (Context.get model).id module type Entries = sig type key type data val name : string val compare : key -> key -> int val pretty : Format.formatter -> key -> unit end module type Registry = sig type key type data val mem : key -> bool val find : key -> data val get : key -> data option val define : key -> data -> unit val update : key -> data -> unit val memoize : (key -> data) -> key -> data val compile : (key -> data) -> key -> unit val callback : (key -> data -> unit) -> unit val iter : (key -> data -> unit) -> unit val iter_sorted : (key -> data -> unit) -> unit end module Index(E : Entries) = struct type key = E.key type data = E.data module KEY = struct type t = E.key let compare = E.compare end module MAP = Map.Make(KEY) module SET = Set.Make(KEY) let demon = ref [] type entries = { mutable ident : int ; mutable index : E.data MAP.t ; mutable lock : SET.t ; } module ENTRIES : Datatype.S with type t = entries = Datatype.Make (struct type t = entries include Datatype.Serializable_undefined let reprs = [{ident=0;index=MAP.empty;lock=SET.empty}] let name = "Wp.Model.Index." ^ E.name end) module REGISTRY = State_builder.Hashtbl (Datatype.String.Hashtbl) (ENTRIES) (struct let name = "Wp.Model." ^ E.name let dependencies = [Ast.self] let size = 32 end) (* Projectified entry map, indexed by model *) let entries () : entries = let mid = (Context.get model).id in try REGISTRY.find mid with Not_found -> let e = { ident=0 ; index=MAP.empty ; lock=SET.empty } in REGISTRY.add mid e ; e let mem k = let e = entries () in MAP.mem k e.index || SET.mem k e.lock let find k = let e = entries () in MAP.find k e.index let get k = try Some (find k) with Not_found -> None let fire k d = List.iter (fun f -> f k d) !demon let callback f = demon := !demon @ [f] let define k d = begin let e = entries () in if MAP.mem k e.index then Wp_parameters.fatal "Duplicate definition (%s:%a)" E.name E.pretty k ; if SET.mem k e.lock then Wp_parameters.fatal "Locked definition (%s:%a)" E.name E.pretty k ; e.index <- MAP.add k d e.index ; fire k d ; end let update k d = begin let e = entries () in e.index <- MAP.add k d e.index ; fire k d ; end let memoize f k = let e = entries () in try MAP.find k e.index with Not_found -> let lock = e.lock in e.lock <- SET.add k e.lock ; let d = f k in e.index <- MAP.add k d e.index ; fire k d ; e.lock <- lock ; d (* in case of exception, the entry remains intentionally locked *) let compile f k = ignore (memoize f k) let iter f = MAP.iter f (entries()).index let iter_sorted f = let e = entries () in let s = MAP.fold (fun k _ s -> SET.add k s) e.index SET.empty in SET.iter (fun k -> f k (MAP.find k e.index)) s end module type Key = sig type t val compare : t -> t -> int val pretty : Format.formatter -> t -> unit end module type Data = sig type key type data val name : string val compile : key -> data end module type Generator = sig type key type data val get : key -> data end module Generator(K : Key)(D : Data with type key = K.t) = struct module G = Index (struct include K include D end) type key = D.key type data = D.data let get = G.memoize D.compile end module S = D type t = S.t frama-c-Fluorine-20130601/src/wp/Factory.ml0000644000175000017500000001736712155630215017171 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Factory --- *) (* -------------------------------------------------------------------------- *) type mheap = Hoare | Typed of MemTyped.pointer type mvar = Raw | Var | Ref type setup = { mvar : mvar ; mheap : mheap ; cint : Cint.model ; cfloat : Cfloat.model ; } (*[LC] All types in [model] must be Pervasives-comparable *) (* -------------------------------------------------------------------------- *) (* --- Description & Id --- *) (* -------------------------------------------------------------------------- *) let main (i,t) name = begin Buffer.add_string i name ; Buffer.add_string t (String.capitalize name) ; end let add (i,t) part = begin Buffer.add_char i '_' ; Buffer.add_string i part ; Buffer.add_char t ' ' ; Buffer.add_char t '(' ; Buffer.add_string t (String.capitalize part) ; Buffer.add_char t ')' ; end let descr_mtyped d = function | MemTyped.NoCast -> add d "nocast" | MemTyped.Unsafe -> add d "cast" | MemTyped.Fits -> () let descr_mheap d = function | Hoare -> main d "hoare" | Typed p -> main d "typed" ; descr_mtyped d p let descr_mvar d = function | Var -> () | Ref -> add d "ref" | Raw -> add d "raw" let descr_cint d = function | Cint.Natural -> () | Cint.Machine -> add d "int" let descr_cfloat d = function | Cfloat.Real -> () | Cfloat.Float -> add d "float" let descr (s:setup) = begin let i = Buffer.create 40 in let t = Buffer.create 40 in let d = (i,t) in descr_mheap d s.mheap ; descr_mvar d s.mvar ; descr_cint d s.cint ; descr_cfloat d s.cfloat ; ( Buffer.contents i , Buffer.contents t ) end (* -------------------------------------------------------------------------- *) (* --- Generator & Model --- *) (* -------------------------------------------------------------------------- *) module VarHoare : MemVar.VarUsage = struct let datatype = "Value" let param _x = MemVar.ByValue end module VarRef0 : MemVar.VarUsage = struct let datatype = "Ref0" let param x = match Variables_analysis.dispatch_cvar x with | Variables_analysis.Fvar -> MemVar.ByValue | _ -> MemVar.InHeap end module VarRef2 : MemVar.VarUsage = struct let datatype = "Ref2" let param x = match VarUsage.of_cvar x with | VarUsage.NotUsed | VarUsage.ByValue | VarUsage.ByArray _ | VarUsage.ByRefArray _ -> MemVar.ByValue | VarUsage.ByReference -> MemVar.ByRef | VarUsage.ByAddress -> MemVar.InHeap end module MHoareVar = MemVar.Make(VarHoare)(MemEmpty) module MHoareRef = MemVar.Make(VarRef2)(MemEmpty) module MTypedVar = MemVar.Make(VarRef0)(MemTyped) module MTypedRef = MemVar.Make(VarRef2)(MemTyped) module WP_HoareVar = CfgWP.Computer(MHoareVar) module WP_HoareRef = CfgWP.Computer(MHoareRef) module WP_TypedRaw = CfgWP.Computer(MemTyped) module WP_TypedVar = CfgWP.Computer(MTypedVar) module WP_TypedRef = CfgWP.Computer(MTypedRef) let wp (s:setup) : Model.t -> Generator.computer = match s.mheap , s.mvar with | Hoare , (Raw|Var) -> WP_HoareVar.create | Hoare , Ref -> WP_HoareRef.create | Typed _ , Raw -> WP_TypedRaw.create | Typed _ , Var -> WP_TypedVar.create | Typed _ , Ref -> WP_TypedRef.create (* -------------------------------------------------------------------------- *) (* --- Tuning --- *) (* -------------------------------------------------------------------------- *) let configure_mheap = function | Hoare -> MemEmpty.configure () | Typed p -> MemTyped.configure () ; Context.set MemTyped.pointer p let configure (s:setup) () = begin configure_mheap s.mheap ; Context.set Cint.model s.cint ; Context.set Cfloat.model s.cfloat ; end (* -------------------------------------------------------------------------- *) (* --- Access --- *) (* -------------------------------------------------------------------------- *) module MODEL = Map.Make (struct type t = setup let compare = Pervasives.compare end) type instance = { id : string ; descr : string ; model : Model.t ; } let instances = ref MODEL.empty let instance (s:setup) = try MODEL.find s !instances with Not_found -> let id,descr = descr s in let tuning = [configure s] in let model = Model.register ~id ~descr ~tuning () in let instance = { id = id ; descr = descr ; model = model } in instances := MODEL.add s instance !instances ; instance let id s = (instance s).id let descr s = (instance s).descr let model s = (instance s).model let computer (s:setup) = wp s (instance s).model let split (m:string) : string list = let tk = ref [] in let buffer = Buffer.create 32 in let flush () = if Buffer.length buffer > 0 then begin tk := !tk @ [Buffer.contents buffer] ; Buffer.clear buffer ; end in String.iter (fun c -> match c with | 'A' .. 'Z' -> Buffer.add_char buffer c | '_' | ',' | '@' | '+' | ' ' | '\t' | '\n' | '(' | ')' -> flush () | _ -> Wp_parameters.error "In model spec %S : unexpected character '%c'" m c ) (String.uppercase m) ; flush () ; !tk let rec update_config m s = function | "HOARE" -> { s with mheap = Hoare } | "TYPED" -> { s with mheap = Typed MemTyped.Fits } | "CAST" -> { s with mheap = Typed MemTyped.Unsafe } | "NOCAST" -> { s with mheap = Typed MemTyped.NoCast } | "RAW" -> { s with mvar = Raw } | "REF" -> { s with mvar = Ref } | "VAR" -> { s with mvar = Var } | "NAT" -> { s with cint = Cint.Natural } | "INT" | "CINT" -> { s with cint = Cint.Machine } | "REAL" -> { s with cfloat = Cfloat.Real } | "FLOAT" | "CFLOAT" -> { s with cfloat = Cfloat.Float } | t -> Wp_parameters.error "In model spec %S : unknown '%s' selector@." m t ; s let apply_config (s:setup) m : setup = List.fold_left (update_config m) s (split m) let parse = List.fold_left apply_config { mheap = Typed MemTyped.Fits ; mvar = Var ; cint = Cint.Natural ; cfloat = Cfloat.Real ; } frama-c-Fluorine-20130601/src/wp/LogicAssigns.mli0000644000175000017500000000444612155630215020312 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Ctypes open Lang.F open Memory module type Code = sig type loc val equal_obj : c_object -> loc value -> loc value -> pred end module type Logic = sig type loc val vars : loc Memory.sloc list -> Vars.t val pp_logic : Format.formatter -> loc Memory.logic -> unit val pp_sloc : Format.formatter -> loc Memory.sloc -> unit val pp_region : Format.formatter -> loc Memory.sloc list -> unit end module Make ( M : Memory.Model ) ( C : Code with type loc = M.loc ) ( L : Logic with type loc = M.loc ) : sig open M open Memory type region = (c_object * loc sloc list) list val vars : region -> Vars.t val domain : region -> Heap.set val assigned : sigma sequence -> region -> pred list end frama-c-Fluorine-20130601/src/wp/wprop.mli0000644000175000017500000000562112155630215017070 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 frama-c-Fluorine-20130601/src/wp/Vset.ml0000644000175000017500000003126512155630215016474 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Qed open Lang open Lang.F (* -------------------------------------------------------------------------- *) (* --- Logical Sets --- *) (* -------------------------------------------------------------------------- *) type set = vset list and vset = | Set of tau * term | Singleton of term | Range of term option * term option | Descr of var list * term * pred let occurs_opt x = function | None -> false | Some t -> occurs x t let occurs_vset x = function | Set(_,t) | Singleton t -> occurs x t | Range(a,b) -> occurs_opt x a || occurs_opt x b | Descr(xs,t,p) -> if List.exists (Var.equal x) xs then false else (occurs x t || occursp x p) let occurs x = List.exists (occurs_vset x) let vars_opt = function None -> Vars.empty | Some e -> F.vars e let vars_vset = function | Set(_,t) -> F.vars t | Singleton t -> F.vars t | Range(a,b) -> Vars.union (vars_opt a) (vars_opt b) | Descr(xs,t,p) -> List.fold_left (fun xs x -> Vars.remove x xs) (Vars.union (F.vars t) (F.varsp p)) xs let vars vset = List.fold_left (fun xs s -> Vars.union xs (vars_vset s)) Vars.empty vset (* -------------------------------------------------------------------------- *) (* --- Pretty --- *) (* -------------------------------------------------------------------------- *) (* let is_elt = function Set _ | Descr _ -> false | Singleton _ | Range _ -> true let pp_elt fmt = function | Set _ | Descr _ -> () | Singleton t -> F.pp_term fmt t | Range(Some a,Some b) -> Format.fprintf fmt "%a..%a" F.pp_term a F.pp_term b | Range(None,Some b) -> Format.fprintf fmt "..%a" F.pp_term b | Range(Some a,None) -> Format.fprintf fmt "%a.." F.pp_term a | Range(None,None) -> Format.pp_print_string fmt ".." let pp_elts fmt = function | [] -> () | x::xs -> pp_elt fmt x ; List.iter (fun x -> Format.fprintf fmt ",@,%a" pp_elt x) xs let pp_vset fmt = function | (Singleton _ | Range _) as e -> Format.fprintf fmt "@[{%a}@]" pp_elt e | Set(_,t) -> F.pp_term fmt t | Descr(xs,t,p) -> begin Format.fprintf fmt "@[{ @[%a@]" F.pp_term t ; if xs <> [] then ( Format.fprintf fmt "@ @[for" ; List.iter (fun x -> Format.fprintf fmt "@ %a" Var.pretty x) xs ) ; Format.fprintf fmt "@ @[with %a@] }@]" F.pp_pred p ; end let pretty fmt = function | [] -> Format.fprintf fmt "{}" | s -> begin let es,ds = List.partition is_elt s in Format.fprintf fmt "@[" ; if es <> [] then Format.fprintf fmt "@[{%a}@]" pp_elts es ; match ds with | [] -> () | ds when es <> [] -> List.iter (fun d -> Format.fprintf fmt "@ + %a" pp_vset d) ds | d::ds -> pp_vset fmt d ; List.iter (fun d -> Format.fprintf fmt "@ + %a" pp_vset d) ds end *) (* -------------------------------------------------------------------------- *) (* --- Set Operations --- *) (* -------------------------------------------------------------------------- *) let theory = "vset" let adt_set = Lang.datatype ~link:"set" ~theory let tau_of_set te = Logic.Data( adt_set , [te] ) let p_member = Lang.extern_p ~theory ~prop:"member" ~bool:"member_bool" () let f_empty = Lang.extern_f ~theory "empty" let f_union = Lang.extern_f ~theory "union" let f_inter = Lang.extern_f ~theory "inter" let f_range = Lang.extern_f ~theory "range" let f_range_sup = Lang.extern_f ~theory "range_sup" let f_range_inf = Lang.extern_f ~theory "range_inf" let f_range_all = Lang.extern_f ~theory "range_all" let f_singleton = Lang.extern_f ~theory "singleton" let single a b = match a,b with | Some x , Some y when F.equal x y -> a | _ -> None let test_range x y a b = let p_inf = match a with Some a -> p_leq a x | None -> p_true in let p_sup = match b with Some b -> p_leq y b | None -> p_true in p_and p_inf p_sup let sub_range x y a b = match single a b with | Some z -> p_and (p_equal x z) (p_equal y z) | None -> test_range x y a b let in_size x n = p_and (p_leq e_zero x) (p_lt x (e_int64 n)) let in_range x a b = match single a b with | Some y -> p_equal x y | None -> test_range x x a b let ordered ~limit ~strict a b = match a , b with | Some x , Some y -> if strict then p_lt x y else p_leq x y | _ -> if limit then p_true else p_false let member x xs = p_all (function | Set(_,s) -> p_call p_member [x;s] | Singleton e -> p_equal x e | Range(a,b) -> in_range x a b | Descr(xs,t,p) -> p_exists xs (p_and (p_equal x t) p) ) xs let empty = [] let singleton x = [Singleton x] let range a b = [Range(a,b)] let union xs ys = (xs @ ys) let descr = function | Set(t,s) -> let x = Lang.freshvar t in let e = e_var x in [x] , e , p_call p_member [e;s] | Singleton e -> ( [] , e , p_true ) | Range(a,b) -> let x = Lang.freshvar ~basename:"k" Logic.Int in let e = e_var x in [x] , e , in_range e a b | Descr(xs,t,p) -> xs, t, p (* -------------------------------------------------------------------------- *) (* --- Concretize --- *) (* -------------------------------------------------------------------------- *) let concretize_vset = function | Set(_,s) -> s | Singleton e -> e_fun f_singleton [e] | Range(None,None) -> e_fun f_range_all [] | Range(None,Some b) -> e_fun f_range_inf [b] | Range(Some a,None) -> e_fun f_range_sup [a] | Range(Some a,Some b) -> e_fun f_range [a;b] | Descr _ -> Warning.error "Concretization for comprehension sets not implemented yet" let concretize = function | [] -> e_fun f_empty [] | x::xs -> List.fold_left (fun w x -> e_fun f_union [w;concretize_vset x]) (concretize_vset x) xs let inter xs ys = e_fun f_inter [xs;ys] (* -------------------------------------------------------------------------- *) (* --- Inclusion --- *) (* -------------------------------------------------------------------------- *) let subrange a b = function | [Range(c,d)] -> p_and (match c,a with | None,_ -> p_true | Some _,None -> p_false | Some c,Some a -> p_leq c a) (match b,d with | _,None -> p_true | None,Some _ -> p_false | Some b,Some d -> p_leq b d) | ys -> let x = Lang.freshvar ~basename:"k" Logic.Int in let k = e_var x in p_forall [x] (p_imply (in_range k a b) (member k ys)) let subset xs ys = p_all (function | Set(t,s) -> let x = Lang.freshvar t in let e = e_var x in p_forall [x] (p_imply (p_call p_member [e;s]) (member e ys)) | Singleton e -> member e ys | Descr(xs,t,p) -> p_forall xs (p_imply p (member t ys)) | Range(a,b) -> subrange a b ys ) xs (* -------------------------------------------------------------------------- *) (* --- Equality --- *) (* -------------------------------------------------------------------------- *) let equal xs ys = p_and (subset xs ys) (subset ys xs) (* -------------------------------------------------------------------------- *) (* --- Separation --- *) (* -------------------------------------------------------------------------- *) let empty_range a b = match a,b with | None,_ | _,None -> p_false | Some x , Some y -> p_lt y x let disjoint_bounds left right = match left , right with | None,_ | _,None -> p_false | Some x , Some y -> p_lt x y let disjoint_vset x y = match x , y with | Singleton x , Singleton y -> p_neq x y | Singleton e , Range(a,b) | Range(a,b) , Singleton e -> p_not (in_range e a b) | Range(a,b) , Range(c,d) -> p_disj [ empty_range a b ; empty_range c d ; disjoint_bounds b c ; disjoint_bounds d a ; ] | Singleton x , Descr(xs,t,p) | Descr(xs,t,p) , Singleton x -> p_forall xs (p_imply p (p_neq x t)) | Range(a,b) , Descr(xs,t,p) | Descr(xs,t,p) , Range(a,b) -> p_forall xs (p_imply p (p_not (in_range t a b))) | Descr(xs,ta,pa) , Descr(ys,tb,pb) -> p_forall xs (p_forall ys (p_hyps [pa;pb] (p_neq ta tb))) | Singleton e , Set(_,s) | Set(_,s) , Singleton e -> p_not (p_call p_member [e;s]) | Set _ , Set _ -> let xs,a,p = descr x in let ys,b,q = descr y in p_forall (xs @ ys) (p_hyps [p;q] (p_neq a b)) | Set(_,s) , w | w , Set(_,s) -> let xs,t,p = descr w in let t_in_s = p_call p_member [t;s] in p_forall xs (p_not (p_and p t_in_s)) let disjoint xs ys = let ws = List.fold_left (fun w x -> List.fold_left (fun w y -> disjoint_vset x y :: w) w ys ) [] xs in p_conj ws (* -------------------------------------------------------------------------- *) (* --- Lifting & Maping --- *) (* -------------------------------------------------------------------------- *) let cartesian f xs ys = let zs = List.fold_left (fun w x -> List.fold_left (fun w y -> f x y :: w) w ys ) [] xs in List.rev zs let map_vset f x = let xs,t,p = descr x in Descr(xs,f t,p) let map f xs = List.map (function Singleton x -> Singleton (f x) | u -> map_vset f u) xs let map_opt f = function None -> None | Some x -> Some (f x) let map_opp xs = List.map (function | Singleton x -> Singleton (e_opp x) | Range(a,b) -> Range(map_opt e_opp b,map_opt e_opp a) | Descr(xs,t,p) -> Descr(xs,e_opp t,p) | (Set _) as w -> let xs,t,p = descr w in Descr(xs,e_opp t,p) ) xs let lift_vset f x y = let xs,ta,pa = descr x in let ys,tb,pb = descr y in Descr (xs @ ys , f ta tb , p_and pa pb) let lift f xs ys = cartesian (fun x y -> match x , y with | Singleton a , Singleton b -> Singleton (f a b) | _ -> lift_vset f x y ) xs ys let pp_bound fmt = function | None -> () | Some e -> F.pp_term fmt e let bound_shift a k = match a with | None -> None | Some x -> Some (e_add x k) let bound_add a b = match a,b with | None,_ | _,None -> None | Some x , Some y -> Some (e_add x y) let bound_sub a b = match a,b with | None,_ | _,None -> None | Some x , Some y -> Some (e_sub x y) let lift_add xs ys = cartesian (fun x y -> match x , y with | Singleton a , Singleton b -> Singleton(e_add a b) | Singleton u , Range(a,b) | Range(a,b) , Singleton u -> Range(map_opt (e_add u) a, map_opt (e_add u) b) | Range(a,b) , Range(c,d) -> Range(bound_add a c,bound_add b d) | _ -> lift_vset e_add x y ) xs ys let lift_sub xs ys = cartesian (fun x y -> match x , y with | Singleton a , Singleton b -> Singleton(e_sub a b) | Singleton u , Range(a,b) -> Range(bound_sub (Some u) b , bound_sub (Some u) a) | Range(a,b) , Singleton u -> Range(bound_sub a (Some u) , bound_sub b (Some u)) | Range(a,b) , Range(c,d) -> Range(bound_sub a d , bound_sub b c) | _ -> lift_vset e_sub x y ) xs ys (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/MemEmpty.mli0000644000175000017500000000353312155630215017456 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Empty Memory Model --- *) (* -------------------------------------------------------------------------- *) include Memory.Model frama-c-Fluorine-20130601/src/wp/variables_analysis.ml0000644000175000017500000022357012155630215021430 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 = Wp_parameters.register_category "var_analysis" (* debugging key*) let debug = Wp_parameters.debug ~dkey let dkey = Wp_parameters.register_category "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 [*....*t], p always occurs with *:[* p] except in call. As call argument, p can occurs with less than *: [*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. - *x, n <= stars(typ(x)) A by array reference call is characterized by 2 facts : 1a) the formal parameters [p] is of pointer type [*....*t], p always occurs with indexes:[p[i]] except in call. As call argument, p can occurs with less than indexes: [p[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 <= 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 == * 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 == * 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 == [] 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 == [] 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[] 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[] 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 size = 40 end) let logic_param_memory_info x = debug "[LogicParam] %a" Printer.pp_logic_var x; if LogicParam.mem x then (debug "[LogicParam] %a in " Printer.pp_logic_var x; LogicParam.replace x true) else (debug "[LogicParam] %a out"Printer.pp_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 -> Printer.pp_varinfo fmt x | Lv p -> Printer.pp_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.Serializable_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 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 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" Printer.pp_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 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 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 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 Printer.pp_varinfo x n; if x.vformal then (debug "%s %a is a formal" s Printer.pp_varinfo x; let arr = brackets_and_stars_typ x.vtype in if (arr >= n) then (debug "%s %a has dim %d ok!" s Printer.pp_varinfo x arr; Ok (x,arr)) else (debug "%s %a has dim %d when need %d ko!" s Printer.pp_varinfo x arr n; Ko(x,arr)) ) else ( debug "%s %a is not a formal" s Printer.pp_varinfo x; Any) ) | Some (x,n) -> debug "%s %a[]" s Printer.pp_varinfo 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 Printer.pp_logic_var x n; if (is_lformal x) then ( debug "%s %a is a formal" s Printer.pp_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 Printer.pp_logic_var x arr ;Ok (x,arr)) else (debug "%s %a has dim %d when need %d ko!" s Printer.pp_logic_var x arr n ;Ko (x,arr))) else ( debug "%s %a is not a formal" s Printer.pp_logic_var x;Any) end) |Some (x,n) -> debug "%s %a[]" s Printer.pp_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" Printer.pp_varinfo x n ; add_ptr_reference_param (Cv x) n; true | Ko(x,_) -> debug " %a BADLY used as ptr reference param" Printer.pp_varinfo 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" Printer.pp_varinfo x n ; add_array_reference_param (Cv x) n ; true | Ko(x,_) -> debug " %a BADLY used as array reference param" Printer.pp_varinfo 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" Printer.pp_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" Printer.pp_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" Printer.pp_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" Printer.pp_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 (_,_) | Toffset (_,_) -> SkipChildren | t1 -> if reference_parameter_usage_term t1 then SkipChildren else DoChildren method vpredicate = function | Papp (_, _, _) -> SkipChildren | Pvalid _ | Pvalid_read _ | 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)) - *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 < 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 Printer.pp_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 Printer.pp_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 Printer.pp_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 Printer.pp_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 Printer.pp_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 Printer.pp_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 Printer.pp_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*] 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[]] 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*] 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[]] 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 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 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*] 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[]] 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*] 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[]] 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 Printer.pp_varinfo 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 Printer.pp_varinfo 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" Printer.pp_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 Printer.pp_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 Printer.pp_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 Printer.pp_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 Printer.pp_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" Printer.pp_instr e; collect_calls f el ; SkipChildren | _ -> DoChildren method vterm t = match t.term_node with | Tapp (lf,_ , targs) -> debug "[Calls_collection] app %a" Printer.pp_term t; collect_apps lf targs ; SkipChildren | Tblock_length (_label,ta) -> (* [PB] TODO label added *) debug "[Calls_collection] block_length %a" Printer.pp_term t; collect_apps_builtin [ta] ; SkipChildren | _ -> DoChildren method vpredicate = function | Papp (lf, _, targs) -> collect_apps lf targs ; SkipChildren | Pfresh (_todo_label1,_todo_label2,t,n) -> (* [PB] TODO: labels and size added *) debug "[Calls_collection] predicate app on %a, %a" Printer.pp_term t Printer.pp_term n ; collect_apps_builtin [t;n] ; SkipChildren | Pallocable (_todo_label,t) (* [PB] TODO: construct added *) | Pfreeable (_todo_label,t) (* [PB] TODO: construct added *) | Pvalid_read (_todo_label,t)(* [PB] TODO: construct added *) | Pvalid (_todo_label,t) (* [PB] TODO: label added *) | Pinitialized (_todo_label,t) -> (* [PB] TODO: label added *) debug "[Calls_collection] predicate app on %a" Printer.pp_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_sorted (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_sorted (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_sorted (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_sorted (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_sorted (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 emitter = Emitter.create "Wp variable analysis" [ Emitter.Funspec ] ~correctness:[] ~tuning:[] let add_requires hyp kf = (*[LC+JS]: This function does nothing if there is no default bhv (!) *) let spec = Annotations.funspec kf in Extlib.may (fun b -> Annotations.add_requires emitter kf b.b_name [ hyp ]) (Cil.find_default_behavior spec) 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" Printer.pp_identified_predicate hyp; add_requires hyp kf; | 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 *) (* [LC] Discrimination is now performed in Factory *) 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 ~logicvar:true ~refvar:false 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 ~logicvar:true ~refvar:false 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 is_to_scope vinfo = let case = case_of_optimization ~logicvar:true ~refvar:false in is_ref case vinfo || is_memvar case vinfo let precondition_compute () = if (* Wp_parameters.RefVar.get () *) false then begin compute (); kernel_functions_separation_hyps () end else () frama-c-Fluorine-20130601/src/wp/Cstring.mli0000644000175000017500000000450412155630215017331 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- String Constants --- *) (* -------------------------------------------------------------------------- *) open Lang open Lang.F type cst = | C_str of string (** String Literal *) | W_str of int64 list (** Wide String Literal *) val pretty : Format.formatter -> cst -> unit val str_len : cst -> term -> pred val str_val : cst -> term (** The array containing all [char] of the constant *) val str_id : cst -> int (** Non-zero integer, unique for each different string literal *) val char_at : cst -> term -> term val cluster : unit -> Definitions.cluster (** The cluster where all strings are defined. *) frama-c-Fluorine-20130601/src/wp/clabels.ml0000644000175000017500000001075312155630215017157 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 equal = (=) module T = struct type t = c_label let compare = Pervasives.compare end module LabelMap = Map.Make(T) module LabelSet = Set.Make(T) 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 lookup_name = function | Pre -> "Pre" | Here -> "Here" | Post -> "Post" | Exit -> "Exit" | LabelParam p -> p | CallAt sid -> Printf.sprintf "" sid | At(_,sid) -> Printf.sprintf "" sid 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 frama-c-Fluorine-20130601/src/wp/LogicCompiler.mli0000644000175000017500000000767412155630215020463 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Compilation of ACSL Logic-Info --- *) (* -------------------------------------------------------------------------- *) open LogicUsage open Cil_types open Cil_datatype open Clabels open Lang open Lang.F open Memory open Definitions module Make( M : Memory.Model ) : sig (** {3 Definitions} *) type value = M.loc Memory.value type logic = M.loc Memory.logic type sigma = M.Sigma.t type chunk = M.Chunk.t (** {3 Frames} *) type frame val pp_frame : Format.formatter -> frame -> unit val frame : kernel_function -> frame val frame_copy : frame -> frame val call_pre : kernel_function -> value list -> sigma -> frame val call_post : kernel_function -> value list -> sigma sequence -> frame val formal : varinfo -> value option val return : unit -> typ val result : unit -> var val status : unit -> var val trigger : trigger -> unit val guards : frame -> pred list val mem_frame : c_label -> sigma val mem_at_frame : frame -> c_label -> sigma val in_frame : frame -> ('a -> 'b) -> 'a -> 'b val get_frame : unit -> frame (** {3 Environment} *) type env val new_env : Logic_var.t list -> env val move : env -> sigma -> env val sigma : env -> sigma val env_at : env -> c_label -> env val mem_at : env -> c_label -> sigma val env_let : env -> logic_var -> logic -> env val env_letval : env -> logic_var -> value -> env (** {3 Compiler} *) val term : env -> Cil_types.term -> term val pred : bool -> env -> predicate named -> pred val logic : env -> Cil_types.term -> logic val region : env -> Cil_types.term -> M.loc sloc list val bootstrap_term : (env -> Cil_types.term -> term) -> unit val bootstrap_pred : (bool -> env -> predicate named -> pred) -> unit val bootstrap_logic : (env -> Cil_types.term -> logic) -> unit val bootstrap_region : (env -> Cil_types.term -> M.loc sloc list) -> unit (** {3 Application} *) val call_fun : env -> logic_info -> (logic_label * logic_label) list -> F.term list -> F.term val call_pred : env -> logic_info -> (logic_label * logic_label) list -> F.term list -> F.pred (** {3 Logic Variable and ACSL Constants} *) val logic_var : env -> logic_var -> logic (** {3 Logic Lemmas} *) val lemma : logic_lemma -> dlemma end frama-c-Fluorine-20130601/src/wp/Wp.mli0000644000175000017500000000340112155630215016301 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 22051 2013-04-09 13:52:27Z correnson $ *) (** Weakest preconditions. *) (** No function is directly exported: they are registered in {!Db.Properties}. *) frama-c-Fluorine-20130601/src/wp/Generator.ml0000644000175000017500000001331012155630215017470 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Computer (main entry points) --- *) (* -------------------------------------------------------------------------- *) class type computer = object method lemma : bool method add_strategy : WpStrategy.strategy -> unit method add_lemma : LogicUsage.logic_lemma -> unit method compute : Wpo.t Bag.t end (* -------------------------------------------------------------------------- *) (* --- Property Entry Point --- *) (* -------------------------------------------------------------------------- *) let compute_ip cc ip = match ip with | Property.IPLemma _ | Property.IPAxiomatic _ -> let rec iter cc = function | Property.IPLemma(name,_,_,_,_) -> cc#add_lemma (LogicUsage.logic_lemma name) | Property.IPAxiomatic(_,ips) -> List.iter (iter cc) ips | _ -> () in iter cc ip ; cc#compute | Property.IPBehavior (kf,_,b) -> let bhv = [b.Cil_types.b_name] in List.iter cc#add_strategy (WpAnnot.get_function_strategies ~assigns:WpAnnot.WithAssigns ~bhv kf) ; cc#compute | Property.IPComplete _ | Property.IPDisjoint _ | Property.IPCodeAnnot _ | Property.IPAllocation _ | Property.IPAssigns _ | Property.IPFrom _ | Property.IPDecrease _ | Property.IPPredicate _ -> List.iter cc#add_strategy (WpAnnot.get_id_prop_strategies ~assigns:WpAnnot.WithAssigns ip) ; cc#compute | Property.IPAxiom _ | Property.IPReachable _ | Property.IPOther _ -> Wp_parameters.result "Nothing to compute for '%a'" Property.pretty ip ; Bag.empty (* -------------------------------------------------------------------------- *) (* --- Annotations Entry Point --- *) (* -------------------------------------------------------------------------- *) type functions = | F_All | F_List of string list | F_Skip of string list let iter_kf phi = function | None -> Globals.Functions.iter phi | Some kf -> phi kf let iter_fct phi = function | F_All -> Globals.Functions.iter phi | F_Skip fs -> Globals.Functions.iter (fun kf -> let f = Kernel_function.get_name kf in if not (List.mem f fs) then phi kf) | F_List fs -> List.iter (fun f -> try phi (Globals.Functions.find_by_name f) with Not_found -> Wp_parameters.error "Unknown function '%s' (skipped)" f ) fs let add_kf cc ?bhv ?prop kf = List.iter cc#add_strategy (WpAnnot.get_function_strategies ~assigns:WpAnnot.WithAssigns ?bhv ?prop kf) let compute_kf cc ?kf ?bhv ?prop () = begin iter_kf (add_kf cc ?bhv ?prop) kf ; cc#compute end let do_lemmas = function F_All | F_Skip _ -> true | F_List _ -> false let compute_selection cc ?(fct=F_All) ?bhv ?prop () = begin if do_lemmas fct then begin match prop with | None | Some[] -> LogicUsage.iter_lemmas (fun lem -> let idp = WpPropId.mk_lemma_id lem in if WpAnnot.filter_status idp then cc#add_lemma lem) | Some ps -> if List.mem "-@lemmas" ps then () else LogicUsage.iter_lemmas (fun lem -> let idp = WpPropId.mk_lemma_id lem in if WpAnnot.filter_status idp && WpPropId.select_by_name ps idp then cc#add_lemma lem) end ; iter_fct (add_kf cc ?bhv ?prop) fct ; cc#compute end (* -------------------------------------------------------------------------- *) (* --- Calls Entry Point --- *) (* -------------------------------------------------------------------------- *) let compute_call cc stmt = List.iter cc#add_strategy (WpAnnot.get_call_pre_strategies stmt) ; cc#compute (* -------------------------------------------------------------------------- *) (* --- Froms Entry Point --- *) (* -------------------------------------------------------------------------- *) let compute_froms cc ?(fct=F_All) () = iter_fct (fun kf -> List.iter cc#add_strategy (WpFroms.get_strategies_for_froms kf) ) fct ; cc#compute frama-c-Fluorine-20130601/src/wp/Generator.mli0000644000175000017500000000500712155630215017645 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Computer (main entry points) --- *) (* -------------------------------------------------------------------------- *) class type computer = object method lemma : bool method add_strategy : WpStrategy.strategy -> unit method add_lemma : LogicUsage.logic_lemma -> unit method compute : Wpo.t Bag.t end type functions = | F_All | F_List of string list | F_Skip of string list val compute_ip : computer -> Property.t -> Wpo.t Bag.t val compute_call : computer -> Cil_types.stmt -> Wpo.t Bag.t val compute_kf : computer -> ?kf:Kernel_function.t -> ?bhv:string list -> ?prop:string list -> unit -> Wpo.t Bag.t val compute_selection : computer -> ?fct:functions -> ?bhv:string list -> ?prop:string list -> unit -> Wpo.t Bag.t val compute_froms : computer -> ?fct:functions -> unit -> Wpo.t Bag.t frama-c-Fluorine-20130601/src/wp/wprop.ml0000644000175000017500000001047212155630215016717 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 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 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 (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/Letify.ml0000644000175000017500000003126112155630215017003 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Letification of Goals --- *) (* -------------------------------------------------------------------------- *) open Qed.Logic open Lang open Lang.F let vmem x a = Vars.mem x (F.vars a) let occurs xs a = Vars.intersect xs (F.vars a) (* -------------------------------------------------------------------------- *) (* --- Generalized Substitution --- *) (* -------------------------------------------------------------------------- *) module Sigma : sig type t val equal : t -> t -> bool val pretty : string -> Format.formatter -> t -> unit val empty : t val add : var -> term -> t -> t val mem : var -> t -> bool val find : var -> t -> term val e_apply : t -> term -> term val p_apply : t -> pred -> pred val assume : t -> pred -> t val iter : (var -> term -> unit) -> t -> unit val class_of : t -> var -> var list val domain : t -> Vars.t val codomain : t -> Vars.t end = struct module Ceq = Qed.Partition.Make(Var) type t = { dvar : Vars.t ; (* Domain of def *) dcod : Vars.t ; (* Codomain of def *) dall : Vars.t ; (* Domain of cst and def *) def : term Vmap.t ; (* Definitions *) ceq : Ceq.t ; (* Variable Classes *) cst : term Tmap.t ; (* Constants *) mutable mem : term Tmap.t ; (* Memoization *) } let empty = { dcod = Vars.empty ; dvar = Vars.empty ; dall = Vars.empty ; ceq = Ceq.empty ; def = Vmap.empty ; cst = Tmap.empty ; mem = Tmap.empty ; } let equal s1 s2 = Vmap.equal F.equal s1.def s2.def && Tmap.equal F.equal s1.cst s2.cst let mem x sigma = Vmap.mem x sigma.def let find x sigma = Vmap.find x sigma.def let iter f sigma = Vmap.iter f sigma.def let rec m_apply sigma xs (e:term) = match F.repr e with | Var y -> if Vars.mem y xs then e else begin (* memoization or definition *) try Tmap.find e sigma.mem with Not_found -> let r = try Vmap.find y sigma.def with Not_found -> e in sigma.mem <- Tmap.add e r sigma.mem ; r end | _ -> let ys = F.vars e in if not (Vars.intersect ys sigma.dall) then e (* no subst *) else if Vars.intersect ys xs then (* bound variables *) F.f_map (m_apply sigma) xs e else begin (* memoization *) try Tmap.find e sigma.mem with Not_found -> let r = F.f_map (m_apply sigma) xs e in sigma.mem <- Tmap.add e r sigma.mem ; r end let e_apply sigma e = m_apply sigma Vars.empty e let p_apply sigma p = F.p_bool (m_apply sigma Vars.empty (F.e_prop p)) let s_apply sigma x e = m_apply sigma (Vars.singleton x) e (* Returns true if [x:=a] applied to [y:=b] raises a circularity *) let occur_check sigma x a = try if vmem x a then raise Exit ; Vmap.iter (fun y b -> if vmem x b && vmem y a then raise Exit) sigma.def ; false with Exit -> true let add_ceq x e ceq = match F.repr e with | Var y -> Ceq.join x y ceq | _ -> ceq let single x e = let sx = Vars.singleton x in { dvar = sx ; dall = sx ; dcod = F.vars e ; def = Vmap.add x e Vmap.empty ; ceq = add_ceq x e Ceq.empty ; cst = Tmap.empty ; mem = Tmap.empty ; } let add x e sigma = let e = e_apply sigma e in if Vmap.mem x sigma.def then sigma else if occur_check sigma x e then sigma else let sx = single x e in let def = Vmap.add x e (Vmap.map (s_apply sx) sigma.def) in let cst0 = Tmap.filter (fun e _c -> not (vmem x e)) sigma.cst in let cst1 = Tmap.fold (fun e c cst -> if vmem x e then Tmap.add e c cst else cst) cst0 sigma.cst in { mem = cst1 ; cst = cst1 ; def = def ; ceq = add_ceq x e sigma.ceq ; dvar = Vars.add x sigma.dvar ; dall = Vars.add x sigma.dall ; dcod = Vars.union (F.vars e) sigma.dcod ; } let domain sigma = sigma.dvar let codomain sigma = sigma.dcod let class_of sigma x = Ceq.members sigma.ceq x (* --- Constants --- *) (* c must be closed *) let add_cst e c sigma = try let c0 = Tmap.find e sigma.cst in if compare c c0 < 0 then raise Not_found else sigma with Not_found -> let cst = Tmap.add e c sigma.cst in let all = Vars.union (F.vars e) sigma.dall in { mem = cst ; cst = cst ; dall = all ; dvar = sigma.dvar ; dcod = sigma.dcod ; def = sigma.def ; ceq = sigma.ceq ; } let mem_lit l sigma = try Tmap.find l sigma.mem == e_true with Not_found -> false let add_lit l sigma = add_cst l e_true (add_cst (e_not l) e_false sigma) let rec add_pred sigma p = match F.repr p with | And ps -> List.fold_left add_pred sigma ps | Eq(a,b) -> begin match F.is_closed a , F.is_closed b with | true , false -> add_cst b a sigma | false , true -> add_cst a b sigma | _ -> add_lit p sigma end | Leq(a,b) -> if mem_lit (e_leq b a) sigma then add_pred sigma (e_eq a b) else add_lit p sigma | Lt(a,b) -> add_lit p (add_lit (e_leq a b) (add_lit (e_neq a b) sigma)) | Neq _ | Fun _ | Not _ -> add_lit p sigma | _ -> sigma let assume sigma p = add_pred sigma (F.e_prop p) (* --- Pretty --- *) module Xmap = Map.Make(Var) let pretty title fmt sigma = let def = Vmap.fold Xmap.add sigma.def Xmap.empty in begin Format.fprintf fmt "@[@[%s {" title ; Format.fprintf fmt "@ @[vars: %a;@]" F.pp_vars sigma.dall ; Xmap.iter (fun x e -> Format.fprintf fmt "@ @[%a := %a ;@]" F.pp_term (F.e_var x) F.pp_term e ) def ; Tmap.iter (fun e m -> Format.fprintf fmt "@ @[%a ::= %a ;@]" F.pp_term e F.pp_term m ) sigma.mem ; Format.fprintf fmt "@ @]}@]" ; end end (* -------------------------------------------------------------------------- *) (* --- Definition Extractions --- *) (* -------------------------------------------------------------------------- *) module Defs = struct type t = Tset.t Vmap.t let empty = Vmap.empty let merge = Vmap.union (fun _ -> Tset.union) let add_def (w : t ref) x e = let es = try Vmap.find x !w with Not_found -> Tset.empty in w := Vmap.add x (Tset.add e es) !w let rec diff s y = function | [] -> s | e::es -> match F.repr e with | Var x when x==y -> diff s y es | _ -> diff (e_opp e :: s) y es let add_linear w x pos neg = add_def w x (e_sum (diff pos x neg)) let terms e = match F.repr e with Add es -> es | _ -> [e] let rec atoms = function | [] -> [] | e::es -> match F.repr e with | Var x -> x :: atoms es | _ -> atoms es let rec defs w p = match F.repr p with | And ps -> List.iter (defs w) ps | Eq(a,b) -> begin match F.congruence_eq a b with | None -> defs_eq w a b | Some eqs -> List.iter (fun (a,b) -> defs_eq w a b) eqs end | Not p -> begin match F.repr p with | Var x -> add_def w x e_false | _ -> () end | Var x -> add_def w x e_true | _ -> () and defs_affine w a b = let ta = terms a in let tb = terms b in let xa = atoms ta in let yb = atoms tb in begin List.iter (fun x -> add_linear w x tb ta) xa ; List.iter (fun y -> add_linear w y ta tb) yb ; end and defs_eq w a b = match F.repr a , F.repr b with | Add _ , _ | _ , Add _ -> defs_affine w a b | Var x , Var y -> add_def w x b ; add_def w y a | Var x , _ -> add_def w x b | _ , Var y -> add_def w y a | _ -> () let extract p = let w = ref empty in defs w (F.e_prop p) ; !w let domain d = Vmap.fold (fun x _ xs -> Vars.add x xs) d Vars.empty end (* -------------------------------------------------------------------------- *) (* --- Substitution Extraction --- *) (* -------------------------------------------------------------------------- *) module XS = Set.Make(Var) let elements xs = Vars.fold XS.add xs XS.empty let iter f xs = XS.iter f (elements xs) let rec extract defs sref cycle x = if not (Vars.mem x cycle) && not (Sigma.mem x !sref) then try let cycle = Vars.add x cycle in let ds = Vmap.find x defs in (* if no defs, exit early *) let ys = ref [] in (* variables equal to x *) let es = ref [] in (* possible definitions *) let rs = ref [] in (* sigma definitions *) Tset.iter (fun e -> if not (occurs cycle e) then match F.repr e with | Var y -> begin try let d = Sigma.find y !sref in rs := d :: !rs with Not_found -> ys := y :: !ys end | _ -> es := e :: !es ) ds ; (* Now choose the represent of x and the dependencies *) let select d = sref := Sigma.add x d !sref ; d , F.vars d in let ceq , depends = match List.sort F.compare !rs with | r :: _ -> select r | [] -> match List.sort F.compare !es with | e :: _ -> select e | [] -> e_var x , Vars.empty in List.iter (fun y -> sref := Sigma.add y ceq !sref) !ys ; iter (extract defs sref cycle) depends with Not_found -> () let bind sigma defs xs = let sref = ref sigma in iter (extract defs sref Vars.empty) xs ; !sref let get_class sigma xs x = List.sort Var.compare (List.filter (fun y -> Vars.mem y xs) (Sigma.class_of sigma x)) let rec add_eq ps y = function | z::zs -> add_eq (p_equal (e_var y) (e_var z) :: ps) y zs | [] -> ps let add_equals ys ps = match ys with [] -> ps | y::ys -> add_eq ps y ys let add_definitions sigma defs xs ps = let xs = Vars.filter (fun x -> Vmap.mem x defs) xs in Vars.fold (fun x ps -> let ps = add_equals (get_class sigma xs x) ps in try F.p_equal (e_var x) (Sigma.find x sigma) :: ps with Not_found -> ps ) xs ps (* -------------------------------------------------------------------------- *) (* --- Split-Cases --- *) (* -------------------------------------------------------------------------- *) module Split = struct type occur = int F.Tmap.t ref let create () = ref Tmap.empty let literal m p = try let n = Tmap.find p !m in m := Tmap.add p (succ n) !m with Not_found -> m := Tmap.add p 1 !m let rec occur m p = match F.repr p with | And ps | Or ps -> List.iter (occur m) ps | Imply(hs,p) -> List.iter (occur m) (p::hs) | Not p -> occur m p | If(p,a,b) -> occur m p ; occur m a ; occur m b | Eq(a,b) when F.is_closed a || F.is_closed b -> literal m p | Neq(a,b) when F.is_closed a || F.is_closed b -> literal m (e_not p) | Fun _ | Leq _ -> literal m p | Lt _ -> literal m (e_not p) | _ -> () let add m p = occur m (F.e_prop p) let select m = let compare (c1,n1) (c2,n2) = (* most often first *) if n1 < n2 then 1 else if n1 > n2 then (-1) else F.comparep c1 c2 in List.sort compare (Tmap.fold (fun c n s -> (F.p_bool c,n)::s) !m []) end (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/ProverTask.mli0000644000175000017500000000717212155630215020024 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Library for Running Provers --- *) (* -------------------------------------------------------------------------- *) class printer : Format.formatter -> string -> object method paragraph : unit method lines : unit method section : string -> unit method hline : unit method printf : 'a. ('a,Format.formatter,unit) format -> 'a end val pp_file : message:string -> file:string -> unit (** never fails *) class type pattern = object method get_after : ?offset:int -> int -> string (** [get_after ~offset:p k] returns the end of the message starting [p] characters after the end of group [k]. *) method get_string : int -> string method get_int : int -> int method get_float : int -> float end val p_group : string -> string (** Put pattern in group [\(p\)] *) val p_int : string (** Int group pattern [\([0-9]+\)] *) val p_float : string (** Float group pattern [\([0-9.]+\)] *) val p_string : string (** String group pattern ["\(...\)"] *) val p_until_space : string (** No space group pattern "\\([^ \t\n]*\\)" *) val location : string -> int -> Lexing.position type logs = [ `OUT | `ERR | `BOTH ] class virtual command : string -> object method set_command : string -> unit method add : string list -> unit method add_int : name:string -> value:int -> unit method add_positive : name:string -> value:int -> unit method add_float : name:string -> value:float -> unit method add_parameter : name:string -> (unit -> bool) -> unit method add_list : name:string -> string list -> unit method timeout : int -> unit method validate_time : (float -> unit) -> unit method validate_pattern : ?logs:logs -> ?repeat:bool -> Str.regexp -> (pattern -> unit) -> unit method run : ?echo:bool -> ?logout:string -> ?logerr:string -> unit -> int Task.task end val server : unit -> Task.server val spawn : bool Task.task list -> unit (** Spawn all the tasks over the server and retain the first 'validated' one *) frama-c-Fluorine-20130601/src/wp/GuiPanel.mli0000644000175000017500000000375312155630215017431 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 update : unit -> unit val on_update : (unit -> unit) -> unit val reload : unit -> unit val on_reload : (unit -> unit) -> unit val run_and_prove : Design.main_window_extension_points -> GuiSource.selection -> unit val register : main:Design.main_window_extension_points -> available_provers:GuiConfig.provers -> enabled_provers:GuiConfig.provers -> configure_provers:(unit -> unit) -> unit frama-c-Fluorine-20130601/src/wp/cil2cfg.mli0000644000175000017500000001445412155630215017236 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 frama-c-Fluorine-20130601/src/wp/LogicUsage.mli0000644000175000017500000000661512155630215017747 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Dependencies of Logic Definitions --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Cil_datatype open Clabels val basename : varinfo -> string (** Trims the original name *) type logic_lemma = { lem_name : string ; lem_position : Lexing.position ; lem_axiom : bool ; lem_types : string list ; lem_labels : logic_label list ; lem_property : predicate named ; lem_depends : logic_lemma list ; (** in reverse order *) } type axiomatic = { ax_name : string ; ax_position : Lexing.position ; ax_property : Property.t ; mutable ax_types : logic_type_info list ; mutable ax_logics : logic_info list ; mutable ax_lemmas : logic_lemma list ; mutable ax_reads : Varinfo.Set.t ; (* read-only *) } type logic_section = | Toplevel of int | Axiomatic of axiomatic val compute : unit -> unit (** To force computation *) val ip_lemma : logic_lemma -> Property.t val iter_lemmas : (logic_lemma -> unit) -> unit val logic_lemma : string -> logic_lemma val axiomatic : string -> axiomatic val section_of_lemma : string -> logic_section val section_of_type : logic_type_info -> logic_section val section_of_logic : logic_info -> logic_section val proof_context : unit -> logic_lemma list (** Lemmas that are not in an axiomatic. *) val is_recursive : logic_info -> bool val get_induction_labels : logic_info -> string -> LabelSet.t LabelMap.t (** Given an inductive [phi{...A...}]. Whenever in [case C{...B...}] we have a call to [phi{...B...}], then [A] belongs to [(induction phi C).[B]]. *) val get_name : logic_info -> string val pp_profile : Format.formatter -> logic_info -> unit val dump : unit -> unit (** Print on output *) frama-c-Fluorine-20130601/src/wp/driver.ml0000444000175000017500000004500212155634033017040 0ustar mehdimehdi# 27 "src/wp/driver.mll" open Qed.Logic open Lexing open Cil_types open LogicBuiltins type token = | EOF | KEY of string | BOOLEAN | INTEGER | REAL | INT of ikind | FLT of fkind | ID of string | LINK of string let keywords = [ "library" , KEY "library" ; "type" , KEY "type" ; "ctor" , KEY "ctor" ; "logic" , KEY "logic" ; "predicate" , KEY "predicate" ; "boolean" , BOOLEAN ; "integer" , INTEGER ; "real" , REAL ; "char" , INT IChar ; "short" , INT IShort ; "int" , INT IInt ; "unsigned" , INT IUInt ; "float" , FLT FFloat ; "double" , FLT FDouble ; ] let ident x = try List.assoc x keywords with Not_found -> ID x let newline lexbuf = lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_lnum = succ lexbuf.lex_curr_p.pos_lnum } # 45 "src/wp/driver.ml" let __ocaml_lex_tables = { Lexing.lex_base = "\000\000\248\255\075\000\160\000\016\000\003\000\254\255\255\255\ \251\255\027\000\252\255\250\000\249\255\052\000\252\255\253\255\ \012\000\255\255\254\255"; Lexing.lex_backtrk = "\255\255\255\255\007\000\005\000\007\000\002\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \003\000\255\255\255\255"; Lexing.lex_default = "\001\000\000\000\255\255\255\255\255\255\255\255\000\000\000\000\ \000\000\009\000\000\000\255\255\000\000\014\000\000\000\000\000\ \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\005\000\006\000\000\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\ \005\000\000\000\002\000\005\000\000\000\010\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\008\000\018\000\000\000\000\000\015\000\009\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\016\000\003\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\011\000\011\000\011\000\011\000\011\000\ \011\000\011\000\011\000\011\000\011\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\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\011\000\000\000\000\000\ \000\000\000\000\011\000\000\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\011\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\000\000\000\000\000\000\000\000\003\000\ \007\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\255\255\012\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\011\000\011\000\011\000\011\000\011\000\011\000\ \011\000\011\000\011\000\011\000\017\000\000\000\000\000\000\000\ \000\000\000\000\000\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\011\000\000\000\000\000\000\000\ \000\000\011\000\000\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\011\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\255\255\005\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\ \000\000\255\255\000\000\005\000\255\255\009\000\255\255\255\255\ \255\255\255\255\255\255\255\255\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\004\000\016\000\255\255\255\255\013\000\004\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\255\255\255\255\255\255\013\000\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\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\255\255\255\255\ \255\255\255\255\002\000\255\255\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\255\255\255\255\255\255\255\255\003\000\ \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\003\000\009\000\011\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\011\000\011\000\011\000\011\000\011\000\011\000\ \011\000\011\000\011\000\011\000\013\000\255\255\255\255\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\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\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 tok lexbuf = __ocaml_lex_tok_rec lexbuf 0 and __ocaml_lex_tok_rec lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 74 "src/wp/driver.mll" ( EOF ) # 210 "src/wp/driver.ml" | 1 -> # 75 "src/wp/driver.mll" ( newline lexbuf ; tok lexbuf ) # 215 "src/wp/driver.ml" | 2 -> # 76 "src/wp/driver.mll" ( tok lexbuf ) # 220 "src/wp/driver.ml" | 3 -> # 77 "src/wp/driver.mll" ( newline lexbuf ; tok lexbuf ) # 225 "src/wp/driver.ml" | 4 -> # 78 "src/wp/driver.mll" ( comment lexbuf ) # 230 "src/wp/driver.ml" | 5 -> let # 79 "src/wp/driver.mll" a # 236 "src/wp/driver.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in # 79 "src/wp/driver.mll" ( ident a ) # 240 "src/wp/driver.ml" | 6 -> let # 80 "src/wp/driver.mll" a # 246 "src/wp/driver.ml" = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) (lexbuf.Lexing.lex_curr_pos + -1) in # 80 "src/wp/driver.mll" ( LINK a ) # 250 "src/wp/driver.ml" | 7 -> # 81 "src/wp/driver.mll" ( KEY (Lexing.lexeme lexbuf) ) # 255 "src/wp/driver.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_tok_rec lexbuf __ocaml_lex_state and comment lexbuf = __ocaml_lex_comment_rec lexbuf 13 and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 84 "src/wp/driver.mll" ( failwith "Unterminated comment" ) # 266 "src/wp/driver.ml" | 1 -> # 85 "src/wp/driver.mll" ( tok lexbuf ) # 271 "src/wp/driver.ml" | 2 -> # 86 "src/wp/driver.mll" ( newline lexbuf ; comment lexbuf ) # 276 "src/wp/driver.ml" | 3 -> # 87 "src/wp/driver.mll" ( comment lexbuf ) # 281 "src/wp/driver.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_comment_rec lexbuf __ocaml_lex_state ;; # 89 "src/wp/driver.mll" let pretty fmt = function | EOF -> Format.pp_print_string fmt "" | KEY a | ID a -> Format.fprintf fmt "'%s'" a | LINK s -> Format.fprintf fmt "\"%s\"" s | BOOLEAN | INTEGER | REAL | INT _ | FLT _ -> Format.pp_print_string fmt "" type input = { lexbuf : Lexing.lexbuf ; mutable current : token ; } let skip input = if input.current <> EOF then input.current <- tok input.lexbuf let token input = input.current let key input a = match token input with | KEY b when a=b -> skip input ; true | _ -> false let skipkey input a = match token input with | KEY b when a=b -> skip input | _ -> failwith (Printf.sprintf "Missing '%s'" a) let ident input = match token input with | ID x -> skip input ; x | _ -> failwith "missing identifier" let kind input = let kd = match token input with | INTEGER -> Z | REAL -> R | BOOLEAN -> A | INT i -> I (Ctypes.c_int i) | FLT f -> F (Ctypes.c_float f) | ID _ -> A | _ -> failwith " expected" in skip input ; kd let parameter input = let k = kind input in match token input with | ID _ -> skip input ; k | _ -> k let rec parameters input = if key input ")" then [] else let p = parameter input in if key input "," then p :: parameters input else if key input ")" then [p] else failwith "Missing ',' or ')'" let signature input = if key input "(" then parameters input else [] let rec depend input = match token input with | ID a | LINK a -> skip input ; ignore (key input ",") ; a :: depend input | _ -> [] let link input = match token input with | LINK f | ID f -> skip input ; f | _ -> failwith "Missing link symbol" let op = { inversible = false ; associative = false ; commutative = false ; idempotent = false ; neutral = E_none ; absorbant = E_none ; } let op_elt input = ignore (key input ":") ; let op = link input in skipkey input ":" ; match op with | "0" -> E_int 0 | "1" -> E_int 1 | "-1" -> E_int (-1) | _ -> try E_const (LogicBuiltins.symbol op) with Not_found -> failwith (Printf.sprintf "Symbol '%s' undefined" op) let rec op_link bal op input = match token input with | LINK f -> skip input ; bal,Operator op,f | ID "left" -> skip input ; skipkey input ":" ; op_link Lang.Left op input | ID "right" -> skip input ; skipkey input ":" ; op_link Lang.Right op input | ID "associative" -> skip input ; skipkey input ":" ; op_link bal { op with associative = true } input | ID "commutative" -> skip input ; skipkey input ":" ; op_link bal { op with commutative = true } input | ID "ac" -> skip input ; skipkey input ":" ; op_link bal { op with commutative = true ; associative = true } input | ID "idempotent" -> skip input ; skipkey input ":" ; op_link bal { op with idempotent = true } input | ID "inversible" -> skip input ; skipkey input ":" ; op_link bal { op with inversible = true } input | ID "neutral" -> skip input ; let e = op_elt input in op_link bal { op with neutral = e } input | ID "absorbant" -> skip input ; let e = op_elt input in op_link bal { op with absorbant = e } input | ID t -> failwith (Printf.sprintf "Unknown tag '%s'" t) | _ -> failwith "Missing or " let logic_link input = match token input with | LINK f -> skip input ; Lang.Nary,Function,f | ID "constructor" -> skip input ; skipkey input ":" ; Lang.Nary,Function,link input | ID "injective" -> skip input ; skipkey input ":" ; Lang.Nary,Injection,link input | _ -> op_link Lang.Left op input let rec parse theory input = match token input with | EOF -> () | KEY "library" -> skip input ; let name = link input in ignore (key input ":") ; let depends = depend input in ignore (key input ";") ; add_library name depends ; parse name input | KEY "type" -> skip input ; let name = ident input in skipkey input "=" ; let link = link input in add_type name ~theory ~link () ; skipkey input ";" ; parse theory input | KEY "ctor" -> skip input ; let name = ident input in let args = signature input in skipkey input "=" ; let link = link input in add_ctor name args ~theory ~link () ; skipkey input ";" ; parse theory input | KEY "logic" -> skip input ; let result = kind input in let name = ident input in let args = signature input in skipkey input "=" ; let balance,category,link = logic_link input in add_logic result name args ~theory ~category ~balance ~link () ; skipkey input ";" ; parse theory input | KEY "predicate" -> skip input ; let name = ident input in let args = signature input in skipkey input "=" ; let link = link input in add_predicate name args ~theory ~link () ; skipkey input ";" ; parse theory input | _ -> failwith "Unexpected entry" let load file = try let inc = open_in file in let lex = Lexing.from_channel inc in lex.Lexing.lex_curr_p <- { lex.Lexing.lex_curr_p with Lexing.pos_fname = file } ; let input = { current = tok lex ; lexbuf = lex } in try parse "driver" input ; close_in inc with Failure msg -> close_in inc ; let source = lex.Lexing.lex_start_p in Wp_parameters.error ~source "(Driver Error) %s (at %a)" msg pretty (token input) with exn -> Wp_parameters.error "Error in driver '%s': %s" file (Printexc.to_string exn) (*TODO[LC] Think about projectification ... *) let loaded = ref false let load_drivers () = if not !loaded then begin List.iter (fun file -> let path = Wp_parameters.find_lib file in let echo = if Wp_parameters.has_dkey "driver" then path else file in Wp_parameters.feedback "Loading driver '%s'" echo ; load path) (Wp_parameters.Drivers.get ()) ; loaded := true ; if Wp_parameters.has_dkey "driver" then LogicBuiltins.dump () ; end # 505 "src/wp/driver.ml" frama-c-Fluorine-20130601/src/wp/LogicBuiltins.mli0000644000175000017500000000562312155630215020472 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Linker for ACSL Builtins --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Lang type category = Lang.lfun Qed.Logic.category type kind = | Z (** integer *) | R (** real *) | I of Ctypes.c_int (** C-ints *) | F of Ctypes.c_float (** C-floats *) | A (** Abstract Data *) val dependencies : string -> string list (** Of external theories. Raises Not_found if undefined *) val add_library : string -> string list -> unit (** External theories *) val add_const : string -> F.term -> unit val add_type : string -> theory:string -> ?link:string -> unit -> unit val add_ctor : string -> kind list -> theory:string -> ?link:string -> unit -> unit val add_logic : kind -> string -> kind list -> theory:string -> ?category:category -> ?balance:Lang.balance -> ?link:string -> unit -> unit val add_predicate : string -> kind list -> theory:string -> ?link:string -> unit -> unit val symbol : string -> lfun type builtin = | ACSLDEF | LFUN of lfun | CONST of F.term val logic : logic_info -> builtin val ctor : logic_ctor_info -> builtin val dump : unit -> unit frama-c-Fluorine-20130601/src/wp/GuiNavigator.ml0000644000175000017500000003273012155630215020150 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Lower Panel --- *) (* -------------------------------------------------------------------------- *) open Design open Toolbox open Property open GuiSource (* -------------------------------------------------------------------------- *) (* --- Build the Reactive Behavior of GUI --- *) (* -------------------------------------------------------------------------- *) type filter = [ `All | `Module | `Select ] type card = [ `List | `Goal ] type focus = [ `All | `Index of Wpo.index | `Call of GuiSource.call | `Property of Property.t ] let index_of_lemma (l,_,_,_,_) = match LogicUsage.section_of_lemma l with | LogicUsage.Toplevel _ -> Wpo.Axiomatic None | LogicUsage.Axiomatic a -> Wpo.Axiomatic (Some a.LogicUsage.ax_name) let focus_of_selection selection filter = match selection , filter with | S_none , _ | _ , `All -> `All | S_call c , `Select -> `Call c | S_call c , `Module -> `Index (Wpo.Function(c.s_caller,None)) | S_fun kf , (`Select | `Module) -> `Index(Wpo.Function(kf,None)) | S_prop (IPLemma ilem) , `Module -> `Index(index_of_lemma ilem) | S_prop (IPAxiomatic(name,_)) , _ -> `Index(Wpo.Axiomatic (Some name)) | S_prop ip , `Select -> `Property ip | S_prop ip , `Module -> begin match Property.get_kf ip with | None -> `All | Some kf -> `Index(Wpo.Function(kf,None)) end exception FIRST of Wpo.t let first iter = try iter (fun w -> raise (FIRST w)) ; None with FIRST w -> Some w let iter_kf kf f = Wpo.iter ~index:(Wpo.Function(kf,None)) ~on_goal:f () let iter_ip ip f = Wpo.iter ~ip ~on_goal:f () let iter_ips ips f = List.iter (fun ip -> Wpo.iter ~ip ~on_goal:f ()) ips let calls c = List.map snd (Statuses_by_call.all_call_preconditions_at ~warn_missing:false c.s_caller c.s_stmt) let goal_of_selection = function | S_none -> None | S_prop ip -> first (iter_ip ip) | S_call c -> first (iter_ips (calls c)) | S_fun kf -> first (iter_kf kf) class behavior ~(main : Design.main_window_extension_points) ~(filter : filter Toolbox.selector) ~(next : Toolbox.button) ~(prev : Toolbox.button) ~(index : Toolbox.button) ~(clear : Toolbox.button) ~(card : card Toolbox.selector) ~(list : GuiList.pane) ~(goal : GuiGoal.pane) ~(source : GuiSource.highlighter) ~(popup : GuiSource.popup) = object(self) val mutable focus : focus = `All val mutable currentgoal : Wpo.t option = None method update () = begin list#update_all ; source#update ; goal#update ; end method reload () = begin list#reload ; let on_goal = list#add in begin match focus with | `All -> Wpo.iter ~on_goal () | `Index index -> Wpo.iter ~index ~on_goal () | `Property ip -> Wpo.iter ~ip ~on_goal () | `Call c -> iter_ips (calls c) on_goal end ; let n = list#size in let k = match currentgoal with | None -> (-1) | Some w -> try list#index w with Not_found -> (-1) in index#set_enabled (n>0) ; if n=0 then card#set `List ; let src = if n=1 && k=0 then (card#set `Goal ; true) else false in if k<0 then self#navigator false None else self#navigator src (Some (list#get k)) ; end method private set_focus f = focus <- f ; self#reload () method private set_filter f = match f , currentgoal with | `Module , Some w -> self#set_focus (`Index (Wpo.get_index w)) | `Select , Some w -> self#set_focus (`Property (Wpo.get_property w)) | _ , _ -> self#set_focus `All method private set_selection s = let f = filter#get in currentgoal <- goal_of_selection s ; self#set_focus (focus_of_selection s f) (* -------------------------------------------------------------------------- *) (* --- Navigation from Next/Prev/List --- *) (* -------------------------------------------------------------------------- *) method private details = match card#get , currentgoal with | `List , Some w -> list#show w | `List , None -> () | `Goal , sw -> goal#select sw method private navigator src = function | None -> begin currentgoal <- None ; next#set_enabled false ; prev#set_enabled false ; source#set None ; self#details ; end | (Some w) as sw -> try currentgoal <- sw ; let n = list#size in let k = list#index w in prev#set_enabled (k > 0) ; next#set_enabled (succ k < n) ; source#set (if src then sw else None) ; self#details ; with Not_found -> self#navigator false None method private next () = self#move succ method private prev () = self#move pred method private move f = try match currentgoal with | None -> () | Some w -> begin let k = list#index w in let w = list#get (f k) in self#navigator true (Some w) ; end with Not_found -> self#navigator true None method private prove w prover = begin let callback w _prover _result = begin match card#get with | `List -> list#update w | `Goal -> goal#update end in if prover = VCS.Why3ide then let callback w p r = callback w p r in let task = Prover.wp_why3ide ~callback (fun f -> Wpo.iter ~on_goal:f ()) in let kill () = Wpo.set_result w prover VCS.no_result ; Task.cancel task; in Wpo.set_result w prover (VCS.computing kill) ; let server = ProverTask.server () in Task.spawn server (Task.job task) ; Task.launch server ; else let task = Prover.prove w ~interactive:true ~callback prover in let kill () = Wpo.set_result w prover VCS.no_result ; Task.cancel task in Wpo.set_result w prover (VCS.computing kill) ; let server = ProverTask.server () in Task.spawn server (Task.job task) ; Task.launch server ; end method private clear () = begin let title = "Delete Proof Obligations" in let text = Printf.sprintf "Confirm deletion of %d proof obligation(s)" list#count_selected in let icon = GMisc.image ~stock:`DELETE () in let response = GToolbox.question_box ~title ~buttons:["Delete POs" ; "Cancel"] ~default:1 ~icon text in if response = 1 then begin list#iter_selected Wpo.remove ; self#reload () ; end end initializer begin clear#set_enabled false ; next#connect self#next ; prev#connect self#prev ; index#connect (fun () -> card#set `List) ; list#on_click (fun w _p -> self#navigator true (Some w)) ; list#on_double_click (fun w p -> match p with | None -> begin card#set `Goal ; self#navigator true (Some w) ; end | Some p -> begin self#navigator true (Some w) ; self#prove w p ; list#update w ; end ) ; list#on_selection (fun n -> clear#set_enabled (n>0)) ; goal#on_run self#prove ; goal#on_src source#set ; card#connect (fun _ -> self#details) ; filter#connect self#set_filter ; popup#on_click self#set_selection ; popup#on_prove (GuiPanel.run_and_prove main) ; clear#connect self#clear ; end end (* -------------------------------------------------------------------------- *) (* --- Make Panel and Extend Frama-C GUI --- *) (* -------------------------------------------------------------------------- *) let make (main : main_window_extension_points) = begin (* -------------------------------------------------------------------------- *) (* --- Provers --- *) (* -------------------------------------------------------------------------- *) let available = new GuiConfig.provers "wp.available" in let enabled = new GuiConfig.provers "wp.enabled" in if Wp_parameters.Detect.get () then ProverWhy3.detect_provers available#set ; let dp_chooser = new GuiConfig.dp_chooser ~main ~available ~enabled in (* -------------------------------------------------------------------------- *) (* --- Focus Bar --- *) (* -------------------------------------------------------------------------- *) let filter = new Toolbox.switch (`All :> filter) in let switch = new Toolbox.rack [ filter#add_toggle ~label:"All" ~tooltip:"All goals" ~value:`All () ; filter#add_toggle ~label:"Module" ~tooltip:"Goals of current function or axiomatics" ~value:`Module () ; filter#add_toggle ~label:"Property" ~tooltip:"Goals of current property" ~value:`Select () ; ] in let prev = new Toolbox.button ~icon:`GO_BACK ~tooltip:"Previous goal" () in let next = new Toolbox.button ~icon:`GO_FORWARD ~tooltip:"Next goal" () in let index = new Toolbox.button ~icon:`INDEX ~tooltip:"List of goals" () in let navigation = new Toolbox.rack [ (prev :> widget) ; (index :> widget) ; (next :> widget) ; ] in let provers = new Toolbox.button ~label:"Provers..." () in let clear = new Toolbox.button ~label:"Clear" ~icon:`DELETE () in let focusbar = GPack.hbox ~spacing:0 () in begin focusbar#pack ~padding:0 ~expand:false navigation#coerce ; focusbar#pack ~padding:20 ~expand:false switch#coerce ; focusbar#pack ~from:`END ~expand:false clear#coerce ; focusbar#pack ~from:`END ~expand:false provers#coerce ; provers#connect dp_chooser#run ; end ; (* -------------------------------------------------------------------------- *) (* --- List/Goal view --- *) (* -------------------------------------------------------------------------- *) let book : card notebook = new Toolbox.notebook ~default:`List () in let list = new GuiList.pane enabled in let goal = new GuiGoal.pane () in begin book#add `List list#coerce ; book#add `Goal goal#coerce ; end ; (* -------------------------------------------------------------------------- *) (* --- Source Feedback --- *) (* -------------------------------------------------------------------------- *) let source = new GuiSource.highlighter main in let popup = new GuiSource.popup () in (* -------------------------------------------------------------------------- *) (* --- Panel Behavior --- *) (* -------------------------------------------------------------------------- *) let card = (book :> _ Toolbox.selector) in let filter = (filter :> _ Toolbox.selector) in let behavior = new behavior ~main ~next ~prev ~index ~filter ~clear ~list ~card ~goal ~source ~popup in GuiPanel.on_reload behavior#reload ; GuiPanel.on_update behavior#update ; (* -------------------------------------------------------------------------- *) (* --- Panel view --- *) (* -------------------------------------------------------------------------- *) let panel = GPack.vbox ~homogeneous:false () in panel#pack ~expand:false focusbar#coerce ; panel#pack ~expand:true ~fill:true book#coerce ; let tab_label = (GMisc.label ~text:"WP Goals" ())#coerce in ignore (panel#misc#connect#after#realize behavior#reload) ; ignore (main#lower_notebook#append_page ~tab_label panel#coerce) ; main#register_source_highlighter source#highlight ; main#register_source_selector popup#register ; GuiPanel.register ~main ~available_provers:available ~enabled_provers:enabled ~configure_provers:dp_chooser#run ; end let () = Design.register_extension make let () = Design.register_reset_extension (fun main -> main#protect ~cancelable:false GuiPanel.reload) frama-c-Fluorine-20130601/src/wp/LogicBuiltins.ml0000644000175000017500000002150312155630215020314 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* Registry for ACSL Builtins --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Ctypes open Qed open Lang module W = Wp_parameters type category = Lang.lfun Qed.Logic.category type builtin = | ACSLDEF | LFUN of lfun | CONST of F.term type kind = | Z (* integer *) | R (* real *) | I of Ctypes.c_int | F of Ctypes.c_float | A (* abstract data *) (* [LC] kinds can be compared by Pervasives.compare *) let okind = function | C_int i -> I i | C_float f -> F f | _ -> A let ckind typ = okind (object_of typ) let skind = function | I _ | Z -> Logic.Sint | F _ | R -> Logic.Sreal | A -> Logic.Sdata let rec lkind t = match Logic_utils.unroll_type t with | Ctype ty -> ckind ty | Ltype({lt_name="set"},[t]) -> lkind t | Lreal -> R | Linteger -> Z | Ltype _ | Larrow _ | Lvar _ -> A let pp_kind fmt = function | I i -> Ctypes.pp_int fmt i | F f -> Ctypes.pp_float fmt f | Z -> Format.pp_print_string fmt "int" | R -> Format.pp_print_string fmt "real" | A -> Format.pp_print_string fmt "_" let pp_kinds fmt = function | [] -> () | t::ts -> Format.fprintf fmt "(%a" pp_kind t ; List.iter (fun t -> Format.fprintf fmt ",%a" pp_kind t) ts ; Format.fprintf fmt ")" let pp_libs fmt = function | [] -> () | t::ts -> Format.fprintf fmt ": %s" t ; List.iter (fun t -> Format.fprintf fmt ",%s" t) ts let pp_link fmt = function | ACSLDEF -> Format.pp_print_string fmt "(ACSL)" | CONST e -> F.pp_term fmt e | LFUN f -> Fun.pretty fmt f (* -------------------------------------------------------------------------- *) (* --- Lookup & Registry --- *) (* -------------------------------------------------------------------------- *) type sigfun = kind list * builtin let hlogic : (string , sigfun list) Hashtbl.t = Hashtbl.create 131 let symbol : (string , lfun) Hashtbl.t = Hashtbl.create 131 let hlibs = Hashtbl.create 31 let chop_backslash name = if name.[0] == '\\' then String.sub name 1 (String.length name - 1) else name let lookup name kinds = try let sigs = Hashtbl.find hlogic name in try List.assoc kinds sigs with Not_found -> Wp_parameters.feedback ~once:true "Use -wp-logs 'driver' for debugging drivers" ; if kinds=[] then W.error ~current:true "Builtin %s undefined as a constant" name else W.error ~current:true "Builtin %s undefined with signature %a" name pp_kinds kinds ; ACSLDEF with Not_found -> if name.[0] == '\\' then W.error "Builtin %s%a not defined" name pp_kinds kinds ; ACSLDEF let register name kinds link = let sigs = try Hashtbl.find hlogic name with Not_found -> [] in begin if List.exists (fun (s,_) -> s = kinds) sigs then let msg = Pretty_utils.sfprintf "Builtin %s%a already defined" name pp_kinds kinds in failwith msg ; end ; let entry = (kinds,link) in Hashtbl.add hlogic name (entry::sigs) ; match link with LFUN f -> Hashtbl.add symbol (Fun.id f) f | _ -> () let symbol = Hashtbl.find symbol let iter_table f = let items = ref [] in Hashtbl.iter (fun a sigs -> List.iter (fun (ks,lnk) -> items := (a,ks,lnk)::!items) sigs) hlogic ; List.iter f (List.sort Pervasives.compare !items) let iter_libs f = let items = ref [] in Hashtbl.iter (fun a libs -> items := (a,libs) :: !items) hlibs ; List.iter f (List.sort Pervasives.compare !items) let dump () = Log.print_on_output begin fun fmt -> Format.fprintf fmt "Builtins:@\n" ; iter_libs (fun (name,libs) -> Format.fprintf fmt " * Library %s%a@\n" name pp_libs libs) ; iter_table (fun (name,k,lnk) -> Format.fprintf fmt " * Logic %s%a = %a@\n" name pp_kinds k pp_link lnk) ; end (* -------------------------------------------------------------------------- *) (* --- Implemented Builtins --- *) (* -------------------------------------------------------------------------- *) let logic phi = lookup phi.l_var_info.lv_name (List.map (fun v -> lkind v.lv_type) phi.l_profile) let ctor phi = lookup phi.ctor_name (List.map lkind phi.ctor_params) (* -------------------------------------------------------------------------- *) (* --- Declaration of Builtins --- *) (* -------------------------------------------------------------------------- *) let dependencies lib = Hashtbl.find hlibs lib let add_library lib deps = Hashtbl.add hlibs lib deps let add_logic result name kinds ~theory ?category ?balance ?(link=chop_backslash name) () = let result = skind result in let params = List.map skind kinds in let lfun = Lang.extern_s ~theory ?category ?balance ~result ~params link in register name kinds (LFUN lfun) let add_predicate name kinds ~theory ?(link=chop_backslash name) () = let params = List.map skind kinds in let lfun = Lang.extern_fp ~theory ~params link in register name kinds (LFUN lfun) let add_ctor name kinds ~theory ?(link=name) () = let category = Logic.Constructor in let params = List.map skind kinds in let lfun = Lang.extern_s ~theory ~category ~params ~result:Logic.Sdata link in register name kinds (LFUN lfun) let add_const name value = register name [] (CONST value) let add_type name ~theory ?(link=name) () = Lang.builtin ~name ~theory ~link (* -------------------------------------------------------------------------- *) (* --- Abs,Min,Max algebraic properties --- *) (* -------------------------------------------------------------------------- *) open Qed.Logic let minmax = Operator { inversible = false ; commutative = true ; associative = true ; idempotent = true ; neutral = E_none ; absorbant = E_none ; } (* -------------------------------------------------------------------------- *) (* --- Implemented Builtins --- *) (* -------------------------------------------------------------------------- *) let () = begin add_const "\\true" F.e_true ; add_const "\\false" F.e_false ; let theory = "cmath" in add_logic Z "\\abs" [ Z ] ~theory ~link:"abs_int" () ; add_logic R "\\abs" [ R ] ~theory ~link:"abs_real" () ; add_logic Z "\\max" [ Z;Z ] ~theory ~link:"max_int" ~category:minmax () ; add_logic Z "\\min" [ Z;Z ] ~theory ~link:"min_int" ~category:minmax () ; add_logic R "\\max" [ R;R ] ~theory ~link:"max_real" () ; add_logic R "\\min" [ R;R ] ~theory ~link:"min_real" () ; let theory = "cfloat" in add_type "rounding_mode" ~theory () ; add_ctor "Up" [] ~theory () ; add_ctor "Down" [] ~theory () ; add_ctor "ToZero" [] ~theory () ; add_ctor "NearestAway" [] ~theory ~link:"NearestTiesToAway" () ; add_ctor "NearestEven" [] ~theory ~link:"NearestTiesToEven" () ; add_predicate "\\is_finite" [ F Float32 ] ~theory ~link:"is_finite32" () ; add_predicate "\\is_finite" [ F Float64 ] ~theory ~link:"is_finite64" () ; add_logic A "\\round_float" [ A; R ] ~theory () ; add_logic A "\\round_double" [ A ; R ] ~theory () ; end frama-c-Fluorine-20130601/src/wp/wp_error.mli0000644000175000017500000000604212155630215017556 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 frama-c-Fluorine-20130601/src/wp/Memory.mli0000644000175000017500000001203612155630215017167 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Interface --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Ctypes open Lang.F type 'a sequence = { pre : 'a ; post : 'a } (** Memory Values *) type acs = | RW (** Read-Write Access *) | RD (** Read-Only Access *) type 'a value = | Val of term | Loc of 'a type 'a rloc = | Rloc of c_object * 'a | Rarray of 'a * c_object * int64 | Rrange of 'a * c_object * term option * term option type 'a sloc = | Sloc of 'a | Sarray of 'a * c_object * int64 (** full sized-array range *) | Srange of 'a * c_object * term option * term option | Sdescr of var list * 'a * pred type 'a logic = | Vexp of term | Vloc of 'a | Vset of Vset.set | Lset of 'a sloc list (** Memory Variables *) module type Chunk = sig type t val self : string val hash : t -> int val compare : t -> t -> int val pretty : Format.formatter -> t -> unit val tau_of_chunk : t -> tau val basename_of_chunk : t -> string end (** Memory Environment *) module type Sigma = sig type chunk type domain type t val create : unit -> t val copy : t -> t val merge : t -> t -> t * Passive.t * Passive.t val join : t -> t -> Passive.t (** pairwise equal *) val assigned : t -> t -> domain -> pred Bag.t (** equal chunks outside domain *) val mem : t -> chunk -> bool val get : t -> chunk -> var val value : t -> chunk -> term val iter : (chunk -> var -> unit) -> t -> unit val iter2 : (chunk -> var option -> var option -> unit) -> t -> t -> unit val havoc : t -> domain -> t val havoc_chunk : t -> chunk -> t val havoc_any : t -> t val domain : t -> domain val pretty : Format.formatter -> t -> unit end (** Memory Model *) module type Model = sig val configure : Model.tuning val datatype : string (** for projectification *) module Chunk : Chunk module Heap : Qed.Collection.S with type t = Chunk.t module Sigma : Sigma with type chunk = Chunk.t and type domain = Heap.set type loc type chunk = Chunk.t type sigma = Sigma.t type segment = loc rloc val pretty : Format.formatter -> loc -> unit val vars : loc -> Vars.t val occurs : var -> loc -> bool val null : loc val literal : eid:int -> Cstring.cst -> loc val cvar : varinfo -> loc val pointer_loc : term -> loc val pointer_val : loc -> term val field : loc -> fieldinfo -> loc val shift : loc -> c_object -> term -> loc val base_addr : loc -> loc val block_length : sigma -> c_object -> loc -> term val cast : c_object sequence -> loc -> loc val loc_of_int : c_object -> term -> loc val int_of_loc : c_int -> loc -> term val domain : c_object -> loc -> Heap.set val load : sigma -> c_object -> loc -> loc value val copied : sigma sequence -> c_object -> loc -> loc -> pred list val stored : sigma sequence -> c_object -> loc -> term -> pred list val assigned : sigma sequence -> c_object -> loc sloc -> pred list val is_null : loc -> pred val loc_eq : loc -> loc -> pred val loc_lt : loc -> loc -> pred val loc_neq : loc -> loc -> pred val loc_leq : loc -> loc -> pred val loc_diff : c_object -> loc -> loc -> term val valid : sigma -> acs -> segment -> pred val scope : sigma -> Mcfg.scope -> varinfo list -> sigma * pred list val included : segment -> segment -> pred val separated : segment -> segment -> pred end frama-c-Fluorine-20130601/src/wp/Conditions.ml0000644000175000017500000005531012155630215017661 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Weakest Pre Accumulator --- *) (* -------------------------------------------------------------------------- *) open Qed.Logic open Cil_types open Lang open Lang.F (* -------------------------------------------------------------------------- *) (* --- Datatypes --- *) (* -------------------------------------------------------------------------- *) type step = { stmt : stmt option ; descr : string option ; deps : Property.t list ; warn : Warning.Set.t ; condition : condition ; } and condition = | Type of pred | Have of pred | When of pred | Branch of pred * step list * step list | Either of step list list let is_cond_true = function | Have p | Type p | When p -> F.is_ptrue p | Either [] -> No | Either [[]] -> Yes | Branch(_,[],[]) -> Yes | Branch _ | Either _ -> Maybe let is_seq_true = function | [] -> Yes | s::_ -> is_cond_true s.condition module Bundle : sig type t val empty : t val is_empty : t -> bool (* val non_empty : t -> bool *) (* unused for now *) val is_true : t -> Qed.Logic.maybe val add : step -> t -> t val factorize : t -> t -> t * t * t val big_inter : t list -> t val diff : t -> t -> t (* val iter : (step -> unit) -> t -> unit *) (* unused for now *) val freeze : t -> step list val exists : (condition -> bool) -> t -> bool val map : (condition -> 'a) -> t -> 'a list (* val debug : Format.formatter -> t -> unit *) (* unused for now *) end = struct module SEQ = Qed.Listset.Make (struct type t = int * step let equal (k1,_) (k2,_) = k1 = k2 let compare (k1,s1) (k2,s2) = let rank = function | Type _ -> 0 | When _ -> 1 | _ -> 2 in let r = rank s1.condition - rank s2.condition in if r = 0 then Pervasives.compare k2 k1 else r end) let cid = ref 0 let fresh () = incr cid ; assert (!cid > 0) ; !cid type t = SEQ.t let add s t = SEQ.add (fresh (),s) t let empty = [] let is_empty = function [] -> true | _ -> false (* unused for now *) (* let non_empty = function [] -> false | _ -> true *) let factorize = SEQ.factorize let big_inter = SEQ.big_inter let diff = SEQ.diff (* unused for now *) (* let iter f b = SEQ.iter (fun (_,s) -> f s) b *) let freeze b = List.map snd b let map f b = List.map (fun (_,s) -> f s.condition) b let exists f b = List.exists (fun (_,s) -> f s.condition) b (* unused for now *) (* let debug fmt hs = begin Format.fprintf fmt "{" ; List.iter (fun (id,step) -> Format.fprintf fmt " %d:" id ; match step.condition with | Have _ -> Format.fprintf fmt "H" | Type _ -> Format.fprintf fmt "T" | When _ -> Format.fprintf fmt "W" | Branch _ -> Format.fprintf fmt "IF" | Either cs -> Format.fprintf fmt "CS(%d)" (List.length cs) ) hs ; Format.fprintf fmt " }" ; end *) let is_true = function | [] -> Yes | (_,s) :: _ -> is_cond_true s.condition end type bundle = Bundle.t type t = step list (* -------------------------------------------------------------------------- *) (* --- Pretty --- *) (* -------------------------------------------------------------------------- *) type link = Lstmt of stmt | Lprop of Property.t type linker = (string,link) Hashtbl.t let glinker = ref None let pid = ref 0 let linker () = Hashtbl.create 131 let get_link = Hashtbl.find let pp_link link pp fmt a = match !glinker with | None -> pp fmt a | Some href -> begin let aref = match link with | Lstmt s -> Printf.sprintf "s%d" s.sid | Lprop _ -> incr pid ; Printf.sprintf "p%d" !pid in Hashtbl.add href aref link ; Format.pp_open_tag fmt ("link:" ^ aref) ; pp fmt a ; Format.pp_close_tag fmt () ; end let pp_loc fmt loc = let file = loc.Lexing.pos_fname in let line = loc.Lexing.pos_lnum in Format.fprintf fmt "%s:%d: " file line let pp_stmt fmt = function | None -> () | Some stmt -> let loc = fst (Cil_datatype.Stmt.loc stmt) in pp_link (Lstmt stmt) pp_loc fmt loc let pp_descr fmt s = match s.descr with | None -> () | Some msg -> Format.fprintf fmt "@ @{(* %a%s *)@}" pp_stmt s.stmt msg let pp_depend fmt s p = let stmt = match Property.get_kinstr p with Kstmt stmt -> Some stmt | _ -> s.stmt in Format.fprintf fmt "@ @{(* %a@[%a@]: *)@}" pp_stmt stmt (pp_link (Lprop p) Description.pp_local) p let pp_warning fmt w = Format.fprintf fmt "@ @[@{@{Warning@}@}[%s]: %s@ (%s).@]" w.Warning.source w.Warning.reason w.Warning.effect let pp_clause fmt env title p = Format.fprintf fmt "@ @[@{%s@}: %a.@]" title (F.pp_epred env) p let mark_seq m seq = List.iter (fun s -> match s.condition with | When p | Type p | Have p | Branch(p,_,_) -> F.mark_p m p | Either _ -> () ) seq let rec pp_step fmt env s = begin pp_descr fmt s ; List.iter (pp_depend fmt s) s.deps ; Warning.Set.iter (pp_warning fmt) s.warn ; pp_condition fmt env s.condition ; end and pp_condition fmt env = function | Type p -> pp_clause fmt env "Type" p | Have p -> pp_clause fmt env "Have" p | When p -> pp_clause fmt env "When" p | Branch(p,a,b) -> begin Format.fprintf fmt "@ @[@{If@}: %a@]" (F.pp_epred env) p ; if a<>[] then pp_sequence fmt "Then" env a ; if b<>[] then pp_sequence fmt "Else" env b ; end | Either cases -> begin Format.fprintf fmt "@[@[@{Either@} {" ; List.iter (fun seq -> Format.fprintf fmt "@ @[@{Case@}:" ; pp_block fmt env seq ; Format.fprintf fmt "@]" ; ) cases ; Format.fprintf fmt "@]@ }@]" ; end and pp_sequence fmt title env = function | [] -> Format.fprintf fmt "@ @{%s@} {}" title | seq -> begin Format.fprintf fmt "@ @[@[@{%s@} {" title ; pp_block fmt env seq ; Format.fprintf fmt "@]@ }@]" ; end and pp_block fmt env seq = let m = F.marker env in mark_seq m seq ; let env = F.define (fun env x t -> Format.fprintf fmt "@ @[@{Let@} %s = %a.@]" x (F.pp_eterm env) t) env m in List.iter (pp_step fmt env) seq let dump fmt (b:bundle) = pp_sequence fmt "Assume" F.empty (Bundle.freeze b) let pp_seq title fmt s = pp_sequence fmt title F.empty s (* -------------------------------------------------------------------------- *) (* --- Extraction --- *) (* -------------------------------------------------------------------------- *) let rec occurs_cond x = function | Type p | When p | Have p -> Vars.mem x (F.varsp p) | Branch(p,a,b) -> Vars.mem x (F.varsp p) || occurs_seq x a || occurs_seq x b | Either cases -> List.exists (occurs_seq x) cases and occurs_seq x seq = List.exists (fun s -> occurs_cond x s.condition) seq let occurs x bundle = Bundle.exists (occurs_cond x) bundle let rec intersect_cond p = function | Type q | When q | Have q -> F.intersectp p q | Branch(q,a,b) -> F.intersectp p q || intersect_seq p a || intersect_seq p b | Either cases -> List.exists (intersect_seq p) cases and intersect_seq p s = List.exists (fun s -> intersect_cond p s.condition) s let intersect p bundle = Bundle.exists (intersect_cond p) bundle let rec vars_cond xs = function | Type q | When q | Have q -> vars_pred xs q | Branch(p,a,b) -> vars_seq (vars_seq (vars_pred xs p) a) b | Either cases -> List.fold_left vars_seq xs cases and vars_seq xs seq = List.fold_left vars_step xs seq and vars_step xs s = vars_cond xs s.condition and vars_pred xs p = Vars.union xs (F.varsp p) let rec pred_cond = function | When p | Type p | Have p -> p | Branch(p,a,b) -> F.p_if p (pred_seq a) (pred_seq b) | Either cases -> F.p_any pred_seq cases and pred_seq seq = F.p_all (fun s -> pred_cond s.condition) seq let extract bundle = Bundle.map pred_cond bundle let freeze = Bundle.freeze (* -------------------------------------------------------------------------- *) (* --- Pretty Printer --- *) (* -------------------------------------------------------------------------- *) let pretty ?linker fmt hyps goal = try glinker := linker ; let env = F.closed (vars_seq (F.varsp goal) hyps) in let m = F.marker env in mark_seq m hyps ; F.mark_p m goal ; let env = F.define (fun env x t -> Format.fprintf fmt "@[@{Let@} %s = %a.@]@\n" x (F.pp_eterm env) t ) env m in Format.fprintf fmt "@[@[@{Assume@} {" ; List.iter (pp_step fmt env) hyps ; Format.fprintf fmt "@]@ }@]@\n" ; Format.fprintf fmt "@[@{Prove:@} %a.@]@." (F.pp_epred env) goal ; glinker := None ; with err -> glinker := None ; raise err (* -------------------------------------------------------------------------- *) (* --- Constructors --- *) (* -------------------------------------------------------------------------- *) let empty = Bundle.empty let step ?descr ?stmt ?(deps=[]) ?(warn=Warning.Set.empty) cond = { stmt = stmt ; descr = descr ; warn = warn ; deps = deps ; condition = cond ; } type 'a disjunction = TRUE | FALSE | EITHER of 'a list let disjunction phi cases = let positive = ref false in (* invariant : OR { bundles } <-> ( positive \/ OR { filter } *) let remains = List.filter (fun case -> match phi case with | Yes -> positive := true ; false (* ? \/ True \/ Ci <-> True \/ filer Ci *) | No -> false (* positive \/ False \/ Ci <-> positive \/ filter Ci *) | Maybe -> true) (* positive \/ C \/ Ci <-> positive \/ C :: filter Ci *) cases in if remains = [] then if !positive then TRUE else FALSE else EITHER remains (* -------------------------------------------------------------------------- *) (* --- Constructors --- *) (* -------------------------------------------------------------------------- *) type 'a attributed = ( ?descr:string -> ?stmt:stmt -> ?deps:Property.t list -> ?warn:Warning.Set.t -> 'a ) let domain ps hs = if ps = [] then hs else Bundle.add (step ~descr:"Domain" (Type (p_conj ps))) hs let intros ps hs = if ps = [] then hs else Bundle.add (step ~descr:"Goal" (When (p_conj ps))) hs let assume ?descr ?stmt ?deps ?warn p hs = match F.is_ptrue p with | Yes -> hs | No -> let s = step ?descr ?stmt ?deps ?warn (Have p) in Bundle.add s Bundle.empty | Maybe -> begin match Bundle.is_true hs with | Yes | Maybe -> let s = step ?descr ?stmt ?deps ?warn (Have p) in Bundle.add s hs | No -> hs end let branch ?descr ?stmt ?deps ?warn p ha hb = match F.is_ptrue p with | Yes -> ha | No -> hb | Maybe -> match Bundle.is_true ha , Bundle.is_true hb with | Yes , Yes -> Bundle.empty | _ , No -> assume ?descr ?stmt ?deps ?warn p ha | No , _ -> assume ?descr ?stmt ?deps ?warn (p_not p) hb | _ -> let ha,hs,hb = Bundle.factorize ha hb in if Bundle.is_empty ha && Bundle.is_empty hb then hs else let a = Bundle.freeze ha in let b = Bundle.freeze hb in let s = step ?descr ?stmt ?deps ?warn (Branch(p,a,b)) in Bundle.add s hs let either ?descr ?stmt ?deps ?warn cases = match disjunction Bundle.is_true cases with | TRUE -> Bundle.empty | FALSE -> let s = step ?descr ?stmt ?deps ?warn (Have p_false) in Bundle.add s Bundle.empty | EITHER cases -> let trunk = Bundle.big_inter cases in let cases = List.map (fun case -> Bundle.diff case trunk) cases in match disjunction Bundle.is_true cases with | TRUE -> trunk | FALSE -> let s = step ?descr ?stmt ?deps ?warn (Have p_false) in Bundle.add s Bundle.empty | EITHER cases -> let cases = List.map Bundle.freeze cases in let s = step ?descr ?stmt ?deps ?warn (Either cases) in Bundle.add s trunk let merge cases = either ~descr:"Merge" cases (* -------------------------------------------------------------------------- *) (* --- Flattening --- *) (* -------------------------------------------------------------------------- *) let flat_cons step tail = match is_seq_true tail with | Yes | Maybe -> step :: tail | No -> tail let flat_concat head tail = match is_seq_true head with | Yes -> tail | No -> head | Maybe -> match is_seq_true tail with | Yes -> head | No -> tail | Maybe -> head @ tail let rec flatten_sequence m = function | [] -> [] | step :: seq -> match step.condition with | Have p | Type p | When p -> begin match F.is_ptrue p with | Yes -> m := true ; flatten_sequence m seq | No -> if seq <> [] then m := true ; [step] | Maybe -> flat_cons step (flatten_sequence m seq) end | Branch(p,sa,sb) -> begin match F.is_ptrue p with | Yes -> m := true ; flat_concat sa (flatten_sequence m seq) | No -> m := true ; flat_concat sb (flatten_sequence m seq) | Maybe -> match is_seq_true sa , is_seq_true sb with | Yes , Yes -> m := true ; flatten_sequence m seq | _ , No -> m := true ; let step = { step with condition = Have p } in step :: sa @ flatten_sequence m seq | No , _ -> m := true ; let step = { step with condition = Have (p_not p) } in step :: sb @ flatten_sequence m seq | _ -> step :: flatten_sequence m seq end | Either [] -> [step] | Either cases -> match disjunction is_seq_true cases with | TRUE -> m := true ; flatten_sequence m seq | FALSE -> m := true ; [ { step with condition = Have p_false } ] | EITHER [hc] -> m := true ; flat_concat hc (flatten_sequence m seq) | EITHER cs -> let step = { step with condition = Either cs } in flat_cons step (flatten_sequence m seq) (* -------------------------------------------------------------------------- *) (* --- Letify --- *) (* -------------------------------------------------------------------------- *) module Sigma = Letify.Sigma module Defs = Letify.Defs let used_of_dseq = Array.fold_left (fun ys (xs,_,_) -> Vars.union ys xs) Vars.empty let bind_dseq target (_,di,_) sigma = Letify.bind (Letify.bind sigma di target) di (Defs.domain di) let locals sigma ~target ~required ?(step=Vars.empty) k dseq = (* returns ( target , export ) *) let t = ref target in let e = ref (Vars.union required step) in Array.iteri (fun i (xs,_,_) -> if i > k then t := Vars.union !t xs ; if i <> k then e := Vars.union !e xs ; ) dseq ; Vars.diff !t (Sigma.domain sigma) , !e let dseq_of_step sigma step = let xs = match step.condition with | Type _ -> Vars.empty | cond -> vars_cond Vars.empty cond in let defs = match step.condition with | Have p | When p -> Defs.extract (Sigma.p_apply sigma p) | Type _ | Branch _ | Either _ -> Defs.empty in (xs , defs , step) let letify_assume sref (_,_,step) = let current = !sref in begin match step.condition with | Type _ | Branch _ | Either _ -> () | Have p | When p -> if Wp_parameters.Simpl.get () then sref := Sigma.assume current p ; end ; current let rec letify_type sigma used p = match F.pred p with | And ps -> p_all (letify_type sigma used) ps | _ -> let p = Sigma.p_apply sigma p in if Vars.intersect used (F.varsp p) then p else F.p_true let rec letify_seq sigma0 ~target ~export (seq : step list) = let dseq = Array.map (dseq_of_step sigma0) (Array.of_list seq) in let sigma1 = Array.fold_right (bind_dseq target) dseq sigma0 in let sref = ref sigma1 in (* with definitions *) let dsigma = Array.map (letify_assume sref) dseq in let sigma2 = !sref in (* with assumptions *) let outside = Vars.union export target in let inside = used_of_dseq dseq in let used = Vars.diff (Vars.union outside inside) (Sigma.domain sigma2) in let required = Vars.union outside (Sigma.codomain sigma2) in let sequence = Array.mapi (letify_step dseq dsigma ~used ~required ~target) dseq in let modified = ref (not (Sigma.equal sigma0 sigma1)) in let sequence = flatten_sequence modified (Array.to_list sequence) in !modified , sigma1 , sigma2 , sequence and letify_step dseq dsigma ~required ~target ~used i (_,d,s) = let sigma = dsigma.(i) in let cond = match s.condition with | Have p -> let p = Sigma.p_apply sigma p in let ps = Letify.add_definitions sigma d required [p] in Have (p_conj ps) | When p -> When (Sigma.p_apply sigma p) | Type p -> Type (letify_type sigma used p) | Branch(p,a,b) -> let p = Sigma.p_apply sigma p in let step = F.varsp p in let (target,export) = locals sigma ~target ~required ~step i dseq in let sa = Sigma.assume sigma p in let sb = Sigma.assume sigma (p_not p) in let a = letify_case sa ~target ~export a in let b = letify_case sb ~target ~export b in Branch(p,a,b) | Either cases -> let (target,export) = locals sigma ~target ~required i dseq in Either (List.map (letify_case sigma ~target ~export) cases) in { s with condition = cond } and letify_case sigma ~target ~export seq = let (_,_,_,seq) = letify_seq sigma ~target ~export seq in seq let rec fixpoint n sigma hs p = let target = F.varsp p in let export = Vars.empty in let modified , sigma1 , sigma2 , hs = letify_seq sigma ~target ~export hs in let p = Sigma.p_apply sigma2 p in if not modified then hs , p else fixpoint (succ n) sigma1 hs p let letify hs p = fixpoint 0 Sigma.empty hs p (* -------------------------------------------------------------------------- *) (* --- Filtering --- *) (* -------------------------------------------------------------------------- *) let residual p = { stmt = None ; descr = Some "Residual" ; deps = [] ; warn = Warning.Set.empty ; condition = When p ; } let rec add_case p = function | ( { condition = (Type _) } as step ):: tail -> step :: add_case p tail | hs -> residual p :: hs let is_absurd h = match h.condition with | (Type p | When p | Have p) -> p == F.p_false | _ -> false let is_trivial (hs,g) = g == F.p_true || List.exists is_absurd hs let test_case p (hs,g) = let w = letify (add_case p hs) g in if is_trivial w then None else Some w let tc = ref 0 let rec test_cases sequent = function | [] -> sequent | (p,_) :: tail -> match test_case p sequent , test_case (p_not p) sequent with | None , None -> incr tc ; [],F.p_true | Some w , None -> incr tc ; test_cases w tail | None , Some w -> incr tc ; test_cases w tail | Some _ , Some _ -> test_cases sequent tail let rec collect_cond m = function | When _ | Have _ | Type _ -> () | Branch(p,a,b) -> Letify.Split.add m p ; collect_seq m a ; collect_seq m b | Either cs -> List.iter (collect_seq m) cs and collect_seq m seq = List.iter (fun s -> collect_cond m s.condition) seq let pruning hs g = let sequent = (hs,g) in if is_trivial sequent then sequent else begin let m = Letify.Split.create () in collect_seq m hs ; tc := 0 ; let sequent = test_cases (hs,g) (Letify.Split.select m) in if !tc > 0 && Wp_parameters.has_dkey "pruning" then if is_trivial sequent then Wp_parameters.feedback "[Pruning] Trivial" else Wp_parameters.feedback "[Pruning] %d branche(s) removed" !tc ; sequent end (* -------------------------------------------------------------------------- *) (* --- Cleaning --- *) (* -------------------------------------------------------------------------- *) let rec collect_cond u = function | When p -> Cleaning.as_have u p | Have p -> Cleaning.as_have u p | Type p -> Cleaning.as_type u p | Branch(p,a,b) -> Cleaning.as_atom u p ; collect_seq u a ; collect_seq u b | Either cs -> List.iter (collect_seq u) cs and collect_seq u seq = List.iter (fun s -> collect_cond u s.condition) seq let rec clean_cond u = function | When p -> When (Cleaning.filter_pred u p) | Have p -> Have (Cleaning.filter_pred u p) | Type p -> Type (Cleaning.filter_pred u p) | Branch(p,a,b) -> Branch(p,clean_seq u a,clean_seq u b) | Either cases -> Either(List.map (clean_seq u) cases) and clean_seq u = function | [] -> [] | s :: seq -> let c = clean_cond u s.condition in let seq = clean_seq u seq in match is_cond_true c with | Yes -> seq | No -> [{ s with condition = c }] | Maybe -> { s with condition = c } :: seq let clean hs p = let u = Cleaning.create () in Cleaning.as_atom u p ; collect_seq u hs ; clean_seq u hs , p (* -------------------------------------------------------------------------- *) (* --- Utilities --- *) (* -------------------------------------------------------------------------- *) let hypotheses hs = List.map (fun s -> pred_cond s.condition) hs let close hs goal = F.p_close (F.p_hyps (hypotheses hs) goal) (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/configure0000755000175000017500000030074212155634042017131 0ustar mehdimehdi#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME= PACKAGE_TARNAME= PACKAGE_VERSION= PACKAGE_STRING= PACKAGE_BUGREPORT= PACKAGE_URL= ac_unique_file="Makefile.in" ac_subst_vars='LTLIBOBJS LIBOBJS COQC DYNAMIC_WP ENABLE_WP ENABLE_GUI FRAMAC_VERSION 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 enable_wpcoq ' ac_precious_vars='build_alias host_alias target_alias' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures this package to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then cat <<\_ACEOF 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 WP plug-in (default: yes) --enable-wpcoq Wp precompiled coq libraries (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.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu 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 FRAMAC_VERSION=`frama-c -version | sed -n -e "s|^Version: *\(.*\)$|\1|p"` # 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 ${ac_cv_prog_ENABLE_GUI+:} false; 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 as_fn_executable_p "$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 ${ac_cv_file_Makefile_in+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "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" = xyes; 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]) # Check whether --enable-wpcoq was given. if test "${enable_wpcoq+set}" = set; then : enableval=$enable_wpcoq; WPCOQ=$enableval else WPCOQ=yes fi 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 if test "$WPCOQ" = "yes" ; then ## coq # Extract the first word of "coqc", so it can be a program name with args. set dummy coqc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_COQC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$COQC"; then ac_cv_prog_COQC="$COQC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_COQC="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_COQC" && ac_cv_prog_COQC="no" fi fi COQC=$ac_cv_prog_COQC if test -n "$COQC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $COQC" >&5 $as_echo "$COQC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$COQC" = "yes" ; then COQVERSION=`coqc -v | sed -n -e 's|.*version* *\([^ ]*\) .*$|\1|p' ` case $COQVERSION in 8.4*|trunk) { $as_echo "$as_me:${as_lineno-$LINENO}: result: coqc version $COQVERSION found" >&5 $as_echo "coqc version $COQVERSION found" >&6; } ;; *) { $as_echo "$as_me:${as_lineno-$LINENO}: result: wp needs coq 8.4" >&5 $as_echo "wp needs coq 8.4" >&6; } COQC="no" ;; esac else { $as_echo "$as_me:${as_lineno-$LINENO}: rerun configure to make wp using coq 8.4" >&5 $as_echo "$as_me: rerun configure to make wp using coq 8.4" >&6;} fi else COQC="no" 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 if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\[/\\&/g s/\]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "./Makefile") 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= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" eval set X " :F $CONFIG_FILES " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac 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 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi frama-c-Fluorine-20130601/src/wp/GuiConfig.mli0000644000175000017500000000427212155630215017574 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Provers Configuration Panel --- *) (* ------------------------------------------------------------------------ *) open ProverWhy3 class provers : string -> [dp list] Toolbox.selector class dp_chooser : main:Design.main_window_extension_points -> available:provers -> enabled:provers -> object method run : unit -> unit (** Edit enabled provers *) end class dp_button : available:provers -> enabled:provers -> object inherit Toolbox.widget method update : unit -> unit end frama-c-Fluorine-20130601/src/wp/wpAnnot.mli0000644000175000017500000000700612155630215017346 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 in 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 filter_status : WpPropId.prop_id -> bool (*----------------------------------------------------------------------------*) val get_called_preconditions_at : kernel_function -> stmt -> Property.t 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 (*----------------------------------------------------------------------------*) type asked_assigns = NoAssigns | OnlyAssigns | WithAssigns val get_id_prop_strategies : ?assigns:asked_assigns -> Property.t -> WpStrategy.strategy list val get_call_pre_strategies : stmt -> WpStrategy.strategy list val get_function_strategies : ?assigns:asked_assigns -> ?bhv:string list -> ?prop:string list -> Kernel_function.t -> WpStrategy.strategy list (*----------------------------------------------------------------------------*) frama-c-Fluorine-20130601/src/wp/wpo.mli0000644000175000017500000001502512155630215016525 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 LogicUsage open VCS open Cil_types open Cil_datatype open WpPropId type index = | Axiomatic of string option | Function of kernel_function * string option (* ------------------------------------------------------------------------ *) (**{1 Proof Obligations} *) (* ------------------------------------------------------------------------ *) module DISK : sig val cache_log : pid:prop_id -> model:Model.t -> prover:prover -> result:result -> string val pretty : pid:prop_id -> model:Model.t -> prover:prover -> result:result -> Format.formatter -> unit val file_kf : kf:kernel_function -> model:Model.t -> prover:prover -> string val file_goal : pid:prop_id -> model:Model.t -> prover:prover -> string val file_logout : pid:prop_id -> model:Model.t -> prover:prover -> string val file_logerr : pid:prop_id -> model:Model.t -> prover:prover -> string end module GOAL : sig type t open Lang val dummy : t val trivial : t val is_trivial : t -> bool val make : Conditions.t -> F.pred -> t val compute_proof : t -> F.pred val compute_descr : t -> Conditions.t * F.pred val get_descr : t -> Conditions.t * F.pred val compute : t -> unit val qed_time : t -> float end module VC_Lemma : sig type t = { lemma : Definitions.dlemma ; depends : logic_lemma list ; (* list of axioms and lemma on which the proof depends on *) } val is_trivial : t -> bool val cache_descr : t -> (prover * result) list -> string end module VC_Annot : sig type t = { goal : GOAL.t ; tags : Splitter.tag list ; warn : Warning.t list ; deps : Property.Set.t ; path : Stmt.Set.t ; effect : (stmt * effect_source) option ; } val resolve : t -> bool val is_trivial : t -> bool val cache_descr : pid:prop_id -> t -> (prover * result) list -> string end (* ------------------------------------------------------------------------ *) (**{1 Proof Obligations} *) (* ------------------------------------------------------------------------ *) type formula = | GoalLemma of VC_Lemma.t | GoalAnnot of VC_Annot.t (** Dynamically exported as ["Wpo.po"] *) type po = t and t = { po_gid : string ; (* goal identifier *) po_name : string ; (* goal informal name *) po_idx : index ; (* goal index *) po_model : Model.t ; po_pid : WpPropId.prop_id ; (* goal target property *) po_updater : Emitter.t ; (* property status updater *) po_formula : formula ; (* proof obligation *) } module S : Datatype.S_with_collections with type t = po (** Dynamically exported @since Nitrogen-20111001 *) val get_gid: t -> string (** Dynamically exported @since Oxygen-20120901 *) val get_property: t -> Property.t val get_index : t -> index val get_label : t -> string val get_model : t -> Model.t val get_model_id : t -> string val get_model_name : t -> string val get_file_logout : t -> prover -> string (** only filename, might not exists *) val get_file_logerr : t -> prover -> string (** only filename, might not exists *) val get_files : t -> (string * string) list val clear : unit -> unit val remove : t -> unit val gid : model:string -> propid:WpPropId.prop_id -> string val add : t -> unit val age : t -> int (* generation *) val set_result : t -> prover -> result -> unit (** Dynamically exported. *) val get_result : t -> prover -> result val get_results : t -> (prover * result) list val get_proof : t -> bool * Property.t val is_trivial : t -> bool val warnings : t -> Warning.t list (** [true] if the result is valid. Dynamically exported. @since Nitrogen-20111001 *) val is_valid: result -> bool (** [true] if the result is meaningfull (Valid, Unknown or Timeout) *) val is_verdict: result -> bool val get_time: result -> float val get_steps: result -> int val iter : ?ip:Property.t -> ?index:index -> ?on_axiomatics:(string option -> 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 (** All POs related to a given property. Dynamically exported @since Oxygen-20120901 *) val goals_of_property: Property.t -> t list val bar : string val kf_context : index -> Description.kf val pp_index : Format.formatter -> index -> unit val pp_warnings : Format.formatter -> Warning.t list -> unit val pp_depend : Format.formatter -> Property.t -> unit val pp_dependency : Description.kf -> Format.formatter -> Property.t -> unit val pp_dependencies : Description.kf -> Format.formatter -> Property.t list -> unit val pp_goal : Format.formatter -> t -> unit val pp_title : Format.formatter -> t -> unit val pp_logfile : Format.formatter -> t -> prover -> unit val pp_function : Format.formatter -> Kernel_function.t -> string option -> unit val pp_goal_flow : Format.formatter -> t -> unit (** Dynamically exported. *) val prover_of_name : string -> prover option frama-c-Fluorine-20130601/src/wp/script.ml0000444000175000017500000005261012155634033017054 0ustar mehdimehdi# 23 "src/wp/script.mll" type token = | Id of string | Key of string | Proof of string | Word | Eof 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 } # 22 "src/wp/script.ml" let __ocaml_lex_tables = { Lexing.lex_base = "\000\000\247\255\248\255\000\000\250\255\078\000\160\000\254\255\ \002\000\238\000\060\001\138\001\216\001\007\000\253\255\249\255\ \111\001\251\255\252\255\253\255\001\000\000\000\255\255\254\255\ \011\002\249\255\250\255\251\255\006\000\018\000\027\000\024\000\ \036\000\015\000\255\255\019\000\037\000\016\000\000\000\254\255\ \252\255\112\001\251\255\252\255\253\255\022\000\049\000\255\255\ \254\255"; Lexing.lex_backtrk = "\255\255\255\255\255\255\008\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\006\000\006\000\006\000\006\000\ \255\255\255\255\255\255\255\255\255\255\255\255\002\000\255\255\ \255\255\255\255\255\255\255\255\255\255\004\000\004\000\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\255\255\000\000\ \000\000\042\000\000\000\000\000\000\000\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\005\000\004\000\040\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\038\000\034\000\034\000\048\000\ \039\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\047\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\035\000\032\000\005\000\005\000\ \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ \033\000\036\000\037\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\005\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\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\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\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\018\000\043\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\ \046\000\021\000\045\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\ \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\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\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\026\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\029\000\000\000\028\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\031\000\000\000\030\000\000\000\ \000\000\000\000\000\000\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\ \044\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\027\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\000\000\000\000\028\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\029\000\033\000\037\000\045\000\ \038\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\046\000\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\030\000\031\000\005\000\005\000\ \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ \032\000\035\000\036\000\255\255\255\255\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\006\000\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\255\255\255\255\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\255\255\255\255\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\041\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\ \041\000\016\000\041\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\ \255\255\255\255\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\ \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\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\024\000\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\024\000\255\255\024\000\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\024\000\255\255\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\016\000\ \041\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\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\024\000"; 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 -> # 46 "src/wp/script.mll" ( token lexbuf ) # 267 "src/wp/script.ml" | 1 -> # 47 "src/wp/script.mll" ( newline lexbuf ; token lexbuf ) # 272 "src/wp/script.ml" | 2 -> # 49 "src/wp/script.mll" ( newline lexbuf ; let buffer = Buffer.create 512 in proof buffer 0 lexbuf ; Proof (Buffer.contents buffer) ) # 282 "src/wp/script.ml" | 3 -> # 56 "src/wp/script.mll" ( let buffer = Buffer.create 512 in proof buffer 0 lexbuf ; Proof (Buffer.contents buffer) ) # 291 "src/wp/script.ml" | 4 -> # 62 "src/wp/script.mll" ( Id (Lexing.lexeme lexbuf) ) # 298 "src/wp/script.ml" | 5 -> # 65 "src/wp/script.mll" ( Key(Lexing.lexeme lexbuf) ) # 303 "src/wp/script.ml" | 6 -> # 66 "src/wp/script.mll" ( comment 0 lexbuf ) # 308 "src/wp/script.ml" | 7 -> # 67 "src/wp/script.mll" ( Eof ) # 313 "src/wp/script.ml" | 8 -> # 68 "src/wp/script.mll" ( Word ) # 318 "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 -> # 71 "src/wp/script.mll" ( if n > 0 then comment (pred n) lexbuf else token lexbuf ) # 329 "src/wp/script.ml" | 1 -> # 72 "src/wp/script.mll" ( comment (succ n) lexbuf ) # 334 "src/wp/script.ml" | 2 -> # 73 "src/wp/script.mll" ( failwith "Non-terminated comment" ) # 339 "src/wp/script.ml" | 3 -> # 74 "src/wp/script.mll" ( newline lexbuf ; comment n lexbuf ) # 344 "src/wp/script.ml" | 4 -> # 75 "src/wp/script.mll" ( comment n lexbuf ) # 349 "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 -> # 79 "src/wp/script.mll" ( if n > 0 then proof buffer (pred n) lexbuf ) # 362 "src/wp/script.ml" | 1 -> # 82 "src/wp/script.mll" ( skip 0 lexbuf ; proof buffer n lexbuf ) # 367 "src/wp/script.ml" | 2 -> # 83 "src/wp/script.mll" ( fill buffer lexbuf ; proof buffer (succ n) lexbuf ) # 372 "src/wp/script.ml" | 3 -> # 84 "src/wp/script.mll" ( fill buffer lexbuf ; if n>0 then proof buffer (pred n) lexbuf else failwith "Non-terminated comment (inside proof)" ) # 379 "src/wp/script.ml" | 4 -> # 87 "src/wp/script.mll" ( failwith "Non-terminated proof" ) # 384 "src/wp/script.ml" | 5 -> # 88 "src/wp/script.mll" ( fill buffer lexbuf ; newline lexbuf ; proof buffer n lexbuf ) # 389 "src/wp/script.ml" | 6 -> # 89 "src/wp/script.mll" ( fill buffer lexbuf ; proof buffer n lexbuf ) # 394 "src/wp/script.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_proof_rec buffer n lexbuf __ocaml_lex_state and skip n lexbuf = __ocaml_lex_skip_rec n lexbuf 41 and __ocaml_lex_skip_rec n lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 92 "src/wp/script.mll" ( skip (succ n) lexbuf ) # 405 "src/wp/script.ml" | 1 -> # 93 "src/wp/script.mll" ( if n>0 then skip (pred n) lexbuf ) # 410 "src/wp/script.ml" | 2 -> # 94 "src/wp/script.mll" ( () ) # 415 "src/wp/script.ml" | 3 -> # 95 "src/wp/script.mll" ( newline lexbuf ; skip n lexbuf ) # 420 "src/wp/script.ml" | 4 -> # 96 "src/wp/script.mll" ( skip n lexbuf ) # 425 "src/wp/script.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_skip_rec n lexbuf __ocaml_lex_state ;; # 98 "src/wp/script.mll" let filter key = let lexbuf = Lexing.from_string key in match token lexbuf with | Id a -> Some a | _ -> None 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 key input k = match input.token with | (Key a) | (Id 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] | _ -> [] # 503 "src/wp/script.ml" frama-c-Fluorine-20130601/src/wp/cfgWP.mli0000644000175000017500000000371012155630215016724 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Calculus --- *) (* -------------------------------------------------------------------------- *) module VC( M : Memory.Model ) : Mcfg.S module Computer( M : Memory.Model ) : sig val create : Model.t -> Generator.computer end frama-c-Fluorine-20130601/src/wp/VCS.ml0000644000175000017500000001515212155630215016203 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Provers --- *) (* -------------------------------------------------------------------------- *) type prover = | Why3 of string (* Prover via WHY *) | Why3ide | AltErgo (* Alt-Ergo *) | Coq (* Coq and Coqide *) | Qed (* Qed Solver *) type language = | L_why3 | L_coq | L_altergo let prover_of_name = function | "" | "none" -> None | "alt-ergo" | "altgr-ergo" -> Some AltErgo | "coq" | "coqide" -> Some Coq | "why3ide" -> Some Why3ide | s -> match Extlib.string_del_prefix "why3:" s with | Some "" -> None | Some "ide" -> Some Why3ide | Some s' -> Some (Why3 s') | None -> Some (Why3 s) let name_of_prover = function | Why3ide -> "Why3" | Why3 s -> s | AltErgo -> "Alt-Ergo" | Coq -> "Coq" | Qed -> "Qed" let sanitize_why3 s = let buffer = Buffer.create 80 in assert (s <> "ide"); Buffer.add_string buffer "Why3_" ; String.iter (fun c -> let c = if ('0' <= c && c <= '9') || ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') then c else '_' in Buffer.add_char buffer c) s ; Buffer.contents buffer let filename_for_prover = function | Why3 s -> sanitize_why3 s | Why3ide -> "Why3_ide" | AltErgo -> "Alt-Ergo" | Coq -> "Coq" | Qed -> "Qed" let language_of_name = function | "" | "none" -> None | "alt-ergo" | "altgr-ergo" -> Some L_altergo | "coq" | "coqide"-> Some L_coq | "why" -> Some L_why3 | s -> Wp_parameters.abort "Language '%s' unknown" s let language_of_prover = function | Why3 _ -> L_why3 | Why3ide -> L_why3 | Coq -> L_coq | AltErgo -> L_altergo | Qed -> L_why3 let language_of_prover_name = function | "" | "none" -> None | "alt-ergo" | "altgr-ergo" -> Some L_altergo | "coq" | "coqide" -> Some L_coq | _ -> Some L_why3 let is_interactive = function | "coqide" | "altgr-ergo" -> true | _ -> false let cmp_prover p q = match p,q with | Qed , Qed -> 0 | Qed , _ -> (-1) | _ , Qed -> 1 | AltErgo , AltErgo -> 0 | AltErgo , _ -> (-1) | _ , AltErgo -> 1 | Coq , Coq -> 0 | Coq , _ -> (-1) | _ , Coq -> 1 | Why3 p , Why3 q -> String.compare p q | Why3 _, _ -> (-1) | _, Why3 _ -> 1 | Why3ide, Why3ide -> 0 let pp_prover fmt = function | AltErgo -> Format.pp_print_string fmt "Alt-Ergo" | Why3ide -> Format.pp_print_string fmt "Why3ide" | Coq -> Format.pp_print_string fmt "Coq" | Why3 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) | Qed -> Format.fprintf fmt "Qed" let pp_language fmt = function | L_altergo -> Format.pp_print_string fmt "Alt-Ergo" | L_coq -> Format.pp_print_string fmt "Coq" | L_why3 -> Format.pp_print_string fmt "Why3" (* -------------------------------------------------------------------------- *) (* --- Results --- *) (* -------------------------------------------------------------------------- *) type verdict = | NoResult | Invalid | Unknown | Timeout | Stepout | Computing of (unit -> unit) (* kill function *) | Valid | Failed type result = { verdict : verdict ; solver_time : float ; prover_time : float ; prover_steps : int ; prover_errpos : Lexing.position option ; prover_errmsg : string ; } let result ?(solver=0.0) ?(time=0.0) ?(steps=0) verdict = { verdict = verdict ; solver_time = solver ; prover_time = time ; prover_steps = steps ; prover_errpos = None ; prover_errmsg = "" ; } let no_result = result NoResult let valid = result Valid let invalid = result Invalid let unknown = result Unknown let timeout = result Timeout let stepout = result Stepout let computing kill = result (Computing kill) let failed ?pos msg = { verdict = Failed ; solver_time = 0.0 ; prover_time = 0.0 ; prover_steps = 0 ; prover_errpos = pos ; prover_errmsg = msg ; } let pp_perf fmt r = begin let t = r.solver_time in if t > Rformat.epsilon && not (Wp_parameters.has_dkey "no-time-info") then Format.fprintf fmt " (Qed:%a)" Rformat.pp_time t ; let t = r.prover_time in if t > Rformat.epsilon && not (Wp_parameters.has_dkey "no-time-info") then Format.fprintf fmt " (%a)" Rformat.pp_time t ; let s = r.prover_steps in if s > 0 && not (Wp_parameters.has_dkey "no-step-info") then Format.fprintf fmt " (%d)" s end let pp_result fmt r = match r.verdict with | NoResult -> Format.pp_print_string fmt "-" | Invalid -> Format.pp_print_string fmt "Invalid" | Computing _ -> Format.pp_print_string fmt "Computing" | Valid -> Format.fprintf fmt "Valid%a" pp_perf r | Unknown -> Format.fprintf fmt "Unknown%a" pp_perf r | Timeout -> Format.fprintf fmt "Timeout%a" pp_perf r | Stepout -> Format.fprintf fmt "Step limit%a" pp_perf r | Failed -> Format.fprintf fmt "Failed@\nError: %s" r.prover_errmsg frama-c-Fluorine-20130601/src/wp/Passive.ml0000644000175000017500000000537312155630215017166 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Passive Forms --- *) (* -------------------------------------------------------------------------- *) open Lang open Lang.F type binding = | B1 of var * pred | B2 of var * var * pred type t = binding list let empty = [] let union = List.append let bind ~fresh ~bound bs = B1(bound , p_equal (e_var fresh) (e_var bound)) :: bs let join x y bs = if Var.equal x y then bs else B2(x,y,p_equal (e_var x) (e_var y)) :: bs let rec collect phi hs = function | [] -> hs | B1(x,eq)::bs -> collect phi (if phi x then eq :: hs else hs) bs | B2(x,y,eq)::bs -> collect phi (if phi x || phi y then eq :: hs else hs) bs let apply bindings p = let xs = varsp p in let hs = collect (fun x -> Vars.mem x xs) [] bindings in p_conj (p::hs) let conditions bindings phi = collect phi [] bindings let pretty fmt = List.iter begin function | B1(x,p) -> Format.fprintf fmt "@ @[([%a] %a)@]" F.pp_var x F.pp_pred p | B2(x,y,p) -> Format.fprintf fmt "@ @[([%a,%a] %a)@]" F.pp_var x F.pp_var y F.pp_pred p end frama-c-Fluorine-20130601/src/wp/Makefile.in0000644000175000017500000002303012155630215017255 0ustar mehdimehdi########################################################################## # # # This file is part of WP plug-in of Frama-C. # # # # Copyright (C) 2007-2013 # # CEA (Commissariat a l'energie atomique et aux energies # # 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 PLUGIN_DIR ?=. include $(FRAMAC_SHARE)/Makefile.config COQLIBS:= \ share/Qedlib.v \ share/Bits.v \ share/Cbits.v \ share/Cint.v \ share/Cfloat.v \ share/Cmath.v \ share/Vset.v \ share/Memory.v ERGOLIBS:= \ share/qed.mlw \ share/cbits.mlw \ share/cint0.mlw \ share/cint.mlw \ share/cfloat.mlw \ share/cmath.mlw \ share/vset.mlw \ share/memory.mlw WHY3LIBS:= \ share/qed.why \ share/cint.why \ share/cfloat.why \ share/cmath.why \ share/memory.why \ share/vset.why MODELS:= $(WHY3LIBS) $(COQLIBS) $(ERGOLIBS) ifeq (@COQC@,yes) RESOURCES:= $(MODELS) $(addsuffix o,$(COQLIBS)) else RESOURCES:= $(MODELS) endif # Extension of the GUI for wp is compilable # only if gnomecanvas is available ifeq ($(HAS_GNOMECANVAS),yes) PLUGIN_GUI_CMO:= \ GuiConfig \ GuiList \ GuiGoal \ GuiSource \ GuiPanel \ GuiNavigator endif PLUGIN_ENABLE:=@ENABLE_WP@ PLUGIN_DYNAMIC:=@DYNAMIC_WP@ PLUGIN_NAME:=Wp PLUGIN_CMO:= \ rformat wprop \ wp_parameters wp_error \ ctypes clabels \ LogicUsage VarUsage RefUsage variables_analysis \ cil2cfg normAtLabels \ wpPropId wpStrategy wpFroms wpAnnot \ Context Warning Model Lang Matrix Passive Splitter \ Letify Cleaning Partitioning Conditions \ LogicBuiltins Definitions \ Cint Cfloat Vset Region Cstring Cvalues \ CodeSemantics \ LogicCompiler \ LogicSemantics LogicAssigns \ Sigma MemEmpty MemVar MemTyped \ VCS script proof wpo wpReport \ ProverTask ProverErgo ProverCoq ProverWhy3 \ why3_xml why3_session \ driver prover \ calculus \ cfgDump cfgWP \ Generator Factory \ register PLUGIN_CMI:= mcfg Memory \ PLUGIN_GENERATED:= \ $(PLUGIN_DIR)/script.ml \ $(PLUGIN_DIR)/rformat.ml \ $(PLUGIN_DIR)/driver.ml \ $(PLUGIN_DIR)/why3_xml.ml PLUGIN_UNDOC+= PLUGIN_DOCFLAGS+= -I $(PLUGIN_DIR)/qed/bin 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 \ share/Makefile \ $(MODELS) CEA_WP+= $(addprefix $(PLUGIN_DIR)/, Makefile.in configure.ac) \ $(addprefix $(PLUGIN_DIR)/, share/Makefile) \ $(addprefix $(PLUGIN_DIR)/, $(MODELS)) \ $(addprefix $(PLUGIN_DIR)/, script.mll rformat.mll driver.mll) \ $(addprefix $(PLUGIN_DIR)/, *.ml) \ $(addprefix $(PLUGIN_DIR)/, *.mli) \ $(PLUGIN_DIR)/why3_xml.mll \ ifeq ("$(OCAMLGRAPH_LOCAL)","") OFLAGS+=-I +ocamlgraph BFLAGS+=-I +ocamlgraph endif # -------------------------------------------------------------------------- # --- Qed Dependencies --- # -------------------------------------------------------------------------- QED_LIB := $(PLUGIN_DIR)/qed/bin QED_CMO = $(QED_LIB)/Qed.cmo QED_CMX = $(QED_LIB)/Qed.cmx QED_SRC = $(PLUGIN_DIR)/qed/src include $(QED_SRC)/Makefile.src QED_FILES = Makefile.src Makefile MakeOcaml ocamldoc.css lexer.mll numbers.mll \ $(addsuffix .mli,$(QED_LIB_ML) $(QED_SRC_ML) $(QED_SRC_MLI)) \ $(addsuffix .ml, \ $(filter-out $(QED_GENERATED), \ $(QED_LIB_ML) $(QED_SRC_ML))) QED_SOURCES:= $(addprefix $(QED_SRC)/,$(QED_FILES)) PLUGIN_BFLAGS:= -I $(QED_LIB) PLUGIN_OFLAGS:= -I $(QED_LIB) PLUGIN_EXTRA_BYTE:=$(QED_CMO) PLUGIN_EXTRA_OPT:=$(QED_CMX) QED_DISTRIB_SRC:=$(addprefix qed/src/,$(QED_FILES)) CEA_WP+=$(QED_SOURCES) PLUGIN_DISTRIB_EXTERNAL+= $(QED_DISTRIB_SRC) # -------------------------------------------------------------------------- # --- Tests --- # -------------------------------------------------------------------------- PLUGIN_TESTS_DIRS:= \ wp wp_plugin wp_acsl wp_bts \ wp_store wp_hoare wp_typed # -------------------------------------------------------------------------- # --- Dynamic Plugin --- # -------------------------------------------------------------------------- # Hide warnings that are bothersome during development PLUGIN_BFLAGS+=-w -32..39 PLUGIN_OFLAGS+=-w -32..39 include $(FRAMAC_SHARE)/Makefile.dynamic # Regenerating the Makefile on need ifeq ("$(FRAMAC_INTERNAL)","yes") CONFIG_STATUS_DIR=$(FRAMAC_SRC) else CONFIG_STATUS_DIR=. endif $(Wp_DIR)/Makefile: $(Wp_DIR)/Makefile.in $(QED_SRC)/Makefile.src $(CONFIG_STATUS_DIR)/config.status @cd $(CONFIG_STATUS_DIR) && ./config.status $(QUIET_MAKE) depend # -------------------------------------------------------------------------- # --- Qed Dependencies --- # -------------------------------------------------------------------------- .PHONY: qed qed: @echo "Cleaning Qed" @rm -f $(QED_LIB)/* @rm -f $(Wp_DIR)/qed/src/*.cm? $(MAKE) $(QED_CMO) $(QED_CMX) clean:: @echo "Cleaning Qed" @rm -f $(QED_LIB)/* $(QUIET_MAKE) -C $(Wp_DIR)/qed/src clean $(Wp_DIR)/Memory.cmi: $(QED_CMO) $(Wp_DIR)/ctypes.cmi: $(QED_CMO) $(Wp_DIR)/ctypes.cmo: $(QED_CMO) $(Wp_DIR)/ctypes.cmx: $(QED_CMX) $(Wp_DIR)/RefUsage.cmi: $(QED_CMO) $(Wp_DIR)/RefUsage.cmo: $(QED_CMO) $(Wp_DIR)/RefUsage.cmx: $(QED_CMX) $(Wp_DIR)/Splitter.cmi: $(QED_CMO) $(Wp_DIR)/Splitter.cmo: $(QED_CMO) $(Wp_DIR)/Splitter.cmx: $(QED_CMX) $(Wp_DIR)/Lang.cmi: $(QED_CMO) $(Wp_DIR)/Lang.cmo: $(QED_CMO) $(Wp_DIR)/Lang.cmx: $(QED_CMX) $(Wp_DIR)/Vset.cmo: $(QED_CMO) $(Wp_DIR)/Vset.cmx: $(QED_CMX) ifeq (@COQC@,yes) byte:: .make-wpcoqc opt:: .make-wpcoqc endif ifeq ($(OCAMLOPT),ocamlopt.opt) QEDOPT=.opt else QEDOPT= endif $(QED_CMO): $(QED_SOURCES) @echo "Compiling Qed (byte$(QEDOPT))" $(QUIET_MAKE) -C $(Wp_DIR)/qed/src depend OCAMLDEP=$(OCAMLDEP) $(QUIET_MAKE) OPT=$(QEDOPT) -C $(Wp_DIR)/qed/src byte \ OCAMLC=$(OCAMLC) \ OCAMLLEX=$(OCAMLLEX) $(QED_CMX): $(QED_CMO) #- To avoid parallel invocation of Qed makefile @echo "Compiling Qed (opt$(QEDOPT))" $(QUIET_MAKE) OPT=$(QEDOPT) -C $(Wp_DIR)/qed/src opt \ OCAMLOPT=$(OCAMLOPT) \ OCAMLLEX=$(OCAMLLEX) # -------------------------------------------------------------------------- # --- Pre-Compiled Coq Libraries --- # -------------------------------------------------------------------------- .PHONY: wpcoqc wpcoq: .make-wpcoqc @echo "Run 'make install-wpcoq' to install the precompiled libraries" install-wpcoq: $(PRINT_CP) Precompiled Coq Libraries $(CP) $(addprefix $(Wp_DIR)/,$(addsuffix o,$(COQLIBS))) $(FRAMAC_DATADIR)/wp @echo "Run 'make uninstall-wpcoq' to uninstall the precompiled libraries" uninstall-wpcoq: $(PRINT_RM) Precompiled Coq Libraries $(RM) -f $(FRAMAC_DATADIR)/wp/*.vo .make-wpcoqc: .make-wpcoqs @echo "Compiling Wp-Coq Library" $(MAKE) -C $(Wp_DIR)/share coq #Don't use QUIET_MAKE because too long! @touch .make-wpcoqc .make-wpcoqs: $(addprefix $(Wp_DIR)/,$(COQLIBS)) @echo "Preparing Wp-Coq Sources" $(QUIET_MAKE) -C $(Wp_DIR)/share depend @touch .make-wpcoqs clean:: @echo "Cleaning Wp-Coq Libraries" @rm -f .make-wpcoqs .make-wpcoqc $(QUIET_MAKE) -C $(Wp_DIR)/share clean # -------------------------------------------------------------------------- # --- Installation --- # -------------------------------------------------------------------------- # note: installation and uninstallation do not use environment variable FRAMA_SHARE! install:: $(PRINT_CP) WP shared files $(MKDIR) $(FRAMAC_DATADIR)/wp $(CP) $(addprefix $(Wp_DIR)/,$(RESOURCES)) $(FRAMAC_DATADIR)/wp uninstall:: $(PRINT_RM) WP shared files $(RM) -r $(FRAMAC_DATADIR)/wp # -------------------------------------------------------------------------- # --- WP Release Stuff (CEA-LIST Only) # -------------------------------------------------------------------------- sinclude MakeDistrib # -------------------------------------------------------------------------- $(Wp_DIR)/.depend: $(Wp_DIR)/driver.mll $(Wp_DIR)/driver.mll: $(Wp_DIR)/Makefile.in $(Wp_DIR)/Makefile frama-c-Fluorine-20130601/src/wp/GuiGoal.mli0000644000175000017500000000406112155630215017245 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- PO Details View --- *) (* -------------------------------------------------------------------------- *) class pane : unit -> object method select : Wpo.t option -> unit method update : unit method coerce : GObj.widget method on_run : (Wpo.t -> VCS.prover -> unit) -> unit method on_src : (Wpo.t option -> unit) -> unit end frama-c-Fluorine-20130601/src/wp/LogicSemantics.mli0000644000175000017500000000742512155630215020631 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- ACSL Translation --- *) (* -------------------------------------------------------------------------- *) open Definitions open LogicUsage open Cil_types open Ctypes open Clabels open Lang.F open Memory module Make(M : Memory.Model) : sig type loc = M.loc type sigma = M.Sigma.t type value = M.loc Memory.value type logic = M.loc Memory.logic type region = M.loc Memory.sloc list (** {3 Debug} *) val pp_logic : Format.formatter -> logic -> unit val pp_sloc : Format.formatter -> loc Memory.sloc -> unit val pp_region : Format.formatter -> region -> unit (** {3 Frames} *) type frame val pp_frame : Format.formatter -> frame -> unit val get_frame : unit -> frame val in_frame : frame -> ('a -> 'b) -> 'a -> 'b val mem_frame : c_label -> sigma val mem_at_frame : frame -> c_label -> sigma val frame : kernel_function -> frame val frame_copy : frame -> frame val call_pre : kernel_function -> value list -> sigma -> frame val call_post : kernel_function -> value list -> sigma sequence -> frame val return : unit -> typ val result : unit -> var val status : unit -> var val guards : frame -> pred list (** {3 Traductions} *) type env val new_env : logic_var list -> env val move : env -> sigma -> env val sigma : env -> sigma val mem_at : env -> c_label -> sigma val call : sigma -> env val term : env -> Cil_types.term -> term val pred : positive:bool -> env -> Cil_types.predicate named -> pred val region : env -> Cil_types.term -> region val assigns : env -> identified_term assigns -> (c_object * region) list option val assigns_from : env -> identified_term from list -> (c_object * region) list val val_of_term : env -> Cil_types.term -> term val loc_of_term : env -> Cil_types.term -> loc val lemma : logic_lemma -> dlemma (** {3 Regions} *) val vars : region -> Vars.t val occurs : var -> region -> bool val valid : sigma -> acs -> c_object -> region -> pred val included : c_object -> region -> c_object -> region -> pred val separated : (c_object * region) list -> pred end frama-c-Fluorine-20130601/src/wp/Region.mli0000644000175000017500000000510712155630215017143 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Path and Regions --- *) (* -------------------------------------------------------------------------- *) open Lang open Lang.F open Vset (** {2 Paths} *) type path = offset list and offset = | Oindex of term | Ofield of field val access : term -> path -> term val update : term -> path -> term -> term (** {2 Regions} *) type rpath = roffset list and roffset = | Rindex of set | Rfield of field type region val empty : region val full : region val path : path -> region (** Empty, but Full for the path *) val rpath : rpath -> region (** Empty, but Full for the r-paths *) val merge : region -> region -> region val disjoint : region -> region -> pred val subset : region -> region -> pred val equal_but : tau -> region -> term -> term -> pred val vars : region -> Vars.t val occurs : var -> region -> bool val pretty : Format.formatter -> region -> unit frama-c-Fluorine-20130601/src/wp/Cleaning.ml0000644000175000017500000001354112155630215017270 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Variables Cleaning --- *) (* -------------------------------------------------------------------------- *) open Qed.Logic open Lang open Lang.F (* -------------------------------------------------------------------------- *) (* --- Latice --- *) (* -------------------------------------------------------------------------- *) type 'a occur = | TOP | TRUE | FALSE | EQ of 'a let cup eq a y = match a with | EQ x when eq x y -> a | _ -> TOP let cup_true = function | TRUE -> TRUE | _ -> TOP let cup_false = function | FALSE -> FALSE | _ -> TOP let set_top m p = Vars.fold (fun x m -> Vmap.add x TOP m) (F.varsp p) m let add eq x d m = Vmap.add x (try cup eq (Vmap.find x m) d with Not_found -> EQ d) m let add_true m x = Vmap.add x (try cup_true (Vmap.find x m) with Not_found -> TRUE) m let add_false m x = Vmap.add x (try cup_false (Vmap.find x m) with Not_found -> FALSE) m let add_var = add Var.equal let add_fun = add Fun.equal (* -------------------------------------------------------------------------- *) (* --- Collector --- *) (* -------------------------------------------------------------------------- *) let rec add_pred m p = match F.pred p with | And ps -> List.fold_left add_pred m ps | If(e,a,b) -> add_pred (add_pred (set_top m e) a) b | Eq(a,b) -> begin match F.pred a , F.pred b with | Var x , Var y -> add_var x y (add_var y x m) | _ -> set_top m p end | Var x -> add_true m x | Not p -> begin match F.pred p with | Var x -> add_false m x | _ -> set_top m p end | _ -> set_top m p let rec add_type m p = match F.pred p with | And ps -> List.fold_left add_type m ps | Fun(f,[e]) -> begin match F.pred e with | Var x -> add_fun x f m | _ -> set_top m p end | _ -> set_top m p (* -------------------------------------------------------------------------- *) (* --- Usage --- *) (* -------------------------------------------------------------------------- *) type usage = { mutable eq_var : var occur Vmap.t ; mutable eq_fun : lfun occur Vmap.t ; } let create () = { eq_var = Vmap.empty ; eq_fun = Vmap.empty } let as_atom m p = m.eq_var <- set_top m.eq_var p let as_have m p = m.eq_var <- add_pred m.eq_var p let as_type m p = m.eq_fun <- add_type m.eq_fun p (* -------------------------------------------------------------------------- *) (* --- Extraction --- *) (* -------------------------------------------------------------------------- *) let get x m = try Some (Vmap.find x m) with Not_found -> None let is_true x m = try match Vmap.find x m with TRUE -> true | _ -> false with Not_found -> false let is_false x m = try match Vmap.find x m with FALSE -> true | _ -> false with Not_found -> false let is_var x m = try match Vmap.find x m.eq_var with | EQ y -> begin match get x m.eq_fun , get y m.eq_fun with | None , _ -> true (* we eliminate x, which has no guard... *) | Some (EQ f) , Some (EQ g) -> Fun.equal f g | _ -> false end | _ -> false with Not_found -> false (* -------------------------------------------------------------------------- *) (* --- Filtering --- *) (* -------------------------------------------------------------------------- *) let rec filter_pred m p = match F.pred p with | And ps -> F.p_all (filter_pred m) ps | If(e,a,b) -> p_if e (filter_pred m a) (filter_pred m b) | Eq(a,b) -> begin match F.pred a , F.pred b with | Var x , Var y when is_var x m || is_var y m -> p_true | _ -> p end | Var x when is_true x m.eq_var -> p_true | Not q -> begin match F.pred q with | Var x when is_false x m.eq_var -> p_true | _ -> p end | _ -> p let rec filter_type m p = match F.pred p with | And ps -> F.p_all (filter_type m) ps | Fun(_,[e]) -> begin match F.pred e with | Var x when is_var x m -> p_true | _ -> p end | _ -> p frama-c-Fluorine-20130601/src/wp/ProverErgo.ml0000644000175000017500000003537712155630215017655 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Alt-Ergo Interface --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Qed open Lang open Definitions let dkey = Wp_parameters.register_category "prover" (* -------------------------------------------------------------------------- *) (* --- Making Goal File --- *) (* -------------------------------------------------------------------------- *) let altergo_gui = lazy begin let x = Command.command "altgr-ergo" [| "-version" |] in match x with | Unix.WEXITED 0 -> true | _ -> false end let append_file out file = let lines = ref 0 in Command.read_lines file begin fun line -> output_string out line ; output_string out "\n" ; incr lines ; end ; !lines let rec locate_error files file line = match files with | [] -> ProverTask.location file line | (f,n)::files -> if line <= n then ProverTask.location f line else locate_error files file (line-n) let cluster_file c = let dir = Model.directory () in let base = cluster_id c in Printf.sprintf "%s/%s.ergo" dir base (* -------------------------------------------------------------------------- *) (* --- Exporting Formulae to Alt-Ergo --- *) (* -------------------------------------------------------------------------- *) type depend = | D_file of string | D_cluster of cluster module TYPES = Model.Index (struct type key = adt type data = tau let name = "ProverErgo.TYPES" let compare = ADT.compare let pretty = ADT.pretty end) let engine = let module E = Qed.Export_altergo.Make(Lang.F) in object inherit E.engine as super method datatype = ADT.id method field = Field.id method link = Lang.link method set_typedef = TYPES.define method get_typedef = TYPES.get method typeof_call = Lang.tau_of_lfun method typeof_getfield = Lang.tau_of_field method typeof_setfield = Lang.tau_of_record val mutable share = true method is_shareable e = share && super#is_shareable e method declare_axiom fmt a xs tgs phi = try share <- false ; super#declare_axiom fmt a xs tgs phi ; share <- true with err -> share <- true ; raise err end class visitor fmt c = object(self) inherit Definitions.visitor c inherit ProverTask.printer fmt (cluster_title c) val mutable deps = [] (* --- Managing Formatter --- *) method flush = begin Format.pp_print_newline fmt () ; List.rev deps end (* --- Files, Theories and Clusters --- *) method add_dfile f = let df = D_file f in if not (List.mem df deps) then deps <- df :: deps method add_shared f = self#add_dfile (Wp_parameters.Share.file ~error:true f) method add_library f = self#add_dfile (Wp_parameters.find_lib f) method on_cluster c = deps <- (D_cluster c) :: deps method private cintlib = if Wp_parameters.AltErgoLightInt.get () then "cint0.mlw" else "cint.mlw" method on_theory = function | "qed" | "driver" -> () | "cint" -> self#add_shared self#cintlib | "cbits" -> List.iter self#add_shared [ self#cintlib ; "cbits.mlw" ] | "cfloat" -> self#add_shared "cfloat.mlw" | "vset" -> self#add_shared "vset.mlw" | "memory" -> self#add_shared "memory.mlw" | "cmath" -> self#add_shared "cmath.mlw" | thy -> Wp_parameters.fatal ~current:false "No builtin theory '%s' for alt-ergo" thy method on_library thy = self#add_library (thy ^ ".mlw") method on_type lt def = begin self#lines ; engine#declare_type fmt (Lang.atype lt) (List.length lt.lt_params) def ; end method on_comp c fts = begin (*TODO:NUPW: manage UNIONS *) self#lines ; engine#declare_type fmt (Lang.comp c) 0 (Qed.Engine.Trec fts) ; end method on_dlemma l = begin self#paragraph ; engine#declare_axiom fmt (Lang.lemma_id l.l_name) l.l_forall l.l_triggers (F.e_prop l.l_lemma) end method on_dfun d = begin self#paragraph ; match d.d_definition with | Logic t -> engine#declare_signature fmt d.d_lfun (List.map F.tau_of_var d.d_params) t ; | Value(t,_,v) -> engine#declare_definition fmt d.d_lfun d.d_params t v | Predicate(_,p) -> engine#declare_definition fmt d.d_lfun d.d_params Logic.Prop (F.e_prop p) | Inductive _ -> engine#declare_signature fmt d.d_lfun (List.map F.tau_of_var d.d_params) Logic.Prop end end let write_cluster c job = let f = cluster_file c in Wp_parameters.debug ~dkey "Generate '%s'" f ; let output = Command.print_file f begin fun fmt -> let v = new visitor fmt c in job v ; v#flush end in if Wp_parameters.has_dkey "cluster" then Log.print_on_output begin fun fmt -> Format.fprintf fmt "---------------------------------------------@\n" ; Format.fprintf fmt "--- File '%s.ergo' @\n" (cluster_id c) ; Format.fprintf fmt "---------------------------------------------@\n" ; Command.pp_from_file fmt f ; end ; output (* -------------------------------------------------------------------------- *) (* --- File Assembly --- *) (* -------------------------------------------------------------------------- *) module CLUSTERS = Model.Index (struct type key = cluster type data = int * depend list let name = "ProverErgo.CLUSTERS" let compare = cluster_compare let pretty = pp_cluster end) type export = { out : out_channel ; mutable files : (string * int) list ; } let rec assemble export = function | D_file file -> assemble_file export file | D_cluster c -> assemble_cluster export c and assemble_file export file = if List.for_all (fun (f,_) -> f <> file) export.files then let lines = append_file export.out file in export.files <- (file,lines) :: export.files and assemble_cluster export c = let (age,deps) = try CLUSTERS.find c with Not_found -> (-1,[]) in let deps = if age < cluster_age c then let deps = write_cluster c (fun v -> v#vself) in CLUSTERS.update c (cluster_age c , deps) ; deps else deps in List.iter (assemble export) deps ; let file = cluster_file c in assemble_file export file and assemble_lib export lib = assemble_file export (Wp_parameters.find_lib lib) (* -------------------------------------------------------------------------- *) (* --- Assembling Goal --- *) (* -------------------------------------------------------------------------- *) let assemble_goal ~file ~id ~title ~axioms prop = let goal = cluster ~id ~title () in let model = if Wp_parameters.UnsatModel.get () then 1 else 0 in let deps = write_cluster goal begin fun v -> v#vgoal axioms prop ; v#paragraph ; engine#global begin fun () -> v#printf "@[goal %s:@ %a@]@." id (engine#pp_goal ~model) (F.e_prop prop) ; end ; end in Command.write_file file begin fun out -> let export = { files = [] ; out = out } in assemble_file export (Wp_parameters.Share.file ~error:true "qed.mlw") ; List.iter (assemble export) deps ; let libs = Wp_parameters.AltErgoLibs.get () in List.iter (assemble_lib export) libs ; assemble_file export (cluster_file goal) ; List.rev export.files end (* -------------------------------------------------------------------------- *) (* --- Running AltErgo --- *) (* -------------------------------------------------------------------------- *) open ProverTask (*bug in Alt-Ergo: sometimes error messages are repeated. *) (*let p_loc = "^File " ... *) let p_loc = "File " ^ p_string ^ ", line " ^ p_int ^ ", [^:]+:" let p_valid = p_loc ^ "Valid (" ^ p_float ^ ") (" ^ p_int ^ ")" let p_unsat = p_loc ^ "I don't know" let p_limit = "^Steps limit reached: " ^ p_int let re_error = Str.regexp p_loc let re_valid = Str.regexp p_valid let re_limit = Str.regexp p_limit let re_unsat = Str.regexp p_unsat class altergo ~pid ~gui ~file ~lines ~logout ~logerr = object(ergo) inherit ProverTask.command "alt-ergo" val mutable files = [] val mutable error = None val mutable valid = false val mutable limit = false val mutable unsat = false val mutable time = 0.0 val mutable steps = 0 method private time t = time <- t method private error (a : pattern) = let lpos = locate_error files (a#get_string 1) (a#get_int 2) in let message = a#get_after ~offset:1 2 in error <- Some ( lpos , message ) method private valid (a : pattern) = begin valid <- true ; time <- a#get_float 3 ; steps <- a#get_int 4 ; end method private limit (a : pattern) = begin limit <- true ; steps <- pred (a#get_int 1) ; end method private unsat (_ : pattern) = begin unsat <- true ; end method result r = if unsat && Wp_parameters.UnsatModel.get () then begin let message = Pretty_utils.sfprintf "Model for %a" WpPropId.pretty pid in ProverTask.pp_file ~message ~file:logout ; end ; match error with | Some(pos,message) -> Wp_parameters.error ~source:pos "Alt-Ergo error:@\n%s" message ; VCS.failed ~pos message | None -> try let verdict = if unsat then VCS.Unknown else if valid then VCS.Valid else if limit then VCS.Stepout else raise Not_found in VCS.result ~time:(if gui then 0.0 else time) ~steps verdict with | Not_found when Wp_parameters.wpcheck () -> if r = 0 then VCS.no_result else begin ProverTask.pp_file ~message:"Alt-Ergo (stdout)" ~file:logout ; ProverTask.pp_file ~message:"Alt-Ergo (stderr)" ~file:logerr ; VCS.failed "Alt-Ergo type-checking failed" end | Not_found -> begin ProverTask.pp_file ~message:"Alt-Ergo (stdout)" ~file:logout ; ProverTask.pp_file ~message:"Alt-Ergo (stderr)" ~file:logerr ; if r <> 0 then VCS.failed (Printf.sprintf "Alt-Ergo exits with status [%d]" r) else VCS.failed "Can not understand Alt-Ergo output." end method prove = let depth = Wp_parameters.Depth.get () in let steps = Wp_parameters.Steps.get () in let time = Wp_parameters.Timeout.get () in files <- lines ; if gui then ergo#set_command "altgr-ergo" ; ergo#add_positive ~name:"-age-limite" ~value:depth ; ergo#add_positive ~name:"-stop" ~value:depth ; ergo#add_positive ~name:"-steps" ~value:steps ; ergo#add_parameter ~name:"-proof" Wp_parameters.ProofTrace.get ; ergo#add_parameter ~name:"-model" Wp_parameters.UnsatModel.get ; ergo#add (Wp_parameters.AltErgoFlags.get ()) ; ergo#add [ file ] ; if not gui then ergo#timeout time ; ergo#validate_time ergo#time ; ergo#validate_pattern ~logs:`ERR re_error ergo#error ; ergo#validate_pattern ~logs:`OUT re_valid ergo#valid ; ergo#validate_pattern ~logs:`OUT re_limit ergo#limit ; ergo#validate_pattern ~logs:`OUT re_unsat ergo#unsat ; ergo#run ~logout ~logerr end open VCS open Wpo open Task let try_prove ~pid ~gui ~file ~lines ~logout ~logerr = let ergo = new altergo ~pid ~gui ~file ~lines ~logout ~logerr in ergo#prove () >>> function | Task.Timeout -> Task.return VCS.timeout | Task.Result r -> Task.call ergo#result r | st -> Task.status (Task.map (fun _ -> assert false) st) let prove_file ~pid ~interactive ~file ~lines ~logout ~logerr = try_prove ~pid ~gui:false ~file ~lines ~logout ~logerr >>= function | { verdict=(VCS.Unknown|VCS.Timeout|VCS.Stepout) } when interactive && Lazy.force altergo_gui -> try_prove ~pid ~gui:true ~file ~lines ~logout ~logerr | r -> Task.return r let prove_prop ~pid ~interactive ~model ~axioms ~prop = let prover = AltErgo in let file = DISK.file_goal ~pid ~model ~prover in let logout = DISK.file_logout ~pid ~model ~prover in let logerr = DISK.file_logerr ~pid ~model ~prover in let id = WpPropId.get_propid pid in let title = Pretty_utils.to_string WpPropId.pretty pid in let lines = Model.with_model model (assemble_goal ~file ~id ~title ~axioms) prop in if Wp_parameters.Generate.get () then Task.return VCS.no_result else prove_file ~pid ~interactive ~file ~lines ~logout ~logerr let prove_annot model pid vcq ~interactive = Task.todo begin fun () -> let axioms = None in let prop = GOAL.compute_proof vcq.VC_Annot.goal in prove_prop ~pid ~interactive ~model ~axioms ~prop end let prove_lemma model pid vca ~interactive = Task.todo begin fun () -> let lemma = vca.Wpo.VC_Lemma.lemma in let depends = vca.Wpo.VC_Lemma.depends in let prop = F.p_forall lemma.l_forall lemma.l_lemma in let axioms = Some(lemma.l_cluster,depends) in prove_prop ~pid ~interactive ~model ~axioms ~prop end let prove wpo ~interactive = let pid = wpo.Wpo.po_pid in let model = wpo.Wpo.po_model in match wpo.Wpo.po_formula with | Wpo.GoalAnnot vcq -> prove_annot model pid vcq ~interactive | Wpo.GoalLemma vca -> prove_lemma model pid vca ~interactive frama-c-Fluorine-20130601/src/wp/Conditions.mli0000644000175000017500000000561612155630215020036 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Weakest Pre Accumulator --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Lang open Lang.F (** Bundles *) type bundle val dump : Format.formatter -> bundle -> unit type 'a attributed = ( ?descr:string -> ?stmt:stmt -> ?deps:Property.t list -> ?warn:Warning.Set.t -> 'a ) val empty : bundle val occurs : var -> bundle -> bool val intersect : pred -> bundle -> bool val merge : bundle list -> bundle val domain : pred list -> bundle -> bundle val intros : pred list -> bundle -> bundle val assume : (pred -> bundle -> bundle) attributed val branch : (pred -> bundle -> bundle -> bundle) attributed val either : (bundle list -> bundle) attributed val extract : bundle -> pred list (** Hypotheses *) type t val freeze : bundle -> t val clean : t -> pred -> t * pred val letify : t -> pred -> t * pred val pruning : t -> pred -> t * pred val hypotheses : t -> pred list val close : t -> pred -> pred (** Pretty *) type linker type link = Lstmt of stmt | Lprop of Property.t val linker : unit -> linker val get_link : linker -> string -> link val pretty : ?linker:linker -> Format.formatter -> t -> F.pred -> unit frama-c-Fluorine-20130601/src/wp/wpo.ml0000644000175000017500000006373012155630215016362 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 LogicUsage open VCS open Cil_types open Cil_datatype open Lang type index = | Axiomatic of string option | Function of kernel_function * string option let bar = String.make 60 '-' let flow = ref false (* -------------------------------------------------------------------------- *) (* --- Pretty Printers --- *) (* -------------------------------------------------------------------------- *) let pp_index fmt = function | Axiomatic None -> Format.pp_print_string fmt "Axiomatics" | Axiomatic (Some a) -> Format.pp_print_string fmt a | Function(f,None) -> Kernel_function.pretty fmt f | Function(f,Some b) -> Format.fprintf fmt "%a for %s:" Kernel_function.pretty f b 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_warnings fmt ws = List.iter (fun w -> Format.fprintf fmt "%a@\n" Warning.pretty w) ws let kf_context = function Axiomatic _ -> `Always | Function(kf,_) -> `Context kf let pp_dependency context fmt d = Format.fprintf fmt " - Assumes %a" (Description.pp_localized ~kf:context ~ki:false ~kloc:true) d let pp_dependencies context fmt ds = List.iter (fun d -> Format.fprintf fmt "%a@\n" (pp_dependency context) d) ds let pp_depend fmt d = Format.fprintf fmt " - Assumes %a" (Description.pp_localized ~kf:`Always ~ki:false ~kloc:true) d (* ------------------------------------------------------------------------ *) (* --- Proof Obligations Definition --- *) (* ------------------------------------------------------------------------ *) module DISK = struct let file ~id ~model ?prover ?suffix ~ext () = let dir = Wp_parameters.get_output () in let mid = Model.get_id model in let buffer = Buffer.create 80 in let fmt = Format.formatter_of_buffer buffer in Format.fprintf fmt "%s/%s/%s" dir mid id ; (match prover with None -> () | Some p -> Format.fprintf fmt "_%s" (filename_for_prover p)) ; (match suffix with None -> () | Some s -> Format.fprintf fmt "_%s" s) ; Format.fprintf fmt ".%s" ext ; Format.pp_print_flush fmt (); Buffer.contents buffer let file_logout ~pid ~model ~prover = let id = WpPropId.get_propid pid in file ~id ~model ~prover ~ext:"out" () let file_logerr ~pid ~model ~prover = let id = WpPropId.get_propid pid in file ~id ~model ~prover ~ext:"err" () let file_goal ~pid ~model ~prover = let ext = match prover with | Qed -> "qed" | AltErgo -> "mlw" | Why3 _ -> "why" | Why3ide -> "why" | Coq -> "v" in let id = WpPropId.get_propid pid in file ~id ~model ~prover ~ext () let file_kf ~kf ~model ~prover = let ext = match prover with | Qed -> "qed" | AltErgo -> "mlw" | Why3 _ -> "why" | Why3ide -> "why" | Coq -> "v" in let id = (Kf.vi kf).vname in file ~id ~model ~prover ~ext () let dump_file fmt title file = if Sys.file_exists file then begin Format.fprintf fmt "--- %s ---------------------------------@\n" title ; Command.pp_from_file fmt file end let pretty ~pid ~model ~prover ~result fmt = begin Format.fprintf fmt "[%a] Goal %a : %a@\n" pp_prover prover WpPropId.pp_propid pid pp_result result ; dump_file fmt "StdOut" (file_logout ~pid ~model ~prover) ; dump_file fmt "StdErr" (file_logerr ~pid ~model ~prover) ; end let cache_log ~pid ~model ~prover ~result = (*TODO: put a cache here *) let dir = Wp_parameters.get_output () in let file = Printf.sprintf "%s/log.txt" dir in Command.print_file file (pretty ~pid ~model ~prover ~result) ; file let cache_descr pretty = (*TODO: put a cache here *) let dir = Wp_parameters.get_output () in let file = Printf.sprintf "%s/goal.txt" dir in Command.print_file file (fun fmt -> pretty fmt) ; file end module GOAL = struct type t = { mutable simplified : bool ; mutable time : float ; mutable hyps : Conditions.t ; mutable goal : F.pred ; mutable obligation : F.pred ; } let dummy = { simplified = false ; time = 0.0 ; hyps = Conditions.freeze Conditions.empty ; goal = F.p_false ; obligation = F.p_false ; } let trivial = { simplified = true ; time = 0.0 ; hyps = Conditions.freeze Conditions.empty ; goal = F.p_true ; obligation = F.p_true ; } let make hyps goal = { simplified = false ; time = 0.0 ; hyps = hyps ; goal = goal ; obligation = F.p_false ; } let is_trivial g = g.goal == F.p_true let apply phi g = let (hs,p) = phi g.hyps g.goal in g.hyps <- hs ; g.goal <- p let preprocess g = if Wp_parameters.Let.get () then begin apply Conditions.letify g ; if Wp_parameters.Prune.get () then apply Conditions.pruning g ; end else if Wp_parameters.Clean.get () then apply Conditions.clean g ; g.obligation <- Conditions.close g.hyps g.goal let dkey = Wp_parameters.register_category "prover" let compute g = if not g.simplified then begin g.simplified <- true ; let timer = ref 0.0 in Wp_parameters.debug ~dkey "Simplify goal" ; Command.time ~rmax:timer preprocess g ; Wp_parameters.debug ~dkey "Simplification time: %a" Rformat.pp_time !timer ; g.time <- !timer ; end let compute_proof g = compute g ; g.obligation let compute_descr g = compute g ; g.hyps , g.goal let get_descr g = g.hyps , g.goal let qed_time g = g.time end module VC_Lemma = struct open Lang open Definitions type t = { lemma : Definitions.dlemma ; depends : logic_lemma list ; } let is_trivial vc = vc.lemma.l_lemma == F.p_true let pretty fmt vc results = begin Format.fprintf fmt "Lemma %s:@\n" vc.lemma.l_name ; if vc.depends <> [] then begin Format.fprintf fmt "@[@{Assume@}:" ; List.iter (fun a -> Format.fprintf fmt "@ '%s'" a.lem_name) vc.depends ; Format.fprintf fmt "@]@." ; end ; Format.fprintf fmt "@{Prove@}: @[%a@]@." F.pp_pred vc.lemma.l_lemma ; List.iter (fun (prover,result) -> if result.verdict <> NoResult then Format.fprintf fmt "Prover %a returns %a@\n" pp_prover prover pp_result result ) results ; end let cache_descr vc results = DISK.cache_descr (fun fmt -> pretty fmt vc results) end module VC_Annot = struct type t = { goal : GOAL.t ; tags : Splitter.tag list ; warn : Warning.t list ; deps : Property.Set.t ; path : Stmt.Set.t ; effect : (stmt * WpPropId.effect_source) option ; } let repr = { goal = GOAL.dummy ; tags = [] ; warn = [] ; deps = Property.Set.empty ; path = Stmt.Set.empty ; effect = None ; } let resolve vcq = GOAL.compute_proof vcq.goal == Lang.F.p_true let is_trivial vcq = GOAL.is_trivial vcq.goal let pp_effect fmt = function | None -> () | Some(s,e) -> let loc = fst (Stmt.loc s) in let line = loc.Lexing.pos_lnum in let desc = match e with | WpPropId.FromCode -> "Effect" | WpPropId.FromCall -> "Call Effect" | WpPropId.FromReturn -> "Call Result" in Format.fprintf fmt "%s at line %d@\n" desc line let pretty fmt pid vc results = begin Format.fprintf fmt "@{Goal@} %a:@\n" WpPropId.pretty pid ; pp_effect fmt vc.effect ; if vc.tags <> [] then begin Format.fprintf fmt "@[@{Tags@}:" ; List.iter (fun tg -> Format.fprintf fmt "@ %a" Splitter.pretty tg) vc.tags ; Format.fprintf fmt "@].@\n" ; end ; pp_warnings fmt vc.warn ; let hyps,goal = GOAL.compute_descr vc.goal in Conditions.pretty fmt hyps goal ; List.iter (fun (prover,result) -> if result.verdict <> NoResult then Format.fprintf fmt "Prover %a returns %a@\n" pp_prover prover pp_result result ) results ; end let cache_descr ~pid vc results = DISK.cache_descr (fun fmt -> pretty fmt pid vc results) end (* ------------------------------------------------------------------------ *) (* --- Proof Obligations Database --- *) (* ------------------------------------------------------------------------ *) type formula = | GoalLemma of VC_Lemma.t | GoalAnnot of VC_Annot.t type po = t and t = { po_gid : string ; (* goal identifier *) po_name : string ; (* goal informal name *) po_idx : index ; (* goal index *) po_model : Model.t ; po_pid : WpPropId.prop_id ; (* goal target property *) po_updater : Emitter.t ; (* property status updater *) po_formula : formula ; (* proof obligation *) } let get_index w = w.po_idx let get_label w = WpPropId.label_of_prop_id w.po_pid let get_model x = x.po_model let get_model_id w = Model.get_id (get_model w) let get_model_name w = Model.get_descr (get_model w) let get_depend = function | { po_formula = GoalAnnot { VC_Annot.deps = ips } } -> Property.Set.elements ips | { po_formula = GoalLemma { VC_Lemma.depends = ips } } -> List.map LogicUsage.ip_lemma ips let get_file_logout w prover = DISK.file_logout ~pid:w.po_pid ~model:(get_model w) ~prover let get_file_logerr w prover = DISK.file_logerr ~pid:w.po_pid ~model:(get_model w) ~prover module Index = struct type t = index let cmpopt a b = match a,b with | Some a,Some b -> String.compare a b | None,Some _ -> (-1) | Some _,None -> 1 | None,None -> 0 let compare a b = match a,b with | Axiomatic a , Axiomatic b -> cmpopt a b | Axiomatic _ , Function _ -> (-1) | Function _ , Axiomatic _ -> 1 | Function(f,a) , Function(g,b) -> let c = if Kernel_function.equal f g then 0 else String.compare (Kernel_function.get_name f) (Kernel_function.get_name g) in if c=0 then cmpopt a b else c end module PODatatype = Datatype.Make_with_collections (struct type t = po include Datatype.Undefined let hash a = Hashtbl.hash a.po_gid let equal a b = (a.po_gid = b.po_gid) let compare a b = let c = Index.compare a.po_idx b.po_idx 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 let ma = get_model_name a in let mb = get_model_name b in let c = String.compare ma mb in if c<>0 then c else String.compare a.po_gid b.po_gid let pretty fmt wpo = Format.pp_print_string fmt wpo.po_name let name = "Wpo.po" let reprs = [{ po_idx = Function(List.hd Kernel_function.reprs,Some "default") ; po_pid = List.hd WpPropId.PropId.reprs; po_gid = "xxx"; po_model = Model.repr ; po_updater = List.hd Emitter.reprs; po_name = "dummy"; po_formula = GoalAnnot VC_Annot.repr ; }] end) module ProverType = Datatype.Make (struct type t = prover include Datatype.Undefined let name = "Wpo.prover" let reprs = [ AltErgo; Coq; Qed; Why3 "z3" ] end) module ResultType = Datatype.Make (struct type t = result include Datatype.Undefined let name = "Wpo.result" let reprs = List.map VCS.result [ Valid ; Invalid ; Unknown ; Timeout ; Failed ] end) (* -------------------------------------------------------------------------- *) (* --- 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_property = Dynamic.register ~plugin:"Wp" "Wpo.get_property" ~journalize:false (Datatype.func PODatatype.ty Property.ty) (fun g -> WpPropId.property_of_id g.po_pid) (* -------------------------------------------------------------------------- *) (* --- Proof Collector --- *) (* -------------------------------------------------------------------------- *) let is_verdict r = match r.verdict with | Valid | Unknown | Invalid | Timeout | Stepout | Failed -> true | NoResult | Computing _ -> false module Hproof = Hashtbl.Make(Datatype.Pair(Datatype.String)(Property)) (* Table indexed by ( Model name , Property proved ) *) module Results = struct type t = (prover * result) list ref let create () = ref [] let rec cancel = function | (_,{verdict = VCS.Computing _})::rs -> cancel rs | u::rs -> u :: cancel rs | [] -> [] let rec filter p = function | (q,_)::rs when p=q -> filter p rs | u::rs -> u :: filter p rs | [] -> [] let replace (rs:t) p r = if p = Qed then rs := (p,r) :: cancel !rs else rs := (p,r) :: filter p !rs let get (rs:t) p = try List.assoc p !rs with Not_found -> VCS.no_result let list (rs:t) = List.sort (fun (p,_) (q,_) -> VCS.cmp_prover p q) (List.filter (fun (_,r) -> is_verdict r) !rs) end (* -------------------------------------------------------------------------- *) (* --- Wpo Database --- *) (* -------------------------------------------------------------------------- *) module WPOset = PODatatype.Set module WPOmap = PODatatype.Map module Gmap = Map.Make(Index) module Fmap = Kernel_function.Map module Pmap = Property.Map let index_wpo iadd iget k w m = let set = try iget k m with Not_found -> WPOset.empty in iadd k (WPOset.add w set) m let unindex_wpo iadd iget k w m = try let set = iget k m in iadd k (WPOset.remove w set) m with Not_found -> m type system = { mutable wpo_idx : WPOset.t Gmap.t ; (* index -> WPOs *) mutable wpo_kf : WPOset.t Fmap.t ; (* kf -> WPOs *) mutable wpo_ip : WPOset.t Pmap.t ; (* ip -> WPOs *) mutable age : int WPOmap.t ; (* wpo -> age *) mutable results : Results.t WPOmap.t ; (* results collector *) proofs : WpAnnot.proof Hproof.t ; (* proof collector *) } let create_system () = { wpo_idx = Gmap.empty ; wpo_kf = Fmap.empty ; wpo_ip = Pmap.empty ; results = WPOmap.empty ; age = WPOmap.empty ; proofs = Hproof.create 131 ; } let clear_system system = begin system.wpo_idx <- Gmap.empty ; system.wpo_kf <- Fmap.empty ; system.wpo_ip <- Pmap.empty ; system.results <- WPOmap.empty ; system.age <- WPOmap.empty ; Hproof.clear system.proofs ; end module SYSTEM = State_builder.Ref (Datatype.Make (struct include Datatype.Undefined type t = system let name = "Wpo.SYSTEM.Datatype" let reprs = [ create_system () ] let mem_project = Datatype.never_any_project end)) (struct let name = "Wpo.SYSTEM.System" let dependencies = [ Ast.self ] let default = create_system end) let clear () = clear_system (SYSTEM.get ()) (* ------------------------------------------------------------------------ *) (* --- WPO Construction --- *) (* ------------------------------------------------------------------------ *) (* A WPO is uniquely determined by : 1. The model name (unique per updater by construction) 2. The kernel-function 3. The behavior 4. The target prop-id *) let gid ~model ~propid = let gname = WpPropId.get_propid propid in Printf.sprintf "%s_%s" model gname (* -------------------------------------------------------------------------- *) (* --- Registry of POs --- *) (* -------------------------------------------------------------------------- *) let added = ref 0 let age g = let system = SYSTEM.get () in try WPOmap.find g system.age with Not_found -> 0 let current_age = ref (-1) let add g = let system = SYSTEM.get () in begin let ip = WpPropId.property_of_id g.po_pid in let proof = ( get_model_id g , ip ) in Hproof.remove system.proofs proof ; let age = incr current_age; !current_age in system.age <- WPOmap.add g age system.age ; system.results <- WPOmap.remove g system.results ; system.wpo_idx <- index_wpo Gmap.add Gmap.find g.po_idx g system.wpo_idx ; system.wpo_ip <- index_wpo Pmap.add Pmap.find ip g system.wpo_ip ; begin match g.po_idx with | Function(kf,_) -> system.wpo_kf <- index_wpo Fmap.add Fmap.find kf g system.wpo_kf | _ -> () end ; incr added ; if !added >= 100 then begin added := 0 ; Gmap.iter (fun _ ws -> WPOset.iter (fun _ -> incr added) ws) system.wpo_idx ; if not (Wp_parameters.has_dkey "no-goals-info") then Wp_parameters.feedback "Computing [%d goals...]" !added ; added := 0 ; end ; end let remove g = let system = SYSTEM.get () in begin let ip = WpPropId.property_of_id g.po_pid in system.wpo_idx <- unindex_wpo Gmap.add Gmap.find g.po_idx g system.wpo_idx ; system.wpo_ip <- unindex_wpo Pmap.add Pmap.find ip g system.wpo_ip ; begin match g.po_idx with | Function(kf,_) -> system.wpo_kf <- unindex_wpo Fmap.add Fmap.find kf g system.wpo_kf | Axiomatic _ -> () end ; system.results <- WPOmap.remove g system.results ; Hproof.remove system.proofs (get_model_id g , ip ) ; end let warnings = function | { po_formula = GoalAnnot vcq } -> vcq.VC_Annot.warn | { po_formula = GoalLemma _ } -> [] let is_valid = function { verdict=Valid } -> true | _ -> false let get_time = function { prover_time=t } -> t let get_steps= function { prover_steps=n } -> n let get_proof g = let system = SYSTEM.get () in let target = WpPropId.property_of_id g.po_pid in let status = try let pi = ( get_model_id g , target ) in let proof = Hproof.find system.proofs pi in WpAnnot.is_proved proof with Not_found -> false in status , target let set_po_result g r = let system = SYSTEM.get () in try let pi = ( get_model_id g , 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 is_valid r then WpAnnot.add_proof proof g.po_pid (get_depend g) ; 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 err -> Wp_parameters.failure "Update-status failed (%s)" (Printexc.to_string err) ; raise err let set_result g p r = let system = SYSTEM.get () in begin let rs = try WPOmap.find g system.results with Not_found -> let rs = Results.create () in system.results <- WPOmap.add g rs system.results ; rs in Results.replace rs p r ; set_po_result g r ; end let get_result g p : VCS.result = let system = SYSTEM.get () in try Results.get (WPOmap.find g system.results) p with Not_found -> VCS.no_result let is_trivial g = match g.po_formula with | GoalLemma g -> VC_Lemma.is_trivial g | GoalAnnot g -> VC_Annot.is_trivial g let get_result = Dynamic.register ~plugin:"Wp" "Wpo.get_result" ~journalize:false (Datatype.func2 PODatatype.ty ProverType.ty ResultType.ty) get_result let is_valid = Dynamic.register ~plugin:"Wp" "Wpo.is_valid" ~journalize:false (Datatype.func ResultType.ty Datatype.bool) is_valid let get_results g = let system = SYSTEM.get () in try Results.list (WPOmap.find g system.results) with Not_found -> [] (* -------------------------------------------------------------------------- *) (* --- Proof Obligations : Pretty-printing --- *) (* -------------------------------------------------------------------------- *) let pp_title fmt w = WpPropId.pretty_local fmt w.po_pid let pp_goal fmt w = begin match w.po_formula with | GoalAnnot vcq -> VC_Annot.pretty fmt w.po_pid vcq (get_results w) | GoalLemma vca -> VC_Lemma.pretty fmt vca (get_results w) 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 (* -------------------------------------------------------------------------- *) (* --- Iterator --- *) (* -------------------------------------------------------------------------- *) type part = | Pnone | Paxiomatic of string option | Pbehavior of kernel_function * string option let iter ?ip ?index ?on_axiomatics ?on_behavior ?on_goal () = let system = SYSTEM.get () in let current = ref Pnone in let apply_lemma a = match on_axiomatics with None -> () | Some phi -> phi a in let apply_behavior f bhv = match on_behavior with None -> () | Some phi -> phi f bhv in let on_part idx = match !current , idx with | Paxiomatic a , Axiomatic b when a=b -> () | _ , Axiomatic b -> apply_lemma b ; current := Paxiomatic b | Pbehavior(f,None) , Function(g,None) when Kernel_function.equal f g -> () | Pbehavior(f,Some a) , Function(g,Some b) when Kernel_function.equal f g && a=b -> () | _ , Function(g,bhv) -> apply_behavior g bhv ; current := Pbehavior(g,bhv) in let on_goals poset = if not (WPOset.is_empty poset) then begin match on_goal with | None -> () | Some phi -> WPOset.iter phi poset end in match index,ip with | None,None -> Gmap.iter (fun idx ws -> on_part idx ; on_goals ws) system.wpo_idx | _,Some ip -> begin match on_goal with | None -> () | Some phi -> let poset = try Pmap.find ip system.wpo_ip with Not_found -> WPOset.empty in WPOset.iter phi poset end | Some (Function(kf,None)),None -> begin try on_goals (Fmap.find kf system.wpo_kf) with Not_found -> () end | Some idx,None -> begin try on_goals (Gmap.find idx system.wpo_idx) with Not_found -> () end 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 ()) let goals_of_property prop = let system = SYSTEM.get () in let poset = try Pmap.find prop system.wpo_ip with Not_found -> WPOset.empty in WPOset.elements poset let goals_of_property = Dynamic.register ~plugin:"Wp" "Wpo.goals_of_property" (Datatype.func Property.ty (Datatype.list PODatatype.ty)) ~journalize:false goals_of_property let prover_of_name = Dynamic.register ~plugin:"Wp" "Wpo.prover_of_name" ~journalize:false (Datatype.func Datatype.string (Datatype.option ProverType.ty)) VCS.prover_of_name (* -------------------------------------------------------------------------- *) (* --- Prover and Files --- *) (* -------------------------------------------------------------------------- *) let get_model w = w.po_model let get_logfile w prover result = let model = get_model w in DISK.cache_log ~pid:w.po_pid ~model ~prover ~result let _ = Dynamic.register ~plugin:"Wp" "Wpo.file_for_log_proof" ~journalize:false (Datatype.func2 PODatatype.ty ProverType.ty (Datatype.pair Datatype.string Datatype.string)) (fun w p -> (DISK.file_logout w.po_pid (get_model w) p, DISK.file_logerr w.po_pid (get_model w) p)) let pp_logfile fmt w prover = let model = get_model w in let result = get_result w prover in DISK.pretty ~pid:w.po_pid ~model ~prover ~result fmt let is_computing = function VCS.Computing _ -> true | _ -> false let get_files w = let results = get_results w in let descr_files = match w.po_formula with | GoalAnnot vcq -> [ "Goal" , VC_Annot.cache_descr ~pid:w.po_pid vcq results ] | GoalLemma vca -> [ "Lemma" , VC_Lemma.cache_descr vca results ] in let result_files = List.fold_right (fun (prover,result) files -> if prover <> VCS.Qed && not (is_computing result.verdict) then let filename = get_logfile w prover result in if filename <> "" && Sys.file_exists filename then let title = name_of_prover prover in (title,filename) :: files else files else files ) results [] in descr_files @ result_files module S = PODatatype frama-c-Fluorine-20130601/src/wp/MemTyped.ml0000644000175000017500000010324212155630215017272 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Empty Memory Model --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Cil_datatype open Ctypes open Lang open Lang.F open Memory open Definitions module L = Qed.Logic let datatype = "MemTyped" let theory = "memory" let a_addr = Lang.datatype ~theory ~link:"addr" let t_addr = L.Data(a_addr,[]) let f_base = Lang.extern_f ~theory ~result:L.Sint "base" let f_offset = Lang.extern_f ~theory ~result:L.Sint "offset" let f_shift = Lang.extern_f ~theory "shift" let f_global = Lang.extern_f ~theory "global" let f_null = Lang.extern_f ~theory "null" let p_valid_rd = Lang.extern_fp ~theory "valid_rd" let p_valid_rw = Lang.extern_fp ~theory "valid_rw" let p_separated = Lang.extern_fp ~theory "separated" let p_included = Lang.extern_fp ~theory "included" let p_eqmem = Lang.extern_fp ~theory "eqmem" let p_havoc = Lang.extern_fp ~theory "havoc" let f_region = Lang.extern_f ~theory ~result:L.Sint "region" (* base -> region *) let p_linked = Lang.extern_fp ~theory "linked" (* allocation-table -> prop *) let p_sconst = Lang.extern_fp ~theory "sconst" (* int-memory -> prop *) let p_framed = Lang.extern_fp ~theory "framed" (* m-pointer -> prop *) let a_lt = Lang.extern_p ~theory ~prop:"addr_lt" ~bool:"addr_lt_bool" () let a_leq = Lang.extern_p ~theory ~prop:"addr_le" ~bool:"addr_le_bool" () let a_cast = Lang.extern_f ~result:L.Sint ~category:L.Injection ~theory "cast" let a_hardware = Lang.extern_f ~result:L.Sint ~category:L.Injection ~theory "hardware" (* -------------------------------------------------------------------------- *) (* --- Utilities on loc-as-term --- *) (* -------------------------------------------------------------------------- *) let rec a_base l = match F.repr l with | L.Fun(f,[p;_]) when f==f_shift -> a_base p | L.Fun(f,[b]) when f==f_global -> b | L.Fun(f,[]) when f==f_null -> e_zero | _ -> F.e_funraw f_base [l] let rec a_offset l = match F.repr l with | L.Fun(f,[p;k]) when f==f_shift -> F.e_add (a_offset p) k | L.Fun(f,_) when f==f_global || f==f_null -> F.e_zero | _ -> F.e_funraw f_offset [l] let rec a_shift l k = match F.repr l with | L.Fun(f,[p;i]) when f==f_shift -> F.e_funraw f_shift [p;e_add i k] | _ -> F.e_funraw f_shift [l;k] let a_null = F.e_funraw f_null [] let a_global base = if base == e_zero then a_null else F.e_funraw f_global [base] let a_addr base offset = a_shift (a_global base) offset let eq_shift a b = let p = a_base a in let q = a_base b in let i = a_offset a in let j = a_offset b in if i==j then F.p_equal p q else match F.is_equal p q with | L.No -> F.p_false | L.Yes -> F.p_equal i j | L.Maybe -> raise Not_found let () = begin F.add_builtin_1 f_base a_base ; F.add_builtin_1 f_offset a_offset ; F.add_builtin_2 f_shift a_shift ; F.add_builtin_peq f_shift eq_shift ; F.add_builtin_peq f_global eq_shift ; end (* -------------------------------------------------------------------------- *) (* --- Model Parameters --- *) (* -------------------------------------------------------------------------- *) let configure () = begin Context.set Lang.pointer (fun _ -> t_addr) ; Context.set Cvalues.null (p_equal a_null) ; end type pointer = NoCast | Fits | Unsafe let pointer = Context.create ~default:NoCast "MemTyped.pointer" (* -------------------------------------------------------------------------- *) (* --- Chunks --- *) (* -------------------------------------------------------------------------- *) type chunk = | M_int | M_char | M_float | M_pointer | T_alloc module Chunk = struct type t = chunk let self = "typed" let rank = function | M_int -> 0 | M_char -> 1 | M_float -> 2 | M_pointer -> 3 | T_alloc -> 4 let hash = rank let name = function | M_int -> "Mint" | M_char -> "Mchar" | M_float -> "Mflt" | M_pointer -> "Mptr" | T_alloc -> "Malloc" let compare a b = rank a - rank b let equal = (=) let pretty fmt c = Format.pp_print_string fmt (name c) let key_of_chunk = function | M_int | M_char | M_float | M_pointer -> t_addr | T_alloc -> L.Int let val_of_chunk = function | M_int | M_char -> L.Int | M_float -> L.Real | M_pointer -> t_addr | T_alloc -> L.Int let tau_of_chunk = let m = Array.create 5 L.Int in List.iter (fun c -> m.(rank c) <- L.Array(key_of_chunk c,val_of_chunk c)) [M_int;M_char;M_float;M_pointer;T_alloc] ; fun c -> m.(rank c) let basename_of_chunk = name end module Heap = Qed.Collection.Make(Chunk) module Sigma = Sigma.Make(Chunk)(Heap) type loc = term (* of type addr *) (* -------------------------------------------------------------------------- *) (* --- Utilities on locations --- *) (* -------------------------------------------------------------------------- *) let m_int i = if Ctypes.is_char i then M_char else M_int let rec footprint = function | C_int i -> Heap.Set.singleton (m_int i) | C_float _ -> Heap.Set.singleton M_float | C_pointer _ -> Heap.Set.singleton M_pointer | C_array a -> footprint (object_of a.arr_element) | C_comp c -> footprint_comp c and footprint_comp c = List.fold_left (fun ft f -> Heap.Set.union ft (footprint (object_of f.ftype)) ) Heap.Set.empty c.cfields let signature ft = let s = Sigma.create () in let xs = ref [] in let cs = ref [] in Heap.Set.iter (fun c -> cs := c :: !cs ; xs := (Sigma.get s c) :: !xs ; ) ft ; List.rev !xs , List.rev !cs , s let memories sigma ft = List.map (Sigma.value sigma) ft let rec size_of_object = function | C_int _ | C_float _ | C_pointer _ -> Int64.one | C_comp c -> size_of_comp c | C_array { arr_flat = Some { arr_size = n } ; arr_element = elt } -> Int64.mul n (size_of_typ elt) | C_array _ as a -> Wp_parameters.abort ~current:true "Undefined array-size (%a)" Ctypes.pretty a and size_of_typ t = size_of_object (object_of t) and size_of_field f = size_of_typ f.ftype and size_of_comp c = List.fold_left (fun s f -> Int64.add s (size_of_field f)) Int64.zero c.cfields let offset_of_field f = let rec fnext k f = function | [] -> assert false | g::gs -> if Fieldinfo.equal f g then k else fnext (Int64.add k (size_of_field g)) f gs in fnext Int64.zero f f.fcomp.cfields (* -------------------------------------------------------------------------- *) (* --- Utilities on loc-as-term --- *) (* -------------------------------------------------------------------------- *) type sigma = Sigma.t type segment = loc rloc let pretty fmt l = F.pp_term fmt l let vars l = F.vars l let occurs x l = F.occurs x l (* -------------------------------------------------------------------------- *) (* --- Basic Manipulation --- *) (* -------------------------------------------------------------------------- *) let loadrec = ref (fun _ _ _ -> assert false) let field l f = a_shift l (F.e_int64 (offset_of_field f)) let shift l obj k = a_shift l (F.e_mul (F.e_int64 (size_of_object obj)) k) (* -------------------------------------------------------------------------- *) (* --- Generated Axiomatization --- *) (* -------------------------------------------------------------------------- *) let cluster_globals () = Definitions.cluster ~id:"Globals" ~title:"Global Variables" () let cluster_memory () = Definitions.cluster ~id:"Compound" ~title:"Memory Compound Updates" () module LITERAL = struct type t = int * Cstring.cst let compare (a:t) (b:t) = Pervasives.compare (fst a) (fst b) let pretty fmt (eid,cst) = Format.fprintf fmt "%a@%d" Cstring.pretty cst eid end module STRING = Model.Generator(LITERAL) (struct let name = "MemTyped.STRING" type key = LITERAL.t type data = term let linked lfun base cst = let name = Fun.id lfun ^ "_linked" in let a = Lang.freshvar ~basename:"alloc" (Chunk.tau_of_chunk T_alloc) in let m = e_var a in let m_linked = p_call p_linked [m] in let base_size = Cstring.str_len cst (F.e_get m base) in Definitions.define_lemma { l_assumed = true ; l_name = name ; l_types = 0 ; l_triggers = [] ; l_forall = [] ; l_lemma = p_forall [a] (p_imply m_linked base_size) ; l_cluster = Cstring.cluster () ; } let region lfun base cst = let name = Fun.id lfun ^ "_region" in let re = - Cstring.str_id cst in Definitions.define_lemma { l_assumed = true ; l_name = name ; l_types = 0 ; l_triggers = [] ; l_forall = [] ; l_lemma = p_equal (e_fun f_region [base]) (e_int re) ; l_cluster = Cstring.cluster () ; } let sconst lfun base cst = let name = Fun.id lfun ^ "_literal" in let i = Lang.freshvar ~basename:"i" L.Int in let c = Cstring.char_at cst (e_var i) in let addr = a_addr base (e_var i) in let m = Lang.freshvar ~basename:"mchar" (Chunk.tau_of_chunk M_char) in let m_sconst = F.p_call p_sconst [e_var m] in let v = F.e_get (e_var m) addr in let read = F.p_equal c v in Definitions.define_lemma { l_assumed = true ; l_name = name ; l_types = 0 ; l_triggers = [] ; l_forall = [m;i] ; l_cluster = Cstring.cluster () ; l_lemma = F.p_imply m_sconst read ; } let compile (eid,cst) = let lfun = Lang.generated_f ~result:L.Sint "Str_%d" eid in let base = F.e_fun lfun [] in Definitions.define_symbol { d_lfun = lfun ; d_types = 0 ; d_params = [] ; d_definition = Logic L.Int ; d_cluster = Cstring.cluster () ; } ; Definitions.define_lemma { l_name = Lang.Fun.id lfun ^ "_base" ; l_assumed = true ; l_types = 0 ; l_triggers = [] ; l_forall = [] ; l_lemma = F.p_lt base F.e_zero ; l_cluster = Cstring.cluster () ; } ; region lfun base cst ; linked lfun base cst ; sconst lfun base cst ; base end) module BASE = Model.Generator(Varinfo) (struct let name = "MemTyped.BASE" type key = varinfo type data = term let region lfun x base = let name = Fun.id lfun ^ "_region" in let re = if x.vglob then 0 else if x.vformal then 1 else 2 in Definitions.define_lemma { l_assumed = true ; l_name = name ; l_types = 0 ; l_triggers = [] ; l_forall = [] ; l_lemma = p_equal (e_fun f_region [base]) (e_int re) ; l_cluster = cluster_globals () ; } let linked lfun x base = let name = Fun.id lfun ^ "_linked" in let size = Ctypes.sizeof_typ x.vtype in let a = Lang.freshvar ~basename:"alloc" (Chunk.tau_of_chunk T_alloc) in let m = e_var a in let m_linked = p_call p_linked [m] in let base_size = p_equal (F.e_get m base) (e_int64 size) in Definitions.define_lemma { l_assumed = true ; l_name = name ; l_types = 0 ; l_triggers = [] ; l_forall = [] ; l_lemma = p_forall [a] (p_imply m_linked base_size) ; l_cluster = cluster_globals () ; } let generate x = let prefix = if x.vglob then "G" else if x.vformal then "P" else "L" in let lfun = Lang.generated_f ~category:L.Constructor ~result:L.Sint "%s_%s_%d" prefix x.vorig_name x.vid in let dfun = Definitions.Value( L.Int , Def , e_int (succ x.vid) ) in Definitions.define_symbol { d_lfun = lfun ; d_types = 0 ; d_params = [] ; d_definition = dfun ; d_cluster = cluster_globals () ; } ; let base = e_fun lfun [] in region lfun x base ; linked lfun x base ; base let compile = Lang.local generate end) module MONOTONIC : sig val generate : lfun -> var list -> chunk list -> (term list -> term) -> unit end = struct type env = { lfun : lfun ; sigma : sigma ; vars : var list ; params : term list ; range : term ; chunks : chunk list ; memories : term list ; } let _cluster () = Definitions.cluster ~id:"TypedMemory" () (* projectified *) let update env c m = List.map (fun c' -> if Chunk.equal c c' then m else Sigma.value env.sigma c' ) env.chunks let separated env q k = F.p_call p_separated [q;k;List.hd env.params;env.range] let included env q k = F.p_call p_included [q;k;List.hd env.params;env.range] let generate_update env c = let name = Lang.Fun.id env.lfun ^ "_update_" ^ Chunk.name c in let q = e_var (Lang.freshvar ~basename:"q" (Chunk.key_of_chunk c)) in let v = e_var (Lang.freshvar ~basename:"v" (Chunk.val_of_chunk c)) in let phi = e_fun env.lfun (env.params @ env.memories) in let mem' = e_set (Sigma.value env.sigma c) q v in let phi' = e_fun env.lfun (env.params @ update env c mem') in let lemma = p_imply (separated env q e_one) (p_equal phi' phi) in Definitions.define_lemma { l_assumed = true ; l_name = name ; l_types = 0 ; l_triggers = [[Trigger.of_term phi']] ; l_forall = Vars.elements (F.varsp lemma) ; l_lemma = lemma ; l_cluster = cluster_memory () ; } let generate_eqmem env c = let name = Lang.Fun.id env.lfun ^ "_eqmem_" ^ Chunk.name c in let q = e_var (Lang.freshvar ~basename:"q" (Chunk.key_of_chunk c)) in let k = e_var (Lang.freshvar ~basename:"k" L.Int) in let phi = e_fun env.lfun (env.params @ env.memories) in let mem = Sigma.value env.sigma c in let mem' = e_var (Lang.freshen (Sigma.get env.sigma c)) in let phi' = e_fun env.lfun (env.params @ update env c mem') in let eqmem = F.p_call p_eqmem [mem;mem';q;k] in let lemma = p_hyps [separated env q k;eqmem] (p_equal phi' phi) in Definitions.define_lemma { l_assumed = true ; l_name = name ; l_types = 0 ; l_triggers = [ [Trigger.of_pred eqmem ; Trigger.of_term phi ] ; [Trigger.of_pred eqmem ; Trigger.of_term phi'] ; ] ; l_forall = Vars.elements (F.varsp lemma) ; l_lemma = lemma ; l_cluster = cluster_memory () ; } let generate_havoc env c = let name = Lang.Fun.id env.lfun ^ "_havoc_" ^ Chunk.name c in let q = e_var (Lang.freshvar ~basename:"q" (Chunk.key_of_chunk c)) in let k = e_var (Lang.freshvar ~basename:"k" L.Int) in let phi = e_fun env.lfun (env.params @ env.memories) in let mem = Sigma.value env.sigma c in let mem' = e_var (Lang.freshen (Sigma.get env.sigma c)) in let phi' = e_fun env.lfun (env.params @ update env c mem') in let havoc = F.p_call p_havoc [mem;mem';q;k] in let lemma = p_hyps [included env q k;havoc] (p_equal phi' phi) in Definitions.define_lemma { l_assumed = true ; l_name = name ; l_types = 0 ; l_triggers = [ [ Trigger.of_pred havoc ; Trigger.of_term phi ] ; [ Trigger.of_pred havoc ; Trigger.of_term phi'] ; ] ; l_forall = Vars.elements (F.varsp lemma) ; l_lemma = lemma ; l_cluster = cluster_memory () ; } let generate lfun xs cs range = let sigma = Sigma.create () in let xp = Lang.freshvar ~basename:"p" t_addr in let xs = List.map Lang.freshen xs in let ps = List.map e_var xs in let ms = memories sigma cs in let env = { sigma = sigma ; lfun = lfun ; vars = xp::xs ; params = e_var xp::ps ; chunks = cs ; memories = ms ; range = range ps ; } in List.iter (fun chunk -> generate_update env chunk ; generate_eqmem env chunk ; generate_havoc env chunk ; ) cs end module COMP = Model.Generator(Compinfo) (struct let name = "MemTyped.COMP" type key = compinfo type data = lfun * chunk list let generate c = let lfun = Lang.generated_f "Load_%s" (Lang.comp_id c) in let xmem,ft,sigma = signature (footprint_comp c) in let xloc = Lang.freshvar ~basename:"p" t_addr in let loc = e_var xloc in let def = List.map (fun f -> Cfield f , !loadrec sigma (object_of f.ftype) (field loc f) ) c.cfields in let dfun = Definitions.Value( Lang.tau_of_comp c , Def , e_record def ) in Definitions.define_symbol { d_lfun = lfun ; d_types = 0 ; d_params = xloc :: xmem ; d_definition = dfun ; d_cluster = cluster_memory () ; } ; let range = e_int64 (size_of_comp c) in MONOTONIC.generate lfun [] ft (fun _ -> range) ; lfun , ft let compile = Lang.local generate end) module ARRAY = Model.Generator(Matrix.NATURAL) (struct open Matrix let name = "MemTyped.ARRAY" type key = matrix type data = lfun * chunk list let generate (obj,ds) = let lfun = Lang.generated_f "Array%s_%s" (Matrix.id ds) (Matrix.natural_id obj) in let axiom = Fun.id lfun ^ "_access" in let xmem,ft,sigma = signature (footprint obj) in let xloc = Lang.freshvar ~basename:"p" t_addr in let loc = e_var xloc in let denv = Matrix.denv ds in let phi = e_fun lfun (loc :: denv.size_val @ List.map e_var xmem) in let arr = List.fold_left e_get phi denv.index_val in let elt = !loadrec sigma obj (shift loc obj (e_sum denv.index_offset)) in let lemma = p_hyps denv.index_range (p_equal arr elt) in let cluster = cluster_memory () in Definitions.define_symbol { d_lfun = lfun ; d_types = 0 ; d_params = xloc :: denv.size_var @ xmem ; d_definition = Logic (Matrix.tau obj ds) ; d_cluster = cluster ; } ; Definitions.define_lemma { l_assumed = true ; l_name = axiom ; l_types = 0 ; l_forall = Vars.elements (F.varsp lemma) ; l_triggers = [[Trigger.of_term arr]] ; l_lemma = lemma ; l_cluster = cluster ; } ; if denv.monotonic then MONOTONIC.generate lfun denv.size_var ft F.e_prod ; lfun , ft let compile = Lang.local generate end) (* -------------------------------------------------------------------------- *) (* --- Loading Elementary Values --- *) (* -------------------------------------------------------------------------- *) let loadvalue sigma obj l = match obj with | C_int i -> F.e_get (Sigma.value sigma (m_int i)) l | C_float _ -> F.e_get (Sigma.value sigma M_float) l | C_pointer _ -> F.e_get (Sigma.value sigma M_pointer) l | C_comp c -> let phi,cs = COMP.get c in e_fun phi (l :: memories sigma cs) | C_array a -> let m = Matrix.of_array a in let phi,cs = ARRAY.get m in e_fun phi ( l :: Matrix.size m @ memories sigma cs ) let () = loadrec := loadvalue let load sigma obj l = Val (loadvalue sigma obj l) (* -------------------------------------------------------------------------- *) (* --- Locations --- *) (* -------------------------------------------------------------------------- *) let null = a_null let literal ~eid cst = a_addr (STRING.get (eid,cst)) e_zero let cvar x = a_addr (BASE.get x) e_zero let pointer_loc t = t let pointer_val t = t let get_alloc sigma l = F.e_get (Sigma.value sigma T_alloc) (a_base l) let get_last sigma l = e_add (get_alloc sigma l) e_minus_one let base_addr l = a_addr (a_base l) e_zero let block_length sigma obj l = e_fact (Ctypes.sizeof_object obj) (get_alloc sigma l) (* -------------------------------------------------------------------------- *) (* --- Cast --- *) (* -------------------------------------------------------------------------- *) module Layout = struct type atom = P of typ | I of c_int | F of c_float let pp_atom fmt = function | P ty -> Printer.pp_typ fmt (TPtr(ty,[])) | I i -> Ctypes.pp_int fmt i | F f -> Ctypes.pp_float fmt f let is_one n = (Int64.compare n Int64.one = 0) let eqatom a1 a2 = match a1 , a2 with | P _ , P _ -> true | _ -> (a1 = a2) type block = | Str of atom * int64 | Arr of layout * int64 (* non-homogeneous, more than one *) | Garbled and layout = block list let rec pp_block fmt = function | Str(a,n) when is_one n -> pp_atom fmt a | Str(a,n) -> Format.fprintf fmt "%a[%s]" pp_atom a (Int64.to_string n) | Arr(ly,n) -> Format.fprintf fmt "%a[%s]" pp_layout ly (Int64.to_string n) | Garbled -> Format.fprintf fmt "..." and pp_layout fmt = function | [b] -> pp_block fmt b | bs -> begin Format.fprintf fmt "@[{" ; List.iter (fun b -> Format.fprintf fmt "@ %a" pp_block b) bs ; Format.fprintf fmt " }@]" ; end let add_atom a ly = match ly with | Str(b,m) :: w when eqatom a b -> Str(b,Int64.succ m)::w | _ -> Str(a,Int64.one) :: ly let add_block p ly = match p , ly with | Str(a,n) , Str(b,m)::w when eqatom a b -> Str(b,Int64.add n m)::w | Garbled , Garbled::_ -> ly | _ -> p :: ly (* requires n > 1 *) let add_many ly n w = match ly with | [] -> w | [Str(a,m)] -> add_block (Str(a,Int64.mul m n)) w | Garbled::_ -> add_block Garbled w | ly -> Arr(ly,n) :: w let rec rlayout w = function | C_int i -> add_atom (I i) w | C_float f -> add_atom (F f) w | C_pointer t -> add_atom (P t) w | C_comp c -> if c.cstruct then List.fold_left flayout w c.cfields else (* TODO: can be the longuest common prefix *) add_block Garbled w | C_array { arr_flat = Some a } -> let ly = rlayout [] (Ctypes.object_of a.arr_cell) in if is_one a.arr_cell_nbr then ly @ w (* ly is in reversed order *) else add_many (List.rev ly) a.arr_cell_nbr w | C_array { arr_element = e } -> if Wp_parameters.ExternArrays.get () then let ly = rlayout [] (Ctypes.object_of e) in add_many (List.rev ly) Int64.max_int w else add_block Garbled w and flayout w f = rlayout w (Ctypes.object_of f.ftype) let layout (obj : c_object) : layout = List.rev (rlayout [] obj) type comparison = Fit | Equal | Mismatch let add_array ly n w = if is_one n then ly @ w else add_many ly n w let rec compare l1 l2 = match l1 , l2 with | [] , [] -> Equal | [] , _ -> Fit | _ , [] -> Mismatch | p::w1 , q::w2 -> match p , q with | Garbled , _ | _ , Garbled -> Mismatch | Str(a,n) , Str(b,m) -> if eqatom a b then let cmp = Int64.compare n m in if cmp < 0 then (* n < m *) let w2 = Str(a,Int64.sub m n)::w2 in compare w1 w2 else if cmp > 0 then (* n > m *) let w1 = Str(a,Int64.sub n m)::w1 in compare w1 w2 else (* n = m *) compare w1 w2 else Mismatch | Arr(u,n) , Arr(v,m) -> begin match compare u v with | Mismatch -> Mismatch | Fit -> if is_one n then Fit else Mismatch | Equal -> let cmp = Int64.compare n m in if cmp < 0 then (* n < m *) let w2 = add_array v (Int64.sub m n) w2 in compare w1 w2 else if cmp > 0 then (* n > m *) let w1 = add_array u (Int64.sub n m) w1 in compare w1 w2 else (* n = m *) compare w1 w2 end | Arr(v,n) , Str _ -> compare (v @ add_array v (Int64.pred n) w1) l2 | Str _ , Arr(v,n) -> compare l1 (v @ add_array v (Int64.pred n) w2) let rec fits obj1 obj2 = match obj1 , obj2 with | C_int i1 , C_int i2 -> i1 = i2 | C_float f1 , C_float f2 -> f1 = f2 | C_comp c , C_comp d when Compinfo.equal c d -> true | C_pointer _ , C_pointer _ -> true | _ -> match compare (layout obj1) (layout obj2) with | Equal | Fit -> true | Mismatch -> false let rec pretty fmt = function | C_pointer ty -> Format.fprintf fmt "%a*" pretty (Ctypes.object_of ty) | obj -> pp_layout fmt (layout obj) end let pp_mismatch fmt s = if Context.get pointer <> NoCast && Wp_parameters.has_dkey "layout" then Format.fprintf fmt "Cast with incompatible pointers types@\n\ @[@[Source: %a*@]@ @[(layout: %a)@]@]@\n\ @[@[Target: %a*@]@ @[(layout: %a)@]@]" Ctypes.pretty s.pre Layout.pretty s.pre Ctypes.pretty s.post Layout.pretty s.post else Format.fprintf fmt "@[Cast with incompatible pointers types\ @ (source: %a*)@ (target: %a*)@]" Ctypes.pretty s.pre Ctypes.pretty s.post let cast s l = if F.is_zero l then null else match Context.get pointer with | NoCast -> Warning.error ~source:"Typed Model" "%a" pp_mismatch s | Fits -> if Layout.fits s.post s.pre then l else Warning.error ~source:"Typed Model" "%a" pp_mismatch s | Unsafe -> if not (Layout.fits s.post s.pre) then Warning.emit ~severe:false ~source:"Typed Model" ~effect:"Keep pointer value" "%a" pp_mismatch s ; l let loc_of_int _ v = match F.repr v with | L.Kint _ -> a_addr e_zero (e_fun a_hardware [v]) | _ -> Warning.error ~source:"Typed Model" "Forbidden cast of int to pointer" let int_of_loc _i loc = e_fun a_cast [pointer_val loc] (* -------------------------------------------------------------------------- *) (* --- Updates --- *) (* -------------------------------------------------------------------------- *) let domain obj _l = footprint obj let updated s c l v = let m1 = Sigma.value s.pre c in let m2 = Sigma.value s.post c in [p_equal m2 (F.e_set m1 l v)] let havoc_range s obj l n = let ps = ref [] in Heap.Set.iter (fun c -> let m1 = Sigma.value s.pre c in let m2 = Sigma.value s.post c in ps := F.p_call p_havoc [m1;m2;l;n] :: !ps ) (footprint obj) ; !ps let havoc s obj l = havoc_range s obj l (e_int64 (size_of_object obj)) let eqmem s obj l = let ps = ref [] in let n = e_int64 (size_of_object obj) in Heap.Set.iter (fun c -> let m1 = Sigma.value s.pre c in let m2 = Sigma.value s.post c in if m1 != m2 then ps := F.p_call p_eqmem [m1;m2;l;n] :: !ps ) (footprint obj) ; !ps (* -------------------------------------------------------------------------- *) (* --- Copy --- *) (* -------------------------------------------------------------------------- *) let stored s obj l v = match obj with | C_int i -> updated s (m_int i) l v | C_float _ -> updated s M_float l v | C_pointer _ -> updated s M_pointer l v | C_comp _ | C_array _ -> p_equal (loadvalue s.post obj l) v :: havoc s obj l let copied s obj p q = stored s obj p (loadvalue s.pre obj q) (* -------------------------------------------------------------------------- *) (* --- Assignation --- *) (* -------------------------------------------------------------------------- *) let assigned_loc s obj l = match obj with | C_int _ | C_float _ | C_pointer _ -> let x = Lang.freshvar ~basename:"v" (Lang.tau_of_object obj) in stored s obj l (e_var x) | C_comp _ | C_array _ -> havoc s obj l let equal_loc s obj l = match obj with | C_int _ | C_float _ | C_pointer _ -> [p_equal (loadvalue s.pre obj l) (loadvalue s.post obj l)] | C_comp _ | C_array _ -> eqmem s obj l let assigned_range s obj l a b = let l = shift l obj a in let n = e_fact (size_of_object obj) (e_range a b) in havoc_range s obj l n let assigned s obj = function | Sloc l -> assigned_loc s obj l | Sdescr(xs,l,p) -> let hs = equal_loc s obj l in List.map (fun h -> p_forall xs (p_or p h)) hs | Sarray(l,obj,n) -> assigned_range s obj l (e_zero) (e_int64 (Int64.pred n)) | Srange(l,obj,u,v) -> let a = match u with Some a -> a | None -> e_zero in let b = match v with Some b -> b | None -> get_last s.pre l in assigned_range s obj l a b (* -------------------------------------------------------------------------- *) (* --- Loc Comparison --- *) (* -------------------------------------------------------------------------- *) let loc_compare f_cmp i_cmp p q = match F.is_equal (a_base p) (a_base q) with | L.Yes -> i_cmp (a_offset p) (a_offset q) | L.Maybe | L.No -> p_call f_cmp [p;q] let is_null l = p_equal l null let loc_eq = p_equal let loc_neq = p_neq let loc_lt = loc_compare a_lt p_lt let loc_leq = loc_compare a_leq p_leq let loc_diff obj p q = let delta = e_sub (a_offset p) (a_offset q) in e_fact (Ctypes.sizeof_object obj) delta (* -------------------------------------------------------------------------- *) (* --- Validity --- *) (* -------------------------------------------------------------------------- *) let s_valid sigma acs p n = let p_valid = match acs with RW -> p_valid_rw | RD -> p_valid_rd in p_call p_valid [Sigma.value sigma T_alloc;p;n] let access acs l = match acs with | RW -> p_lt e_zero (a_base l) | RD -> p_true let valid sigma acs = function | Rloc(obj,l) -> s_valid sigma acs l (e_int64 (size_of_object obj)) | Rarray(l,obj,s) -> let n = e_fact (size_of_object obj) (e_int64 s) in s_valid sigma acs l n | Rrange(l,obj,Some a,Some b) -> let l = shift l obj a in let n = e_fact (size_of_object obj) (e_range a b) in s_valid sigma acs l n | Rrange(l,obj,None,Some b) -> let n = e_add b e_one in s_valid sigma acs l (e_fact (size_of_object obj) n) | Rrange(l,obj,Some a,None) -> let k = e_add (a_offset l) (e_fact (size_of_object obj) a) in p_conj [ access acs l ; p_lt e_zero k ; p_leq k (get_alloc sigma l) ] | Rrange(l,_obj,None,None) -> p_conj [ access acs l ; p_lt e_zero (get_alloc sigma l) ] type alloc = ALLOC | FREE let allocates spost xs a = if xs = [] then spost, [] else let spre = Sigma.havoc_chunk spost T_alloc in let alloc = List.fold_left (fun m x -> let size = match a with | FREE -> Int64.zero | ALLOC -> size_of_typ x.vtype in F.e_set m (BASE.get x) (e_int64 size)) (Sigma.value spre T_alloc) xs in spre , [ p_equal (Sigma.value spost T_alloc) alloc ] let framed sigma = let frame phi chunk = if Sigma.mem sigma chunk then [ p_call phi [Sigma.value sigma chunk] ] else [] in frame p_linked T_alloc @ frame p_sconst M_char @ frame p_framed M_pointer let scope sigma scope xs = match scope with | Mcfg.SC_Global -> sigma , framed sigma | Mcfg.SC_Function_in -> sigma , [] | Mcfg.SC_Function_frame | Mcfg.SC_Block_in -> allocates sigma xs ALLOC | Mcfg.SC_Function_out | Mcfg.SC_Block_out -> allocates sigma xs FREE (* -------------------------------------------------------------------------- *) (* --- Domain --- *) (* -------------------------------------------------------------------------- *) type range = | LOC of term * term (* loc - size *) | RANGE of term * Vset.set (* base - range offset *) let range = function | Rloc(obj,l) -> LOC( l , e_int64 (size_of_object obj) ) | Rarray(l,obj,n) -> let n = e_fact (size_of_object obj) (e_int64 n) in LOC( l , n ) | Rrange(l,obj,Some a,Some b) -> let l = shift l obj a in let n = e_fact (size_of_object obj) (e_range a b) in LOC( l , n ) | Rrange(l,_obj,None,None) -> RANGE( a_base l , Vset.range None None ) | Rrange(l,obj,Some a,None) -> let se = size_of_object obj in RANGE( a_base l , Vset.range (Some (e_fact se a)) None ) | Rrange(l,obj,None,Some b) -> let se = size_of_object obj in RANGE( a_base l , Vset.range None (Some (e_fact se b)) ) let range_set = function | LOC(l,n) -> let a = a_offset l in let b = e_add a n in a_base l , Vset.range (Some a) (Some b) | RANGE(base,set) -> base , set let r_included r1 r2 = match r1 , r2 with | LOC(l1,n1) , LOC(l2,n2) -> p_call p_included [l1;n1;l2;n2] | _ -> let base1,set1 = range_set r1 in let base2,set2 = range_set r2 in p_and (p_equal base1 base2) (Vset.subset set1 set2) let r_disjoint r1 r2 = match r1 , r2 with | LOC(l1,n1) , LOC(l2,n2) -> p_call p_separated [l1;n1;l2;n2] | _ -> let base1,set1 = range_set r1 in let base2,set2 = range_set r2 in p_imply (p_equal base1 base2) (Vset.disjoint set1 set2) let included s1 s2 = r_included (range s1) (range s2) let separated s1 s2 = r_disjoint (range s1) (range s2) (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/Definitions.mli0000644000175000017500000001126512155630215020175 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 LogicUsage open Cil_types open Ctypes open Lang open Lang.F type cluster val cluster : id:string -> ?title:string -> ?position:Lexing.position -> unit -> cluster val axiomatic : axiomatic -> cluster val section : logic_section -> cluster val compinfo : compinfo -> cluster val matrix : c_object -> cluster val cluster_id : cluster -> string (** Unique *) val cluster_title : cluster -> string val cluster_position : cluster -> Lexing.position option val cluster_age : cluster -> int val cluster_compare : cluster -> cluster -> int val pp_cluster : Format.formatter -> cluster -> unit type trigger = (var,lfun) Qed.Engine.ftrigger type typedef = (tau,field,lfun) Qed.Engine.ftypedef type dlemma = { l_name : string ; l_cluster : cluster ; l_assumed : bool ; l_types : int ; l_forall : var list ; l_triggers : trigger list list ; (** OR of AND-triggers *) l_lemma : pred ; } type definition = | Logic of tau | Value of tau * recursion * term | Predicate of recursion * pred | Inductive of dlemma list and recursion = Def | Rec type dfun = { d_lfun : lfun ; d_cluster : cluster ; d_types : int ; d_params : var list ; d_definition : definition ; } module Trigger : sig val of_term : term -> trigger val of_pred : pred -> trigger val vars : trigger -> Vars.t val plug : trigger list list -> pred -> var list * pred end val define_symbol : dfun -> unit val update_symbol : dfun -> unit val find_lemma : logic_lemma -> dlemma (* raises Not_found *) val compile_lemma : (logic_lemma -> dlemma) -> logic_lemma -> unit val define_lemma : dlemma -> unit val define_type : cluster -> logic_type_info -> unit val call_fun : lfun -> (lfun -> dfun) -> term list -> term val call_pred : lfun -> (lfun -> dfun) -> term list -> pred type axioms = cluster * logic_lemma list class virtual visitor : cluster -> object (** {2 Locality} *) method set_local : cluster -> unit method do_local : cluster -> bool (** {2 Visiting items} *) method vadt : ADT.t -> unit method vtype : logic_type_info -> unit method vcomp : compinfo -> unit method vfield : Field.t -> unit method vtau : tau -> unit method vparam : var -> unit method vterm : term -> unit method vpred : pred -> unit method vsymbol : lfun -> unit method vlemma : logic_lemma -> unit method vcluster : cluster -> unit method vtheory : string -> unit method vgoal : axioms option -> F.pred -> unit method vself : unit (** {2 Visited definitions} *) method virtual section : string -> unit (** Comment *) method virtual on_theory : string -> unit (** Builtin theory to import *) method virtual on_library : string -> unit (** External library to import *) method virtual on_cluster : cluster -> unit (** Outer cluster to import *) method virtual on_type : logic_type_info -> typedef -> unit (** This local type must be defined *) method virtual on_comp : compinfo -> (field * tau) list -> unit (** This local compinfo must be defined *) method virtual on_dlemma : dlemma -> unit (** This local lemma must be defined *) method virtual on_dfun : dfun -> unit (** This local function must be defined *) end frama-c-Fluorine-20130601/src/wp/CodeSemantics.ml0000644000175000017500000003335012155630215020271 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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-Code Translation --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Ctypes open Qed open Memory open Lang open Lang.F module Make(M : Memory.Model) = struct type loc = M.loc type value = M.loc Memory.value type sigma = M.Sigma.t let cval = function | Val e -> e | Loc l -> M.pointer_val l let cloc = function | Loc l -> l | Val e -> M.pointer_loc e (* -------------------------------------------------------------------------- *) (* --- Initializers --- *) (* -------------------------------------------------------------------------- *) let is_zero_int = function | Val e -> p_equal e e_zero | Loc l -> M.is_null l let is_zero_float = function | Val e -> p_equal e e_zero_real | Loc l -> M.is_null l let is_zero_ptr v = M.is_null (cloc v) let rec is_zero sigma obj l = match obj with | C_int _ -> is_zero_int (M.load sigma obj l) | C_float _ -> is_zero_float (M.load sigma obj l) | C_pointer _ -> is_zero_ptr (M.load sigma obj l) | C_comp c -> p_all (fun f -> is_zero sigma (Ctypes.object_of f.ftype) (M.field l f)) c.cfields | C_array a -> (*TODO[LC] make zero-initializers model-dependent. For instance, a[N][M] becomes a[N*M] in MemTyped, but not in MemVar *) let x = Lang.freshvar ~basename:"k" Logic.Int in let k = e_var x in let obj = Ctypes.object_of a.arr_element in let range = match a.arr_flat with | None -> [] | Some f -> [ p_leq e_zero k ; p_lt k (e_int64 f.arr_size) ] in let init = is_zero sigma obj (M.shift l obj k) in p_forall [x] (p_hyps range init) let is_zero_range sigma l obj a b = let x = Lang.freshvar ~basename:"k" Logic.Int in let k = e_var x in let range = [ p_leq a k ; p_leq k b ] in let init = is_zero sigma obj (M.shift l obj k) in p_forall [x] (p_hyps range init) (* -------------------------------------------------------------------------- *) (* --- Recursion --- *) (* -------------------------------------------------------------------------- *) let s_exp : (sigma -> exp -> value) ref = ref (fun _ _ -> assert false) let s_cond : (sigma -> exp -> pred) ref = ref (fun _ _ -> assert false) let val_of_exp env e = cval (!s_exp env e) let loc_of_exp env e = cloc (!s_exp env e) (* -------------------------------------------------------------------------- *) (* --- L-Values --- *) (* -------------------------------------------------------------------------- *) let loc_of_lhost env = function | Var x -> M.cvar x | Mem e -> loc_of_exp env e let rec loc_of_offset env l typ = function | NoOffset -> l | Field(f,offset) -> loc_of_offset env (M.field l f) f.ftype offset | Index(e,offset) -> let k = val_of_exp env e in let te = Cil.typeOf_array_elem typ in let obj = Ctypes.object_of te in loc_of_offset env (M.shift l obj k) te offset let lval env (lhost,offset) = loc_of_offset env (loc_of_lhost env lhost) (Cil.typeOfLhost lhost) offset (* -------------------------------------------------------------------------- *) (* --- Unary Operator --- *) (* -------------------------------------------------------------------------- *) let exp_unop env typ unop e = let v = match Ctypes.object_of typ , unop with | C_int i , Neg -> Cint.iopp i (val_of_exp env e) | C_int i , BNot -> Cint.bnot i (val_of_exp env e) | C_float f , Neg -> Cfloat.fopp f (val_of_exp env e) | C_int _ , LNot -> Cvalues.bool_eq (val_of_exp env e) e_zero | C_float _ , LNot -> Cvalues.bool_eq (val_of_exp env e) e_zero_real | C_pointer _ , LNot -> Cvalues.is_true (M.is_null (loc_of_exp env e)) | _ -> Warning.error "Undefined unary operator (%a)" Printer.pp_typ typ in Val v (* -------------------------------------------------------------------------- *) (* --- Binary Operator --- *) (* -------------------------------------------------------------------------- *) let arith env tr iop fop e1 e2 = match Ctypes.object_of tr with | C_int i -> Val (iop i (val_of_exp env e1) (val_of_exp env e2)) | C_float f -> Val (fop f (val_of_exp env e1) (val_of_exp env e2)) | _ -> assert false let arith_int env tr iop e1 e2 = match Ctypes.object_of tr with | C_int i -> Val (iop i (val_of_exp env e1) (val_of_exp env e2)) | _ -> assert false let bool_of_comp env iop lop e1 e2 = let t1 = Cil.typeOf e1 in let t2 = Cil.typeOf e2 in if Cil.isPointerType t1 && Cil.isPointerType t2 then Cvalues.is_true (lop (loc_of_exp env e1) (loc_of_exp env e2)) else iop (val_of_exp env e1) (val_of_exp env e2) let bool_of_exp env e = match Ctypes.object_of (Cil.typeOf e) with | C_int _ -> Cvalues.bool_neq (val_of_exp env e) e_zero | C_float _ -> Cvalues.bool_neq (val_of_exp env e) e_zero_real | C_pointer _ -> Cvalues.is_false (M.is_null (loc_of_exp env e)) | _ -> assert false let exp_binop env tr binop e1 e2 = match binop with | PlusA -> arith env tr Cint.iadd Cfloat.fadd e1 e2 | MinusA -> arith env tr Cint.isub Cfloat.fsub e1 e2 | Mult -> arith env tr Cint.imul Cfloat.fmul e1 e2 | Div -> arith env tr Cint.idiv Cfloat.fdiv e1 e2 | Mod -> arith_int env tr Cint.imod e1 e2 | Shiftlt -> arith_int env tr Cint.blsl e1 e2 | Shiftrt -> arith_int env tr Cint.blsr e1 e2 | BAnd -> arith_int env tr Cint.band e1 e2 | BOr -> arith_int env tr Cint.bor e1 e2 | BXor -> arith_int env tr Cint.bxor e1 e2 | Eq -> Val (bool_of_comp env Cvalues.bool_eq M.loc_eq e1 e2) | Ne -> Val (bool_of_comp env Cvalues.bool_neq M.loc_neq e1 e2) | Lt -> Val (bool_of_comp env Cvalues.bool_lt M.loc_lt e1 e2) | Gt -> Val (bool_of_comp env Cvalues.bool_lt M.loc_lt e2 e1) | Le -> Val (bool_of_comp env Cvalues.bool_leq M.loc_leq e1 e2) | Ge -> Val (bool_of_comp env Cvalues.bool_leq M.loc_leq e2 e1) | LAnd -> Val (Cvalues.bool_and (bool_of_exp env e1) (bool_of_exp env e2)) | LOr -> Val (Cvalues.bool_or (bool_of_exp env e1) (bool_of_exp env e2)) | PlusPI | IndexPI -> let te = Cil.typeOf_pointed (Cil.typeOf e1) in let obj = Ctypes.object_of te in Loc(M.shift (loc_of_exp env e1) obj (val_of_exp env e2)) | MinusPI -> let te = Cil.typeOf_pointed (Cil.typeOf e1) in let obj = Ctypes.object_of te in Loc(M.shift (loc_of_exp env e1) obj (e_opp (val_of_exp env e2))) | MinusPP -> let te = Cil.typeOf_pointed (Cil.typeOf e1) in let obj = Ctypes.object_of te in Val(M.loc_diff obj (loc_of_exp env e1) (loc_of_exp env e2)) (* -------------------------------------------------------------------------- *) (* --- Cast --- *) (* -------------------------------------------------------------------------- *) let cast tr te ve = match Ctypes.object_of tr , Ctypes.object_of te with | C_int ir , C_int ie -> let v = cval ve in Val( if Ctypes.sub_c_int ie ir then v else Cint.iconvert ir v ) | C_float fr , C_float fe -> let v = cval ve in Val( if Ctypes.sub_c_float fe fr then v else Cfloat.fconvert fr v ) | C_int ir , C_float _ -> Val(Cint.of_real ir (cval ve)) | C_float fr , C_int _ -> Val(Cfloat.float_of_int fr (cval ve)) | C_pointer tr , C_pointer te -> let obj_r = Ctypes.object_of tr in let obj_e = Ctypes.object_of te in if Ctypes.compare obj_r obj_e = 0 then ve else Loc (M.cast {pre=obj_e;post=obj_r} (cloc ve)) | C_pointer te , C_int _ -> let e = cval ve in Loc(if F.equal e (F.e_zero) then M.null else M.loc_of_int (Ctypes.object_of te) e) | C_int ir , C_pointer _ -> Val (M.int_of_loc ir (cloc ve)) | t1, t2 when Ctypes.equal t1 t2 -> ve | _ -> Warning.error "cast (%a) into (%a) not yet implemented" Printer.pp_typ te Printer.pp_typ tr (* -------------------------------------------------------------------------- *) (* --- Exp-Node --- *) (* -------------------------------------------------------------------------- *) let exp_node env e = match e.enode with | Const (CStr s) -> Loc (M.literal ~eid:e.eid (Cstring.C_str s)) | Const (CWStr s) -> Loc (M.literal ~eid:e.eid (Cstring.W_str s)) | Const c -> Val (Cvalues.constant c) | Lval lv -> let loc = lval env lv in let typ = Cil.typeOfLval lv in let obj = Ctypes.object_of typ in M.load env obj loc | AddrOf lv | StartOf lv -> Loc (lval env lv) | UnOp(op,e,ty) -> exp_unop env ty op e | BinOp(op,e1,e2,tr) -> exp_binop env tr op e1 e2 | Info(e,_) -> !s_exp env e | AlignOfE _ | AlignOf _ | SizeOfE _ | SizeOf _ | SizeOfStr _ -> Val (Cvalues.constant_exp e) | CastE(tr,e) -> cast tr (Cil.typeOf e) (!s_exp env e) (* -------------------------------------------------------------------------- *) (* --- Exp with Error --- *) (* -------------------------------------------------------------------------- *) let exp_handler e = let ty = Cil.typeOf e in let x = Lang.freshvar ~basename:"W" (Lang.tau_of_ctype ty) in Val (e_var x) let exp_protected env e = Warning.handle ~handler:exp_handler ~severe:false ~effect:"Hide sub-term definition" (exp_node env) e (* -------------------------------------------------------------------------- *) (* --- Condition-Node --- *) (* -------------------------------------------------------------------------- *) let equal_typ t v1 v2 = match v1 , v2 with | Loc p , Loc q -> M.loc_eq p q | Val a , Val b -> p_equal a b | _ -> if Cil.isPointerType t then M.loc_eq (cloc v1) (cloc v2) else p_equal (cval v1) (cval v2) let equal_obj t v1 v2 = match v1 , v2 with | Loc p , Loc q -> M.loc_eq p q | Val a , Val b -> p_equal a b | _ -> if Ctypes.is_pointer t then M.loc_eq (cloc v1) (cloc v2) else p_equal (cval v1) (cval v2) let compare env vop lop e1 e2 = let t1 = Cil.typeOf e1 in let t2 = Cil.typeOf e2 in if Cil.isPointerType t1 && Cil.isPointerType t2 then lop (loc_of_exp env e1) (loc_of_exp env e2) else vop (val_of_exp env e1) (val_of_exp env e2) let cond_node env e = match e.enode with | UnOp( LNot, e,_) -> p_not (!s_cond env e) | BinOp( LAnd, e1,e2,_) -> p_and (!s_cond env e1) (!s_cond env e2) | BinOp( LOr, e1,e2,_) -> p_or (!s_cond env e1) (!s_cond env e2) | BinOp( Eq, e1,e2,_) -> compare env p_equal M.loc_eq e1 e2 | BinOp( Ne, e1,e2,_) -> compare env p_neq M.loc_neq e1 e2 | BinOp( Lt, e1,e2,_) -> compare env p_lt M.loc_lt e1 e2 | BinOp( Gt, e1,e2,_) -> compare env p_lt M.loc_lt e2 e1 | BinOp( Le, e1,e2,_) -> compare env p_leq M.loc_leq e1 e2 | BinOp( Ge, e1,e2,_) -> compare env p_leq M.loc_leq e2 e1 | _ -> begin match Ctypes.object_of (Cil.typeOf e) with | C_int _ -> p_neq (val_of_exp env e) e_zero | C_float _ -> p_neq (val_of_exp env e) e_zero_real | C_pointer _ -> p_not (M.is_null (loc_of_exp env e)) | obj -> Warning.error "Condition from (%a)" Ctypes.pretty obj end (* -------------------------------------------------------------------------- *) (* --- BootStrapping --- *) (* -------------------------------------------------------------------------- *) let exp env e = Context.with_current_loc e.eloc (exp_protected env) e let cond env e = Context.with_current_loc e.eloc (cond_node env) e let return env tr e = cval (cast tr (Cil.typeOf e) (exp env e)) let () = s_exp := exp let () = s_cond := cond end frama-c-Fluorine-20130601/src/wp/wpStrategy.ml0000644000175000017500000005701012155630215017720 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 = Wp_parameters.register_category "strategy" (* debugging key *) let debug fmt = Wp_parameters.debug ~dkey fmt open Cil_types open LogicUsage (* -------------------------------------------------------------------------- *) (** 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 debug_txt = try let p = NormAtLabels.preproc_annot labels p in let _ = debug "take as %s (@[%a:@ %a@])@." debug_txt WpPropId.pretty id Printer.pp_predicate_named p in Some (WpPropId.mk_pred_info id p) with e -> NormAtLabels.catch_label_error e (WpPropId.get_propid id) "annotation"; None in let add_hyp l = match get_p "hyp" with None -> l | Some p -> p::l in let add_goal l = (* if goal_to_select config id then *) match get_p "goal" with None -> l | Some p -> ( (* has_prop_goal := true; *) p::l ) (* else l *) in let add_both goal l = match get_p ("both goal=" ^ if goal then "true" else "false") 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" Printer.pp_post_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_propid 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)) = debug "[add_node_annots] on %a@." Cil2cfg.pp_node v; 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] on %a@."Cil2cfg.pp_node vloop; 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 lemma = try (* Labels does not need normalization *) let axiom = WpPropId.mk_axiom_info lemma in debug "take %a@." WpPropId.pp_axiom_info axiom; tbl.tbl_axioms <- axiom::tbl.tbl_axioms with e -> NormAtLabels.catch_label_error e ("axiom "^lemma.lem_name) "axiom" let add_all_axioms tbl = let rec do_g g = match g with | Daxiomatic (_ax_name, globs,_) -> do_globs globs | Dlemma (name,_,_,_,_,_) -> let lem = LogicUsage.logic_lemma name in add_axiom tbl lem | _ -> () and do_globs globs = List.iter do_g globs in Annotations.iter_global (fun _ -> do_g) let get_annots tbl e = try (* TODO clean : 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 get_kf s = Cil2cfg.cfg_kf s.cfg let get_bhv s = s.behavior_name let is_default_behavior s = match s.behavior_name with None -> true | Some _ -> false 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 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) (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/script.mll0000644000175000017500000001266712155630215017240 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 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' '_' '-' ]+ { Id (Lexing.lexeme lexbuf) } | [ '.' ':' ',' ';' ] { Key(Lexing.lexeme lexbuf) } | "(*" { comment 0 lexbuf } | eof { Eof } | _ { 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 } | "(*@" { skip 0 lexbuf ; proof buffer 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 } and skip n = parse | "(*" { skip (succ n) lexbuf } | "*)" { if n>0 then skip (pred n) lexbuf } | eof { () } | "\n" { newline lexbuf ; skip n lexbuf } | _ { skip n lexbuf } { let filter key = let lexbuf = Lexing.from_string key in match token lexbuf with | Id a -> Some a | _ -> None 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 key input k = match input.token with | (Key a) | (Id 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] | _ -> [] } frama-c-Fluorine-20130601/src/wp/Vset.mli0000644000175000017500000000622512155630215016643 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Lang.F (** Logical Sets *) type set = vset list and vset = | Set of tau * term | Singleton of term | Range of term option * term option | Descr of var list * term * pred val tau_of_set : tau -> tau val vars : set -> Vars.t val occurs : var -> set -> bool val empty : set val singleton : term -> set val range : term option -> term option -> set val union : set -> set -> set val inter : term -> term -> term val member : term -> set -> pred val in_size : term -> int64 -> pred val in_range : term -> term option -> term option -> pred val sub_range : term -> term -> term option -> term option -> pred val ordered : limit:bool -> strict:bool -> term option -> term option -> pred (** - [limit]: result when either parameter is [None] - [strict]: if [true], comparison is [<] instead of [<=] *) val equal : set -> set -> pred val subset : set -> set -> pred val disjoint : set -> set -> pred val concretize : set -> term val pp_bound : Format.formatter -> term option -> unit val bound_shift : term option -> term -> term option val bound_add : term option -> term option -> term option val bound_sub : term option -> term option -> term option (** {3 Maping} These operations computes different kinds of [{f x y with x in A, y in B}]. *) val map : (term -> term) -> set -> set val map_opp : set -> set (** {3 Lifting} These operations computes different sort of [{f x y with x in A, y in B}]. *) val lift : (term -> term -> term) -> set -> set -> set val lift_add : set -> set -> set val lift_sub : set -> set -> set val descr : vset -> var list * term * pred frama-c-Fluorine-20130601/src/wp/Splitter.mli0000644000175000017500000000526612155630215017534 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 tag = | MARK of stmt | THEN of stmt | ELSE of stmt | CASE of stmt * int64 list | DEFAULT of stmt | ASSERT of identified_predicate * int * int (* part / Npart *) val loc : tag -> location val pretty : Format.formatter -> tag -> unit val mark : stmt -> tag val if_then : stmt -> tag val if_else : stmt -> tag val switch_cases : stmt -> int64 list -> tag val switch_default : stmt -> tag val cases : identified_predicate -> (tag * predicate named) list option type 'a t val empty : 'a t val singleton : 'a -> 'a t val group : tag -> ('a list -> 'a) -> 'a t -> 'a t val union : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val merge : left:('a -> 'c) -> both:('a -> 'b -> 'c) -> right:('b -> 'c) -> 'a t -> 'b t -> 'c t val merge_all : ('a list -> 'a) -> 'a t list -> 'a t val length : 'a t -> int val map : ('a -> 'b) -> 'a t -> 'b t val iter : (tag list -> 'a -> unit) -> 'a t -> unit val fold : (tag list -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val exists : ('a -> bool) -> 'a t -> bool val for_all : ('a -> bool) -> 'a t -> bool val filter : ('a -> bool) -> 'a t -> 'a t frama-c-Fluorine-20130601/src/wp/ProverWhy3.mli0000644000175000017500000000501412155630215017745 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Task open VCS (* -------------------------------------------------------------------------- *) (* --- Why3 Multi-Theorem Prover --- *) (* -------------------------------------------------------------------------- *) type goal_id = { gfile : string; gtheory : string; ggoal : string; } val assemble_wpo: Wpo.t -> (string list (* includes *) * goal_id) option (** None if the po is trivial *) val prove : Wpo.t -> prover:string -> result task (** The string must be a valid why3 prover identifier Return NoResult if it is already proved by Qed *) val call_ide : includes:string list -> files:string list -> session:string -> bool Task.task type dp = { dp_name : string ; dp_version : string ; dp_prover : string ; } val detect_why3 : (dp list option -> unit) -> unit val detect_provers : (dp list -> unit) -> unit val find : string -> dp list -> dp val parse : string -> dp frama-c-Fluorine-20130601/src/wp/prover.mli0000644000175000017500000000440712155630215017237 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 VCS (* -------------------------------------------------------------------------- *) (* --- Prover Implementation against Task API --- *) (* -------------------------------------------------------------------------- *) val prove : Wpo.t -> ?interactive:bool -> ?callin:(Wpo.t -> prover -> unit) -> ?callback:(Wpo.t -> prover -> result -> unit) -> prover -> bool Task.task val spawn : Wpo.t -> ?callin:(Wpo.t -> prover -> unit) -> ?callback:(Wpo.t -> prover -> result -> unit) -> (bool * prover) list -> unit val wp_why3ide: ?callback:(Wpo.S.Hashtbl.key -> VCS.prover -> VCS.result -> unit) -> ((Wpo.t -> unit) -> unit) -> unit Task.task frama-c-Fluorine-20130601/src/wp/proof.ml0000644000175000017500000002371512155630215016701 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 : (string, string list * string) Hashtbl.t = Hashtbl.create 81 (* [ goal name -> sorted hints , script ] *) let scriptfile = ref None (* current file script name *) let needback = ref false (* file script need backup before modification *) let needsave = ref false (* file script need to be saved *) let needwarn = ref false (* user should be prompted for chosen scriptfile *) let clear () = begin Hashtbl.clear scriptbase ; scriptfile := None ; needback := false ; needsave := false ; end let register_script goal hints proof = Hashtbl.replace scriptbase goal (List.sort String.compare hints,proof) let delete_script goal = Hashtbl.remove scriptbase goal (* -------------------------------------------------------------------------- *) (* --- Proof Scripts Parsers --- *) (* -------------------------------------------------------------------------- *) open Script let is_empty script = try for i=0 to String.length script - 1 do match script.[i] with '\n' | ' ' | '\t' -> () | _ -> raise Exit done ; true with Exit -> false 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 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" ; let goals = Hashtbl.fold (fun goal _ gs -> goal::gs) scriptbase [] in List.iter (fun goal -> let (hints,proof) = Hashtbl.find scriptbase goal in Format.fprintf fmt "Goal %s.@\n" goal ; (match hints 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 ) (List.sort String.compare goals) ; 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 -> if Wp_parameters.UpdateScript.get () then try if !needback then ( Command.copy file (file ^ ".back") ; needback := false ) ; if !needwarn then ( needwarn := false ; Wp_parameters.warning ~current:false "No script file specified.@\n\ Your proofs are saved in '%s'@\n\ Use -wp-script '%s' to re-run them." file file ; ) ; dump_scripts file ; needsave := false ; with e -> Wp_parameters.abort "Error when dumping script file '%s':@\n%s" file (Printexc.to_string e) else Wp_parameters.warning ~once:true ~current:false "Script base modified : modification will not be saved" let loadscripts () = let user = Wp_parameters.Script.get () in if !scriptfile <> Some user then begin savescripts () ; begin try parse_scripts user ; with e -> Wp_parameters.error "Error in script file '%s':@\n%s" user (Printexc.to_string e) end ; if Wp_parameters.UpdateScript.get () then if user = "" then (* update new file *) begin let ftmp = choose 0 in Wp_parameters.Script.set ftmp ; scriptfile := Some ftmp ; needwarn := true ; needback := false ; end else (* update user's file *) begin scriptfile := Some user ; needback := Sys.file_exists user ; end else (* do not update *) begin scriptfile := Some user ; needback := false ; end end let find_script_for_goal goal = loadscripts () ; try Some(snd (Hashtbl.find scriptbase goal)) with Not_found -> None let update_hints_for_goal goal hints = try let old_hints,script = Hashtbl.find scriptbase goal in let new_hints = List.sort String.compare hints in if Pervasives.compare new_hints old_hints <> 0 then begin Hashtbl.replace scriptbase goal (new_hints,script) ; needsave := true ; end with Not_found -> () let rec matches n xs ys = match xs , ys with | x::rxs , y::rys -> let c = String.compare x y in if c < 0 then matches n rxs ys else if c > 0 then matches n xs rys else matches (succ n) rxs rys | _ -> n let rec filter xs ys = match xs , ys with | [] , _ -> ys | _::_ , [] -> raise Not_found | x::rxs , y::rys -> let c = String.compare x y in if c < 0 then raise Not_found else if c > 0 then y :: filter xs rys else filter rxs rys let most_suitable (n,_,_) (n',_,_) = n'-n let find_script_with_hints required hints = loadscripts () ; let required = List.sort String.compare required in let hints = List.sort String.compare hints in List.sort most_suitable begin Hashtbl.fold (fun g (xs,p) scripts -> try let n = matches 0 hints (filter required xs) in (n,g,p)::scripts with Not_found -> scripts) scriptbase [] end let add_script goal hints proof = needsave := true ; register_script goal hints proof (* -------------------------------------------------------------------------- *) (* --- Prover API --- *) (* -------------------------------------------------------------------------- *) let script_for ~pid ~gid = match find_script_for_goal gid with | None -> None | (Some _) as script -> let required,hints = WpPropId.prop_id_keys pid in let all = List.merge String.compare required hints in update_hints_for_goal gid all ; script let rec head n = function [] -> [] | x::xs -> if n > 0 then x :: head (pred n) xs else [] let hints_for ~pid = let default = match Wp_parameters.CoqTactic.get () with | "none" -> [] | tactic -> ["Default tactic",Printf.sprintf " %s.\n" tactic] in if Wp_parameters.TryHints.get () then let nhints = Wp_parameters.Hints.get () in if nhints > 0 then let required,hints = WpPropId.prop_id_keys pid in let scripts = find_script_with_hints required hints in default @ List.map (fun (_,_,s) -> "Hint",s) (head nhints scripts) else default else default let script_for_ide ~pid ~gid = match find_script_for_goal gid with | Some script -> script | None -> let required,hints = WpPropId.prop_id_keys pid in let scripts = find_script_with_hints required hints in if scripts = [] then begin match Wp_parameters.CoqTactic.get () with | "none" -> "" | tactic -> Pretty_utils.sfprintf "(* %s. *)\n" tactic end else begin let nhints = Wp_parameters.Hints.get () in Pretty_utils.sfprintf "%t" (fun fmt -> List.iter (fun (_,g,script) -> Format.fprintf fmt "(*@ --------------------------------------\n \ @ From '%s': \n%s*)\n%!" g script ) (head nhints scripts)) end frama-c-Fluorine-20130601/src/wp/Warning.mli0000644000175000017500000000573612155630215017335 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** Contextual Errors *) exception Error of string * string (** Source, Reason *) val error : ?source:string -> ('a,Format.formatter,unit,'b) format4 -> 'a (** Warning Manager *) type t = { loc : Lexing.position ; severe : bool ; source : string ; reason : string ; effect : string ; } val compare : t -> t -> int val pretty : Format.formatter -> t -> unit module Set : Set.S with type elt = t module Map : Map.S with type key = t val severe : Set.t -> bool type context val context : ?source:string -> unit -> context val flush : context -> Set.t val add : t -> unit val emit : ?severe:bool -> ?source:string -> effect:string -> ('a,Format.formatter,unit) format -> 'a (** Emit a warning in current context. Defaults: [severe=true], [source="wp"]. *) val handle : ?severe:bool -> effect:string -> handler:('a -> 'b) -> ('a -> 'b) -> 'a -> 'b (** Handle the error and emit a warning with specified severity and effect if a context has been set. Otherwise, a WP-fatal error is raised instead. Default for [severe] is false. *) type 'a outcome = | Result of Set.t * 'a | Failed of Set.t val catch : ?source:string -> ?severe:bool -> effect:string -> ('a -> 'b) -> 'a -> 'b outcome (** Set up a context for the job. If non-handled errors are raised, then a warning is emitted with specified severity and effect. Default for [severe] is [true]. *) frama-c-Fluorine-20130601/src/wp/wpAnnot.ml0000644000175000017500000016241012155630215017176 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 = Wp_parameters.register_category "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 = try let _, _, f = !rte_st () in f with Failure _ -> Wp_parameters.warning ~once:true "RTE plugin not present"; (fun _ -> false) 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 (* Seems unused *) 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"; (* both below are too strong for Runtime model. *) "signed overflow" , rte_signedOv_status , "-warn-signed-overflow"; "unsigned overflow" , rte_unsignedOv_status , "-warn-unsigned-overflow"; ] let missing_rte kf = List.map (fun (name, _, _) -> name) (List.filter (fun (_, rte, _) -> not (rte kf)) rte_wp) let compute_rte_for kf = Dynamic.Parameter.Bool.set "-rte" true ; (* RTE is using the kernel option "-safe-arrays". Its default value leads to generation of stronger properties for the model runtime. These stronger properties are necessary conditions for application of Hoare and Typed model. So, the default value of this option is not modified. Dynamic.Parameter.Bool.set "-safe-arrays" false ; (* Weakest RTE for Runtime model. *) *) List.iter (fun (_, _, opt) -> Dynamic.Parameter.Bool.set opt true) rte_wp ; !Db.RteGen.annotate_kf kf (* -------------------------------------------------------------------------- *) (* --- Selection of relevant assigns and postconditions --- *) (* -------------------------------------------------------------------------- *) (* Properties for kf-conditions of termination-kind 'tkind' *) let get_called_postconds (tkind:termination_kind) kf = let bhvs = Annotations.behaviors 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) [] bhvs 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 bhvs = Annotations.behaviors 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) [] bhvs (* -------------------------------------------------------------------------- *) (* --- Status of Unreachable Annotations --- *) (* -------------------------------------------------------------------------- *) let wp_unreachable = Emitter.create "Unreachable Annotations" [ Emitter.Property_status ] ~correctness:[] (* TBC *) ~tuning:[] (* TBC *) let set_unreachable pid = let emit p = debug "unreachable annotation %a@." Property.pretty p; Property_status.emit wp_unreachable ~hyps:[] p Property_status.True in let pids = match WpPropId.property_of_id pid with | Property.IPBehavior(kf, kinstr, bhv) -> (Property.ip_post_cond_of_behavior kf kinstr bhv) @ (Property.ip_requires_of_behavior kf kinstr bhv) | p -> Wp_parameters.result "[WP:unreachability] Goal %a : Valid" WpPropId.pp_propid pid ; [p] in List.iter emit pids (*----------------------------------------------------------------------------*) (* 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 let called_pre_p = Statuses_by_call.precondition_at_call called_kf called_pre s_call in WpPropId.mk_call_pre_id called_kf s_call called_pre called_pre_p (* -------------------------------------------------------------------------- *) (* --- Preconditions --- *) (* -------------------------------------------------------------------------- *) let call_preconditions = Statuses_by_call.all_call_preconditions_at ~warn_missing:true (* Preconditiosn at call-point as WpPropId.t *) let preconditions_at_call s vkf = let kf = Globals.Functions.get vkf in let preconds = call_preconditions kf s in let aux (pre, pre_call) = WpPropId.mk_call_pre_id kf s pre pre_call in List.map aux preconds let get_called_preconditions_at kf stmt = List.map snd (call_preconditions kf stmt) (* -------------------------------------------------------------------------- *) (* --- 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 | NamedProp of string list | 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" | NamedProp names -> Format.fprintf fmt "properties %a" (Pretty_utils.pp_list ~sep:"," Format.pp_print_string) names | IdProp p -> Format.fprintf fmt "property %s" (Property.Names.get_prop_name_id p) | CallPre (s, Some p) -> Format.fprintf fmt "pre %s at stmt %a" (Property.Names.get_prop_name_id 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_assign config pid = match config.assigns_filter, WpPropId.property_of_id pid with | NoAssigns, Property.IPAssigns _ -> false | (OnlyAssigns | WithAssigns), Property.IPAssigns _ -> true | OnlyAssigns, _ -> false | (NoAssigns | WithAssigns), _ -> true let filter_speconly config pid = if Cil2cfg.cfg_spec_only config.cfg then match WpPropId.property_of_id pid with | Property.IPPredicate( Property.PKRequires _ , _ , Kglobal , _ ) -> true | _ -> false else true let filter_status pid = Wp_parameters.StatusAll.get () || begin let module C = Property_status.Consolidation in match C.get (WpPropId.property_of_id pid) with | C.Never_tried -> true | C.Considered_valid | C.Inconsistent _ -> false | C.Valid _ | C.Valid_under_hyp _ | C.Invalid_but_dead _ | C.Valid_but_dead _ | C.Unknown_but_dead _ -> Wp_parameters.StatusTrue.get () | C.Unknown _ -> Wp_parameters.StatusMaybe.get () | C.Invalid _ | C.Invalid_under_hyp _ -> Wp_parameters.StatusFalse.get () end let filter_configstatus config pid = (match config.asked_prop with IdProp _ -> true | _ -> false) || (filter_status pid) let filter_asked config pid = match config.asked_prop with | AllProps -> true | IdProp idp -> Property.equal (WpPropId.property_of_id pid) idp | CallPre (s_call, asked_pre) -> WpPropId.select_call_pre s_call asked_pre pid | NamedProp names -> WpPropId.select_by_name names pid let rec filter config pid = function | [] -> None | (f,name)::fs -> if f config pid then filter config pid fs else Some name let dkey = Wp_parameters.register_category "select" let goal_to_select config pid = let result = filter config pid [ filter_assign , "assigns/non-assigns pass" ; filter_asked , "user selection" ; filter_configstatus , "proved status" ; filter_speconly , "no code and not main precondition" ; ] in match result with | None -> Wp_parameters.debug ~dkey "Goal '%a' selected" WpPropId.pp_propid pid ; true | Some f -> Wp_parameters.debug ~dkey "Goal '%a' skipped (%s)" WpPropId.pp_propid pid f ; false (*----------------------------------------------------------------------------*) (* 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:"") 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 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 ~once:true "Ignored 'decrease' specification:@, %a@." Printer.pp_decreases v in acc let add_terminates acc spec = (* TODO *) let _ = match spec.spec_terminates with None -> () | Some p -> Wp_parameters.warning ~once:true "Ignored 'terminates' specification:@, %a@." Printer.pp_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 is_empty_behavior bhv = bhv.b_requires = [] && bhv.b_assumes = [] && bhv.b_post_cond = [] && bhv.b_assigns = WritesAny && bhv.b_allocation = FreeAllocAny let is_empty_spec s = s.spec_variant = None && s.spec_terminates = None && List.for_all is_empty_behavior s.spec_behavior let add_stmt_spec_annots config v s spec ((b_acc, (p_acc, e_acc)) as acc) = if is_empty_spec spec then acc else 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 = Annotations.funspec 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 Kernel_function.get_called fct with | Some kf -> let spec = Annotations.funspec 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 ~once:true ~source:(fst (Stmt.loc s)) "Call through function pointer in function '%a' not implemented yet: \ ignore called function properties." Kernel_function.pretty config.kf; 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 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) = match a.annot_content with | AInvariant (b_list, true, inv) -> add_loop_invariant_annot config vloop s a b_list inv acc | AVariant (var_exp, None) -> let loop_entry, loop_back = add_variant_annot config s a var_exp loop_entry loop_back in assigns, loop_entry , loop_back , loop_core | AVariant (_v, _rel) -> Wp_parameters.warning ~once:true "Ignored 'loop variant' specification with measure : %a" Printer.pp_code_annotation a; acc | AAssigns (_,WritesAny) -> assert false | AAssigns (b_list, Writes w) -> (* 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 (a,w), check_assigns g_assigns (a,w) | TBRhyp -> check_assigns h_assigns (a,w), 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.fold_code_annot 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) = match a.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 a b_list inv acc else begin Wp_parameters.warning ~once:true "Ignored 'invariant' specification (use -wp-invariants option):@, %a" Printer.pp_code_annotation a; 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 a p in (b_acc, (a_acc, e_acc)) | TBRok | TBRpart -> let id = WpPropId.mk_assert_id config.kf s a in let kind = WpStrategy.Aboth (goal_to_select config id) in let b_acc = WpStrategy.add_prop_assert b_acc kind kf s a p in (b_acc, (a_acc, e_acc)) in acc | AAllocation (_b_list, _frees_allocates) -> (* [PB] TODO *) acc | AAssigns (_b_list, _assigns) -> (* loop assigns: see get_loop_annots *) acc | AVariant (_v, _rel) -> (* see get_loop_annots *) acc | APragma _ -> Wp_parameters.warning ~once:true "Ignored 'pragma' specification:@, %a" Printer.pp_code_annotation a; acc | AStmtSpec (b_list, spec) -> if b_list <> [] then (* TODO ! *) Wp_parameters.warning ~once:true "Ignored specification '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.fold_code_annot 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 = Annotations.funspec 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 --- *) (* ------------------------------------------------------------------------ *) module GS = Cil_datatype.Global_annotation.Set let add_global_annotations annots = let rec do_global g = let (source,_) = Cil_datatype.Global_annotation.loc g in match g with | Daxiomatic (_ax_name, globs,_) -> do_globals 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 ~once:true "Type invariant not handled yet ('%s' ignored)" linfo.l_var_info.lv_name; () | Dmodel_annot (mf,_) -> Wp_parameters.warning ~source ~once:true "Model fields not handled yet (model field '%s' ignored)" mf.mi_name; () | Dcustom_annot (_c,_n,_) -> Wp_parameters.warning ~source ~once:true "Custom annotation not handled (ignored)"; () | Dinvariant (linfo,_) -> Wp_parameters.warning ~source ~once:true "Global invariant not handled yet ('%s' ignored)" linfo.l_var_info.lv_name; () | Dlemma (name,_,_,_,_,_) -> WpStrategy.add_axiom annots (LogicUsage.logic_lemma name) and do_globals gs = List.iter do_global gs in (*[LC]: forcing order of iteration: hash is not the same on 32 and 64 bits *) let pool = ref GS.empty in Annotations.iter_global (fun _ g -> pool := GS.add g !pool); GS.iter do_global !pool; 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.code_annot ~filter:Logic_utils.is_contract stmt 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 f_bhvs = Annotations.behaviors kf 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 = Annotations.funspec kf in let add_id acc id = 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 acc (WpPropId.mk_fct_post_id kf b p) 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 = List.fold_left add_id acc (WpPropId.mk_code_annot_ids kf s a) 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.Vcall (s, _, {enode=Lval (Var vkf, NoOffset)}, _) -> Annotations.fold_code_annot (do_annot s) s acc @ preconditions_at_call s vkf | Cil2cfg.Vcall (s, _, _, _) | Cil2cfg.Vstmt s | Cil2cfg.VblkIn (Cil2cfg.Bstmt s, _) | Cil2cfg.Vtest (true, s, _) | Cil2cfg.Vloop (_, s) | Cil2cfg.Vswitch (s,_) -> Annotations.fold_code_annot (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 cfg let build_configs assigns kf behaviors ki property = debug "[get_strategies] for behaviors names: %a@." (Wp_error.pp_string_list ~sep:" " ~empty:"") (match behaviors with [] -> [""] | _ :: _ 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 def_annot_bhv, bhvs = find_behaviors kf cfg ki behaviors in if bhvs <> [] then 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 when not (Cil2cfg.cfg_spec_only config.cfg) -> let froms = Property.ip_from_of_behavior kf Kglobal b in if froms <> [] then if Wp_parameters.Froms.get () then 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 else begin Wp_parameters.warning ~current:false ~once:true "Ignoring '\\from' part of assigns specification in function '%a'" Kernel_function.pretty kf ; stgs end else stgs | _, _ -> (* TODO *) stgs in add_stgs configs (*----------------------------------------------------------------------------*) (* Public functions to build the strategies *) (*----------------------------------------------------------------------------*) let get_precond_strategies p = debug "[get_precond_strategies] %s@." (Property.Names.get_prop_name_id 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 ~once:true "No direct call sites for function '%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 Kernel_function.get_called 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@." (Property.Names.get_prop_name_id 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" (Property.Names.get_prop_name_id 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_function_strategies ?(assigns=WithAssigns) ?(bhv=[]) ?(prop=[]) kf = let prop = match prop with [] -> AllProps | _ -> NamedProp prop in get_strategies assigns kf bhv None prop frama-c-Fluorine-20130601/src/wp/GuiNavigator.mli0000644000175000017500000000357512155630215020326 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Lower Panel --- *) (* -------------------------------------------------------------------------- *) val make : Design.main_window_extension_points -> unit frama-c-Fluorine-20130601/src/wp/share/0000755000175000017500000000000012155634040016314 5ustar mehdimehdiframa-c-Fluorine-20130601/src/wp/share/cint0.mlw0000644000175000017500000001105412155630174020057 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* ---------------------------------------------------------------------- *) (* --- cint library: C-Integer Arithmetics for Alt-Ergo --- *) (* ---------------------------------------------------------------------- *) (* C-Integer Ranges *) logic is_uint8 : int -> prop logic is_sint8 : int -> prop logic is_uint16 : int -> prop logic is_sint16 : int -> prop logic is_uint32 : int -> prop logic is_sint32 : int -> prop logic is_uint64 : int -> prop logic is_sint64 : int -> prop (* C-Integer Conversion *) logic to_uint8 : int -> int logic to_sint8 : int -> int logic to_uint16 : int -> int logic to_sint16 : int -> int logic to_uint32 : int -> int logic to_sint32 : int -> int logic to_uint64 : int -> int logic to_sint64 : int -> int (* Unsigned C-Integer are positive *) axiom positive_uint8 : forall x:int [ is_uint8(x) ]. is_uint8(x) -> x>=0 axiom positive_uint16 : forall x:int [ is_uint16(x) ]. is_uint16(x) -> x>=0 axiom positive_uint32 : forall x:int [ is_uint32(x) ]. is_uint32(x) -> x>=0 axiom positive_uint64 : forall x:int [ is_uint64(x) ]. is_uint64(x) -> x>=0 (* C-Integer Conversions are in-range *) axiom is_to_uint8 : forall x:int [ is_uint8(to_uint8(x)) ]. is_uint8(to_uint8(x)) axiom is_to_sint8 : forall x:int [ is_sint8(to_sint8(x)) ]. is_sint8(to_sint8(x)) axiom is_to_uint16 : forall x:int [ is_uint16(to_uint16(x)) ]. is_uint16(to_uint16(x)) axiom is_to_sint16 : forall x:int [ is_sint16(to_sint16(x)) ]. is_sint16(to_sint16(x)) axiom is_to_uint32 : forall x:int [ is_uint32(to_uint32(x)) ]. is_uint32(to_uint32(x)) axiom is_to_sint32 : forall x:int [ is_sint32(to_sint32(x)) ]. is_sint32(to_sint32(x)) axiom is_to_uint64 : forall x:int [ is_uint64(to_uint64(x)) ]. is_uint64(to_uint64(x)) axiom is_to_sint64 : forall x:int [ is_sint64(to_sint64(x)) ]. is_sint64(to_sint64(x)) (* C-Integer Conversions are identity when in-range *) axiom id_uint8 : forall x:int [ to_uint8(x) ]. 0 <= x < 256 -> to_uint8(x) = x axiom id_sint8 : forall x:int [ to_sint8(x) ]. -128 <= x < 128 -> to_sint8(x) = x axiom id_uint16 : forall x:int [ to_uint16(x) ]. 0 <= x < 65536 -> to_uint16(x) = x axiom id_sint16 : forall x:int [ to_sint16(x) ]. -32768 <= x < 32768 -> to_sint16(x) = x axiom id_uint32 : forall x:int [ to_uint32(x) ]. 0 <= x < 4294967296 -> to_uint32(x) = x axiom id_sint32 : forall x:int [ to_sint32(x) ]. -2147483648 <= x < 2147483648 -> to_sint32(x) = x axiom id_uint64 : forall x:int [ to_uint64(x) ]. 0 <= x < 18446744073709551616 -> to_uint64(x) = x axiom id_sint64 : forall x:int [ to_sint64(x) ]. -9223372036854775808 <= x < 9223372036854775808 -> to_sint64(x) = x (* C-Integer Bits Signature *) logic lnot : int -> int logic ac land : int,int -> int logic ac lxor : int,int -> int logic ac lor : int,int -> int logic lsl : int,int -> int logic lsr : int,int -> int logic bit_test : int,int -> bool (* End of cint library *) frama-c-Fluorine-20130601/src/wp/share/cmath.mlw0000644000175000017500000000710312155630174020136 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Mathematics for Alt-Ergo --- *) (* -------------------------------------------------------------------------- *) (* Abs of integers *) logic abs_int : int -> int axiom abs_int_def : forall x:int [abs_int(x)]. (x >= 0 and abs_int(x)=x) or (x <= 0 and abs_int(x)=-x) axiom abs_int_pos : forall x:int [abs_int(x)]. 0 <= abs_int(x) (* Abs of reals *) logic abs_real : real -> real axiom abs_real_def : forall x:real [abs_real(x)]. (x >= 0.0 and abs_real(x)=x) or (x <= 0.0 and abs_real(x)=-x) axiom abs_real_pos : forall x:real [abs_real(x)]. 0.0 <= abs_real(x) (* Max/Min of integers *) logic max_int : int,int -> int logic min_int : int,int -> int axiom max_same : forall x:int [max_int(x,x)]. max_int(x,x) = x axiom min_same : forall x:int [min_int(x,x)]. min_int(x,x) = x axiom max_le : forall x,y:int [max_int(x,y)]. x <= max_int(x,y) and y <= max_int(x,y) axiom min_le : forall x,y:int [min_int(x,y)]. min_int(x,y) <= x and min_int(x,y) <= y axiom max_int_def : forall x,y:int [max_int(x,y)]. (x>=y and max_int(x,y) = x) or (x<=y and max_int(x,y) = y) axiom min_int_def : forall x,y:int [min_int(x,y)]. (x>=y and min_int(x,y) = y) or (x<=y and min_int(x,y) = x) (* Max/Min of reals *) logic max_real : real,real -> real logic min_real : real,real -> real axiom max_same : forall x:real [max_real(x,x)]. max_real(x,x) = x axiom min_same : forall x:real [min_real(x,x)]. min_real(x,x) = x axiom max_le : forall x,y:real [max_real(x,y)]. x <= max_real(x,y) and y <= max_real(x,y) axiom min_le : forall x,y:real [min_real(x,y)]. min_real(x,y) <= x and min_real(x,y) <= y axiom max_real_def : forall x,y:real [max_real(x,y)]. (x>=y and max_real(x,y) = x) or (x<=y and max_real(x,y) = y) axiom min_real_def : forall x,y:real [min_real(x,y)]. (x>=y and min_real(x,y) = y) or (x<=y and min_real(x,y) = x) frama-c-Fluorine-20130601/src/wp/share/vset.mlw0000644000175000017500000000735412155630174020033 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Classical Sets for Alt-Ergo --- *) (* -------------------------------------------------------------------------- *) type 'a set logic empty : 'a set logic singleton : 'a -> 'a set logic ac union : 'a set,'a set -> 'a set logic ac inter : 'a set,'a set -> 'a set logic member : 'a,'a set -> prop logic member_bool : 'a,'a set -> bool logic range_all : int set (* [..] *) logic range_sup : int -> int set (* [a..] *) logic range_inf : int -> int set (* [..b] *) logic range : int,int -> int set (* [a..b] *) predicate eqset(a : 'a set,b : 'a set) = forall x : 'a. member(x,a) <-> member(x,b) predicate subset(a : 'a set,b : 'a set) = forall x : 'a. member(x,a) -> member(x,b) predicate disjoint(a : 'a set,b : 'a set) = forall x : 'a. member(x,a) -> member(x,b) -> false (* -------------------------------------------------------------------------- *) axiom member_bool : forall x:'a. forall s:'a set [member_bool(x,s)]. if member_bool(x,s) then member(x,s) else not(member(x,s)) axiom member_empty : forall x:'a [member(x,empty)]. not (member(x,empty)) axiom member_singleton : forall x,y:'a [member(x,singleton(y))]. member(x,singleton(y)) <-> x=y axiom member_union : forall x:'a. forall a,b:'a set [member(x,union(a,b))]. member(x,union(a,b)) <-> member(x,a) or member(x,b) axiom member_inter : forall x:'a. forall a,b:'a set [member(x,inter(a,b))]. member(x,inter(a,b)) <-> member(x,a) and member(x,b) axiom union_empty : forall a:'a set [union(a,empty)|union(empty,a)]. union(a,empty) = a and union(empty,a) = a axiom inter_empty : forall a:'a set [inter(a,empty)|inter(empty,a)]. inter(a,empty) = empty and inter(empty,a) = empty axiom member_range : forall x,a,b:int [member(x,range(a,b))]. member(x,range(a,b)) <-> (a <= x and x <= b) axiom member_range_sup : forall x,a:int [member(x,range_sup(a))]. member(x,range_sup(a)) <-> (a <= x) axiom member_range_inf : forall x,b:int [member(x,range_inf(b))]. member(x,range_inf(b)) <-> (x <= b) axiom member_range_all : forall x:int [member(x,range_all)]. member(x,range_all) frama-c-Fluorine-20130601/src/wp/share/memory.mlw0000644000175000017500000001113112155630174020346 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Addresses and Memories for Alt-Ergo --- *) (* -------------------------------------------------------------------------- *) (* Addresses *) type addr = { base : int ; offset : int } logic addr_le : addr,addr -> prop logic addr_lt : addr,addr -> prop axiom addr_le_def : forall p,q:addr [ addr_le(p,q) ]. p.base = q.base -> (addr_le(p,q) <-> p.offset <= q.offset) axiom addr_lt_def : forall p,q:addr [ addr_lt(p,q) ]. p.base = q.base -> (addr_lt(p,q) <-> p.offset < q.offset) logic addr_le_bool : addr,addr -> bool logic addr_lt_bool : addr,addr -> bool axiom addr_le_bool_def: forall p,q:addr [ addr_le_bool(p,q) ]. addr_le(p,q) <-> addr_le_bool(p,q) = true axiom addr_lt_bool_def: forall p,q:addr [ addr_lt_bool(p,q) ]. addr_lt(p,q) <-> addr_lt_bool(p,q) = true (* Pointer Arithmetic *) function null () : addr = { base = 0 ; offset = 0 } function global( b:int ) : addr = { base = b ; offset = 0 } function base( p:addr ) : int = p.base function offset( p:addr ) : int = p.offset function shift( p:addr , k:int ) : addr = { p with offset = p.offset + k } predicate included (p:addr,a:int,q:addr,b:int) = a > 0 -> ( b >= 0 and p.base = q.base and (q.offset <= p.offset) and (p.offset + a <= q.offset + b) ) predicate separated (p:addr,a:int,q:addr,b:int) = a <= 0 or b <= 0 or p.base <> q.base or q.offset + b <= p.offset or p.offset + a <= q.offset predicate eqmem (m1:(addr,'a)farray, m2:(addr,'a)farray, p:addr, a:int) = forall q:addr [m1[q]|m2[q]]. included(q,1,p,a) -> m1[q] = m2[q] predicate havoc (m1:(addr,'a)farray, m2:(addr,'a)farray, p:addr, a:int) = forall q:addr [m1[q]|m2[q]]. separated(q,1,p,a) -> m1[q] = m2[q] predicate valid_rd (m : int farray , p : addr , n : int) = (n > 0) -> ( 0 <= p.offset and p.offset + n <= m[p.base] ) predicate valid_rw (m : int farray , p : addr , n : int) = (n > 0) -> ( 0 < p.base and 0 <= p.offset and p.offset + n <= m[p.base] ) axiom separated_1 : forall p,q:addr. separated(p,1,q,1) -> p<>q axiom separated_k : forall p,q:addr. forall a,b,i,j:int [ separated(p,a,q,b) , {base=p.base;offset=i} , {base=q.base;offset=j} ]. separated(p,a,q,b) -> p.offset <= i < p.offset + a -> q.offset <= j < q.offset + b -> {base=p.base;offset=i} <> {base=q.base;offset=j} (* Regions *) logic region : int -> int logic linked : (int,int) farray -> prop (* Allocation Table *) logic sconst : (addr,int) farray -> prop (* Chars Memory *) predicate framed( m : (addr,addr) farray ) = forall p:addr [m[p]]. region(m[p].base) = 0 (* Cast to Integer *) logic cast : addr -> int axiom cast_injective : forall p,q : addr [cast(p),cast(q)]. cast(p) = cast(q) -> p = q (* Physical Addresses *) logic hardware : int -> int (* returns the offset in base NULL *) axiom hardnull : hardware(0) = 0 (* To be discussed: logic hardware_injective : forall p,q : int [hardware(p),hardware(q)]. hardware(p) = hardware(q) -> p = q *) frama-c-Fluorine-20130601/src/wp/share/cbits.mlw0000644000175000017500000002510312155630174020146 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* ---------------------------------------------------------------------- *) (* --- cbits library: C-Integer Arithmetics for Alt-Ergo --- *) (* ---------------------------------------------------------------------- *) (* Some properties of bit extration *) axiom lnot_extraction: forall x, i:int [bit_test(lnot(x),i)]. 0<=i -> bit_test (lnot(x), i) = notb (bit_test(x,i)) axiom land_extraction: forall x,y,i:int [bit_test(land(x, y),i)]. 0<=i -> bit_test (land(x, y), i) = andb (bit_test(x,i),bit_test(y,i)) axiom lor_extraction : forall x,y,i:int [bit_test(lor(x,y),i)]. 0<=i -> bit_test (lor(x,y), i) = orb (bit_test(x,i),bit_test(y,i)) axiom lxor_extraction: forall x,y,i:int [bit_test(lxor(x,y),i)]. 0<=i -> bit_test (lxor(x,y),i) = xorb (bit_test(x,i),bit_test(y,i)) axiom lsl_extraction_sup: forall x,n,m:int [bit_test(lsl(x,n),m)]. 0<=n -> 0<=m -> m>=n -> bit_test(lsl(x,n),m)=bit_test(x,m-n) axiom lsl_extraction_inf: forall x,n,m:int [bit_test(lsl(x,n),m)]. 0<=n -> 0<=m -> m< n -> bit_test(lsl(x,n),m)=false axiom lsr_extraction: forall x,n,m:int [bit_test(lsr(x,n),m)]. 0<=n -> 0<=m -> bit_test(lsr(x,n),m)=bit_test(x,m+n) axiom lsl1_extraction: forall i,j:int [bit_test(lsl(1,i),j)]. 0<=i -> 0<=j -> bit_test(lsl(1,i),j) = eqb(i,j) (* sint8 *) axiom to_sint8_extraction_sup: forall x,i:int [is_sint8(x),bit_test(x,i)]. 7<=i -> is_sint8(x) -> x>=0 -> bit_test(x,i) = zlt(x,0) axiom to_sint8_extraction_inf: forall x,i:int [bit_test(to_sint8(x),i)]. 0<=i<8 -> bit_test(to_sint8(x),i)=bit_test(x,i) (* uint8 *) axiom to_uint8_extraction_sup: forall x,i:int [is_uint8(x),bit_test(x,i)]. 8<=i -> is_uint8(x) -> bit_test(x,i)=false axiom to_uint8_extraction_inf: forall x,i:int [bit_test(to_uint8(x),i)]. 0<=i<8 -> bit_test(to_uint8(x),i)=bit_test(x,i) (* sint16 *) axiom to_sint16_extraction_sup: forall x,i:int [is_sint16(x),bit_test(x,i)]. 15<=i -> is_sint16(x) -> bit_test(x,i) = zlt(x,0) axiom to_sint16_extraction_inf: forall x,i:int [bit_test(to_sint16(x),i)]. 0<=i<16 -> bit_test(to_sint16(x),i)=bit_test(x,i) (* uint16 *) axiom to_uint16_extraction_sup: forall x,i:int [is_uint16(x),bit_test(x,i)]. 16<=i -> is_uint16(x) -> bit_test(x,i)=false axiom to_uint16_extraction_inf: forall x,i:int [bit_test(to_uint16(x),i)]. 0<=i<16 -> bit_test(to_uint16(x),i)=bit_test(x,i) (* sint32 *) axiom to_sint32_extraction_sup: forall x,i:int [is_sint32(x),bit_test(x,i)]. 31<=i -> is_sint32(x) -> bit_test(x,i) = zlt(x,0) axiom to_sint32_extraction_inf: forall x,i:int [bit_test(to_sint32(x),i)]. 0<=i<32 -> bit_test(to_sint32(x),i)=bit_test(x,i) (* uint32 *) axiom to_uint32_extraction_sup: forall x,i:int [is_uint32(x),bit_test(x,i)]. 32<=i -> is_uint32(x) -> bit_test(x,i)=false axiom to_uint32_extraction_inf: forall x,i:int [bit_test(to_uint32(x),i)]. 0<=i<32 -> bit_test(to_uint32(x),i)=bit_test(x,i) (* sint64 *) axiom to_sint64_extraction_sup: forall x,i:int [is_sint64(x),bit_test(x,i)]. 63<=i -> is_sint64(x) -> bit_test(x,i) = zlt(x,0) axiom to_sint64_extraction_inf: forall x,i:int [bit_test(to_sint64(x),i)]. 0<=i<64 -> bit_test(to_sint64(x),i)=bit_test(x,i) (* uint64 *) axiom to_uint64_extraction_sup: forall x,i:int [is_uint64(x),bit_test(x,i)]. 64<=i -> is_uint64(x) -> bit_test(x,i)=false axiom to_uint64_extraction_inf: forall x,i:int [bit_test(to_uint64(x),i)]. 0<=i<64 -> bit_test(to_uint64(x),i)=bit_test(x,i) (* Some C-Integer Bits Conversions are identity *) (* Signed conversions *) (* sint8 *) axiom is_sint8_lnot : forall x:int [to_sint8(lnot(x))]. is_sint8(x) -> lnot(x)=to_sint8(lnot(x)) axiom is_sint8_lxor : forall x,y:int [to_sint8(lxor(x,y))]. is_sint8(x) -> is_sint8(y) -> lxor(x,y)=to_sint8(lxor(x,y)) axiom is_sint8_lor : forall x,y:int [to_sint8(lor(x,y))]. is_sint8(x) -> is_sint8(y) -> lor(x,y)=to_sint8(lor(x,y)) axiom is_sint8_land : forall x,y:int [to_sint8(land(x,y))]. is_sint8(x) -> is_sint8(y) -> land(x,y)=to_sint8(land(x,y)) axiom is_sint8_lsr : forall x,y:int [to_sint8(lsr(x,y))]. 0<=y -> is_sint8(x) -> lsr(x,y)=to_sint8(lsr(x,y)) axiom is_sint8_lsl1 : lsl(1,7)=128 axiom is_sint8_lsl1_inf : forall y:int [lsl(1,y)]. 0<=y<7 -> is_sint8(lsl(1,y)) axiom is_sint8_lsl1_sup : forall y:int [to_sint8(lsl(1,y))]. 8<=y -> 0=to_sint8(lsl(1,y)) (* sint16 *) axiom is_sint16_lnot : forall x:int [to_sint16(lnot(x))]. is_sint16(x) -> lnot(x)=to_sint16(lnot(x)) axiom is_sint16_lxor : forall x,y:int [to_sint16(lxor(x,y))]. is_sint16(x) -> is_sint16(y) -> lxor(x,y)=to_sint16(lxor(x,y)) axiom is_sint16_lor : forall x,y:int [to_sint16(lor(x,y))]. is_sint16(x) -> is_sint16(y) -> lor(x,y)=to_sint16(lor(x,y)) axiom is_sint16_land : forall x,y:int [to_sint16(land(x,y))]. is_sint16(x) -> is_sint16(y) -> land(x,y)=to_sint16(land(x,y)) axiom is_sint16_lsr : forall x,y:int [to_sint16(lsr(x,y))]. 0<=y -> is_sint16(x) -> lsr(x,y)=to_sint16(lsr(x,y)) axiom is_sint16_lsl1 : lsl(1,15)=32768 axiom is_sint16_lsl1_inf : forall y:int [lsl(1,y)]. 0<=y<15 -> is_sint16(lsl(1,y)) axiom is_sint16_lsl1_sup : forall y:int [to_sint16(lsl(1,y))]. 16<=y -> 0=to_sint16(lsl(1,y)) (* sint32 *) axiom is_sint32_lnot : forall x:int [to_sint32(lnot(x))]. is_sint32(x) -> lnot(x)=to_sint32(lnot(x)) axiom is_sint32_lxor : forall x,y:int [to_sint32(lxor(x,y))]. is_sint32(x) -> is_sint32(y) -> lxor(x,y)=to_sint32(lxor(x,y)) axiom is_sint32_lor : forall x,y:int [to_sint32(lor(x,y))]. is_sint32(x) -> is_sint32(y) -> lor(x,y)=to_sint32(lor(x,y)) axiom is_sint32_land : forall x,y:int [to_sint32(land(x,y))]. is_sint32(x) -> is_sint32(y) -> land(x,y)=to_sint32(land(x,y)) axiom is_sint32_lsr : forall x,y:int [to_sint32(lsr(x,y))]. 0<=y -> is_sint32(x) -> lsr(x,y)=to_sint32(lsr(x,y)) axiom is_sint32_lsl1 : lsl(1,31)=2147483648 axiom is_sint32_lsl1_inf : forall y:int [lsl(1,y)]. 0<=y<31 -> is_sint32(lsl(1,y)) axiom is_sint32_lsl1_sup : forall y:int [to_sint32(lsl(1,y))]. 32<=y -> 0=to_sint32(lsl(1,y)) (* sint64 *) axiom is_sint64_lnot : forall x:int [to_sint64(lnot(x))]. is_sint64(x) -> lnot(x)=to_sint64(lnot(x)) axiom is_sint64_lxor : forall x,y:int [to_sint64(lxor(x,y))]. is_sint64(x) -> is_sint64(y) -> lxor(x,y)=to_sint64(lxor(x,y)) axiom is_sint64_lor : forall x,y:int [to_sint64(lor(x,y))]. is_sint64(x) -> is_sint64(y) -> lor(x,y)=to_sint64(lor(x,y)) axiom is_sint64_land : forall x,y:int [to_sint64(land(x,y))]. is_sint64(x) -> is_sint64(y) -> land(x,y)=to_sint64(land(x,y)) axiom is_sint64_lsr : forall x,y:int [to_sint64(lsr(x,y))]. 0<=y -> is_sint64(x) -> lsr(x,y)=to_sint64(lsr(x,y)) axiom is_sint64_lsl1 : lsl(1,63)=9223372036854775808 axiom is_sint64_lsl1_inf : forall y:int [lsl(1,y)]. 0<=y<63 -> is_sint64(lsl(1,y)) axiom is_sint64_lsl1_sup : forall y:int [to_sint64(lsl(1,y))]. 64<=y -> 0=to_sint64(lsl(1,y)) (* Unsigned conversions *) (* uint8 *) axiom is_uint8_lor : forall x,y:int [to_uint8(lor(x,y))]. is_uint8(x) -> is_uint8(y) -> lor(x,y)=to_uint8(lor(x,y)) axiom is_uint8_land : forall x,y:int [to_uint8(land(x,y))]. is_uint8(x) -> is_uint8(y) -> land(x,y)=to_uint8(land(x,y)) axiom is_uint8_lsr : forall x,y:int [to_uint8(lsr(x,y))]. 0<=y -> is_uint8(x) -> lsr(x,y)=to_uint8(lsr(x,y)) axiom is_uint8_lsl1_inf : forall y:int [to_uint8(lsl(1,y))]. 0<=y<8 -> lsl(1,y)=to_uint8(lsl(1,y)) axiom is_uint16_lsl1_sup : forall y:int [to_uint8(lsr(1,y))]. 8<=y -> 0=to_uint8(lsl(1,y)) (* uint16 *) axiom is_uint16_lor : forall x,y:int [to_uint16(lor(x,y))]. is_uint16(x) -> is_uint16(y) -> lor(x,y)=to_uint16(lor(x,y)) axiom is_uint16_land : forall x,y:int [to_uint16(land(x,y))]. is_uint16(x) -> is_uint16(y) -> land(x,y)=to_uint16(land(x,y)) axiom is_uint16_lsr : forall x,y:int [to_uint16(lsr(x,y))]. 0<=y -> is_uint16(x) -> lsr(x,y)=to_uint16(lsr(x,y)) axiom is_uint16_lsl1_inf : forall y:int [to_uint16(lsr(1,y))]. 0<=y<16 -> lsr(1,y)=to_uint16(lsr(1,y)) axiom is_uint16_lsl1_sup : forall y:int [to_uint16(lsr(1,y))]. 16<=y -> 0=to_uint16(lsr(1,y)) (* uint32 *) axiom is_uint32_lor : forall x,y:int [to_uint32(lor(x,y))]. is_uint32(x) -> is_uint32(y) -> lor(x,y)=to_uint32(lor(x,y)) axiom is_uint32_land : forall x,y:int [to_uint32(land(x,y))]. is_uint32(x) -> is_uint32(y) -> land(x,y)=to_uint32(land(x,y)) axiom is_uint32_lsr : forall x,y:int [to_uint32(lsr(x,y))]. 0<=y -> is_uint32(x) -> lsr(x,y)=to_uint32(lsr(x,y)) axiom is_uint32_lsl1_inf : forall y:int [to_uint32(lsr(1,y))]. 0<=y<32 -> lsr(1,y)=to_uint32(lsr(1,y)) axiom is_uint16_lsl1_sup : forall y:int [to_uint32(lsr(1,y))]. 32<=y -> 0=to_uint32(lsr(1,y)) (* uint64 *) axiom is_uint64_lor : forall x,y:int [to_uint64(lor(x,y))]. is_uint64(x) -> is_uint64(y) -> lor(x,y)=to_uint64(lor(x,y)) axiom is_uint64_land : forall x,y:int [to_uint64(land(x,y))]. is_uint64(x) -> is_uint64(y) -> land(x,y)=to_uint64(land(x,y)) axiom is_uint64_lsr : forall x,y:int [to_uint64(lsr(x,y))]. 0<=y -> is_uint64(x) -> lsr(x,y)=to_uint64(lsr(x,y)) axiom is_uint64_lsl1_inf : forall y:int [to_uint64(lsr(1,y))]. 0<=y<64 -> lsr(1,y)=to_uint64(lsr(1,y)) axiom is_uint16_lsl1_sup : forall y:int [to_uint64(lsl(1,y))]. 64<=y -> 0=to_uint64(lsl(1,y)) (* End of cbits library *) frama-c-Fluorine-20130601/src/wp/share/qed.why0000644000175000017500000000453712155630174017633 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* Additional Libraries for Why-3 *) theory Arith use import bool.Bool use import int.Int use import real.RealInfix use import real.FromInt function eqb 'a 'a : bool axiom eqb : forall x:'a, y:'a. eqb x y = True <-> x = y function neqb 'a 'a : bool axiom neqb : forall x:'a, y:'a. neqb x y = True <-> x <> y function zlt int int : bool function zleq int int : bool axiom zlt : forall x:int, y:int. zlt x y = True <-> x < y axiom zleq : forall x:int, y:int. zleq x y = True <-> x <= y function rlt real real : bool function rleq real real : bool axiom rlt : forall x:real, y:real. rlt x y = True <-> x <. y axiom rleq : forall x:real, y:real. rleq x y = True <-> x <=. y function real_of_int (x:int) : real = FromInt.from_int x end frama-c-Fluorine-20130601/src/wp/share/Cbits.v0000644000175000017500000013201012155630174017550 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** * ACSL Logical and Bitwise Operators *) (* -------------------------------------------------------------------------- *) (** The characteristic function of integers have {!arith:arithmetic} properties and allows to define logical operators over [Z]. Logical [land], [lor], [lxor] and [lnot] are defined as the lifting over bits of the associated boolean operators. As a corollary, the consistency of bitwise [lnot] definition and two's complements [zlnot] is assessed. These definitions are provided in two stages: - {!bitwise:bitwise} definitions of logical operators - {!ACSL:ACSL} operators definitions *) (** ** Tacticals *) Require Import ZArith. Require Import FunctionalExtensionality. Require Import Qedlib. Require Import Cint. Require Import Bits. Open Local Scope Z_scope. Local Ltac omegaContradiction := cut False; [contradiction|omega]. Local Ltac caseEq name := generalize (refl_equal name); pattern name at -1 in |- *; case name. Local Ltac unfold_hyp h := match goal with | h:(?X1) |- _ => unfold X1 in h | h:(?X1 _ ) |- _ => unfold X1 in h | h:(?X1 _ _) |- _ => unfold X1 in h | h:(?X1 _ _ _) |- _ => unfold X1 in h | h:(?X1 _ _ _ _) |- _ => unfold X1 in h | _ => idtac end. Lemma split_range: forall a x b: Z, a <= x -> x < b -> a <= x < b. Proof. intros. omega. Qed. (** Some remarks about absolute value *) Remark zabs_gt: forall n m: Z, Zabs m < Zabs n -> (Zabs_nat m < Zabs_nat n)%nat. Proof. intros. apply (inj_lt_rev (Zabs_nat m) (Zabs_nat n)). rewrite (inj_Zabs_nat n). rewrite (inj_Zabs_nat m). omega. Qed. Remark zabs_le: forall n m: Z, Zabs n <= Zabs m -> (Zabs_nat n <= Zabs_nat m)%nat. Proof. intros. apply (inj_le_rev (Zabs_nat n) (Zabs_nat m)). rewrite (inj_Zabs_nat n). rewrite (inj_Zabs_nat m). omega. Qed. Remark zabs_le_plus: forall (n m:Z) (k: nat), Zabs n <= Zabs m -> (Zabs_nat n <= k + Zabs_nat m)%nat. Proof. intros. apply (inj_le_rev (Zabs_nat n) (k + Zabs_nat m)%nat). rewrite (inj_Zabs_nat n). rewrite inj_plus. rewrite (inj_Zabs_nat m). omega. Qed. Remark zabs_nat_zabs: forall n: Z, Zabs_nat (Zabs n) = Zabs_nat n. Proof. intro. rewrite <- (inj_Zabs_nat n). rewrite Zabs_nat_Z_of_nat. auto. Qed. Remark zabs_minus: forall n m: Z, Zabs n <= Zabs m -> (Zabs_nat m - Zabs_nat n)%nat = Zabs_nat (Zabs m - Zabs n). Proof. intros. rewrite Zabs_nat_Zminus by (generalize (Zabs_pos n); omega). repeat rewrite zabs_nat_zabs. auto. Qed. Remark zabs_plus: forall n m: Z, (Zabs_nat m + Zabs_nat n)%nat = Zabs_nat (Zabs m + Zabs n). Proof. intros. rewrite Zabs_nat_Zplus. (** cont. *) repeat rewrite zabs_nat_zabs. auto. (** hyp 1 *) generalize (Zabs_pos m). omega. (** hyp 2 *) generalize (Zabs_pos n). omega. Qed. (** Some usefull properties *) Remark upper_positive_mult_positive: forall p x: Z, 0 <= x -> 0 < p -> x <= x * p. Proof. intros. rewrite <- Zmult_1_r at 1. apply Zmult_le_compat_l; omega. Qed. Remark lower_negative_mult_positive: forall p x: Z, x <= 0 -> 0 < p -> x * p <= x. Proof. intros. cut (-x <= -(x * p)). omega. rewrite Zopp_mult_distr_l. apply upper_positive_mult_positive; omega. Qed. (* -------------------------------------------------------------------------- *) (** {@arith:} *) (** * Arithmetic Properties of the Characteristic Function of integers *) (* -------------------------------------------------------------------------- *) Remark Zbit_2x_0: forall x: Z, Zbit (2 * x) O = false. Proof. unfold Zbit. unfold bits_of_Z. intro. case_leq 0 (2*x); intro; unfold btest. (** case 0 <= 2*x *) unfold Nabs. unfold N_decomp. unfold P_decomp. destruct x; auto. (** case 0 > 2*x *) unfold zlnot. destruct x; auto. destruct p; simpl; auto. Qed. Remark Zle_2x: forall x:Z, Zle_bool 0 (2*x) = Zle_bool 0 x. Proof. induction x; auto. Qed. Remark Zbit_2x_p: forall (n:nat) (x:Z), Zbit (2*x) (S n) = Zbit x n. Proof. intros. unfold Zbit; unfold bits_of_Z; rewrite Zle_2x. case_leq 0 x; intro; unfold btest. (** case 0<=x *) unfold Nabs; unfold N_decomp; unfold P_decomp; destruct x; auto. (** case 0>x *) unfold zlnot; destruct x; [ compute in H; discriminate H | discriminate H | destruct p; simpl; auto]. Qed. Remark Zle_div2: forall x:Z, Zle_bool 0 (x/2) = Zle_bool 0 x. Proof. intro x. case_leq 0 (x/2); case_leq 0 x; try auto; intros; apply False_ind. (** 0>x *) assert (x/2 < 0); [ apply Zdiv_lt_upper_bound | ]; omega. (** 0<=x *) assert (0 <= (x/2)); [ apply Z_div_pos | ]; omega. Qed. Remark Zbit_div2: forall (n:nat) (x:Z), Zbit (x/2) n = Zbit x (S n). Proof. intros. unfold Zbit; unfold bits_of_Z; rewrite Zle_div2. case_leq 0 x; intro; unfold btest; unfold Nabs; unfold N_decomp; unfold P_decomp. (** case 0<=x *) destruct x; [by compute | | (apply False_ind; compute in H; auto) ]. destruct p. (** 2p+1 *) rewrite <- (Zdiv_unique (Zpos (xI (p)) ) 2 (Zpos p) 1); by compute. (** 2p *) rewrite <- (Zdiv_unique (Zpos (xO (p)) ) 2 (Zpos p) 0); by compute. (** one *) by compute. (** case 0>x *) unfold zlnot. destruct x; [ by compute | (compute in H; discriminate H) | ]. destruct p. (** -(2p+1) *) rewrite <- (Zdiv_unique (Zneg (xI (p)) ) 2 (Zneg p - 1) 1); [ (replace (Zneg p - 1 + 1) -> (Zneg p) by omega); (replace (-Zneg p) -> (Zpos p) by compute); replace (-(Zneg (xI (p)) + 1)) -> (Zpos (xO(p))) by compute | | replace (2*(Zneg p - 1) + 1) -> (2*Zneg p - 1) by omega ]; by compute. (** -2p *) rewrite <- (Zdiv_unique (Zneg (xO (p)) ) 2 (Zneg p) 0); [ | by compute | by compute]. replace (-(Zneg (xO (p)) + 1)) -> (Zpos (xO(p)) - 1) by compute. replace (-(Zneg p + 1)) -> ((-Zneg p) - 1) by omega. replace (- Zneg p) -> (Zpos p) by compute. destruct p; [ (** -2(2p+1) *) (replace (Zpos (xI(p)) -1) -> (Zpos (xO(p))) by compute); replace (Zpos (xO(xI(p))) -1) -> (Zpos (xI(xO(p)))) by compute | (** -2(2p) *) | (** -2 *) ]; by compute. (** minus one *) by compute. Qed. Lemma Zbit_shift_l: forall (n m:nat) (x:Z), Zbit (x * (two_power_nat n)) m = if leb n m then Zbit x (m - n)%nat else false. Proof. induction n; intros. (** base *) rewrite (leb_correct O m) by omega. unfold two_power_nat. unfold shift_nat. rewrite <- (minus_n_O m). f_equal. simpl. omega. (** ind. *) rewrite two_power_nat_S. replace (x * (2 * two_power_nat n)) -> ((2 * x) * two_power_nat n) by ring. rewrite (IHn m (2*x)). nat_compare Inf EQ Sup n m. (** nm *) rewrite (leb_correct_conv m n) by omega. rewrite (leb_correct_conv m (S n)) by omega. auto. Qed. Lemma Zbit_shift_r: forall (n m:nat) (x:Z), Zbit (x / (two_power_nat n)) m = Zbit x (n + m)%nat. Proof. induction n; intros. (** base *) unfold two_power_nat. unfold shift_nat. f_equal. simpl. apply Zdiv_1_r. (** ind. *) rewrite two_power_nat_S. replace (2 * two_power_nat n) -> ((two_power_nat n)*2) by ring. rewrite <- Zdiv_Zdiv; [ | generalize (two_power_nat_is_positive n); omega | omega]. rewrite (plus_Snm_nSm n m). rewrite <- (IHn (S m) x). apply Zbit_div2. Qed. (** {@bitwise:} *) (** * Bitwise Shifting Operators *) Program Definition bitwise_lsl (x: bits) (n:nat): bits := let sign := (bsign x) in let btest := (fun i: nat => if leb n i %nat then btest x (i - n)%nat else false) in let last := last btest ((bsize x) + n) sign in mkbits last sign btest _ . Next Obligation. apply trailing_last. generalize (btrail x). unfold trailing. intro Tx. intro k. nat_compare Inf EQ Sup n k. (** n < k *) rewrite (leb_correct n k) by omega. intros. rewrite (Tx (k - n)%nat) by omega. auto. (** n = k *) rewrite (leb_correct n n) by omega. intros. rewrite (Tx (n - n)%nat) by omega. auto. (** n > k *) intro. omegaContradiction. Qed. Program Definition bitwise_lsr (x: bits) (n:nat): bits := let sign := (bsign x) in let btest := (fun i: nat => btest x (i + n)%nat) in let last := last btest (bsize x) sign in mkbits last sign btest _ . Next Obligation. apply trailing_last. generalize (btrail x). unfold trailing. intro Tx. intros. rewrite (Tx (k + n)%nat); auto with arith. Qed. Definition lsl_shift_def (x:Z) (n:nat): Z := Z_of_bits (bitwise_lsl (bits_of_Z x) n). Definition lsr_shift_def (x:Z) (n:nat): Z := Z_of_bits (bitwise_lsr (bits_of_Z x) n). (** ** Link between bitwise shifting operators and arithmetics *) Definition lsl_arithmetic_def (x:Z) (n:nat): Z := x * (two_power_nat n). Lemma lsl_arithmetic_shift: lsl_shift_def = lsl_arithmetic_def. Proof. extensionality x; extensionality n; Zbit_ext k. (** right term *) unfold lsl_arithmetic_def; rewrite (Zbit_shift_l n k x). (** left term *) unfold lsl_shift_def; unfold Zbit; rewrite Z_decomp_recomp; unfold bitwise_lsl; unfold btest. auto. Qed. Definition lsr_arithmetic_def (x:Z) (n:nat): Z := x / (two_power_nat n). (** Note: [lsr_arithmetic_def x n] is different than [lsr_arithmetic_def x (two_power_nat n)] for negative [x]. *) Remark lsr_differs_to_Cdiv: lsr_arithmetic_def (-1) 1%nat <> Cdiv (-1) (two_power_nat 1). Proof. by compute. Qed. Lemma lsr_arithmetic_shift: lsr_shift_def = lsr_arithmetic_def. Proof. extensionality x; extensionality n; Zbit_ext k. (** right term *) unfold lsr_arithmetic_def; rewrite (Zbit_shift_r n k x); replace (n+k)%nat -> (k+n)%nat by omega. (** left term *) unfold lsr_shift_def; unfold Zbit; rewrite Z_decomp_recomp; unfold bitwise_lsr; unfold btest. auto. Qed. (** * Bitwise Logical Operators *) Program Definition bitwise (f: bool -> bool -> bool) (x y: bits): bits := let sign := f (bsign x) (bsign y) in let btest := (fun i: nat => f (btest x i) (btest y i)) in let last := last btest (max (bsize x) (bsize y)) sign in mkbits last sign btest _ . Next Obligation. apply trailing_last. generalize (btrail x). generalize (btrail y). unfold trailing. intros Ty Tx k Max. rewrite Tx. rewrite Ty. trivial. generalize (Max.max_lub_r (bsize x) (bsize y) k). omega. generalize (Max.max_lub_l (bsize x) (bsize y) k). omega. Qed. Definition Z_bitwise (f: bool -> bool -> bool) (x y: Z): Z := Z_of_bits (bitwise f (bits_of_Z x) (bits_of_Z y)). (** ** Properties of Bitwise Logical Operators *) Lemma Zbit_bitwise: forall (f: bool -> bool -> bool) (x y: Z) (k: nat), Zbit (Z_bitwise f x y) k = f (Zbit x k) (Zbit y k). Proof. intros. unfold Zbit. unfold Z_bitwise. rewrite Z_decomp_recomp. auto. Qed. (** Tactical. *) Ltac Zbit_bitwise k := Zbit_ext k; repeat rewrite Zbit_bitwise. (** Range of bitwise operators *) Lemma Z_bitwise_ZxHpos: forall (f: bool -> bool -> bool) (x y: Z), (ZxHpos (Z_bitwise f x y) <= max (ZxHpos x) (ZxHpos y))%nat. Proof. intros f x y. unfold Z_bitwise. rewrite (bsize_over_approx). unfold bitwise. unfold btest at 1; unfold bsize at 1; unfold bsign at 3; apply Max.max_case_strong; rewrite <- (bsize_exact x); rewrite <- (bsize_exact y); intro CASE. (** (ZxHpos y <= ZxHpos x) *) rewrite Max.max_l by auto. generalize (last_leq (fun i: nat => f (btest (bits_of_Z x) i) (btest (bits_of_Z y) i)) (ZxHpos x) (f (bsign (bits_of_Z x)) (bsign (bits_of_Z y)))); intro. generalize (last_leq (fun i : nat => f (btest (bits_of_Z x) i) (btest (bits_of_Z y) i)) (last (fun i : nat => f (btest (bits_of_Z x) i) (btest (bits_of_Z y) i)) (ZxHpos x) (f (bsign (bits_of_Z x)) (bsign (bits_of_Z y)))) (f (bsign (bits_of_Z x)) (bsign (bits_of_Z y)))); intro. omega. (** cont. (ZxHpos x <= ZxHpos y) *) rewrite Max.max_r by auto. generalize (last_leq (fun i: nat => f (btest (bits_of_Z x) i) (btest (bits_of_Z y) i)) (ZxHpos y) (f (bsign (bits_of_Z x)) (bsign (bits_of_Z y)))); intro. generalize (last_leq (fun i: nat => f (btest (bits_of_Z x) i) (btest (bits_of_Z y) i)) (last (fun i: nat => f (btest (bits_of_Z x) i) (btest (bits_of_Z y) i)) (ZxHpos y) (f (bsign (bits_of_Z x)) (bsign (bits_of_Z y)))) (f (bsign (bits_of_Z x)) (bsign (bits_of_Z y)))); intro. omega. Qed. Lemma Z_bitwise_ZxHbound: forall (f: bool -> bool -> bool) (x y: Z), ZxHbound (Z_bitwise f x y) <= Zmax (ZxHbound x) (ZxHbound y). Proof. intros f x y. generalize (Z_bitwise_ZxHpos f x y). apply Z.max_case_strong; intro. (** ZxHbound y <= ZxHbound x *) assert (ZxHpos y <= ZxHpos x)%nat by by (apply ZxHpos_le). rewrite max_l; by try (intro; apply ZxHbound_le). (** ZxHbound x <= ZxHbound y *) assert (ZxHpos x <= ZxHpos y)%nat by by (apply ZxHpos_le). rewrite max_r; by try (intro; apply ZxHbound_le). Qed. Lemma Z_bitwise_in_sint_range: forall (f: bool -> bool -> bool) (n: nat) (x y: Z), let b := two_power_nat n in -b <= x < b -> -b <= y < b -> -b <= (Z_bitwise f x y) < b. Proof. intros f n x y b Rx Ry. assert (ZxHbound x <= b) as Bx. unfold b. unfold b in Rx. apply (ZxHpower n x). omega. assert (ZxHbound y <= b) as By. unfold b. unfold b in Ry. apply (ZxHpower n y). omega. generalize (Z_bitwise_ZxHbound f x y). pose (zxy := Z_bitwise f x y); fold zxy. generalize (ZxHrange zxy). apply Zmax_case_strong. (** ZxHbound y <= ZxHbound x *) intros Ryx Rzxy. destruct Rzxy. omega. (** ZxHbound x <= ZxHbound y *) intros Ryx Rzxy. destruct Rzxy. omega. Qed. Lemma Z_bitwise_in_uint_range: forall (f: bool -> bool -> bool) (n: nat) (x y: Z), let b := two_power_nat n in 0 <= x < b -> 0 <= y < b -> f false false = false -> 0 <= (Z_bitwise f x y) < b. Proof. intros f n x y b Rx Ry. assert (ZxHbound x <= b) as Bx. unfold b. unfold b in Rx. apply (ZxHpower n x). omega. assert (ZxHbound y <= b) as By. unfold b. unfold b in Ry. apply (ZxHpower n y). omega. intro Fsign. assert (0 <= (Z_bitwise f x y)) as Bz. unfold Z_bitwise. pose (bz := (bitwise f (bits_of_Z x) (bits_of_Z y))). fold bz. unfold Z_of_bits. destruct (bsign bz) eqn:BSIGN. (** negative sign *) assert (bsign bz = false) as OPP. unfold bz. unfold bitwise. unfold bsign. unfold bits_of_Z. unfold bsign. case_leq 0 x; intro; try omegaContradiction. case_leq 0 y; intros; try omegaContradiction. auto. rewrite BSIGN in OPP. discriminate. (** positive sign *) apply (N_recomp_pos). generalize (Z_bitwise_ZxHbound f x y). pose (zxy := Z_bitwise f x y); fold zxy; fold zxy in Bz. generalize (ZxHrange zxy). apply Zmax_case_strong. (** ZxHbound y <= ZxHbound x *) intros Ryx Rzxy. destruct Rzxy. auto with zarith. (** ZxHbound x <= ZxHbound y *) intros Ryx Rzxy. destruct Rzxy. (* auto with zarith. *) omega. Qed. (** Commutative bitwise operators *) Definition commutative {A B: Type} (f: A -> A -> B) := forall x y: A, f x y = f y x. Lemma Z_bitwise_commut: forall (f: bool -> bool -> bool), commutative f -> commutative (Z_bitwise f). Proof. unfold commutative. intros. apply btest_ext. simpl. extensionality k. apply H. Qed. (** Associative bitwise operators *) Definition associative {A: Type} (f: A -> A -> A) := forall x y z: A, f (f x y) z = f x (f y z). Lemma Z_bitwise_assoc: forall (f: bool -> bool -> bool), associative f -> associative (Z_bitwise f). Proof. unfold associative. intros. apply btest_ext. simpl. extensionality k. unfold Z_bitwise. repeat rewrite Z_decomp_recomp. simpl. apply H. Qed. (** Idempotent bitwise operators *) Definition idempotent {A: Type} (f: A -> A -> A) := forall x: A, f x x = x. Lemma Z_bitwise_idempotent: forall (f: bool -> bool -> bool), idempotent f -> idempotent (Z_bitwise f). Proof. unfold idempotent. intros. Zbit_bitwise k. auto. Qed. (** Distributive bitwise operators *) Definition distributive_l {A: Type} (f : A -> A -> A) (g : A -> A -> A) := forall x y z: A, f x (g y z) = g (f x y) (f x z). Definition distributive_r {A: Type} (f : A -> A -> A) (g : A -> A -> A) := forall x y z: A, f (g x y) z = g (f x z) (f y z). Lemma Z_bitwise_distrib_l: forall (f g: bool -> bool -> bool), distributive_l f g -> distributive_l (Z_bitwise f) (Z_bitwise g) . Proof. unfold distributive_l. intros. Zbit_bitwise k. auto. Qed. Lemma Z_bitwise_distrib_r: forall (f g: bool -> bool -> bool), distributive_r f g -> distributive_r (Z_bitwise f) (Z_bitwise g) . Proof. unfold distributive_r. intros. Zbit_bitwise k. auto. Qed. (** Neutral elements of bitwise operators *) Definition neutral {A: Type} (e: A) (f: A -> A -> A) := forall x: A, f e x = x. Lemma Z_bitwise_neutral (e:bool): forall (f: bool -> bool -> bool), neutral e f -> neutral (if e then (-1) else 0) (Z_bitwise f). Proof. unfold neutral. intros. Zbit_bitwise k. destruct e; simpl. (** TRUE *) rewrite Zbit_of_mone. rewrite H. auto. (** FALSE *) rewrite Zbit_of_zero. rewrite H. auto. Qed. (** Absorbant element of bitwise operators *) Definition absorbant {A: Type} (a: A) (f: A -> A -> A) := forall x: A, f a x = a. Lemma Z_bitwise_absorbant (a:bool) : forall f, absorbant a f -> absorbant (if a then (-1) else 0) (Z_bitwise f). Proof. unfold absorbant. intros. Zbit_bitwise k. destruct a; simpl. (** TRUE *) rewrite Zbit_of_mone. rewrite H. auto. (** FALSE *) rewrite Zbit_of_zero. rewrite H. auto. Qed. (** {@ACSL:} *) (** * ACSL shifting operators *) Parameter lsl_undef: Z -> Z -> Z. Definition lsl_def (x:Z) (n:Z): Z := lsl_shift_def x (Zabs_nat n). Definition lsl (x : Z) (y : Z) : Z := if Zle_bool 0 y then lsl_def x y else lsl_undef x y. (* Lemma test_compute: lsl 2 1 = 4. *) (* Proof. *) (* compute; reflexivity. *) (* Qed. *) Parameter lsr_undef: Z -> Z -> Z. Definition lsr_def (x:Z) (n:Z): Z := lsr_shift_def x (Zabs_nat n). Definition lsr (x : Z) (y : Z) : Z := if Zle_bool 0 y then lsr_def x y else lsr_undef x y. (** ** Properties of shifting operators *) Theorem Zbit_lsl: forall (x n: Z) (k: nat), Zbit (lsl_def x n) k = if (Zle_bool (Zabs n) (Z_of_nat k)) then Zbit x (Zabs_nat ((Z_of_nat k) - (Zabs n))) else false. Proof. intros. unfold lsl_def. rewrite lsl_arithmetic_shift. unfold lsl_arithmetic_def. rewrite Zbit_shift_l. case_leq (Zabs n) (Z_of_nat k). (** case |n| <= k *) intro LEQ. cut (leb (Zabs_nat n) k= true). intro LEB. rewrite LEB. f_equal. rewrite Zabs_nat_Zminus; try split; try apply Zabs_pos; auto. rewrite Zabs_nat_Z_of_nat. rewrite zabs_nat_zabs; auto. auto. apply leb_correct. rewrite <- Zabs_nat_Z_of_nat. apply zabs_le. rewrite <- (inj_Zabs_nat (Z_of_nat k)). rewrite Zabs_nat_Z_of_nat. auto. (** case |n| > k *) intro GT. cut (leb (Zabs_nat n) k = false). intro GTB. rewrite GTB. auto. apply leb_correct_conv. rewrite <- (Zabs_nat_Z_of_nat k). apply zabs_gt. rewrite <- (inj_Zabs_nat (Z_of_nat k)). rewrite Zabs_nat_Z_of_nat. omega. Qed. Theorem Zbit_lsr: forall (x n: Z) (k: nat), Zbit (lsr_def x n) k = Zbit x (k + (Zabs_nat n))%nat. Proof. intros. (** left term *) unfold lsr_def. unfold lsr_shift_def. unfold Zbit. rewrite Z_decomp_recomp. unfold bitwise_lsr. unfold btest at 1. auto. Qed. Lemma lsl_of_lsl: forall (n m: Z) (x:Z), lsl_def (lsl_def x n) m = lsl_def x (Zabs n + Zabs m). Proof. intros. unfold lsl_def. rewrite <- zabs_plus. rewrite lsl_arithmetic_shift. unfold lsl_arithmetic_def. replace (x * two_power_nat (Zabs_nat n) * two_power_nat (Zabs_nat m)) -> (x *(two_power_nat (Zabs_nat n) * two_power_nat (Zabs_nat m))) by ring. f_equal. repeat rewrite two_power_nat_correct. rewrite Zpower_nat_is_exp. auto. Qed. Lemma lsr_of_lsr: forall (n m: Z) (x:Z), lsr_def (lsr_def x n) m = lsr_def x (Zabs n + Zabs m). Proof. intros. unfold lsr_def. rewrite <- zabs_plus. unfold lsr_shift_def at 3. unfold lsr_shift_def at 1. unfold bitwise_lsr. apply btest_ext. unfold btest at 1. unfold btest at 2. extensionality k. unfold lsr_shift_def. rewrite Z_decomp_recomp. unfold bitwise_lsr. unfold btest at 1. f_equal. omega. Qed. Lemma lsr_of_lsl: forall (n m: Z) (x:Z), Zabs n <= Zabs m -> lsr_def (lsl_def x n) m = lsr_def x (Zabs m - Zabs n). Proof. intros. unfold lsr_def. rewrite <- zabs_minus by auto. unfold lsr_shift_def. unfold bitwise_lsr. apply btest_ext. unfold btest at 1. unfold btest at 2. extensionality k. unfold lsl_def. unfold lsl_shift_def. rewrite Z_decomp_recomp. unfold bitwise_lsl. unfold btest at 1. rewrite (leb_correct (Zabs_nat n) (k + Zabs_nat m)). f_equal. (** arg 1 *) rewrite (inj_eq_rev (k + Zabs_nat m - Zabs_nat n) (k + (Zabs_nat m - Zabs_nat n))). auto. rewrite inj_minus1 by (apply zabs_le_plus; omega). repeat rewrite inj_plus. rewrite inj_minus1 at 1 by (apply zabs_le; auto). omega. (** arg 2 *) apply zabs_le_plus. omega. Qed. (** * ACSL bitwise operators *) Definition limpl (x y: Z): Z := Z_bitwise implb x y. Definition land (x y: Z): Z := Z_bitwise andb x y. Definition lor (x y: Z): Z := Z_bitwise orb x y. Definition lxor (x y: Z): Z := Z_bitwise xorb x y. Definition lnot (x: Z): Z := lxor (-1) x. (** ** Properties of lnot operator *) (** lnot x equals -(x+1) *) Theorem lnot_zlnot_equiv: forall x: Z, lnot x = zlnot x. Proof. intro x. unfold lnot. unfold lxor. Zbit_bitwise k. rewrite Zbit_of_mone. rewrite Bool.xorb_true_l. (** Now to prove that zlnot negates bits *) unfold Zbit. unfold bits_of_Z. pose (y := zlnot x). fold y. case_leq 0 x; case_leq 0 y; intros Y X; try ( unfold y in Y; unfold zlnot in Y; apply False_ind; omega); simpl. (** Negative *) unfold y. rewrite zlnot_inv. unfold fnot. trivial. (** Positive *) unfold fnot. rewrite Bool.negb_involutive. trivial. Qed. (** Tactical *) Local Ltac lnot_with_omega := repeat rewrite lnot_zlnot_equiv; unfold zlnot; omega. Theorem lnot_0: lnot 0 = -1. Proof. auto with arith. Qed. Theorem lnot_1: lnot (-1) = 0. Proof. auto with arith. Qed. (** Involution of the double negation *) Theorem lnot_inv: forall x: Z, lnot (lnot x) = x. Proof. intros x. lnot_with_omega. Qed. Theorem lnot_sym: forall x y: Z, lnot x = y -> lnot y = x. Proof. intros x y. lnot_with_omega. Qed. Theorem lnot_inj: forall x y: Z, lnot x = lnot y -> y = x. Proof. intros x y. lnot_with_omega. Qed. (** ** Associative and commutative bitwise operators *) (** land is AC *) Theorem land_assoc: associative land. Proof. apply (Z_bitwise_assoc andb). unfold associative. intros. symmetry. apply Bool.andb_assoc. Qed. Theorem land_commut: commutative land. Proof. apply (Z_bitwise_commut andb Bool.andb_comm). Qed. (** lor is AC *) Theorem lor_assoc: associative lor. Proof. apply (Z_bitwise_assoc orb). unfold associative. intros. symmetry. apply Bool.orb_assoc. Qed. Theorem lor_commut: commutative lor. Proof. apply (Z_bitwise_commut orb Bool.orb_comm). Qed. (** lxor is AC *) Theorem lxor_assoc: associative lxor. Proof. apply (Z_bitwise_assoc xorb Bool.xorb_assoc). Qed. Theorem lxor_commut: commutative lxor. Proof. apply (Z_bitwise_commut xorb Bool.xorb_comm). Qed. (** ** Idempotent bitwise operators *) (** land is idempotent *) Theorem land_idemp: idempotent land. Proof. apply (Z_bitwise_idempotent andb). unfold idempotent. intro. destruct x; auto. Qed. (** lor is idempotent *) Theorem lor_idemp: idempotent lor. Proof. apply (Z_bitwise_idempotent orb). unfold idempotent. intro. destruct x; auto. Qed. (** ** Neutral elements of bitwise operators *) (** Zero is the neutral element of lor *) Theorem lor_0: neutral 0 lor. Proof. apply (Z_bitwise_neutral false orb). unfold neutral. auto. Qed. (** Zero is the neutral element of lxor *) Theorem lxor_0: neutral 0 lxor. Proof. apply (Z_bitwise_neutral false xorb). unfold neutral. apply Bool.orb_false_r. Qed. (** Minus one is the neutral element of land *) Theorem land_1: neutral (-1) land. Proof. apply (Z_bitwise_neutral true andb). unfold neutral. auto. Qed. (** ** Absorbant elements of bitwise operators *) (** Zero is the absorbant element of land *) Theorem land_0: absorbant 0 land. Proof. apply (Z_bitwise_absorbant false andb). unfold absorbant. auto. Qed. (** Minus one is the absorbant element of lor *) Theorem lor_1: absorbant (-1) lor. Proof. apply (Z_bitwise_absorbant true orb). unfold absorbant. auto. Qed. (** ** De Morgan laws of bitwise operators *) Theorem lnot_land_de_morgan: forall x y: Z, lnot (land x y) = lor (lnot x) (lnot y). Proof. intros. unfold lnot. unfold lxor. Zbit_bitwise k. rewrite Zbit_of_mone. rewrite Bool.xorb_true_l. unfold land. rewrite Zbit_bitwise. unfold lor. rewrite Zbit_bitwise. unfold Zbit. unfold Z_bitwise. rewrite Z_decomp_recomp. rewrite Z_decomp_recomp. unfold bitwise. simpl. pose (xb:= btest (bits_of_Z x) k). fold xb. pose (yb:= btest (bits_of_Z y) k). fold yb. destruct xb; destruct yb; simpl; auto. Qed. Theorem lnot_lor_de_morgan: forall x y: Z, lnot (lor x y) = land (lnot x) (lnot y). Proof. intros. unfold lnot. unfold lxor. Zbit_bitwise k. rewrite Zbit_of_mone. rewrite Bool.xorb_true_l. unfold land. rewrite Zbit_bitwise. unfold lor. rewrite Zbit_bitwise. unfold Zbit. unfold Z_bitwise. rewrite Z_decomp_recomp. rewrite Z_decomp_recomp. unfold bitwise. simpl. pose (xb:= btest (bits_of_Z x) k). fold xb. pose (yb:= btest (bits_of_Z y) k). fold yb. destruct xb; destruct yb; simpl; auto. Qed. (** ** Distributivity of bitwise operators *) (** Distributive lor land *) Theorem lor_land_distrib_l: distributive_l lor land. Proof. apply (Z_bitwise_distrib_l orb andb). unfold distributive_l. destruct x; destruct y; destruct z; auto. Qed. Theorem lor_land_distrib_r: distributive_r lor land. Proof. apply (Z_bitwise_distrib_r orb andb). unfold distributive_r. destruct x; destruct y; destruct z; auto. Qed. (** Distributive land lor *) Theorem land_lor_distrib_l: distributive_l land lor. Proof. apply (Z_bitwise_distrib_l andb orb). unfold distributive_l. destruct x; destruct y; destruct z; auto. Qed. Theorem land_lor_distrib_r: distributive_r land lor. Proof. apply (Z_bitwise_distrib_r andb orb). unfold distributive_r. destruct x; destruct y; destruct z; auto. Qed. (** Distributive land lxor *) Theorem land_lxor_distrib_l: distributive_l land lxor. Proof. apply (Z_bitwise_distrib_l andb xorb). unfold distributive_l. destruct x; destruct y; destruct z; auto. Qed. Theorem land_lxor_distrib_r: distributive_r land lxor. Proof. apply (Z_bitwise_distrib_r andb xorb). unfold distributive_r. destruct x; destruct y; destruct z; auto. Qed. (** ** Properties of lxor operator *) Theorem lxor_nilpotent: forall x: Z, lxor x x = 0. Proof. intro. unfold lxor. Zbit_bitwise k. rewrite Bool.xorb_nilpotent. rewrite Zbit_of_zero. auto. Qed. Theorem lxor_1: forall x: Z, lxor (-1) x = lnot x. Proof. trivial. Qed. Theorem lxor_lnot: forall x y: Z, lxor (lnot x) y = lnot (lxor x y). Proof. intros. unfold lnot. apply (lxor_assoc (-1) x y). Qed. (** ** Link between shifting and bitwise operators *) Local Ltac lsl_distrib_r lop z := unfold distributive_r; let k := fresh in intros; unfold lop; Zbit_bitwise k; repeat rewrite Zbit_lsl; rewrite Zbit_bitwise; case_leq (Zabs z) (Z_of_nat k); [ (intro; trivial) | trivial ]. (** Distributive lsl lor *) Lemma lsl_lor_distrib_r: distributive_r lsl_def lor. Proof. lsl_distrib_r lor z. Qed. (** Distributive lsl land *) Lemma lsl_land_distrib_r: distributive_r lsl_def land. Proof. lsl_distrib_r land z. Qed. (** Distributive lsl lxor *) Lemma lsl_lxor_distrib_r: distributive_r lsl_def lxor. Proof. lsl_distrib_r lxor z. Qed. Local Ltac lsr_distrib_r lop := unfold distributive_r; intros; Zbit_ext fresh; unfold lop; rewrite Zbit_bitwise; repeat rewrite Zbit_lsr; rewrite Zbit_bitwise; trivial. (** Distributive lsr lor *) Lemma lsr_lor_distrib_r: distributive_r lsr_def lor. Proof. lsr_distrib_r lor. Qed. (** Distributive lsr land *) Lemma lsr_land_distrib_r: distributive_r lsr_def land. Proof. lsr_distrib_r land. Qed. (** Distributive lsr lxor *) Lemma lsr_lxor_distrib_r: distributive_r lsr_def lxor. Proof. lsr_distrib_r lxor. Qed. (** lsr lnot *) Lemma lsr_lnot: forall x y: Z, lnot (lsr_def x y) = lsr_def (lnot x) y . Proof. unfold lnot. lsr_distrib_r lxor. Qed. (** ** Some properties of equations of bitwise operators *) Local Ltac f_equal_hyp h f k := match goal with | [ h:(?X1 = ?X2) |- _ ] => let H := fresh in assert (H : f X1 k = f X2 k) by (f_equal; auto); clear h; assert (h: f X1 k = f X2 k) by auto; clear H end. Local Ltac linear2 := intros x y; (try split); intro H; (try split); let k := fresh "k" in Zbit_ext k; try (destruct H as [H H0] ; f_equal_hyp H0 Zbit k; generalize H0; clear H0); f_equal_hyp H Zbit k; generalize H; clear H; (try unfold limpl); (try unfold lnot); (try unfold land); (try unfold lor); (try unfold lxor); repeat (replace (Zbit (-1) k) -> true by simpl); repeat (replace (Zbit 0 k) -> false by simpl); repeat rewrite Zbit_bitwise; destruct (Zbit x k); destruct (Zbit y k); simpl; auto. Lemma linear_land: forall x y: Z, limpl x y = -1 <-> land x y = x. Proof. linear2. Qed. Lemma linear_lor: forall x y: Z, lor x y = x <-> limpl y x = -1. Proof. linear2. Qed. Lemma linear_lxor: forall x y: Z, lxor x y = x <-> y=0. Proof. linear2. Qed. Lemma linear_limpl_r: forall x y: Z, limpl x y = y <-> lor x y = -1. Proof. linear2. Qed. Local Ltac F_equal_hyp h f k := match goal with | [ h:(?X1 = ?X2) |- _ ] => idtac h; let H := fresh in assert (H : f X1 k = f X2 k) by (f_equal; auto); clear h; assert (h: f X1 k = f X2 k) by (apply H); clear H end. Lemma linear_limpl_l: forall x y: Z, limpl x y = x <-> x=-1 /\ y=-1. Proof. linear2. Qed. Lemma linear_land_lnot: forall x y: Z, land x y = lnot x <-> x=-1 /\ y=0. Proof. linear2. Qed. Lemma linear_lor_lnot: forall x y: Z, lor x y = lnot x <-> x=0 /\ y=-1. Proof. linear2. Qed. Lemma linear_lxor_lnot : forall x y: Z, lxor x y = lnot x <-> y=-1. Proof. linear2. Qed. Lemma linear_limpl_r_lnot: forall x y: Z, limpl x y = lnot y <-> x=0 /\ y=0. Proof. linear2. Qed. Lemma linear_limpl_l_lnot: forall x y: Z, limpl x y = lnot x <-> land x y = 0. Proof. linear2. Qed. Local Ltac linear3 := intros x y z; (try split); intro H; (try split); let k := fresh "k" in Zbit_ext k; try (destruct H as [H H0] ; f_equal_hyp H0 Zbit k; generalize H0; clear H0); f_equal_hyp H Zbit k; generalize H; clear H; (try unfold limpl); (try unfold lnot); (try unfold land); (try unfold lor); (try unfold lxor); repeat (replace (Zbit (-1) k) -> true by simpl); repeat (replace (Zbit 0 k) -> false by simpl); repeat rewrite Zbit_bitwise; destruct (Zbit x k); destruct (Zbit y k); destruct (Zbit z k); simpl; auto. Lemma linear_lxor_land: forall x y z: Z, lxor x y = land x z <-> lnot y = limpl x z. Proof. linear3. Qed. Lemma linear_lxor_lor: forall x y z: Z, lxor x y = lor x z <-> lnot y = limpl z x. Proof. linear3. Qed. Lemma linear_lxor_limpl_l: forall x y z: Z, lxor x y = limpl x z <-> lnot y = land x z. Proof. linear3. Qed. Lemma linear_lxor_limpl_r: forall x y z: Z, lxor x y = limpl z x <-> lnot y = lor z x. Proof. linear3. Qed. Lemma linear_land_land: forall x y z: Z, land x y = land z x <-> land x (lxor y z) = 0. Proof. linear3. Qed. Lemma linear_lnot_land_land: forall x y z: Z, lnot (land x y) = land z x <-> x=-1 /\ y = lnot z. Proof. linear3. Qed. Lemma linear_lor_lor: forall x y z: Z, lor x y = lor z x <-> land (lnot x) (lxor y z) = 0. Proof. linear3. Qed. Lemma linear_lnot_lor_lor: forall x y z: Z, lnot (lor x y) = lor z x <-> x=0 /\ y = lnot z. Proof. linear3. Qed. Lemma linear_lor_land: forall x y z: Z, lor x y = land x z <-> y = land x (lnot (lxor y z)). Proof. linear3. Qed. Lemma land_discrimination_inv: forall x y z:Z, x = land y z -> land x (lnot y) = 0. Proof. linear3. Qed. Lemma land_discrimination: forall x y z:Z, land x (lnot y) <> 0 -> x <> land y z. Proof. intros x y z. generalize (land_discrimination_inv x y z). intuition. Qed. Lemma land_system: forall x1 x2 y1 y2 z:Z, (x1 = land z y1 /\ x2 = land z y2) <-> lor x1 x2 = land z (lor (land (lnot x1) (land (lnot x2) (lor y1 y2))) (lor (land x1 (land y1 (lnot (lxor x2 y2)))) ((land x2 (land y2 (lnot (lxor x1 y1))))))). Proof. intros x1 x2 y1 y2 z. split; intro H ; try split; Zbit_ext k; try (destruct H as [H H0]; f_equal_hyp H0 Zbit k; generalize H0; clear H0); f_equal_hyp H Zbit k; generalize H; clear H; (try unfold limpl); (try unfold lnot); (try unfold land); (try unfold lor); (try unfold lxor); repeat (replace (Zbit (-1) k) -> true by simpl); repeat (replace (Zbit 0 k) -> false by simpl); repeat rewrite Zbit_bitwise; destruct (Zbit x1 k); destruct (Zbit x2 k); destruct (Zbit y1 k); destruct (Zbit y2 k); destruct (Zbit z k); simpl; auto. Qed. (** * Bit extraction *) Parameter bit_test: Z -> Z -> bool. (* Extended version for negative value. *) Definition zbit_test_def (x:Z) (n:Z): bool := Zbit x (Zabs_nat n). Axiom bit_test_partial_def: forall x n: Z, n >=0 -> bit_test x n = zbit_test_def x n. (** Tactical *) Local Ltac bit_extraction bin_op := intros; unfold zbit_test_def; unfold bin_op; rewrite Zbit_bitwise; auto. (** ** Link between Bit extraction and bitwise shifting operators *) Theorem lsl_extraction: forall x n m: Z, zbit_test_def (lsl_def x n) m = if Zle_bool (Zabs n) (Zabs m) then zbit_test_def x ((Zabs m) - (Zabs n)) else false. Proof. intros. unfold zbit_test_def. rewrite Zbit_lsl. repeat rewrite inj_Zabs_nat. auto. Qed. Theorem lsr_extraction: forall x n m: Z, zbit_test_def (lsr_def x n) m = zbit_test_def x ((Zabs m) + (Zabs n)). Proof. intros. unfold zbit_test_def. (** right term *) rewrite <- zabs_plus. (** left term *) rewrite Zbit_lsr. auto. Qed. (** ** Link between Bit extraction and bitwise operators *) Theorem land_extraction: forall x y i: Z, zbit_test_def (land x y) i = andb (zbit_test_def x i) (zbit_test_def y i). Proof. bit_extraction land. Qed. Theorem lor_extraction: forall x y i: Z, zbit_test_def (lor x y) i = orb (zbit_test_def x i) (zbit_test_def y i). Proof. bit_extraction lor. Qed. Theorem lxor_extraction: forall x y i: Z, zbit_test_def (lxor x y) i = xorb (zbit_test_def x i) (zbit_test_def y i). Proof. bit_extraction lxor. Qed. Theorem lnot_extraction: forall x i: Z, zbit_test_def (lnot x) i = negb (zbit_test_def x i). Proof. unfold lnot. bit_extraction lxor. Qed. (** * Some C-Integer Bits Conversions are identity *) (* Tactical *) Lemma lnot_in_range: forall a b z: Z, a <= z < b -> -b <= lnot z < -a. Proof. intros. rewrite lnot_zlnot_equiv. unfold zlnot. omega. Qed. Lemma lsr_upper_bound: forall b x y: Z, 0 <= y -> x < b -> 0 <= b -> lsr x y < b. Proof. intros b x y Ry Rx Rb. apply Zle_is_le_bool in Ry; unfold lsr; rewrite Ry. unfold lsr_def. rewrite lsr_arithmetic_shift. unfold lsr_arithmetic_def. pose (d := two_power_nat (Zabs_nat y)); fold d. assert (PWR2: 0 < d) by apply two_power_nat_is_positive. apply Zdiv_lt_upper_bound; auto. assert (b <= b * d) by apply (upper_positive_mult_positive d b Rb PWR2). omega. Qed. Lemma lsr_lower_bound: forall b x y: Z, 0 <= y -> b <= x -> b <= 0 -> b <= lsr x y. Proof. intros b x y Ry Rx Rb. apply Zle_is_le_bool in Ry; unfold lsr; rewrite Ry. unfold lsr_def. rewrite lsr_arithmetic_shift. unfold lsr_arithmetic_def. pose (d := two_power_nat (Zabs_nat y)); fold d. assert (PWR2: 0 < d) by apply two_power_nat_is_positive. apply Zdiv_le_lower_bound; auto. assert (b * d <= b) by apply (lower_negative_mult_positive d b Rb PWR2). omega. Qed. Local Ltac is_sint_lnot b := intros x Rx; apply id_to_range; apply (lnot_in_range (-b) b x Rx). Local Ltac is_sint_bitwise f n := intros x y Rx Ry; apply id_to_range; apply (Z_bitwise_in_sint_range f n x y Rx Ry); by compute. Local Ltac is_uint_bitwise f n := intros x y Rx Ry; apply id_to_range; apply (Z_bitwise_in_uint_range f n x y Rx Ry); by compute. (** ** Signed conversions *) (* sint8 *) Lemma is_sint8_lnot: forall x: Z, is_sint8 x -> to_sint8 (lnot x) = lnot x. Proof. is_sint_lnot 128. Qed. Lemma is_sint8_lxor: forall x y: Z, is_sint8 x -> is_sint8 y -> to_sint8 (lxor x y) = lxor x y. Proof. is_sint_bitwise xorb 7%nat. Qed. Lemma is_sint8_lor: forall x y: Z, is_sint8 x -> is_sint8 y -> to_sint8 (lor x y) = lor x y. Proof. is_sint_bitwise orb 7%nat. Qed. Lemma is_sint8_land: forall x y: Z, is_sint8 x -> is_sint8 y -> to_sint8 (land x y) = land x y. Proof. is_sint_bitwise andb 7%nat. Qed. Local Ltac lsr_in_sint_range n := intros x y Ry Rx; unfold_hyp Rx; apply id_to_range; split; [ (apply (lsr_lower_bound (-n) _ _ Ry); omega) | (apply (lsr_upper_bound n _ _ Ry); omega)]. Local Ltac lsr_in_uint_range n := intros x y Ry Rx; unfold_hyp Rx; apply id_to_range; split; [ (apply (lsr_lower_bound 0 _ _ Ry); omega) | (apply (lsr_upper_bound n _ _ Ry); omega)]. Lemma is_sint8_lsr: forall x y: Z, 0 <= y -> is_sint8 x -> to_sint8 (lsr x y) = lsr x y. Proof. lsr_in_sint_range 128. Qed. (* sint16 *) Lemma is_sint16_lnot: forall x: Z, is_sint16 x -> to_sint16 (lnot x) = lnot x. Proof. is_sint_lnot 32768. Qed. Lemma is_sint16_lxor: forall x y: Z, is_sint16 x -> is_sint16 y -> to_sint16 (lxor x y) = lxor x y. Proof. is_sint_bitwise xorb 15%nat. Qed. Lemma is_sint16_lor: forall x y: Z, is_sint16 x -> is_sint16 y -> to_sint16 (lor x y) = lor x y. Proof. is_sint_bitwise orb 15%nat. Qed. Lemma is_sint16_land: forall x y: Z, is_sint16 x -> is_sint16 y -> to_sint16 (land x y) = land x y. Proof. is_sint_bitwise andb 15%nat. Qed. Lemma is_sint16_lsr: forall x y: Z, 0 <= y -> is_sint16 x -> to_sint16 (lsr x y) = lsr x y. Proof. lsr_in_sint_range 32768. Qed. (* sint32 *) Lemma is_sint32_lnot: forall x: Z, is_sint32 x -> to_sint32 (lnot x) = lnot x. Proof. is_sint_lnot 2147483648. Qed. Lemma is_sint32_lxor: forall x y: Z, is_sint32 x -> is_sint32 y -> to_sint32 (lxor x y) = lxor x y. Proof. is_sint_bitwise xorb 31%nat. Qed. Lemma is_sint32_lor: forall x y: Z, is_sint32 x -> is_sint32 y -> to_sint32 (lor x y) = lor x y. Proof. is_sint_bitwise orb 31%nat. Qed. Lemma is_sint32_land: forall x y: Z, is_sint32 x -> is_sint32 y -> to_sint32 (land x y) = land x y. Proof. is_sint_bitwise andb 31%nat. Qed. Lemma is_sint32_lsr: forall x y: Z, 0 <= y -> is_sint32 x -> to_sint32 (lsr x y) = lsr x y. Proof. lsr_in_sint_range 2147483648. Qed. (* sint64 *) Lemma is_sint64_lnot: forall x: Z, is_sint64 x -> to_sint64 (lnot x) = lnot x. Proof. is_sint_lnot 9223372036854775808. Qed. Lemma is_sint64_lxor: forall x y: Z, is_sint64 x -> is_sint64 y -> to_sint64 (lxor x y) = lxor x y. Proof. is_sint_bitwise xorb 63%nat. Qed. Lemma is_sint64_lor: forall x y: Z, is_sint64 x -> is_sint64 y -> to_sint64 (lor x y) = lor x y. Proof. is_sint_bitwise orb 63%nat. Qed. Lemma is_sint64_land: forall x y: Z, is_sint64 x -> is_sint64 y -> to_sint64 (land x y) = land x y. Proof. is_sint_bitwise andb 63%nat. Qed. Lemma is_sint64_lsr: forall x y: Z, 0 <= y -> is_sint64 x -> to_sint64 (lsr x y) = lsr x y. Proof. lsr_in_sint_range 9223372036854775808. Qed. (** ** Unsigned conversions *) (* uint8 *) Lemma is_uint8_lor: forall x y: Z, is_uint8 x -> is_uint8 y -> to_uint8 (lor x y) = lor x y. Proof. is_uint_bitwise orb 8%nat. Qed. Lemma is_uint8_land: forall x y: Z, is_uint8 x -> is_uint8 y -> to_uint8 (land x y) = land x y. Proof. is_uint_bitwise andb 8%nat. Qed. Lemma is_uint8_lsr: forall x y: Z, 0 <= y -> is_uint8 x -> to_uint8 (lsr x y) = lsr x y. Proof. lsr_in_uint_range 256. Qed. (* uint16 *) Lemma is_uint16_lor: forall x y: Z, is_uint16 x -> is_uint16 y -> to_uint16 (lor x y) = lor x y. Proof. is_uint_bitwise orb 16%nat. Qed. Lemma is_uint16_land: forall x y: Z, is_uint16 x -> is_uint16 y -> to_uint16 (land x y) = land x y. Proof. is_uint_bitwise andb 16%nat. Qed. Lemma is_uint16_lsr: forall x y: Z, 0 <= y -> is_uint16 x -> to_uint16 (lsr x y) = lsr x y. Proof. lsr_in_uint_range 65536. Qed. (* uint32 *) Lemma is_uint32_lor: forall x y: Z, is_uint32 x -> is_uint32 y -> to_uint32 (lor x y) = lor x y. Proof. is_uint_bitwise orb 32%nat. Qed. Lemma is_uint32_land: forall x y: Z, is_uint32 x -> is_uint32 y -> to_uint32 (land x y) = land x y. Proof. is_uint_bitwise andb 32%nat. Qed. Lemma is_uint32_lsr: forall x y: Z, 0 <= y -> is_uint32 x -> to_uint32 (lsr x y) = lsr x y. Proof. lsr_in_uint_range 4294967296. Qed. (* uint64 *) Lemma is_uint64_lor: forall x y: Z, is_uint64 x -> is_uint64 y -> to_uint64 (lor x y) = lor x y. Proof. is_uint_bitwise orb 64%nat. Qed. Lemma is_uint64_land: forall x y: Z, is_uint64 x -> is_uint64 y -> to_uint64 (land x y) = land x y. Proof. is_uint_bitwise andb 64%nat. Qed. Lemma is_uint64_lsr: forall x y: Z, 0 <= y -> is_uint64 x -> to_uint64 (lsr x y) = lsr x y. Proof. lsr_in_uint_range 18446744073709551616. Qed. (** * Tacticals. *) (** ** Main tactics.*) Ltac rewrite_cst := first [ Bits.rewrite_cst | COMPUTE1 bitwise_lsl Cst_Z Cst_nat | COMPUTE1 bitwise_lsr Cst_Z Cst_nat | COMPUTE1 lsl_shift_def Cst_Z Cst_nat | COMPUTE1 lsr_shift_def Cst_Z Cst_nat | COMPUTE1 lsl_arithmetic_def Cst_Z Cst_nat | COMPUTE1 lsr_arithmetic_def Cst_Z Cst_nat | COMPUTE1 lsl_def Cst_Z Cst_Z | COMPUTE1 lsr_def Cst_Z Cst_Z | COMPUTE1 land Cst_Z Cst_Z | COMPUTE1 lor Cst_Z Cst_Z | COMPUTE1 lxor Cst_Z Cst_Z | COMPUTE1 lnot Cst_Z | COMPUTE1 zbit_test_def Cst_Z Cst_Z ]. (** Example of use. *) Remark rewrite_cst_example: forall x, x + (land 0 (zlnot (land 0 5))) = x + Z_of_nat (ZxHpos 0). Proof. repeat rewrite_cst. intro. auto. Qed. frama-c-Fluorine-20130601/src/wp/share/cfloat.mlw0000644000175000017500000000670112155630174020315 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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-Integer Arithmetics for Alt-Ergo --- *) (* -------------------------------------------------------------------------- *) (* C-Float Conversion *) logic to_float32 : real -> real logic to_float64 : real -> real predicate is_float32(x : real) = to_float32(x)=x predicate is_float64(x : real) = to_float64(x)=x (* C-Float Rounding Modes *) type rounding_mode = Up | Down | ToZero | NearestTiesToAway | NearestTiesToEven logic round_double : rounding_mode,real -> real logic round_float : rounding_mode,real -> real logic is_finite32 : real -> prop logic is_finite64 : real -> prop axiom float_32: forall x:real [ round_float( NearestTiesToEven , x ) ]. to_float32(x) = round_float( NearestTiesToEven , x ) axiom float_64: forall x:real [ round_double( NearestTiesToEven , x ) ]. to_float64(x) = round_double( NearestTiesToEven , x ) axiom is_finite_to_float_32 : forall x:real [is_finite32(to_float32(x))]. is_finite32(to_float32(x)) axiom is_finite_to_float_64 : forall x:real [is_finite64(to_float64(x))]. is_finite64(to_float64(x)) (* C-Float Rounded Arithmetics *) function add_float32(x:real,y:real):real = to_float32(x+y) function add_float64(x:real,y:real):real = to_float64(x+y) function sub_float32(x:real,y:real):real = to_float32(x-y) function sub_float64(x:real,y:real):real = to_float64(x-y) function mul_float32(x:real,y:real):real = to_float32(x*y) function mul_float64(x:real,y:real):real = to_float64(x*y) function div_float32(x:real,y:real):real = to_float32(x/y) function div_float64(x:real,y:real):real = to_float64(x/y) (* Real Arithmetics *) function ropp(x:real):real = -x function radd(x:real,y:real):real = x+y function rsub(x:real,y:real):real = x-y function rmul(x:real,y:real):real = x*y function rdiv(x:real,y:real):real = x/y frama-c-Fluorine-20130601/src/wp/share/qed.mlw0000644000175000017500000001134312155630174017614 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Bool Library for Alt-Ergo --- *) (* -------------------------------------------------------------------------- *) logic ite: bool,'a,'a -> 'a axiom ite: forall p:bool. forall x,y:'a [ite(p,x,y)]. ( p=true and ite(p,x,y)=x ) or ( p=false and ite(p,x,y)=y ) logic eqb: 'a,'a -> bool axiom eqb: forall x,y:'a [eqb(x,y)]. if eqb(x,y) then x=y else x<>y logic neqb: 'a,'a -> bool axiom neqb: forall x,y:'a [neqb(x,y)]. if neqb(x,y) then x<>y else x=y function xorb (a:bool,b:bool):bool = neqb(a,b) function notb (a:bool):bool = if a then false else true function orb (a:bool,b:bool):bool = if a then true else b function andb (a:bool,b:bool):bool = if a then b else false function implb (a:bool,b:bool):bool = if a then b else true (* -------------------------------------------------------------------------- *) (* --- Extension of Array Theory for Alt-Ergo --- *) (* -------------------------------------------------------------------------- *) axiom array: forall k:'a. forall v:'b. forall m:('a,'b) farray [ m[k<-v] ]. m[k<-v][k]=v (* -------------------------------------------------------------------------- *) (* --- Arithmetic Library for Alt-Ergo --- *) (* -------------------------------------------------------------------------- *) logic real_of_int : int -> real logic int_of_real : real -> int logic zlt : int,int -> bool axiom zlt : forall x,y:int [zlt(x,y)]. if zlt(x,y) then x=y logic zleq : int,int -> bool axiom zleq : forall x,y:int [zleq(x,y)]. if zleq(x,y) then x<=y else x>y logic rlt : real,real -> bool axiom rlt : forall x,y:real [rlt(x,y)]. if rlt(x,y) then x=y logic rleq : real,real -> bool axiom rleq : forall x,y:real [rleq(x,y)]. if rleq(x,y) then x<=y else x>y (* -------------------------------------------------------------------------- *) (* --- Division Library for Alt-Ergo --- *) (* -------------------------------------------------------------------------- *) logic cdiv : int,int -> int logic cmod : int,int -> int axiom c_enclidian : forall n,d:int [cdiv(n,d),cmod(n,d)]. n = cdiv(n,d) * d + cmod(n,d) axiom cdiv_cases : forall n,d:int [cdiv(n,d)]. ((n >= 0) -> (d > 0) -> cdiv(n,d) = n/d) and ((n <= 0) -> (d > 0) -> cdiv(n,d) = -((-n)/d)) and ((n >= 0) -> (d < 0) -> cdiv(n,d) = -(n/(-d))) and ((n <= 0) -> (d < 0) -> cdiv(n,d) = (-n)/(-d)) axiom cmod_cases : forall n,d:int [cmod(n,d)]. ((n >= 0) -> (d > 0) -> cmod(n,d) = n % d) and ((n <= 0) -> (d > 0) -> cmod(n,d) = -((-n) % d)) and ((n >= 0) -> (d < 0) -> cmod(n,d) = (n % (-d))) and ((n <= 0) -> (d < 0) -> cmod(n,d) = -((-n) % (-d))) axiom cmod_remainder : forall n,d:int [cmod(n,d)]. ((n >= 0) -> (d > 0) -> 0 <= cmod(n,d) < d) and ((n <= 0) -> (d > 0) -> -d < cmod(n,d) <= 0) and ((n >= 0) -> (d < 0) -> 0 <= cmod(n,d) < -d) and ((n <= 0) -> (d < 0) -> d < cmod(n,d) <= 0) axiom cdiv_neutral : forall a:int [cdiv(a,1)]. cdiv(a,1) = a axiom cdiv_inv : forall a:int [cdiv(a,a)]. a<>0 -> cdiv(a,a) = 1 frama-c-Fluorine-20130601/src/wp/share/cmath.why0000644000175000017500000000447112155630174020153 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Mathematics for Why-3 --- *) (* -------------------------------------------------------------------------- *) theory Cmath use import int.Int use import real.Real use import int.Abs as Iabs use import int.MinMax as Icmp use import real.Abs as Rabs use import real.MinMax as Rcmp function abs_int(x:int):int = Iabs.abs x function max_int(x:int)(y:int):int = Icmp.max x y function min_int(x:int)(y:int):int = Icmp.min x y function abs_real(x:real):real = Rabs.abs x function max_real(x:real)(y:real):real = Rcmp.max x y function min_real(x:real)(y:real):real = Rcmp.min x y endframa-c-Fluorine-20130601/src/wp/share/cfloat.why0000644000175000017500000000774712155630174020340 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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-Integer Arithmetics for Alt-Ergo --- *) (* -------------------------------------------------------------------------- *) theory Cfloat use import real.Real use import real.RealInfix use import real.Abs (* C-Float IEEE-754 *) use export floating_point.Rounding use import floating_point.Single use import floating_point.Double type rounding_mode = Rounding.mode function round_float (m:rounding_mode) (x:real) : real = Single.round m x function round_double (m:rounding_mode) (x:real) : real = Double.round m x (* C-Float Conversion *) function to_float32 (x:real) : real = Single.round NearestTiesToEven x function to_float64 (x:real) : real = Double.round NearestTiesToEven x predicate is_float32 real predicate is_float64 real axiom def_float32: forall x:real [ is_float32(x) ]. is_float32 x -> to_float32 x = x axiom def_float64: forall x:real [ is_float64(x) ]. is_float64 x -> to_float64 x = x predicate is_finite32 (x:real) = abs(x) <= Single.max_single predicate is_finite64 (x:real) = abs(x) <= Double.max_double axiom is_finite_to_float_32 : forall x:real [is_finite32(to_float32 x)]. is_finite32(to_float32 x) axiom is_finite_to_float_64 : forall x:real [is_finite64(to_float64 x)]. is_finite64(to_float64 x) (* C-Float Conversions are projections *) axiom proj_float32 : forall x:real [ to_float32(to_float32 x) ]. to_float32(to_float32 x)=to_float32 x axiom proj_float64 : forall x:real [ to_float64(to_float64 x) ]. to_float64(to_float64 x)=to_float64 x (* C-Float Arithemtics *) function add_float32(x:real)(y:real):real = to_float32(x+y) function add_float64(x:real)(y:real):real = to_float64(x+y) function sub_float32(x:real)(y:real):real = to_float32(x-y) function sub_float64(x:real)(y:real):real = to_float64(x-y) function mul_float32(x:real)(y:real):real = to_float32(x*y) function mul_float64(x:real)(y:real):real = to_float64(x*y) function div_float32(x:real)(y:real):real = to_float32(x/y) function div_float64(x:real)(y:real):real = to_float64(x/y) (* Real Arithemtics *) function ropp (x:real):real = -. x function radd (x:real)(y:real):real = x +. y function rsub (x:real)(y:real):real = x -. y function rmul (x:real)(y:real):real = x *. y function rdiv (x:real)(y:real):real = x /. y end frama-c-Fluorine-20130601/src/wp/share/Cmath.v0000644000175000017500000000424712155630174017552 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Mathematics Library for Coq --- *) (* -------------------------------------------------------------------------- *) Require Import Qedlib. Require Import ZArith. Require Import Reals. Definition abs_int (x : Z) := if (Zlt_bool x 0)%R then (-x)%Z else x. Definition abs_real (x : R) := if (Rlt_bool x 0)%Z then (-x)%R else x. Definition max_int (x : Z) (y:Z) := if (Zlt_bool x y)%Z then y else x. Definition min_int (x : Z) (y:Z) := if (Zlt_bool x y)%Z then x else y. frama-c-Fluorine-20130601/src/wp/share/Bits.v0000644000175000017500000011665112155630174017422 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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-Integer Library for Coq *) (* -------------------------------------------------------------------------- *) (** This module provides a theory of bits over [Z] natural integers. - for natural [n], the [k]-th bit of [2^n] if [(k=n)] ; - for positive integer [x>=0], it is the union of the bits of its binary decomposition (hence, natural powers of two) ; - finaly, the bits of a negative integer [x<0] are the reverted ones of its two's complement [-(x+1)]. The realization of the theory proceeds into several stages, following the Coq definition of type [Z]. We take advantage of the bitwize representation of positive integers provided by the [positive] type in Coq. The successive stages are: - properties of {!trailing:bit-functions} (finally ending by 1-sequence or 0-sequence); - bits of {!positive:positive} integers [p>0]; - bits of {!natural:natural} integers [n>=0]; - bits of {!integer:integers} [n:Z]. The {!Zbit:characteristic} function of integers, denoted [Zbit], have the expected logical properties: - [(Zbit 0 k)] is [false]; - [(Zbit (-1) k)] is [true]; - [(Zbit (2^n) k)] is [(k=n)]; - [Zbit] is injective, ie: the bit representation of each integer is unique. *) (** ** Type of characteristic functions of integers *) Definition Zfc := nat -> bool. (** ** Tacticals *) Require Import ZArith. Require Import FunctionalExtensionality. Require Import Qedlib. Close Scope Z_scope. Remark contrap: forall P Q : Prop, (P -> Q) -> ~Q -> ~P. Proof. intuition. Qed. (** Induction after a given rank. *) Remark upper_nat_ind: forall P (n:nat), P n -> (forall k, (n < k) -> P k) -> (forall k, (n <= k) -> P k). Proof. intros. case (le_lt_eq_dec n k); intuition (subst; auto with arith). Qed. (** Induction over bool with equality. *) Ltac case_eqb H e := pattern e; apply Sumbool.bool_eq_ind; intro H. (** Find arithmetic contradiction. *) Ltac arithContradiction := cut False; [contradiction; try omega|];auto with arith. (** Cases [Inf:ij]. *) Ltac nat_compare Inf EQ Sup i j := destruct (lt_eq_lt_dec i j) as [ TMP | Sup ]; [ destruct TMP as [ Inf | EQ ]; [ | try rewrite <- EQ ] | ]; auto with arith. (** Cases [Inf:ij]. *) Ltac Z_compare Inf EQ Sup i j := destruct (Z_dec i j) as [ TMP| EQ ]; [ destruct TMP as [ Inf | Sup ] | try rewrite <- EQ ]; auto with zarith. (** For proving a symetrical relation [P], it is sufficient to prove [P i j] for [i nat -> Prop), (forall i j, P i j -> P j i) -> (forall i, P i i) -> (forall i j, i < j -> P i j) -> (forall i j, P i j). Proof. intros P Sym Diag Triangle i j. nat_compare Inf EQ Sup i j. Qed. (** {@trailing:} *) (** * Eventually constant functions *) (** The bits representation of [Z] integers are eventualy constant [nat -> bool] functions. Positive integers finally ends with an infinite sequence of 0-bits, while negative inetegers ends with 1-bits. Hence, it is always possible to defined the highest significant sign-bit of a bit function. This section formalize these properties: predicate [trailing] defines an eventually constant bit function, and function [last] returns its highest significant bit. *) (** Function [f] has constant value [b] from rank [k]. *) Definition trailing f (n:nat) (b:bool) := forall k, n <= k -> f k = b. (** Returns the lowest index such than [f n=b], and [n] otherwize. *) Fixpoint last f n b {struct n} := match n with | O => O | S m => if Bool.eqb (f m) b then last f m b else n end. (** Functions last decreases. *) Remark last_leq : forall f n b, last f n b <= n. Proof. intros f n b. induction n; auto. simpl. destruct (Bool.eqb (f n) b); auto. Qed. (** Trailing of previous position. *) Remark trailing_step : forall f n b, f n = b -> trailing f (S n) b -> trailing f n b. Proof. intros f n b fn tl. unfold trailing. apply upper_nat_ind; auto with arith. Qed. (** Last preserves trailing. *) Remark trailing_last : forall f n b, trailing f n b -> trailing f (last f n b) b. Proof. intros f n b. induction n; simpl; auto. intro IHS. case_eqb H (Bool.eqb (f n) b); auto. apply IHn. apply trailing_step; [ apply Bool.eqb_prop | ]; auto. Qed. (** The [last] is null or points to a flip. *) Remark last_null_or_flip: forall (f: Zfc) (n: nat) (b: bool), last f n b = O \/ exists k, last f n b = S k /\ f k <> b. Proof. intros f n b. induction n; simpl; auto. case_eqb BIT (Bool.eqb (f n) b). auto. right. exists n. split; [ auto | apply Bool.eqb_false_iff; auto ]. Qed. (** The [last] of trailing is unique. *) Lemma last_trail_ext: forall (f: Zfc) (b: bool) (n m: nat), trailing f n b -> trailing f m b -> last f n b = last f m b. Proof. intros f b. cut (forall n m, trailing f n b -> trailing f m b -> last f n b < last f m b -> False). intros ABSURD n m. intros Hn Hm. nat_compare INF EQ SUP (last f n b) (last f m b); auto. (** INF *) apply False_ind; apply (ABSURD n m); auto. (** SUP *) apply False_ind; apply (ABSURD m n); auto. intros n m Hn Hm. pose ( i := last f n b ). fold i. pose ( j := last f m b ). fold j. intro Leq. assert (Hi : trailing f i b) by (unfold i; apply trailing_last; auto). assert (Hj : trailing f j b) by (unfold j; apply trailing_last; auto). assert (Range : forall k, i <= k <= j -> f k = b) by (intros k [lo up]; auto with arith). generalize (last_null_or_flip f m b). intros [ Last_null | Last_flip ]. (** Last is Null *) fold j in Last_null. rewrite Last_null in Leq. omega. (** Last if a flip *) destruct Last_flip as [ k [ kj flip ] ]. fold j in kj. absurd (f k = b); auto. apply Range; omega. Qed. (** {@positive:} *) (** * Bits of positive integers *) (** Strictly positive integers are represented in Coq by theirs bits, with lowest bits as head constructors, and highest bit at tail. Conversely, given a finite range of bits ended by a 1-bit, the reconstruction of a [positive] integer is defined. *) (** Position of the highest significant bit of a positive. *) Fixpoint xHpos (p:positive): nat := match p with | xH => O | xI p => S (xHpos p) | xO p => S (xHpos p) end. (** [xHpos] increases. *) Remark xHpos_incr : forall p a: positive, xHpos p <= xHpos (p + a). Proof. induction p; intros; simpl; case a; intros; simpl; try omega; apply le_n_S; try rewrite Pplus_one_succ_r; try (rewrite Pplus_carry_spec; rewrite Pplus_one_succ_r;rewrite<- Pplus_assoc); try solve [apply (IHp p0) | apply (IHp 1%positive)|apply (IHp (p0+1%positive)%positive)]. Qed. (** Return the value of the [i]-th bit of a positive. *) Fixpoint P_decomp (x: positive) (i: nat) { struct x } : bool := match i, x with | O, xH => true | O, xI _ => true | O, xO _ => false | S m, xH => false | S m, xI p => P_decomp p m | S m, xO p => P_decomp p m end. (** Returns the positive of bits [[f i,...,f (i+n-1),1]]. Remark the [n]-th bit is always 1 ([xH]). *) Fixpoint P_recomp (n: nat) (f : Zfc) (i: nat) {struct n } := match n with | O => xH | S m => if (f i) then xI (P_recomp m f (S i)) else xO (P_recomp m f (S i)) end. (** ** Properties of decomposition *) (** After the highest bits, all bits are false. *) Remark P_decomp_limit: forall x k, k > xHpos x -> P_decomp x k = false. Proof. induction x; simpl; intros; destruct k. inversion H. apply IHx. auto with arith. inversion H. apply IHx. auto with arith. inversion H. auto with arith. Qed. (** The highest bit is true. *) Remark P_decomp_xHpos: forall x, P_decomp x (xHpos x) = true. Proof. induction x; simpl; intros; auto. Qed. (** The [shift] of [nat -> A] functions. *) Definition shift {A:Type} f i k : A := f (i + k). (** bits of a positive with one more 1-bit. *) Remark P_decomp_shift1: forall p: positive, shift (P_decomp p~1) 1 = P_decomp p. Proof. intro p. extensionality k. unfold shift. auto. Qed. (** bits of a positive with one more 0-bit. *) Remark P_decomp_shift0: forall p: positive, shift (P_decomp p~0) 1 = P_decomp p. Proof. intro p. extensionality k. unfold shift. auto. Qed. (** ** Properties of recomposition *) (** Recomposition of shifted bits. *) Remark P_recomp_shift: forall (f: Zfc) (n i j: nat), P_recomp n f (i+j) = P_recomp n (shift f i) j. Proof. intros f n. induction n; intros i j; simpl; auto. unfold shift at 1. case_eqb BIT (f (i+j)); f_equal; (replace (S(i+j)) -> (i + S j) by omega); apply IHn. Qed. (** Highest bits of recomposition. *) Remark xHpos_P_recomp: forall (n: nat) (f: Zfc) (i: nat), xHpos (P_recomp n f i) = n. Proof. intros n f. induction n. simpl. auto. intros. simpl. destruct (f i); simpl; f_equal; apply IHn. Qed. (** ** Involution of decomposition and recomposition *) (** Invariance by 1-bit shift. *) Remark NEXT_I: forall (n: nat) (p: positive), P_recomp n (P_decomp p~1) 1 = P_recomp n (P_decomp p) 0. Proof. intros. replace 1 -> (1+0) by omega. rewrite P_recomp_shift. rewrite P_decomp_shift1. auto. Qed. (** Invariance by 0-bit shift. *) Remark NEXT_O: forall (n: nat) (p: positive), P_recomp n (P_decomp p~0) 1 = P_recomp n (P_decomp p) 0. Proof. intros. replace 1 -> (1+0) by omega. rewrite P_recomp_shift. rewrite P_decomp_shift0. auto. Qed. (** Recomposition of Decomposition. *) Lemma P_recomp_decomp: forall (n: nat) (p: positive), n = xHpos p -> P_recomp n (P_decomp p) O = p. Proof. induction n;intros;simpl. destruct p; inversion H; auto. destruct p; unfold P_decomp at 1; f_equal. rewrite NEXT_I. apply IHn. inversion H; auto with arith. rewrite NEXT_O. apply IHn. inversion H; auto with arith. inversion H. Qed. (** Decomposition of Recomposition. The induction scheeme of the proof requires to recompose an arbitrary shifted function. *) Lemma P_decomp_recomp: forall (f: Zfc) (n i k: nat), k < n -> P_decomp (P_recomp n f i) k = f (i+k). Proof. intros f n. induction n. intros. apply False_ind. omega. intros i k Limit. simpl. destruct k. case_eqb Fi (f i); simpl; rewrite <- Fi; f_equal; omega. destruct (f i); simpl. rewrite IHn. f_equal. omega. omega. rewrite IHn. f_equal. omega. omega. Qed. (** Last bits of positive. *) Remark last_P_decomp: forall (p: positive) (m: nat), m = xHpos p -> last (P_decomp p) (S m) false = (S m). Proof. intros p m Hm. unfold last; rewrite Hm; rewrite P_decomp_xHpos; simpl; auto. Qed. (** {@natural:} *) (** * Bits of natural integers *) (** The section naturally extends bits of [positive] to [N]. Zero is represented by the infinite sequence of 0-bits. *) (** Conversion from [Z] to [N]. *) Definition Nabs (x:Z): N := match x with | Z0 => N0 | Zpos p => Npos p | Zneg p => Npos p end. (** Number of significative bits (last 1-bit) of a natural. *) Definition NxHpos (n:N): nat := match n with | N0 => O | Npos p => S (xHpos p) end. (** NxHpos increases. *) Remark NxHpos_incr: forall x a: N, NxHpos x <= NxHpos (x + a). Proof. destruct x; destruct a; simpl; try (by compute). cut (xHpos p <= xHpos (p + p0)). omega. apply xHpos_incr. Qed. (** Arithmetic properties of [NxHpos] *) Remark NxHpos_2x_p0: forall n:N, (0 < n)%N -> NxHpos (2 * n) = S (NxHpos n). Proof. destruct n. (** zero *) by compute. (** positive *) by simpl. Qed. Remark NxHpos_2x_p1: forall n:N, NxHpos (2 * n + 1) = S (NxHpos n). Proof. destruct n. (** zero *) by compute. (** positive *) by simpl. Qed. Remark NxHpos_div2_p: forall n:N, (0 < n)%N -> NxHpos (Ndiv2 n) = pred (NxHpos n). Proof. destruct n. (** zero *) by compute. (** positive *) by destruct p. Qed. Remark two_power_nat_is_positive: forall n, (0 < two_power_nat n)%Z. Proof. induction n. (** base *) by compute. (** ind. *) rewrite two_power_nat_S. apply Zmult_lt_0_compat. by compute. auto. Qed. (** Bits of a natural integer *) Definition N_decomp (x: N): Zfc := match x with | N0 => (fun _ => false) | Npos p => P_decomp p end. (** Recomposition of an integer from a range of [n]-bits *) Definition N_recomp (n: nat) (f: Zfc): Z := match last f n false with | O => Z0 | S m => Zpos (P_recomp m f 0) end. (** Recomposition result is a positive integer. *) Remark N_recomp_pos: forall (n: nat) (f: Zfc), (0 <= N_recomp n f)%Z. Proof. intros. unfold N_recomp. destruct (last f n false); auto with zarith. Qed. (** Zero has a unique representation *) Remark N_recomp_zero: forall (n: nat) (f: Zfc), trailing f n false -> (N_recomp n f = 0)%Z -> forall k, f k = false. Proof. intros n f Trail. unfold N_recomp. destruct (last_null_or_flip f n false) as [ZERO | FLIP]. rewrite ZERO. intros. generalize (trailing_last f n false). intro TLAST. rewrite ZERO in TLAST. apply TLAST; auto with arith. destruct FLIP as [k [L F]]. rewrite L. discriminate. Qed. (** One has a unique representation *) Remark N_recomp_one: forall (n: nat) (f: Zfc), trailing f n false -> (N_recomp n f = 1)%Z -> f O = true /\ forall k, f (S k) = false. Proof. intros n f Trail. unfold N_recomp. destruct (last_null_or_flip f n false) as [ZERO | FLIP]. rewrite ZERO. intros. apply False_ind. omega. destruct (last f n false) eqn:LAST. intros. apply False_ind. omega. intro ONE. assert (XH: P_recomp n0 f 0 = xH). inversion ONE; trivial. destruct FLIP as [ K1 [ SKN B1not ] ]. assert (NK : n0 = K1) by ( auto with arith ). rewrite NK in *. assert (B1 : f K1 = true) by ( destruct (f K1); auto ). assert (T1 : trailing f (S K1) false). rewrite <- LAST. apply trailing_last. auto. destruct K1. rewrite B1 in *. split; auto. intro k; destruct k; apply T1; auto with arith. simpl in XH. destruct (f 0). apply False_ind. discriminate. apply False_ind. discriminate. Qed. (** Involution of Decomposition and Recomposition *) Lemma N_decomp_recomp: forall (n: nat) (f: Zfc), trailing f n false -> N_decomp (Nabs (N_recomp n f)) = f. Proof. intros n f Trail. unfold N_recomp. generalize (last_null_or_flip f n false). intros [ ZERO | FLIP ]. (** ZERO *) rewrite ZERO. simpl. extensionality k. symmetry. cut (trailing f 0 false). intro H. apply H. omega. rewrite <- ZERO. apply trailing_last. auto. (** FLIP *) destruct FLIP as [k [Last Flip]]. rewrite Last. simpl. extensionality i. nat_compare Inf EQ Sup i k. (** Inf *) apply P_decomp_recomp. auto. (** Eq *) generalize (xHpos_P_recomp i f 0). pose (x := P_recomp i f 0). fold x. intro xHi. rewrite <- xHi. rewrite P_decomp_xHpos. rewrite xHi. rewrite EQ. case_eqb FK (f k); auto; contradiction. (** Sup *) generalize (xHpos_P_recomp k f 0). pose (x := P_recomp k f 0). fold x. intro xHk. rewrite (P_decomp_limit x i); [|rewrite xHk;auto]. cut (trailing f (S k) false). intro H. symmetry. apply H. omega. rewrite <- Last. apply trailing_last. auto. Qed. (** [NxHpos] of a recomposition *) Lemma NxHpos_N_recomp_pos: forall (n: nat) (f: Zfc), NxHpos (Nabs (N_recomp n f)) = last f n false. Proof. intros. unfold N_recomp. elim (last_null_or_flip f n false). intro ZERO. rewrite ZERO. auto. intros [ k [ LAST FLIP ] ]. rewrite LAST. simpl. rewrite xHpos_P_recomp. trivial. Qed. (** {@integer:} *) (** * Bits of Integers *) Open Local Scope Z_scope. (** The bits representation of an integer consists of a bit function, packed with its trailing property. This representation is _not_ unique. However, the unicity of last significant bits implies an extensionality equality: if two [bits] records have the same bit function, they represent the same integer, see [Lemma btest_ext]. *) Record bits: Type := mkbits { bsize:nat; bsign: bool; btest: Zfc; btrail : trailing btest bsize bsign }. (** ** Two's complement and bits inversion *) (** As specified in the introduction, the extension positive integers [N] to [Z] is realized by two's complement and bit inversion. *) (** Two's complement and related properties. *) Definition zlnot x:Z := -(x + 1). Remark zlnot_inv: forall x, zlnot (zlnot x) = x. Proof. intros. unfold zlnot. auto with zarith. Qed. Remark zlnot_inj: forall x y : Z, (zlnot x) = (zlnot y) -> x = y. Proof. unfold zlnot. intros. omega. Qed. Remark zlnot_sym: forall x y : Z, (zlnot x) = y -> x = (zlnot y). Proof. unfold zlnot. intros. omega. Qed. Lemma P_zlnot_sym: forall P (b: Z), 0 <= b -> ((forall z: Z, -b <= z -> P z) -> (forall z:Z, z < b -> P (zlnot z))). Proof. intros P b Bge0 Hyp z H. assert (-b <= zlnot z). unfold zlnot. omega. apply Hyp. auto. Qed. Lemma P_zlnot_sym_rev: forall P (b: Z), 0 <= b -> ((forall z:Z, z < b -> P z) -> (forall z:Z, -b <= z -> P (zlnot z))). Proof. intros P b Bge0 Hyp z H. assert (zlnot z < b). unfold zlnot. omega. apply Hyp. auto. Qed. (** Bit inversion and related properties. *) Definition fnot (f: Zfc): Zfc := (fun k => negb (f k)). Remark fnot_inv: forall f: Zfc, fnot (fnot f) = f. Proof. intros. extensionality k. unfold fnot. destruct (f k); auto. Qed. Remark fnot_inj: forall f g, fnot f = fnot g -> f = g. Proof. intros. generalize (fnot_inv f); intro E; rewrite <- E; clear E. generalize (fnot_inv g); intro E; rewrite <- E; clear E. rewrite H. auto. Qed. Remark fnot_sym: forall f g: Zfc, (fnot f) = g -> f = (fnot g). Proof. intros. apply (fnot_inj f). rewrite (fnot_inv). auto. Qed. (** Lifting of [fnot] to [trailing] *) Remark trailing_fnot: forall (f: Zfc) (n: nat) (b: bool), trailing (fnot f) n (negb b) -> trailing f n b. Proof. intros. unfold trailing. intros k Hk. generalize (H k Hk). intro E. rewrite <- (fnot_inv f). unfold fnot. unfold fnot in E. rewrite E. rewrite Bool.negb_involutive. trivial. Qed. (** Lifting of [fnot] to [last] *) Remark last_fnot: forall (f: Zfc) (n: nat) (b: bool), last (fnot f) n (negb b) = last f n b. Proof. intros. induction n. simpl. trivial. simpl. case_eqb H (Bool.eqb (f n) b). (** TRUE *) unfold fnot. destruct (f n); destruct b; simpl in *; (discriminate || apply IHn). (** FALSE *) unfold fnot. destruct (f n); destruct b; simpl in *; ( discriminate || auto). Qed. (** ** Decomposition and Recomposition of integers *) (** Trailing bits of positive integers *) Remark Zpos_decomp_trail: forall n: N, trailing (N_decomp n) (NxHpos n) false. Proof. intro n. induction n. unfold trailing. auto. unfold trailing. simpl. intro k. apply P_decomp_limit. Qed. (** Trailing bits of positive integers *) Remark Zneg_decomp_trail: forall n: N, trailing (fnot (N_decomp n)) (NxHpos n) true. Proof. intro n. unfold trailing. intros. unfold fnot. replace (N_decomp n k) -> false by (apply Zpos_decomp_trail; auto with arith). simpl. auto. Qed. (** Bits decomposition of [Z] integers *) Program Definition bits_of_Z (x:Z): bits := if (Zle_bool 0 x) then let n := Nabs x in mkbits (NxHpos n) false (N_decomp n) (Zpos_decomp_trail n) else let n := Nabs (zlnot x) in mkbits (NxHpos n) true (fnot (N_decomp n)) (Zneg_decomp_trail n). (** Recomposition of an integers from its bits *) Definition Z_of_bits (b: bits): Z := if bsign b then zlnot (N_recomp (bsize b) (fnot (btest b))) else N_recomp (bsize b) (btest b). (** ** Extensional unicity of bits representation *) (** Same [Zfc] implies equality of signs *) Remark btest_sign: forall x y: bits, btest x = btest y -> bsign x = bsign y. Proof. destruct x. destruct y. simpl in * . pose (k := max bsize0 bsize1). generalize (btrail0 k). intro H0. generalize (btrail1 k). intro H1. intro BEQ. rewrite <- H0; unfold k; auto with arith. rewrite <- H1; unfold k; auto with arith. rewrite BEQ. auto. Qed. (** Opposite [Zfc] implies opposite signs *) Remark btest_sign_sym: forall x y: bits, btest x = fnot (btest y) -> bsign x = negb (bsign y). Proof. destruct x. destruct y. simpl in * . pose (k := max bsize0 bsize1). generalize (btrail0 k). intro H0. generalize (btrail1 k). intro H1. intro BEQ. rewrite <- H0; unfold k; auto with arith. rewrite <- H1; unfold k; auto with arith. rewrite BEQ. auto. Qed. (** Same [Zfc] leads to equal represented integers *) Lemma btest_ext: forall x y: bits, btest x = btest y -> Z_of_bits x = Z_of_bits y. Proof. intros x y BEQ. assert (bsign x = bsign y) as SEQ. apply btest_sign. auto. unfold Z_of_bits. rewrite <- BEQ. rewrite <- SEQ. case_eqb SIGNX (bsign x); [ f_equal | ]; unfold N_recomp; rewrite <- (last_trail_ext _ _ (bsize x) (bsize y)); auto. (** x<0 , trailing ~x |x| false *) generalize (btrail x). rewrite SIGNX. unfold trailing. intros T k R. unfold fnot. rewrite T; auto with arith. (** x<0 , trailing ~x |y| false *) rewrite BEQ. generalize (btrail y). rewrite SIGNX in SEQ. rewrite <- SEQ. unfold trailing. intros T k R. unfold fnot. rewrite T; auto with arith. (** x>0 , trailing x |x| false *) generalize (btrail x). rewrite SIGNX. auto. (** x>0 , trailing x |y| false *) generalize (btrail y). rewrite SIGNX in SEQ. rewrite <- SEQ. rewrite <- BEQ. auto. Qed. (** Opposite [Zfc] leads to two's complement represented integers *) Lemma btest_ext_sym: forall x y: bits, btest x = fnot (btest y) -> Z_of_bits x = zlnot (Z_of_bits y). Proof. intros x y BEQ1. assert (btest y = fnot (btest x)) as BEQ2 by (apply fnot_sym; symmetry; auto). assert (bsign x = negb (bsign y)) as SEQ1 by (by apply btest_sign_sym). assert (bsign y = negb (bsign x)) as SEQ2 by (by apply btest_sign_sym). unfold Z_of_bits. rewrite <- BEQ1. rewrite SEQ2. rewrite <- BEQ2. case_eqb SIGNX (bsign x); (try replace (negb true) -> false by (by compute)); (try replace (negb false) -> true by (by compute)); (try rewrite zlnot_inv); [ f_equal | ]; unfold N_recomp; rewrite <- (last_trail_ext _ _ (bsize x) (bsize y)); auto. (** x<0 , trailing ~x |x| false *) rewrite BEQ2. generalize (btrail x). rewrite SIGNX. unfold trailing. intros T k R. unfold fnot. rewrite T; auto with arith. (** x<0 , trailing ~x |y| false *) rewrite BEQ2. generalize (btrail y). rewrite <- BEQ2. rewrite SIGNX in SEQ2. rewrite SEQ2. replace (negb true) -> false by auto. auto. (** x>0 , trailing x |x| false *) generalize (btrail x). rewrite SIGNX. auto. (** x>0 , trailing x |y| false *) generalize (btrail y). rewrite SIGNX in SEQ2. rewrite SEQ2. replace (negb false) -> true by auto. rewrite BEQ1. unfold trailing. intros T k R. unfold fnot. rewrite T; auto with arith. Qed. (** ** Involution of Decomposition and Recomposition *) (** These two fundemental lemmas allow reasoning conversely with bits or integers. *) (** [Z_of_bits] is the inverse of [bits_of_Z] *) Lemma Z_recomp_decomp: forall x: Z, Z_of_bits (bits_of_Z x) = x. Proof. intro x. unfold bits_of_Z. induction x; simpl. (** x = 0 *) unfold Z_of_bits. simpl. unfold N_recomp. simpl. trivial. (** x = Zpos p *) unfold Z_of_bits. simpl. unfold N_recomp. rewrite last_P_decomp; auto. rewrite P_recomp_decomp; auto. (** x = Zneg p *) unfold Z_of_bits. simpl. rewrite fnot_inv. pose ( z := zlnot (Zneg p) ). fold z. generalize (zlnot_inv (Zneg p)). intro H. rewrite <- H. f_equal. fold z. assert (ZDEF: z = Zpos p - 1). (** ZDEF *) unfold z. unfold zlnot. pose (u := Zneg p). fold u. pose (v := Zpos p). fold v. replace u -> (-v) by (unfold u; unfold v; simpl; trivial). omega. (** cont. *) assert (Q : z = 0 \/ exists q, z = Zpos q). (** Q *) destruct p. simpl in ZDEF. right. exists (p~1%positive - 1)%positive. trivial. simpl in ZDEF. right. exists (p~0%positive - 1)%positive. trivial. simpl in ZDEF. left. trivial. (** cont. *) elim Q. intro Z; rewrite Z; simpl. unfold N_recomp. simpl. trivial. intros [q Z]. rewrite Z; simpl. unfold N_recomp. rewrite last_P_decomp; auto. rewrite P_recomp_decomp; auto. Qed. (** [bits_of_Z] is the inverse of [Z_of_bits] modulo [btest] *) Lemma Z_decomp_recomp: forall b: bits, btest (bits_of_Z (Z_of_bits b)) = btest b. Proof. intros. unfold Z_of_bits. destruct (bsign b) eqn:BSIGN ; unfold bits_of_Z. (** NEGATIVE SIGN *) pose ( f := fnot (btest b) ). fold f. assert ( Fnot : btest b = fnot f). unfold f. rewrite fnot_inv. auto. pose ( x := N_recomp (bsize b) f ). fold x. assert ( Xpos : 0 <= x ) by ( apply N_recomp_pos; auto with zarith ). repeat rewrite zlnot_inv. case_leq 0 (zlnot x); intro SIGN; simpl. (** 0 <= zlnot x -> contradiction *) unfold zlnot in SIGN. apply False_ind. omega. (** 0 > zlnot x *) apply fnot_inj. rewrite fnot_inv. fold f. unfold x. apply N_decomp_recomp. apply trailing_fnot. simpl. rewrite <- BSIGN. rewrite <- Fnot. apply (btrail b). (** POSITIVE SIGN *) pose ( f := btest b ). fold f. pose ( x := N_recomp (bsize b) f ). fold x. assert ( Xpos : 0 <= x ) by ( apply N_recomp_pos; auto with zarith ). case_leq 0 x; intro H; try (apply False_ind; omega; fail). simpl. unfold f. unfold x. apply N_decomp_recomp. rewrite <- BSIGN. apply (btrail b). Qed. (** Two's complement symmetry. *) Lemma Z_decomp_recomp_sym: forall b: bits, btest (bits_of_Z (zlnot (Z_of_bits b))) = fnot (btest b). Proof. intros. unfold Z_of_bits. destruct (bsign b) eqn:BSIGN; unfold bits_of_Z; (try rewrite zlnot_inv). (** POSITIVE SIGN *) pose ( f := fnot (btest b)). fold f. pose ( x := N_recomp (bsize b) f ). fold x. assert ( Xpos : 0 <= x ) by ( apply N_recomp_pos; auto with zarith ). case_leq 0 x; intro H; try (apply False_ind; omega; fail). simpl. unfold f. unfold x. apply N_decomp_recomp. apply trailing_fnot. replace (negb false) -> true by auto. rewrite fnot_inv. rewrite <- BSIGN. apply (btrail b). (** NEGATIVE SIGN *) pose ( f := fnot (btest b) ). fold f. assert ( Fnot : btest b = fnot f). unfold f. rewrite fnot_inv. auto. pose ( x := N_recomp (bsize b) (btest b) ). fold x. assert ( Xpos : 0 <= x) by ( apply N_recomp_pos; auto with zarith ). case_leq 0 (zlnot x); intro SIGN; simpl. (** 0 <= zlnot x -> contradiction *) unfold zlnot in SIGN. apply False_ind. omega. (** 0 > zlnot x *) unfold f. f_equal. apply N_decomp_recomp. rewrite <- BSIGN. apply (btrail b). Qed. (** [Zfc] can be used to discriminate. *) Lemma btest_discrimination: forall x y: bits, btest x <> btest y -> Z_of_bits x <> Z_of_bits y. Proof. intros x y. intro BNEQ; apply contrap with (Q := btest x = btest y); auto; clear BNEQ. intro. rewrite <- (Z_decomp_recomp x); rewrite <- (Z_decomp_recomp y). f_equal; f_equal; auto. Qed. (** Sign can be used to discriminate. *) Lemma sign_discrimination: forall x y: bits, bsign x <> bsign y -> Z_of_bits x <> Z_of_bits y. Proof. intros x y SNEQ. apply btest_discrimination. apply contrap with (Q := bsign x = bsign y); auto. apply btest_sign. Qed. (** {@Zbit:} *) (** * Characteristic Function of integers *) (** Extracts the [k]-th bit of [x]. *) Definition Zbit (x : Z): Zfc := btest (bits_of_Z x). Definition TRUE : Zfc := fun _ => true. Definition FALSE : Zfc := fun _ => false. Lemma Zbit_of_zero: Zbit 0 = FALSE. Proof. unfold Zbit. unfold bits_of_Z. simpl. auto. Qed. Lemma Zbit_of_mone: Zbit (-1) = TRUE. Proof. unfold Zbit. unfold bits_of_Z. simpl. auto. Qed. (** The expected characteristic of binary decomposition of an integer *) Theorem Zbit_power: forall n k:nat, Zbit (two_power_nat n) k = beq_nat n k. Proof. unfold two_power_nat. unfold Zbit. unfold bits_of_Z. simpl. induction n; intro k. (** base *) destruct k; simpl; auto. (** ind. *) unfold shift_nat. destruct k; simpl; auto. Qed. (** The extensional unicity of [Zbit] for each integer *) Theorem Zbit_ext : forall x y: Z, Zbit x = Zbit y -> x = y. Proof. unfold Zbit. intros. rewrite <- (Z_recomp_decomp x). rewrite <- (Z_recomp_decomp y). apply btest_ext. auto. Qed. (** Two's complement symmetry *) Theorem Zbit_ext_sym : forall x y: Z, Zbit x = fnot (Zbit y) -> x = zlnot y. Proof. unfold Zbit. intros. rewrite <- (Z_recomp_decomp x). rewrite <- (Z_recomp_decomp y). apply btest_ext_sym. auto. Qed. (** * Position of the Highest Significant Bit in two's complement representation *) Definition ZxHpos (z:Z): nat := if (Zle_bool 0 z) then NxHpos (Nabs z) else NxHpos (Nabs (zlnot z)). (** Zero has no significant bit, as minus one *) Remark ZxHpos_is_zero: ZxHpos 0 = O /\ ZxHpos (-1) = O. Proof. split; by compute. Qed. (** [bsize] of a [bits_of_Z] gives the exact position. The use of the [last] function gives the exact position. *) Lemma bsize_exact: forall z:Z, ZxHpos (z) = bsize (bits_of_Z z). Proof. intro. unfold bits_of_Z. unfold ZxHpos. case_leq 0 z; unfold bsize; auto. Qed. (** [bsize] over approximates the exact position. The use of the [last] function gives the exact position. *) Lemma bsize_over_approx: forall b:bits, ZxHpos (Z_of_bits b) = last (btest b) (bsize b) (bsign b). Proof. intros. unfold ZxHpos. unfold Z_of_bits. destruct (bsign b) eqn:BSIGN. (** Negative *) pose ( f := fnot (btest b)). fold f. pose ( x := N_recomp (bsize b) f ). fold x. assert ( Xpos : 0 <= x ) by (apply N_recomp_pos; auto with zarith ). case_leq 0 (zlnot x); intro H; try (unfold zlnot in H; apply False_ind; omega; fail). rewrite zlnot_inv. unfold x. unfold f. rewrite NxHpos_N_recomp_pos. rewrite <- last_fnot. rewrite fnot_inv. by simpl. (** Positive *) case_leq 0 (N_recomp (bsize b) (btest b)); intro N_recomp. rewrite NxHpos_N_recomp_pos. trivial. generalize (N_recomp_pos(bsize b) (btest b)). intros. apply False_ind. omega. Qed. (** Two's complement symmetry *) Remark ZxHpos_sym: forall z: Z, ZxHpos (zlnot z) = ZxHpos z. Proof. intro. unfold ZxHpos; try rewrite zlnot_inv; unfold zlnot. case_leq 0 z; case_leq 0 (-(z+1)). Qed. (** Position of the highest significant bit of [two_power_nat]. *) Remark ZxHpos_of_two_power_nat: forall n: nat, (ZxHpos (two_power_nat n) = S n)%nat. Proof. intro. unfold ZxHpos. case_leq 0 (two_power_nat n); intro. (** 0 <=two_power_nat n *) induction n. (** Base *) by simpl. (** cont. *) rewrite two_power_nat_S. rewrite two_power_nat_S in H. replace (Nabs (2 * two_power_nat n)) -> (2 * Nabs (two_power_nat n))%N by by compute. rewrite NxHpos_2x_p0. by rewrite IHn. by compute. (** 0 > two_power_nat n *) generalize (two_power_nat_is_positive n). omega. Qed. (** Position of the highest significant bit of the predecesor of [two_power_nat]. *) Remark ZxHpos_of_two_power_nat_minus_one: forall n: nat, (ZxHpos ((two_power_nat n) - 1) = n)%nat. Proof. intro. unfold ZxHpos. case_leq 0 ((two_power_nat n) -1); intro. (** 0 <=(two_power_nat n) - 1 *) induction n. (** Base *) by simpl. (** cont. *) rewrite two_power_nat_S. rewrite two_power_nat_S in H. assert ((Nabs (2 * two_power_nat n - 1) = 2 * Nabs (two_power_nat n - 1) +1)%N) as EQ. generalize (two_power_nat_is_positive n); intro. assert (0 <= (two_power_nat n - 1)) as A0 by omega. assert (0 < 2 * (two_power_nat n - 1) + 1) as A1 by omega. replace (2 * two_power_nat n - 1) -> (2 * (two_power_nat n - 1) + 1) by omega. destruct (two_power_nat n - 1); by auto. rewrite EQ. rewrite NxHpos_2x_p1. by rewrite IHn. (** 0 > two_power_nat n *) generalize (two_power_nat_is_positive n). omega. Qed. (** [ZxHpos] increases for positive input values *) Remark ZxHpos_incr_for_positive: forall x a: Z, 0 <= x -> 0 <= a -> (ZxHpos x <= ZxHpos (x + a))%nat. Proof. intros. unfold ZxHpos. case_leq 0 x. case_leq 0 (x + a). intros. destruct x; destruct a; try (by compute). replace (Nabs (Zpos p + Zpos p0)) -> (Npos p + Npos p0)%N by simpl. apply NxHpos_incr. Qed. (** [ZxHpos] decreases for negative input values *) Remark ZxHpos_decr_for_negative: forall x a: Z, x <= 0 -> a <= 0 -> (ZxHpos x <= ZxHpos (x + a))%nat. Proof. intros. unfold ZxHpos. unfold zlnot. case_leq 0 x; case_leq 0 (x + a); intros; try (replace x -> 0 by omega); try (by compute). case_leq (-1) x; intros; try (replace x -> (-1) by omega); try (by compute). assert (- (x + 1) >= 0) as X by omega. assert (- a >= 0) as A by omega. clear H; clear H0; clear H1; clear H2; clear H3. replace (-(x+a+1)) -> (-(x+1) + -a) by omega. pose (b := -a); fold b; fold b in A. pose (y := -(x+1)); fold y; fold y in X. destruct y; destruct b; try (by compute). replace (Nabs (Zpos p + Zpos p0)) -> (Npos p + Npos p0)%N by simpl. apply NxHpos_incr. Qed. (** [two_power_nat_of (ZxHpos z)] gives an upper bound for [z] *) Remark two_power_nat_of_ZxHpos: forall z: Z, z < two_power_nat (ZxHpos z). Proof. destruct z. (** zero *) by compute. (** positive *) unfold ZxHpos. replace (Nabs (Zpos p)) -> (Npos p) by (by simpl). replace (Zpos p) -> (Z_of_N (Npos p)) by (by simpl). induction p. (** 2p+1 *) simpl. simpl in IHp. replace (Zpos p~1) -> (2*(Zpos p) + 1)%Z by (auto with zarith). rewrite two_power_nat_S. omega. (** 2p *) simpl. simpl in IHp. replace (Zpos p~0) -> (2*Zpos p)%Z by (auto with zarith). rewrite two_power_nat_S. omega. (** one *) by compute. (** negative *) assert (Zneg p < 0)%Z by (by simpl). generalize (two_power_nat_is_positive (ZxHpos (Zneg p))). omega. Qed. (** Lower upper [two_power_nat] bound of an integer. *) Definition ZxHbound (z: Z): Z := two_power_nat (ZxHpos z). Remark ZxHbound_of_two_power_nat_minus_one: forall n: nat, ZxHbound ((two_power_nat n) - 1) = two_power_nat n. Proof. intro. unfold ZxHbound. rewrite ZxHpos_of_two_power_nat_minus_one. auto. Qed. (** [ZxHbound] gives an upper and lower bound. *) Lemma ZxHrange: forall z: Z, let bound := ZxHbound z in -bound <= z < bound. Proof. intro. unfold ZxHbound. case_leq 0 z; intro. (** 0 <= z *) generalize (two_power_nat_of_ZxHpos z). split; omega. (** 0 > z *) generalize (two_power_nat_of_ZxHpos (-(z+1))). rewrite <- (ZxHpos_sym z). unfold zlnot. split; omega. Qed. Remark ZxHpos_le: forall x y: Z, ZxHbound x <= ZxHbound y -> (ZxHpos x <= ZxHpos y)%nat. Proof. unfold ZxHbound. intros x y. pose (X := ZxHpos x). fold X. pose (Y := ZxHpos y). fold Y. generalize X Y. induction X0; intro. (** base *) generalize (two_power_nat_is_positive Y0). replace (two_power_nat 0) -> 1 by compute. omega. (** cont. *) rewrite two_power_nat_S. induction Y0. (** base *) generalize (two_power_nat_is_positive X0). replace (two_power_nat 0) -> 1 by compute. omega. (** cont. *) rewrite two_power_nat_S. cut ((2 * two_power_nat X0) <= (2 * two_power_nat Y0) -> (S X0 <= S Y0)%nat). omega. generalize (IHX0 Y0). omega. Qed. Remark ZxHbound_le: forall x y: Z, (ZxHpos x <= ZxHpos y)%nat -> ZxHbound x <= ZxHbound y. Proof. unfold ZxHbound. intros x y. pose (X := ZxHpos x). fold X. pose (Y := ZxHpos y). fold Y. repeat rewrite two_power_nat_S. generalize X Y. induction X0; intro. (** base *) generalize (two_power_nat_is_positive Y0). replace (two_power_nat 0) -> 1 by compute. omega. (** cont. *) rewrite two_power_nat_S. induction Y0. (** base *) generalize (two_power_nat_is_positive X0). replace (two_power_nat 0) -> 1 by compute. omega. (** cont. *) intro. rewrite two_power_nat_S. cut ((2 * two_power_nat X0) <= (2 * two_power_nat Y0)). omega. apply (IHX0 Y0). omega. Qed. Remark ZxHbound_lt: forall x y: Z, (ZxHpos x < ZxHpos y)%nat -> ZxHbound x < ZxHbound y. Proof. unfold ZxHbound. intros x y. pose (X := ZxHpos x). fold X. pose (Y := ZxHpos y). fold Y. repeat rewrite two_power_nat_S. generalize X Y. induction X0; intro. (** base *) generalize (two_power_nat_is_positive Y0). replace (two_power_nat 0) -> 1 by compute. induction Y0; repeat rewrite two_power_nat_S; omega. (** cont. *) rewrite two_power_nat_S. induction Y0. (** base *) generalize (two_power_nat_is_positive X0). replace (two_power_nat 0) -> 1 by compute. omega. (** cont. *) intro. rewrite two_power_nat_S. apply (IHX0 Y0). omega. Qed. Lemma ZxHpower: forall (n: nat) (z: Z), -(two_power_nat n) <= z < two_power_nat n -> ZxHbound z <= two_power_nat n. Proof. intros. rewrite <- ZxHbound_of_two_power_nat_minus_one. apply ZxHbound_le. destruct H. case_leq 0 z; intro. (** 0 <= z *) clear H. replace (two_power_nat n - 1) -> (z + ((two_power_nat n - 1) - z)) by omega. pose (d := ((two_power_nat n - 1) - z)); fold d. assert (0 <= d) as D by (unfold d; omega). by (apply ZxHpos_incr_for_positive). (** 0 > z *) rewrite <- (ZxHpos_sym z). unfold zlnot. replace (two_power_nat n - 1) -> (-(z+1) + (z+two_power_nat n)) by omega. pose (x := -(z+1)); fold x. pose (d := (z + two_power_nat n)); fold d. assert (0 <= d) as D by (unfold d; omega). apply ZxHpos_incr_for_positive. unfold x. omega. unfold d. omega. Qed. (** ** Main tactics.*) Ltac Zbit_ext k := apply Zbit_ext; extensionality k. Require Import Cint. Ltac rewrite_cst := first [ Cint.rewrite_cst | COMPUTE1 zlnot Cst_Z | COMPUTE1 ZxHpos Cst_Z | COMPUTE1 ZxHpower Cst_Z]. (** Example of use. *) Remark rewrite_cst_example: forall x: Z, x + zlnot (zlnot (0)) = x + Z_of_nat (ZxHpos 0). Proof. rewrite_cst. intro. auto. Qed. frama-c-Fluorine-20130601/src/wp/share/Vset.v0000644000175000017500000000627412155630174017441 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) Require Import ZArith. Set Implicit Arguments. (* -------------------------------------------------------------------------- *) (* --- Set Library for Coq --- *) (* -------------------------------------------------------------------------- *) Parameter set : Set -> Set. Parameter member : forall A : Set, A -> (set A) -> Prop. Hypothesis eqset : forall A : Set, forall (a b : set A), a = b <-> (forall x, member x a <-> member x b). Parameter descr : forall A : Set, (A -> Prop) -> (set A). Hypothesis description : forall (A:Set) (f : A -> Prop) x, member x (descr f) <-> f x. Definition union {A:Set} (a b : set A) := descr (fun x => member x a \/ member x b). Definition inter {A:Set} (a b : set A) := descr (fun x => member x a /\ member x b). Definition empty {A:Set} : set A := descr (fun x => False). Definition disjoint {A:Set} (a b : set A) := forall (x y : A), member x a -> member x b -> False. Definition singleton {A : Set} (e : A) : set A := descr (fun x => x=e). Lemma union_empty : forall A, forall a : set A, union a empty = a. Proof. intros. apply eqset. intro x. unfold union. rewrite description. unfold empty. rewrite description. tauto. Qed. Lemma inter_empty : forall A, forall a : set A, inter a empty = empty. Proof. intros. apply eqset. intro x. unfold inter. rewrite description. unfold empty. rewrite description. tauto. Qed. Definition range a b := descr (fun x => a <= x <= b)%Z. Definition range_sup a := descr (fun x => a <= x)%Z. Definition range_inf b := descr (fun x => x <= b)%Z. Definition range_all := descr (fun (_:Z) => True). frama-c-Fluorine-20130601/src/wp/share/Qedlib.v0000644000175000017500000002364112155630174017715 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) Require Import Bool. Require Import ZArith. Require Import Reals. Open Scope Z_scope. Set Implicit Arguments. (** ** Tactical *) Ltac forward := repeat (first [ split | intros ]) ; try discriminate ; try contradiction ; try tauto ; try constructor ; try (apply False_ind ; omega ; fail) ; try (apply False_ind ; auto with zarith ; fail) ; auto with zarith. Ltac finish := forward ; fail. Tactic Notation "by" tactic(A) := A ; finish. Tactic Notation "replace" constr(A) "->" constr(B) "by" tactic(T) := let H := fresh in assert (H : A=B) by (T ; forward) ; rewrite -> H ; clear H. Tactic Notation "replace" constr(A) "<-" constr(B) "by" tactic(T) := let H := fresh in assert (H : A=B) by (T ; forward) ; rewrite <- H ; clear H. Tactic Notation "replace" constr(A) "->" constr(B) "by" tactic(T) "in" hyp(G) := let H := fresh in assert (H : A=B) by (T ; forward) ; rewrite -> H in G; clear H. Tactic Notation "replace" constr(A) "<-" constr(B) "by" tactic(T) "in" hyp(G) := let H := fresh in assert (H : A=B) by (T ; forward) ; rewrite <- H in G; clear H. (** ** Conditional Property *) Definition itep (A B C : Prop) := (A -> B) /\ (~A -> C). Lemma ite_then : forall A B C : Prop, itep A B C -> A -> B. Proof. by (unfold itep). Qed. Lemma ite_else : forall A B C : Prop, itep A B C -> ~A -> C. Proof. by (unfold itep). Qed. Lemma ite_both : forall A B C : Prop, itep A B C -> (B \/ C). Proof. by (unfold itep). Qed. (** ** Booleans *) Inductive reflect (P:Prop) : bool -> Prop := | R_true : P -> reflect P true | R_false : ~P -> reflect P false. Definition boolean {A : Set} (f : A -> A -> bool) (p : A -> A -> Prop) : Prop := forall x y, reflect (p x y) (f x y). (* forall x y, (f x y = true <-> p x y) /\ (f x y = false <-> ~(p x y)). *) Ltac case_leq x y := generalize (Zle_cases x y) ; induction (Zle_bool x y) ; try omega. Ltac case_lt x y := generalize (Zlt_cases x y) ; induction (Zlt_bool x y) ; try omega. Ltac case_eq x y := generalize (Zeq_bool_if x y) ; induction (Zeq_bool x y) ; try omega. Lemma Zneq_cases : forall x y, if Zneq_bool x y then x <> y else x = y. Proof. intros x y. generalize (Zeq_bool_if x y). unfold Zeq_bool. unfold Zneq_bool. induction (x ?= y) ; auto. Qed. Ltac case_neq x y := generalize (Zneq_cases x y) ; induction (Zneq_bool x y) ; try omega. Inductive Zcases (x y : Z) := | Case_lt : (x < y) -> Zcases x y | Case_eq : (x = y) -> Zcases x y | Case_gt : (x > y) -> Zcases x y. Program Definition Zcompare x y : Zcases x y. Proof. intros. case_leq x y. case_lt x y. intros H _. exact (Case_lt H). intros H1 H2. assert (H : x=y) by omega. exact (Case_eq H). intro H. exact (Case_gt H). Qed. Theorem Zeq_boolean : boolean Zeq_bool (fun x y => (x=y)). Proof. unfold boolean. intros x y. by (case_eq x y). Qed. Theorem Zneq_boolean : boolean Zneq_bool (fun x y => (x <> y)). Proof. unfold boolean. intros x y. by (case_neq x y). Qed. Theorem Zlt_boolean : boolean Zlt_bool Zlt. Proof. unfold boolean. intros x y. by (case_lt x y). Qed. Theorem Zle_boolean : boolean Zle_bool Zle. Proof. unfold boolean. intros x y. by (case_leq x y). Qed. Parameter Req_bool : R -> R -> bool. Parameter Rlt_bool : R -> R -> bool. Parameter Rle_bool : R -> R -> bool. Parameter Rneq_bool : R -> R -> bool. Hypothesis Rlt_boolean : boolean Rlt_bool Rlt. Hypothesis Rle_boolean : boolean Rle_bool Rle. Hypothesis Req_boolean : boolean Req_bool (fun x y => (x=y)). Hypothesis Rneq_boolean : boolean Rneq_bool (fun x y => (x<>y)). Parameter Aeq_bool : forall A : Set, A -> A -> bool. Hypothesis Aeq_boolean : forall A : Set, boolean (@Aeq_bool A) (fun x y => x=y). Definition Aneq_bool {A : Set} (x y : A) := negb (Aeq_bool x y). Hypothesis Aneq_boolean : forall A : Set, boolean (@Aneq_bool A) (fun x y => x<>y). (** ** Integer Induction (after a given rank) *) Theorem Z_induction(m : Z)(P : Z -> Prop) : (forall n, n <= m -> P n ) -> (forall n, n >= m -> P n -> P (n+1)) -> (forall n, P n). Proof. intros. induction (Z_le_dec n m) ; auto with zarith. apply Z.le_ind with (n := m) ; auto with zarith. unfold Morphisms.Proper. unfold Morphisms.respectful. intros. rewrite H1. intuition. intros. apply H0 ; auto with zarith. Qed. (** ** Real Constants *) (** signed power *) Definition real_base e a n := match n with | 0 => 1%R | Zpos n => (a * pow e (Pos.to_nat n))%R | Zneg n => (a / pow e (Pos.to_nat n))%R end. (** an integer multiplied by a (signed) power of 10. *) Definition real_dec := real_base 10%R. (** an integer multiplied by a (signed) power of 2. *) Definition real_hex := real_base 2%R. (** ** Arrays *) Definition equality (A : Set) := forall (x y : A), {x=y}+{x<>y}. Record farray (A B : Set) := { array_eq : equality A ; access :> A -> B }. Definition array (A : Set) := farray Z A. Definition array_def {A : Set} (f : Z -> A) := {| array_eq := Z_eq_dec ; access := f |}. Hypothesis extensionality: forall (A B : Set) (f g : A -> B), (forall x, f x = g x) -> f = g. Lemma farray_eq : forall A B (m1 m2 : farray A B), array_eq m1 = array_eq m2 -> (forall k, m1 k = m2 k) -> m1 = m2. Proof. intros A B m1 m2. induction m1. induction m2. simpl. (intro H ; rewrite H ; clear H). intro K. replace access0 -> access1 by (apply extensionality). finish. Qed. Definition update {A B : Set} (m : farray A B) (k : A) (v : B) : (farray A B) := Build_farray (array_eq m) (fun i => if array_eq m i k then v else m i). Notation " a .[ k <- v ] " := (update a k v) (at level 70). Lemma access_update : forall (A B : Set) (m : farray A B) k v, m.[k <- v] k = v. Proof. intros. simpl. elim (array_eq _ k k) ; intuition. Qed. Lemma access_update_neq : forall (A B : Set) (m : farray A B) i j v, i <> j -> m.[ i <- v ] j = m j. Proof. intros. simpl. by (induction (array_eq m j i) ; [absurd (i=j)|]). Qed. (** ** Division on Z *) Definition Cdiv (n d : Z) : Z := match n , d with | 0 , _ | _ , 0 => 0 | Zpos a , Zpos b | Zneg a , Zneg b => (Zpos a/Zpos b) | Zpos a , Zneg b | Zneg a , Zpos b => (-(Zpos a/Zpos b)) end. Definition Cmod (n d : Z) : Z := match n , d with | 0 , _ | _ , 0 => 0 | Zpos a , Zpos b | Zpos a , Zneg b => ( (Zpos a) mod (Zpos b) ) | Zneg a , Zpos b | Zneg a , Zneg b => (-( (Zpos a) mod (Zpos b) )) end. Lemma Cdiv_cases : forall n d, ((n >= 0) -> (d > 0) -> Cdiv n d = n/d) /\ ((n <= 0) -> (d > 0) -> Cdiv n d = -((-n)/d)) /\ ((n >= 0) -> (d < 0) -> Cdiv n d = -(n/(-d))) /\ ((n <= 0) -> (d < 0) -> Cdiv n d = (-n)/(-d)). Proof. intros. destruct n as [|a|a] ; destruct d as [|b|b] ; intuition ; by auto with zarith. Qed. Lemma Cmod_cases : forall n d, ((n >= 0) -> (d > 0) -> Cmod n d = n mod d) /\ ((n <= 0) -> (d > 0) -> Cmod n d = -((-n) mod d)) /\ ((n >= 0) -> (d < 0) -> Cmod n d = (n mod (-d))) /\ ((n <= 0) -> (d < 0) -> Cmod n d = -((-n) mod (-d))). Proof. intros. destruct n as [|a|a] ; destruct d as [|b|b] ; intuition ; by auto with zarith. Qed. Theorem Cdiv_enclidian : forall (n d : Z), d <> 0 -> let q := Cdiv n d in let r := Cmod n d in (q * d + r = n). Proof. intros n d NEQ q r. assert (OPP: forall p, (- (Zneg p) = Zpos p)) by auto with zarith. assert (NEG: forall p, (Zneg p = - (Zpos p))) by auto with zarith. destruct n as [|a|a] ; destruct d as [|b|b] ; auto with zarith ; unfold Cdiv in q ; unfold Cmod in r ; unfold q ; unfold r ; repeat rewrite OPP ; repeat rewrite NEG ; rewrite (Zmod_eq_full (Zpos a) (Zpos b)) ; try discriminate ; try ring. Qed. Lemma Cmod_less : forall n d, ((n >= 0) -> (d > 0) -> 0 <= Cmod n d < d) /\ ((n <= 0) -> (d > 0) -> -d < Cmod n d <= 0) /\ ((n >= 0) -> (d < 0) -> 0 <= Cmod n d < -d) /\ ((n <= 0) -> (d < 0) -> d < Cmod n d <= 0). Proof. intros. destruct n as [|a|a] ; destruct d as [|b|b] ; intuition ; simpl ; forward ; generalize (Z_mod_lt (Zpos a) (Zpos b) (Zgt_pos_0 b)) ; repeat (replace (Zneg b) -> (- Zpos b) by auto with zarith) ; intuition (auto with zarith). Qed. Lemma Zdiv_less : forall (n d : Z), (n > 0) -> (d > 0) -> (d * (n/d) <= n). Proof. intros n d Npos Dpos. generalize (Zmod_eq n d). pose (x := (n/d)). fold x. intro H. generalize (H Dpos). clear H. pose (r := (n mod d)). fold r. intro H. generalize (Z_mod_lt n d). intro R. generalize (R Dpos). clear R. fold r. replace (d*x) -> (x*d) by ring. omega. Qed. frama-c-Fluorine-20130601/src/wp/share/Memory.v0000644000175000017500000002672712155630174017775 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Formalization of Pointers --- *) (* -------------------------------------------------------------------------- *) Require Import ZArith. Require Import Qedlib. (** ** Addresses *) Record addr : Set := { base : Z ; offset : Z }. Lemma addr_eq : forall (p q : addr), base p = base q -> offset p = offset q -> p=q. Proof. intros p q. induction p. induction q. simpl. repeat ( intro H ; rewrite H ; clear H ). reflexivity. Qed. Lemma addr_eq_inv : forall a i b j, {| base := a ; offset := i |} = {| base := b ; offset := j |} -> ( a = b /\ i = j ). Proof. intros. split. assert ( E : base {| base := a; offset := i |} = base {| base := b; offset := j |} ). by (rewrite H). by (simpl in E). assert ( E : offset {| base := a; offset := i |} = offset {| base := b; offset := j |} ). by (rewrite H). by (simpl in E). Qed. Lemma addr_neq_inv : forall p q, ( base p <> base q \/ offset p <> offset q ) -> p <> q. Proof. intros. elim H ; clear H ; intros NEQ EQ ; by (rewrite EQ in NEQ). Qed. Lemma addr_neq_base : forall p q, base p <> base q -> p <> q. Proof. intros p q NEQ EQ. by (rewrite EQ in NEQ). Qed. Lemma addr_neq_offset : forall p q, offset p <> offset q -> p <> q. Proof. intros p q NEQ EQ. by (rewrite EQ in NEQ). Qed. (** ** Addresses Comparison *) Definition addr_le (p q : addr) := (base p = base q) /\ (offset p <= offset q)%Z. Definition addr_lt (p q : addr) := (base p = base q) /\ (offset p < offset q)%Z. Definition addr_eq_bool (p q : addr) := andb (Zeq_bool (base p) (base q)) (Zeq_bool (offset p) (offset q)). Definition addr_le_bool (p q : addr) := andb (Zeq_bool (base p) (base q)) (Zle_bool (offset p) (offset q)). Definition addr_lt_bool (p q : addr) := andb (Zeq_bool (base p) (base q)) (Zlt_bool (offset p) (offset q)). Lemma addr_le_boolean : boolean addr_le_bool addr_le. Proof. unfold boolean. intros x y. unfold addr_le_bool,addr_le. by ( case_eq (base x) (base y) ; case_leq (offset x) (offset y) ). Qed. Lemma addr_lt_boolean : boolean addr_lt_bool addr_lt. Proof. unfold boolean. intros x y. unfold addr_lt_bool,addr_lt. by ( case_eq (base x) (base y) ; case_lt (offset x) (offset y) ). Qed. (** ** Pointer Arithmetic *) Definition null := {| base := 0 ; offset := 0 |}. Definition global b := {| base := b ; offset := 0 |}. Definition shift p k := {| base := base p ; offset := offset p + k |}. Lemma shift_shift : forall p k1 k2, shift (shift p k1) k2 = shift p (k1+k2). Proof. intros. repeat (unfold shift ; simpl). apply addr_eq ; simpl ; auto with zarith. Qed. Lemma shift_zero : forall p, shift p 0 = p. Proof. intros. unfold shift ; apply addr_eq ; simpl ; auto with zarith. Qed. Definition in_range q p a := exists i, 0 <= i < a /\ q = shift p i. Definition included p a q b := (a > 0)%Z -> ( (b >= 0)%Z /\ base p = base q /\ (offset q <= offset p)%Z /\ (offset p + a <= offset q + b )%Z ). Lemma included_correct : forall p a q b, included p a q b <-> (forall r, in_range r p a -> in_range r q b). Proof. (* ==> *) intros. split. intros INC r [i [ri rsi]]. unfold included in INC. exists (offset p + i - offset q). unfold shift. rewrite rsi. unfold shift ; simpl. split ; try apply addr_eq ; simpl ; auto with zarith. (* <== *) intro Range. unfold included. intros apos. generalize (Range p). intro RP. pose (r := shift p (a-1)). generalize (Range r). intro RR. assert (PA: in_range p p a). exists 0 ; split ; auto with zarith. unfold shift. apply addr_eq ; simpl ; auto with zarith. assert (PB: in_range p q b). by (apply RP). assert (RA: in_range r p a). unfold r. exists (a-1) ; split ; auto with zarith. assert (RB: in_range r q b). by (apply RR). destruct RA as [i [Ir Iaddr]]. destruct RB as [j [Jr Jaddr]]. destruct PB as [k [Kr Kaddr]]. rewrite Iaddr in Jaddr. assert (BASE: base p = base q). by (rewrite Kaddr). assert (OFF1: offset p = offset q + k). by (rewrite Kaddr). assert (OFF2: offset (shift p i) = offset (shift q j)). by (rewrite Jaddr). assert (OFF3: offset r = offset (shift p i)). by (rewrite Iaddr). unfold r in OFF3. simpl in OFF3. assert (OFF4: i = a-1) by omega. simpl in OFF2. intuition auto with zarith. Qed. Definition separated p a q b := (a <= 0)%Z \/ (b <= 0)%Z \/ ( base p <> base q ) \/ ( offset q + b <= offset p )%Z \/ ( offset p + a <= offset q )%Z. Lemma separated_neq : forall p a q b p' q', separated p a q b -> included p' 1 p a -> included q' 1 q b -> p' <> q'. Proof. intros p a q b p' q' SEP InP InQ EQ. unfold separated in SEP. unfold included in InP,InQ. case_lt 0%Z a. case_lt 0%Z b. intros BPOS APOS. generalize InP ; clear InP. intro H ; elim H ; clear H ; auto with zarith. intro H. clear H. intro H ; elim H ; clear H. intro BaseP. intro H ; elim H ; clear H. intros InP1 InP2. generalize InQ ; clear InQ. intro H ; elim H ; clear H ; auto with zarith. intro H. clear H. intro H ; elim H ; clear H. intro BaseQ. intro H ; elim H ; clear H. intros InQ1 InQ2. generalize SEP ; clear SEP. intro H ; elim H ; clear H ; auto with zarith. intro H ; elim H ; clear H ; auto with zarith. intro H ; elim H ; clear H ; auto with zarith. rewrite <- EQ in BaseQ. rewrite BaseP in BaseQ. contradiction. rewrite <- EQ in InQ1,InQ2. omega. Qed. Lemma separated_not_included : forall p a q b, (a > 0)%Z -> (b > 0)%Z -> separated p a q b -> ~(included p a q b). Proof. unfold separated. unfold included. unfold not. intuition. Qed. Lemma included_not_separated : forall p a q b, (a > 0)%Z -> (b > 0)%Z -> included p a q b -> ~(separated p a q b). Proof. unfold separated. unfold included. unfold not. intuition. Qed. Lemma included_trans : forall p a q b r c, included p a q b -> included q b r c -> included p a r c. Proof. intros p a q b r c. unfold included. intuition. Qed. Lemma included_refl : forall p a, included p a p a. Proof. intros p a. unfold included. intuition. Qed. Lemma separated_trans : forall p a q b r c, included p a q b -> separated q b r c -> separated p a r c. Proof. intros p a q b r c. case_leq a 0%Z. unfold separated. intuition. intro Apos. unfold included. unfold separated. intuition. Qed. Lemma separated_sym : forall p a q b, separated p a q b -> separated q b p a. Proof. intros p a q b. unfold separated. intuition. Qed. Ltac pointer_arith := repeat (unfold separated,included,shift ; simpl) ; repeat (intros ; split) ; forward. (** ** Validity *) Definition malloc := farray Z Z. Definition valid_rd ( m : malloc ) p n := (n > 0)%Z -> ( 0 <= offset p /\ offset p + n <= m (base p))%Z. Definition valid_rw ( m : malloc ) p n := (n > 0)%Z -> ( 0 < base p /\ 0 <= offset p /\ offset p + n <= m (base p))%Z. Lemma valid_rw_rd : forall m p n, valid_rw m p n -> valid_rd m p n. Proof. intros m p n. unfold valid_rw. unfold valid_rd. intuition (auto with zarith). Qed. Lemma valid_string : forall (m : malloc) p, ( base p < 0 )%Z -> ( 0 <= offset p < m (base p) )%Z -> ( valid_rd m p 1 /\ ~(valid_rw m p 1) ). Proof. intros m p. unfold valid_rd. unfold valid_rw. intuition (auto with zarith). Qed. (** ** Memories *) Definition mem (A : Set) := farray addr A. Definition eqmem{A} (m1 m2 : mem A) p n := forall q, included q 1 p n -> m1 q = m2 q. Definition havoc{A} (m1 m2 : mem A) p n := forall q, separated q 1 p n -> m1 q = m2 q. Lemma eqmem_sym : forall A (m1 m2 : mem A) p n, eqmem m1 m2 p n -> eqmem m2 m1 p n. Proof. intros A m1 m2 p a. unfold eqmem. intro H. intros. cut (m1 q = m2 q). intro E ; rewrite E ; reflexivity. apply H ; auto. Qed. Lemma havoc_sym : forall A (m1 m2 : mem A) p n, havoc m1 m2 p n -> havoc m2 m1 p n. Proof. intros A m1 m2 p n. unfold havoc. intro H. intros. cut (m1 q = m2 q). intro E ; rewrite E ; reflexivity. apply H ; auto. Qed. Lemma update_separated : forall A (m : mem A) p x q, separated q 1 p 1 -> m.[ p <- x ] q = m q. Proof. intros A m p x q SEP. apply access_update_neq. generalize SEP. unfold separated. intuition. rewrite H in H0. auto. rewrite H in H1. auto with zarith. rewrite H in H1. auto with zarith. Qed. Lemma eqmem_shift : forall A (m1 m2 : mem A) p n k, eqmem m1 m2 p n -> (0 <= k < n)%Z -> m1 (shift p k) = m2 (shift p k). Proof. intros. apply H. unfold included. intuition ; unfold shift ; simpl ; auto with zarith. Qed. Lemma havoc_left : forall A (m1 m2 : mem A) p n k, havoc m1 m2 p n -> (k < 0)%Z -> m1 (shift p k) = m2 (shift p k). Proof. intros. apply H. unfold separated. intuition pointer_arith. Qed. Lemma havoc_right : forall A (m1 m2 : mem A) p n k, havoc m1 m2 p n -> (k >= n)%Z -> m1 (shift p k) = m2 (shift p k). Proof. intros. apply H. unfold separated. intuition pointer_arith. Qed. Lemma eqmem_included : forall A (m1 m2 : mem A) p q a b, included p a q b -> eqmem m1 m2 q b -> eqmem m1 m2 p a. Proof. intros A m1 m2 p q a b INC EQ. unfold eqmem. intros r Range. apply EQ. apply included_trans with (q:=p) (b:=a) ; auto. Qed. Lemma havoc_separated : forall A (m1 m2 : mem A) p q a b, separated p a q b -> havoc m1 m2 q b -> eqmem m1 m2 p a. Proof. intros A m1 m2 p q a b SEP HAVOC. unfold eqmem. intros r Range. apply HAVOC. apply separated_trans with (q:=p) (b:=a) ; auto. Qed. (** ** Regions *) Parameter region : Z -> Z. Parameter linked : malloc -> Prop. Parameter sconst : mem Z -> Prop. Definition framed (m : mem addr) := forall p, region (base (m p)) <= 0%Z. Lemma separated_region : forall p a q b, region (base p) <> region (base q) -> separated p a q b. Proof. intros p a q b RDIFF. unfold separated. right. right. left. intuition. apply RDIFF. rewrite H. auto. Qed. (** ** Cast *) Parameter cast : addr -> Z. Hypothesis cast_injective : forall p q, cast p = cast q -> p = q. (** ** Physical Addresses *) Parameter hardware : Z -> Z. frama-c-Fluorine-20130601/src/wp/share/Cint.v0000644000175000017500000002432412155630174017411 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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-Integer Library for Coq --- *) (* -------------------------------------------------------------------------- *) Require Import ZArith. Require Import Qedlib. Open Local Scope Z_scope. (** * C-Integer Ranges *) Definition is_uint8(x:Z) := 0 <= x < 256. Definition is_sint8(x:Z) := -128 <= x < 128. Definition is_uint16(x:Z) := 0 <= x < 65536. Definition is_sint16(x:Z) := -32768 <= x < 32768. Definition is_uint32(x:Z) := 0 <= x < 4294967296. Definition is_sint32(x:Z) := -2147483648 <= x < 2147483648. Definition is_uint64(x:Z) := 0 <= x < 18446744073709551616. Definition is_sint64(x:Z) := -9223372036854775808 <= x < 9223372036854775808. Definition to_range a b z := a + (z-a) mod (b-a). Lemma is_to_range: forall a b z, a a <= to_range a b z < b. Proof. intros. unfold to_range. assert (Q : b-a > 0) ; auto with zarith. generalize (Z_mod_lt (z-a) (b-a) Q). intro R. auto with zarith. Qed. Definition to_uint8 := to_range 0 256. Definition to_sint8 := to_range (-128) 128. Definition to_uint16 := to_range 0 65536. Definition to_sint16 := to_range (-32768) 32768. Definition to_uint32 := to_range 0 4294967296. Definition to_sint32 := to_range (-2147483648) 2147483648. Definition to_uint64 := to_range 0 18446744073709551616. Definition to_sint64 := to_range (-9223372036854775808) 9223372036854775808. (** * C-Integer Conversions are in-range *) Local Ltac to_range := intro x ; apply is_to_range ; omega. Lemma is_to_uint8 : forall x, is_uint8(to_uint8 x). Proof. to_range. Qed. Lemma is_to_sint8 : forall x, is_sint8(to_sint8 x). Proof. to_range. Qed. Lemma is_to_uint16 : forall x, is_uint16(to_uint16 x). Proof. to_range. Qed. Lemma is_to_sint16 : forall x, is_sint16(to_sint16 x). Proof. to_range. Qed. Lemma is_to_uint32 : forall x, is_uint32(to_uint32 x). Proof. to_range. Qed. Lemma is_to_sint32 : forall x, is_sint32(to_sint32 x). Proof. to_range. Qed. Lemma is_to_uint64 : forall x, is_uint64(to_uint64 x). Proof. to_range. Qed. Lemma is_to_sint64 : forall x, is_sint64(to_sint64 x). Proof. to_range. Qed. (** * C-Integer Conversions are identity when in-range *) Lemma id_to_range : forall a b x, a <= x < b -> to_range a b x = x. Proof. intros a b x Range. unfold to_range. assert (Q : b-a > 0) ; auto with zarith. cut ((x-a) mod (b-a) = (x-a)). omega. apply Zmod_small. omega. Qed. Local Ltac id_range := intro x ; apply id_to_range ; omega. Lemma id_uint8 : forall x, is_uint8 x -> (to_uint8 x) = x. Proof. id_range. Qed. Lemma id_sint8 : forall x, is_sint8 x -> (to_sint8 x) = x. Proof. id_range. Qed. Lemma id_uint16 : forall x, is_uint16 x -> (to_uint16 x) = x. Proof. id_range. Qed. Lemma id_sint16 : forall x, is_sint16 x -> (to_sint16 x) = x. Proof. id_range. Qed. Lemma id_uint32 : forall x, is_uint32 x -> (to_uint32 x) = x. Proof. id_range. Qed. Lemma id_sint32 : forall x, is_sint32 x -> (to_sint32 x) = x. Proof. id_range. Qed. Lemma id_uint64 : forall x, is_uint64 x -> (to_uint64 x) = x. Proof. id_range. Qed. Lemma id_sint64 : forall x, is_sint64 x -> (to_sint64 x) = x. Proof. id_range. Qed. (** * C-Integer Conversions are projections *) Local Ltac proj := intro x ; apply id_to_range ; apply is_to_range ; omega. Lemma proj_uint8 : forall x, to_uint8(to_uint8 x)=to_uint8 x. Proof. proj. Qed. Lemma proj_sint8 : forall x, to_sint8(to_sint8 x)=to_sint8 x. Proof. proj. Qed. Lemma proj_uint16 : forall x, to_uint16(to_uint16 x)=to_uint16 x. Proof. proj. Qed. Lemma proj_sint16 : forall x, to_sint16(to_sint16 x)=to_sint16 x. Proof. proj. Qed. Lemma proj_uint32 : forall x, to_uint32(to_uint32 x)=to_uint32 x. Proof. proj. Qed. Lemma proj_sint32 : forall x, to_sint32(to_sint32 x)=to_sint32 x. Proof. proj. Qed. Lemma proj_uint64 : forall x, to_uint64(to_uint64 x)=to_uint64 x. Proof. proj. Qed. Lemma proj_sint64 : forall x, to_sint64(to_sint64 x)=to_sint64 x. Proof. proj. Qed. (** * Tacticals. *) Fixpoint Cst_nat n := match n with O => true | S c => Cst_nat c end. Fixpoint Cst_pos p := match p with xH => true | xI c | xO c => Cst_pos c end. Fixpoint Cst_N n := match n with N0 => true | Npos c => Cst_pos c end. Definition Cst_Z x := match x with Z0 => true | Zpos c | Zneg c => Cst_pos c end. Ltac COMPUTE e := let R := fresh in pose (R := e); fold R; compute in R; unfold R; clear R. Ltac COMPUTE_HYP h e := let R := fresh in pose (R := e); fold R in h; compute in R; unfold R in h; clear R. Ltac GUARD cst e := let E := fresh in pose (E := cst e); compute in E; match goal with | [ E:=true |- _] => clear E end. Ltac COMPUTE1 f cst := match goal with | [ |- context[f ?e] ] => GUARD cst e; COMPUTE (f e) | [ H:=context[f ?e] |- _ ] => GUARD cst e; COMPUTE_HYP H (f e) | [ H: context[f ?e] |- _ ] => GUARD cst e; COMPUTE_HYP H (f e) end. Ltac COMPUTE2 f cst1 cst2 := match goal with | [ |- context[f ?e1 ?e2] ] => GUARD cst1 e1; GUARD cst2 e2; COMPUTE (f e1 e2) | [ H:=context[f ?e1 ?e2] |- _] => GUARD cst1 e1; GUARD cst2 e2; COMPUTE_HYP H (f e1 e2) | [ H: context[f ?e1 ?e2] |- _] => GUARD cst1 e1; GUARD cst2 e2; COMPUTE_HYP H (f e1 e2) end. Ltac COMPUTE2AC f cst tac := match goal with | [ |- context[f ?e1 (f ?e2 ?e3) ]] => GUARD cst e1; first [ (GUARD cst e2; (replace (f e1 (f e2 e3)) -> (f e3 (f e1 e2)) by tac); COMPUTE (f e1 e2)) | (GUARD cst e3; (replace (f e1 (f e2 e3)) -> (f e2 (f e1 e3)) by tac); COMPUTE (f e1 e3))] | [ |- context[f (f ?e3 ?e2) ?e1 ]] => GUARD cst e1; first [ (GUARD cst e2; (replace (f (f e3 e2) e1) -> (f e3 (f e2 e1)) by tac); COMPUTE (f e2 e1)) | (GUARD cst e3; (replace (f (f e3 e2) e1) -> (f e2 (f e3 e1)) by tac); COMPUTE (f e3 e1))] | [ H:=context[f ?e1 (f ?e2 ?e3) ] |- _] => GUARD cst e1; first [ (GUARD cst e2; (replace (f e1 (f e2 e3)) -> (f e3 (f e1 e2)) by tac in H); COMPUTE_HYP H (f e1 e2)) | (GUARD cst e3; (replace (f e1 (f e2 e3)) -> (f e2 (f e1 e3)) by tac in H); COMPUTE_HYP H (f e1 e3))] | [ H:=context[f (f ?e3 ?e2) ?e1 ] |- _] => GUARD cst e1; first [ (GUARD cst e2; (replace (f (f e3 e2) e1) -> (f e3 (f e2 e1)) by tac in H); COMPUTE_HYP H (f e2 e1)) | (GUARD cst e3; (replace (f (f e3 e2) e1) -> (f e2 (f e3 e1)) by tac in H); COMPUTE_HYP H (f e3 e1))] | [ H: context[f ?e1 (f ?e2 ?e3) ] |- _] => GUARD cst e1; first [ (GUARD cst e2; (replace (f e1 (f e2 e3)) -> (f e3 (f e1 e2)) by tac in H); COMPUTE (f e1 e2)) | (GUARD cst e3; (replace (f e1 (f e2 e3)) -> (f e2 (f e1 e3)) by tac in H); COMPUTE_HYP H (f e1 e3))] | [ H: context[f (f ?e3 ?e2) ?e1 ] |- _] => GUARD cst e1; first [ (GUARD cst e2; (replace (f (f e3 e2) e1) -> (f e3 (f e2 e1)) by tac in H); COMPUTE_HYP H (f e2 e1)) | (GUARD cst e3; (replace (f (f e3 e2) e1) -> (f e2 (f e3 e1)) by tac in H); COMPUTE_HYP H (f e3 e1))] end. Ltac COMPUTE3 f cst1 cst2 cst3 := match goal with | [ |- context[f ?e1 ?e2 ?e3] ] => GUARD cst1 e1; GUARD cst2 e2; GUARD cst3 e3; COMPUTE (f e1 e2 e3) | [ H:=context[f ?e1 ?e2 ?e3] |- _ ] => GUARD cst1 e1; GUARD cst2 e2; GUARD cst3 e3; COMPUTE_HYP H (f e1 e2 e3) | [ H: context[f ?e1 ?e2 ?e3] |- _ ] => GUARD cst1 e1; GUARD cst2 e2; GUARD cst3 e3; COMPUTE_HYP H (f e1 e2 e3) end. (** ** Main tactics.*) Ltac ring_tactic := ring. Ltac rewrite_cst := first [ COMPUTE Zopp Cst_Z | COMPUTE Zsucc Cst_Z | COMPUTE Zpred Cst_Z | COMPUTE Zdouble_plus_one Cst_Z | COMPUTE Zdouble_minus_one Cst_Z | COMPUTE Zdouble Cst_Z | COMPUTE Zabs Cst_Z | COMPUTE Zabs_N Cst_Z | COMPUTE Zabs_nat Cst_Z | COMPUTE Z_of_N Cst_N | COMPUTE Z_of_nat Cst_nat | COMPUTE two_power_nat Cst_nat | COMPUTE2 Zminus Cst_Z Cst_Z | COMPUTE2 Zplus Cst_Z Cst_Z | COMPUTE2 Zmult Cst_Z Cst_Z | COMPUTE2AC Zplus Cst_Z ring_tactic | COMPUTE2AC Zmult Cst_Z ring_tactic | COMPUTE to_uint8 Cst_Z | COMPUTE to_sint8 Cst_Z | COMPUTE to_uint16 Cst_Z | COMPUTE to_sint16 Cst_Z | COMPUTE to_uint32 Cst_Z | COMPUTE to_sint32 Cst_Z | COMPUTE to_uint64 Cst_Z | COMPUTE to_sint64 Cst_Z | COMPUTE3 to_range Cst_Z Cst_Z Cst_Z ]. (** Example of use. *) Remark rewrite_cst_example: forall x y, 1 + ((2 * x) * 3 + 2) = (3 * (2 * y)+ 2) + 1 -> 1 + (2 + (x * 2) * 3 ) = (2 + 3 * (y* 2)) + 1. Proof. intros. repeat rewrite_cst. auto. Qed. frama-c-Fluorine-20130601/src/wp/share/vset.why0000644000175000017500000001041512155630174020033 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Sets for Why-3 --- *) (* -------------------------------------------------------------------------- *) theory Vset use import bool.Bool use import int.Int (* -------------------------------------------------------------------------- *) (* --- Classical Sets for Alt-Ergo --- *) (* -------------------------------------------------------------------------- *) type set 'a function empty : set 'a function singleton 'a : set 'a function union (set 'a) (set 'a) : set 'a function inter (set 'a) (set 'a) : set 'a predicate member 'a (set 'a) function member_bool 'a (set 'a) : bool function range int int : set int (* [a..b] *) function range_sup int : set int (* [a..] *) function range_inf int : set int (* [..b] *) function range_all : set int (* [..] *) predicate eqset (a : set 'a) (b : set 'a) = forall x : 'a. (member x a) <-> (member x b) predicate subset (a : set 'a) (b : set 'a) = forall x : 'a. (member x a) -> (member x b) predicate disjoint (a : set 'a) (b : set 'a) = forall x : 'a. (member x a) -> (member x b) -> false (* -------------------------------------------------------------------------- *) axiom member_bool : forall x:'a. forall s:set 'a [member_bool x s]. if member x s then member_bool x s = True else member_bool x s = False axiom member_empty : forall x:'a [member x empty]. not (member x empty) axiom member_singleton : forall x:'a,y:'a [member x (singleton y)]. member x (singleton y) <-> x=y axiom member_union : forall x:'a. forall a:set 'a,b:set 'a [member x (union a b)]. member x (union a b) <-> (member x a) \/ (member x b) axiom member_inter : forall x:'a. forall a:set 'a,b:set 'a [member x (inter a b)]. member x (inter a b) <-> (member x a) /\ (member x b) axiom union_empty : forall a:set 'a [(union a empty)|(union empty a)]. (union a empty) = a /\ (union empty a) = a axiom inter_empty : forall a:set 'a [(inter a empty)|(inter empty a)]. (inter a empty) = empty /\ (inter empty a) = empty axiom member_range : forall x:int,a:int,b:int [member x (range a b)]. member x (range a b) <-> (a <= x /\ x <= b) axiom member_range_sup : forall x:int,a:int [member x (range_sup a)]. member x (range_sup a) <-> (a <= x) axiom member_range_inf : forall x:int,b:int [member x (range_inf b)]. member x (range_inf b) <-> (x <= b) axiom member_range_all : forall x:int [member x range_all]. member x range_all (* -------------------------------------------------------------------------- *) endframa-c-Fluorine-20130601/src/wp/share/cint.why0000644000175000017500000001201512155630174020005 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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-Integer Arithmetics for Why-3 --- *) (* -------------------------------------------------------------------------- *) theory Cint use import int.Int (* C-Integer Ranges *) predicate is_uint8(x:int) = 0 <= x < 256 predicate is_sint8(x:int) = -128 <= x < 128 predicate is_uint16(x:int) = 0 <= x < 65536 predicate is_sint16(x:int) = -32768 <= x < 32768 predicate is_uint32(x:int) = 0 <= x < 4294967296 predicate is_sint32(x:int) = -2147483648 <= x < 2147483648 predicate is_uint64(x:int) = 0 <= x < 18446744073709551616 predicate is_sint64(x:int) = -9223372036854775808 <= x < 9223372036854775808 (* C-Integer Conversion *) function to_uint8 int : int function to_sint8 int : int function to_uint16 int : int function to_sint16 int : int function to_uint32 int : int function to_sint32 int : int function to_uint64 int : int function to_sint64 int : int (* C-Integer Conversions are in-range *) axiom is_to_uint8 : forall x:int [ is_uint8(to_uint8 x) ]. is_uint8 (to_uint8 x) axiom is_to_sint8 : forall x:int [ is_sint8(to_sint8 x) ]. is_sint8 (to_sint8 x) axiom is_to_uint16 : forall x:int [ is_uint16(to_uint16 x) ]. is_uint16 (to_uint16 x) axiom is_to_sint16 : forall x:int [ is_sint16(to_sint16 x) ]. is_sint16 (to_sint16 x) axiom is_to_uint32 : forall x:int [ is_uint32(to_uint32 x) ]. is_uint32 (to_uint32 x) axiom is_to_sint32 : forall x:int [ is_sint32(to_sint32 x) ]. is_sint32 (to_sint32 x) axiom is_to_uint64 : forall x:int [ is_uint64(to_uint64 x) ]. is_uint64 (to_uint64 x) axiom is_to_sint64 : forall x:int [ is_sint64(to_sint64 x) ]. is_sint64 (to_sint64 x) (* C-Integer Conversions are identity when in-range *) axiom id_uint8 : forall x:int [ to_uint8 x ]. is_uint8 x -> (to_uint8 x) = x axiom id_sint8 : forall x:int [ to_sint8 x ]. is_sint8 x -> (to_sint8 x) = x axiom id_uint16 : forall x:int [ to_uint16 x ]. is_uint16 x -> (to_uint16 x) = x axiom id_sint16 : forall x:int [ to_sint16 x ]. is_sint16 x -> (to_sint16 x) = x axiom id_uint32 : forall x:int [ to_uint32 x ]. is_uint32 x -> (to_uint32 x) = x axiom id_sint32 : forall x:int [ to_sint32 x ]. is_sint32 x -> (to_sint32 x) = x axiom id_uint64 : forall x:int [ to_uint64 x ]. is_uint64 x -> (to_uint64 x) = x axiom id_sint64 : forall x:int [ to_sint64 x ]. is_sint64 x -> (to_sint64 x) = x (* C-Integer Conversions are projections *) lemma proj_uint8 : forall x:int [ to_uint8(to_uint8 x) ]. to_uint8(to_uint8 x)=to_uint8 x lemma proj_sint8 : forall x:int [ to_sint8(to_sint8 x) ]. to_sint8(to_sint8 x)=to_sint8 x lemma proj_uint16 : forall x:int [ to_uint16(to_uint16 x) ]. to_uint16(to_uint16 x)=to_uint16 x lemma proj_sint16 : forall x:int [ to_sint16(to_sint16 x) ]. to_sint16(to_sint16 x)=to_sint16 x lemma proj_uint32 : forall x:int [ to_uint32(to_uint32 x) ]. to_uint32(to_uint32 x)=to_uint32 x lemma proj_sint32 : forall x:int [ to_sint32(to_sint32 x) ]. to_sint32(to_sint32 x)=to_sint32 x lemma proj_uint64 : forall x:int [ to_uint64(to_uint64 x) ]. to_uint64(to_uint64 x)=to_uint64 x lemma proj_sint64 : forall x:int [ to_sint64(to_sint64 x) ]. to_sint64(to_sint64 x)=to_sint64 x (* C-Integer Bits *) function lnot int : int function land int int : int function lxor int int : int function lor int int : int function lsl int int : int function lsr int int : int endframa-c-Fluorine-20130601/src/wp/share/Makefile0000644000175000017500000000503512155630174017763 0ustar mehdimehdi########################################################################## # # # This file is part of WP plug-in of Frama-C. # # # # Copyright (C) 2007-2013 # # CEA (Commissariat a l'energie atomique et aux energies # # 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). # # # ########################################################################## # -------------------------------------------------------------------------- # --- Shared Resources for WP 0.7 --- # -------------------------------------------------------------------------- .PHONY: all coq depend all: coq # -------------------------------------------------------------------------- # --- Coq Libraries for WP --- # -------------------------------------------------------------------------- COQL= Qedlib Cint Bits Cbits Cfloat Cmath Vset Memory COQSRC= $(addsuffix .v,$(COQL)) COQBIN= $(addsuffix .vo,$(COQL)) COQREF= $(addsuffix .glob,$(COQL)) coq: $(COQBIN) # -------------------------------------------------------------------------- clean: rm -f *.vo *~ *.glob *.cm? rm -fr html/* depend: coqdep -I . *.v > .depend .SUFFIXES: .v .vo .v.vo: coqc -I . $< sinclude .depend sinclude Makefile.wp # Wp developers only # -------------------------------------------------------------------------- frama-c-Fluorine-20130601/src/wp/share/Cfloat.v0000644000175000017500000000645412155630174017730 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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-Float Library for Coq --- *) (* -------------------------------------------------------------------------- *) Require Import Reals. (* C-Float Rounding *) Inductive rounding_mode := | Up | Down | ToZero | NearestTiesToAway | NearestTiesToEven. Parameter round_float: rounding_mode -> R -> R. Parameter round_double: rounding_mode -> R -> R. (* C-Float Conversions *) Definition to_float32 := round_float NearestTiesToEven. Definition to_float64 := round_double NearestTiesToEven. Definition is_float32 x := (to_float32 x = x). Definition is_float64 x := (to_float64 x = x). Parameter is_finite32 : R -> Prop. Parameter is_finite64 : R -> Prop. Hypothesis to_float_is_finite_32 : forall x, is_finite32(to_float32 x). Hypothesis to_float_is_finite_64 : forall x, is_finite64(to_float64 x). (* C-Float Conversions are projections *) Hypothesis proj_float32 : forall x, to_float32(to_float32 x) = to_float32 x. Hypothesis proj_float64 : forall x, to_float64(to_float64 x) = to_float64 x. (* C-Float Arithmetics *) Definition add_float32 x y := to_float32 (x+y)%R. Definition add_float64 x y := to_float64 (x+y)%R. Definition sub_float32 x y := to_float32 (x-y)%R. Definition sub_float64 x y := to_float64 (x-y)%R. Definition mul_float32 x y := to_float32 (x*y)%R. Definition mul_float64 x y := to_float64 (x*y)%R. Definition div_float32 x y := to_float32 (x/y)%R. Definition div_float64 x y := to_float64 (x/y)%R. (* Real Arithmetics *) Definition ropp x := (-x)%R. Definition radd x y := (x+y)%R. Definition rsub x y := (x-y)%R. Definition rmul x y := (x*y)%R. Definition rdiv x y := (x/y)%R. frama-c-Fluorine-20130601/src/wp/share/cint.mlw0000644000175000017500000001203612155630174020000 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* ---------------------------------------------------------------------- *) (* --- cint library: C-Integer Arithmetics for Alt-Ergo --- *) (* ---------------------------------------------------------------------- *) (* C-Integer Ranges *) logic is_uint8 : int -> prop logic is_sint8 : int -> prop logic is_uint16 : int -> prop logic is_sint16 : int -> prop logic is_uint32 : int -> prop logic is_sint32 : int -> prop logic is_uint64 : int -> prop logic is_sint64 : int -> prop (* C-Integer Ranges Definitions *) axiom def_uint8 : forall x:int [ is_uint8(x) ]. 0 <= x < 256 <-> is_uint8(x) axiom def_sint8 : forall x:int [ is_sint8(x) ]. -128 <= x < 128 <-> is_sint8(x) axiom def_uint16 : forall x:int [ is_uint16(x) ]. 0 <= x < 65536 <-> is_uint16(x) axiom def_sint16 : forall x:int [ is_sint16(x) ]. -32768 <= x < 32768 <-> is_sint16(x) axiom def_uint32 : forall x:int [ is_uint32(x) ]. 0 <= x < 4294967296 <-> is_uint32(x) axiom def_sint32 : forall x:int [ is_sint32(x) ]. -2147483648 <= x < 2147483648 <-> is_sint32(x) axiom def_uint64 : forall x:int [ is_uint64(x) ]. 0 <= x < 18446744073709551616 <-> is_uint64(x) axiom def_sint64 : forall x:int [ is_sint64(x) ]. -9223372036854775808 <= x < 9223372036854775808 <-> is_sint64(x) (* C-Integer Conversion *) logic to_uint8 : int -> int logic to_sint8 : int -> int logic to_uint16 : int -> int logic to_sint16 : int -> int logic to_uint32 : int -> int logic to_sint32 : int -> int logic to_uint64 : int -> int logic to_sint64 : int -> int (* C-Integer Conversions are in-range *) axiom is_to_uint8 : forall x:int [ is_uint8(to_uint8(x)) ]. is_uint8(to_uint8(x)) axiom is_to_sint8 : forall x:int [ is_sint8(to_sint8(x)) ]. is_sint8(to_sint8(x)) axiom is_to_uint16 : forall x:int [ is_uint16(to_uint16(x)) ]. is_uint16(to_uint16(x)) axiom is_to_sint16 : forall x:int [ is_sint16(to_sint16(x)) ]. is_sint16(to_sint16(x)) axiom is_to_uint32 : forall x:int [ is_uint32(to_uint32(x)) ]. is_uint32(to_uint32(x)) axiom is_to_sint32 : forall x:int [ is_sint32(to_sint32(x)) ]. is_sint32(to_sint32(x)) axiom is_to_uint64 : forall x:int [ is_uint64(to_uint64(x)) ]. is_uint64(to_uint64(x)) axiom is_to_sint64 : forall x:int [ is_sint64(to_sint64(x)) ]. is_sint64(to_sint64(x)) (* C-Integer Conversions are identity when in-range *) axiom id_uint8 : forall x:int [ to_uint8(x) ]. 0 <= x < 256 -> to_uint8(x) = x axiom id_sint8 : forall x:int [ to_sint8(x) ]. -128 <= x < 128 -> to_sint8(x) = x axiom id_uint16 : forall x:int [ to_uint16(x) ]. 0 <= x < 65536 -> to_uint16(x) = x axiom id_sint16 : forall x:int [ to_sint16(x) ]. -32768 <= x < 32768 -> to_sint16(x) = x axiom id_uint32 : forall x:int [ to_uint32(x) ]. 0 <= x < 4294967296 -> to_uint32(x) = x axiom id_sint32 : forall x:int [ to_sint32(x) ]. -2147483648 <= x < 2147483648 -> to_sint32(x) = x axiom id_uint64 : forall x:int [ to_uint64(x) ]. 0 <= x < 18446744073709551616 -> to_uint64(x) = x axiom id_sint64 : forall x:int [ to_sint64(x) ]. -9223372036854775808 <= x < 9223372036854775808 -> to_sint64(x) = x (* C-Integer Bits Signature *) logic lnot : int -> int logic ac land : int,int -> int logic ac lxor : int,int -> int logic ac lor : int,int -> int logic lsl : int,int -> int logic lsr : int,int -> int logic bit_test : int,int -> bool (* End of cint library *) frama-c-Fluorine-20130601/src/wp/share/memory.why0000644000175000017500000001344312155630174020366 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Addresses and Memories for Why-3 --- *) (* -------------------------------------------------------------------------- *) theory Memory use import bool.Bool use import int.Int use import map.Map type addr = { base : int ; offset : int } predicate addr_le addr addr predicate addr_lt addr addr function addr_le_bool addr addr : bool function addr_lt_bool addr addr : bool axiom addr_le_def: forall p q :addr [addr_le p q]. p.base = q.base -> (addr_le p q <-> p.offset <= q.offset) axiom addr_lt_def: forall p q :addr [addr_lt p q]. p.base = q.base -> (addr_lt p q <-> p.offset < q.offset) axiom addr_le_bool_def : forall p q : addr [ addr_le_bool p q]. addr_le p q <-> addr_le_bool p q = True axiom addr_lt_bool_def : forall p q : addr [ addr_lt_bool p q]. addr_lt p q <-> addr_lt_bool p q = True constant null : addr = { base = 0 ; offset = 0 } function global (b:int) : addr = { base = b ; offset = 0 } function shift (p:addr) (k:int) : addr = { p with offset = p.offset + k } predicate included (p:addr) (a:int) (q:addr) (b:int) = a > 0 -> ( b >= 0 /\ p.base = q.base /\ (q.offset <= p.offset) /\ (p.offset + a <= q.offset + b) ) predicate separated (p:addr) (a:int) (q:addr) (b:int) = a <= 0 \/ b <= 0 \/ p.base <> q.base \/ q.offset + b <= p.offset \/ p.offset + a <= q.offset (* Memories *) predicate eqmem (m1 m2 : map addr 'a) (p:addr) (a:int) = forall q:addr [m1[p]|m2[q]]. included q 1 p a -> m1[q] = m2[q] predicate havoc (m1 m2 : map addr 'a) (p:addr) (a:int) = forall q:addr [m1[p]|m2[q]]. separated q 1 p a -> m1[q] = m2[q] predicate valid_rd (m : map int int) (p:addr) (n:int) = n > 0 -> ( 0 <= p.offset /\ p.offset + n <= m[p.base] ) predicate valid_rw (m : map int int) (p:addr) (n:int) = n > 0 -> ( 0 < p.base /\ 0 <= p.offset /\ p.offset + n <= m[p.base] ) lemma valid_rw_rd : forall m : map int int. forall p : addr. forall n : int. valid_rw m p n -> valid_rd m p n lemma valid_string : forall m : map int int. forall p : addr. p.base < 0 -> 0 <= p.offset < m[p.base] -> (valid_rd m p 1 /\ not (valid_rw m p 1)) lemma separated_1 : forall p q : addr. forall a b i j : int [ separated p a q b , { base = p.base ; offset = i } , { base = q.base ; offset = j } ]. separated p a q b -> p.offset <= i < p.offset + a -> q.offset <= j < q.offset + b -> { base = p.base ; offset = i } <> { base = q.base ; offset = j } (* Regions *) function region int : int predicate linked (map int int) predicate sconst (map addr int) predicate framed (m : map addr addr) = forall p:addr [m[p]]. region(m[p].base) <= 0 (* Properties *) lemma separated_included : forall p q : addr. forall a b : int [ separated p a q b , included p a q b ]. a > 0 -> b > 0 -> separated p a q b -> included p a q b -> false lemma included_trans : forall p q r : addr. forall a b c : int [ included p a q b , included q b r c ]. included p a q b -> included q b r c -> included p a r c lemma separated_trans : forall p q r : addr. forall a b c : int [ included p a q b , separated q b r c ]. included p a q b -> separated q b r c -> separated p a r c lemma separated_sym : forall p q : addr. forall a b : int [ separated p a q b ]. separated p a q b <-> separated q b p a lemma eqmem_included : forall m1 m2 : map addr 'a. forall p q : addr. forall a b : int [ eqmem m1 m2 p a,eqmem m1 m2 q b ]. included p a q b -> eqmem m1 m2 q b -> eqmem m1 m2 p a lemma eqmem_sym : forall m1 m2 : map addr 'a. forall p : addr. forall a : int. eqmem m1 m2 p a -> eqmem m2 m1 p a lemma havoc_sym : forall m1 m2 : map addr 'a. forall p : addr. forall a : int. havoc m1 m2 p a -> havoc m2 m1 p a function cast addr : int axiom cast_injective : forall p q : addr [cast(p),cast(q)]. cast p = cast q -> p = q function hardware int : int axiom hardnull : hardware 0 = 0 endframa-c-Fluorine-20130601/src/wp/Context.mli0000644000175000017500000000520112155630215017337 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** Current Loc *) val with_current_loc : Cil_types.location -> ('a -> 'b) -> 'a -> 'b (** Contextual Values *) type 'a value val create : ?default:'a -> string -> 'a value (** Creates a new context with name *) val defined : 'a value -> bool (** The current value is defined. *) val get : 'a value -> 'a (** Retrieves the current value of the context. Raise an exception if not bound. *) val set : 'a value -> 'a -> unit (** Define the current value. Previous one is lost *) val update : 'a value -> ('a -> 'a) -> unit (** Modification of the current value *) val bind : 'a value -> 'a -> ('b -> 'c) -> 'b -> 'c (** Performs the job with local context bound to local value. *) val free : 'a value -> ('b -> 'c) -> 'b -> 'c (** Performs the job with local context cleared. *) val clear : 'a value -> unit (** Clear the current value. *) val push : 'a value -> 'a -> 'a option val pop : 'a value -> 'a option -> unit val name : 'a value -> string val once : (unit -> unit) -> unit -> unit (** A global configure, executed once. *) frama-c-Fluorine-20130601/src/wp/GuiConfig.ml0000644000175000017500000001630212155630215017420 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 ProverWhy3 (* ------------------------------------------------------------------------ *) (* --- Prover List in Configuration --- *) (* ------------------------------------------------------------------------ *) class provers config = object(self) inherit [dp list] Toolbox.selector [] method private load () = let open Gtk_helper.Configuration in let rec collect w = function | ConfString s -> ProverWhy3.parse s :: w | ConfList fs -> List.fold_left collect w fs | _ -> w in try let data = Gtk_helper.Configuration.find config in self#set (List.rev (collect [] data)) with Not_found -> () method private save () = let open Gtk_helper.Configuration in Gtk_helper.Configuration.set config (ConfList (List.map (fun dp -> ConfString dp.dp_prover) self#get)) initializer begin self#load () ; self#on_event self#save ; end end (* ------------------------------------------------------------------------ *) (* --- WP Provers Configuration Panel --- *) (* ------------------------------------------------------------------------ *) class dp_chooser ~(main:Design.main_window_extension_points) ~(available:provers) ~(enabled:provers) = let dialog = new Toolbox.dialog ~title:"Why3 Provers" ~window:main#main_window ~resize:false () in let array = new Toolbox.warray () in object(self) val mutable provers = [] method private enable dp e = let rec hook dp e = function | [] -> [dp,e] | head :: tail -> if fst head = dp then (dp,e) :: tail else head :: hook dp e tail in provers <- hook dp e provers method private lookup dp = try List.assoc dp provers with Not_found -> false method private entry dp = let text = Printf.sprintf "%s (%s)" dp.dp_name dp.dp_version in let sw = new Toolbox.switchbox () in let lb = new Toolbox.label ~align:`Left ~text () in sw#set (self#lookup dp) ; sw#connect (self#enable dp) ; let hbox = GPack.hbox ~spacing:10 ~homogeneous:false () in hbox#pack ~expand:false sw#coerce ; hbox#pack ~expand:true lb#coerce ; (object method widget = hbox#coerce method update () = sw#set (self#lookup dp) method delete () = () end) method private configure dps = begin available#set dps ; array#set dps ; provers <- List.map (fun dp -> dp , self#lookup dp) dps ; array#update () ; end method private detect () = ProverWhy3.detect_provers self#configure method private select () = let dps = List.fold_right (fun (dp,e) dps -> if e then dp :: dps else dps) provers [] in enabled#set dps method run () = available#send self#configure () ; List.iter (fun dp -> self#enable dp true) enabled#get ; array#update () ; dialog#run () initializer begin dialog#button ~action:(`ACTION self#detect) ~label:"Detect Provers" () ; dialog#button ~action:(`CANCEL) ~label:"Cancel" () ; dialog#button ~action:(`APPLY) ~label:"Apply" () ; array#create self#entry ; dialog#add_block array#coerce ; dialog#on_value `APPLY self#select ; end end (* ------------------------------------------------------------------------ *) (* --- WP Prover Switch Panel --- *) (* ------------------------------------------------------------------------ *) type mprover = | NoProver | AltErgo | Coq | Why3ide | Why3 of dp class dp_button ~(available:provers) ~(enabled:provers) = let render = function | NoProver -> "None" | AltErgo -> "Alt-Ergo (native)" | Coq -> "Coq (native,ide)" | Why3ide -> "Why3 (ide)" | Why3 dp -> Printf.sprintf "Why3: %s (%s)" dp.dp_name dp.dp_version in let items = [ NoProver ; AltErgo ; Coq ; Why3ide ] in let button = new Toolbox.menulist ~default:AltErgo ~render ~items () in object(self) method coerce = button#coerce method set_enabled = button#set_enabled method private import = match Wp_parameters.Provers.get () with | [] -> () | spec :: _ -> match VCS.prover_of_name spec with | Some (VCS.Why3 p) -> let dps = available#get in let dp = ProverWhy3.find p dps in if not (List.mem dp dps) then available#set (dps @ [dp]) ; let en = dp :: enabled#get in enabled#set (List.filter (fun q -> List.mem q en) available#get) | _ -> () method private set_provers dps = button#set_items (items @ List.map (fun dp -> Why3 dp) dps) method private get_selection = function | NoProver -> "none" | AltErgo -> "alt-ergo" | Coq -> "coqide" | Why3ide -> "why3ide" | Why3 dp -> "why3:" ^ dp.dp_prover method private set_selection = function | [] -> () | spec :: _ -> match VCS.prover_of_name spec with | None | Some VCS.Qed -> button#set NoProver | Some VCS.AltErgo -> button#set AltErgo | Some VCS.Coq -> button#set Coq | Some VCS.Why3ide -> button#set Why3ide | Some (VCS.Why3 spec) -> let dp = ProverWhy3.find spec enabled#get in button#set (Why3 dp) val mutable last = [] val mutable init = true method update () = begin if init then self#import ; let current = Wp_parameters.Provers.get () in if current <> last then self#set_selection (Wp_parameters.Provers.get ()) ; last <- current ; if init then begin self#set_provers enabled#get ; enabled#connect self#set_provers ; init <- false ; end end initializer begin button#connect (fun mp -> Wp_parameters.Provers.set [self#get_selection mp]) ; end end frama-c-Fluorine-20130601/src/wp/GuiPanel.ml0000644000175000017500000002775012155630215017263 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Factory open GuiSource (* ------------------------------------------------------------------------ *) (* --- RUN WP --- *) (* ------------------------------------------------------------------------ *) exception Stop let update_callback = ref (fun () -> ()) let on_update f = update_callback := f let update () = !update_callback () let reload_callback = ref (fun () -> ()) let on_reload f = reload_callback := f let reload () = !reload_callback () module Rte_generated = Kernel_function.Make_Table (Datatype.Unit) (struct let name = "GuiSource.Rte_generated" let size = 7 let dependencies = [ Ast.self ] end) let kf_of_selection = function | S_none -> None | S_fun kf -> Some kf | S_prop ip -> Property.get_kf ip | S_call s -> Some s.s_caller let rte_generated s = match kf_of_selection s with | None -> false | Some kf -> if Wp_parameters.RTE.get () then let mem = Rte_generated.mem kf in if not mem then Rte_generated.add kf () ; not mem else false let run_and_prove (main:Design.main_window_extension_points) (selection:GuiSource.selection) = begin try begin match selection with | S_none -> raise Stop | S_fun kf -> Register.wp_compute_kf (Some kf) [] [] | S_prop ip -> Register.wp_compute_ip ip | S_call s -> Register.wp_compute_call s.s_stmt end ; if rte_generated selection then main#redisplay () else reload () with Stop -> () end (* ------------------------------------------------------------------------ *) (* --- Model Panel --- *) (* ------------------------------------------------------------------------ *) type memory = HOARE | TYPED class model_selector (main : Design.main_window_extension_points) = let dialog = new Toolbox.dialog ~title:"WP Memory Model" ~window:main#main_window () in let memory = new Toolbox.switch HOARE in let r_hoare = memory#add_radio ~label:"Hoare Memory Model" ~value:HOARE () in let r_typed = memory#add_radio ~label:"Typed Memory Model" ~value:TYPED () in let c_casts = new Toolbox.checkbox ~label:"Unsafe casts" () in let c_byref = new Toolbox.checkbox ~label:"Reference Arguments" () in let c_cint = new Toolbox.checkbox ~label:"Machine Integers" () in let c_cfloat = new Toolbox.checkbox ~label:"Floating Points" () in let m_label = new Toolbox.label ~style:`Title () in object(self) initializer begin dialog#add_row r_hoare#coerce ; dialog#add_row r_typed#coerce ; dialog#add_row c_casts#coerce ; dialog#add_row c_byref#coerce ; dialog#add_row c_cint#coerce ; dialog#add_row c_cfloat#coerce ; dialog#add_row m_label#coerce ; dialog#button ~label:"Cancel" ~icon:`CANCEL ~action:(`CANCEL) () ; dialog#button ~label:"Apply" ~icon:`APPLY ~action:(`APPLY) () ; memory#on_check TYPED c_casts#set_enabled ; memory#on_event self#connect ; c_casts#on_event self#connect ; c_byref#on_event self#connect ; c_cint#on_event self#connect ; c_cfloat#on_event self#connect ; dialog#on_value `APPLY self#update ; end method update () = Wp_parameters.Model.set [Factory.id self#get] method set (s:setup) = begin (match s.mheap with | Hoare -> memory#set HOARE | Typed m -> memory#set TYPED ; c_casts#set (m = MemTyped.Unsafe)) ; c_byref#set (s.mvar = Ref) ; c_cint#set (s.cint = Cint.Machine) ; c_cfloat#set (s.cfloat = Cfloat.Float) ; end method get : setup = let m = match memory#get with | HOARE -> Hoare | TYPED -> Typed (if c_casts#get then MemTyped.Unsafe else MemTyped.Fits) in { mheap = m ; mvar = if c_byref#get then Ref else Var ; cint = if c_cint#get then Cint.Machine else Cint.Natural ; cfloat = if c_cfloat#get then Cfloat.Float else Cfloat.Real ; } method connect () = m_label#set_text (Factory.descr self#get) method run = begin let s = Factory.parse (Wp_parameters.Model.get ()) in self#set s ; self#connect () ; dialog#run () ; end end (* ------------------------------------------------------------------------ *) (* --- WP Panel --- *) (* ------------------------------------------------------------------------ *) let wp_dir = ref (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_update_model label () = let s = Factory.parse (Wp_parameters.Model.get ()) in label#set_text (Factory.descr s) let wp_configure_model main label () = begin (new model_selector main)#run ; wp_update_model label () ; end let wp_update_script label () = let file = Wp_parameters.Script.get () in let text = if file = "" then "(None)" else Filename.basename file in label#set_text text let wp_panel ~(main:Design.main_window_extension_points) ~(available_provers:GuiConfig.provers) ~(enabled_provers:GuiConfig.provers) ~(configure_provers:unit -> unit) = let vbox = GPack.vbox () in let demon = Gtk_form.demon () in let packing = vbox#pack in let form = new Toolbox.form () in (* Model Row *) let model_cfg = new Toolbox.button ~label:"Model..." ~tooltip:"Configure WP Model" () in let model_lbl = GMisc.label ~xalign:0.0 () in Gtk_form.register demon (wp_update_model model_lbl) ; model_cfg#connect (wp_configure_model main model_lbl) ; form#add_label_widget model_cfg#coerce ; form#add_field model_lbl#coerce ; (* Script Row *) let script_cfg = new Toolbox.button ~label:"Script..." ~tooltip:"Load/Save User Scripts file" () in let script_lbl = GMisc.label ~xalign:0.0 () in Gtk_form.register demon (wp_update_script script_lbl) ; script_cfg#connect wp_script ; form#add_label_widget script_cfg#coerce ; form#add_field script_lbl#coerce ; (* Prover Row *) let prover_cfg = new Toolbox.button ~label:"Provers..." ~tooltip:"Detect WP Provers" () in prover_cfg#connect configure_provers ; form#add_label_widget prover_cfg#coerce ; let prover_menu = new GuiConfig.dp_button ~available:available_provers ~enabled:enabled_provers in form#add_field prover_menu#coerce ; Gtk_form.register demon prover_menu#update ; (* End Form *) packing form#coerce ; let options = GPack.hbox ~spacing:16 ~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:"Splits conjunctions into sub-goals" ~packing:options#pack Wp_parameters.Split.get Wp_parameters.Split.set demon ; Gtk_form.check ~label:"Trace" ~tooltip:"Reports proof information from the provers" ~packing:options#pack Wp_parameters.ProofTrace.get Wp_parameters.ProofTrace.set demon ; Gtk_form.check ~label:"Proof" ~tooltip:"Reports model/proof information from the provers" ~packing:options#pack Wp_parameters.UnsatModel.get Wp_parameters.UnsatModel.set demon ; let options = GPack.hbox ~spacing:8 ~packing () in 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 ; let control = GPack.table ~columns:4 ~col_spacings:8 ~rows:2 ~packing () in let addcontrol line col w = control#attach ~left:(col-1) ~top:(line-1) ~expand:`NONE w in Gtk_form.label ~text:"Steps" ~packing:(addcontrol 1 1) () ; Gtk_form.spinner ~lower:0 ~upper:100000 ~tooltip:"Search steps for alt-ergo prover" ~packing:(addcontrol 1 2) Wp_parameters.Steps.get Wp_parameters.Steps.set demon ; Gtk_form.label ~text:"Depth" ~packing:(addcontrol 1 3) () ; Gtk_form.spinner ~lower:0 ~upper:100000 ~tooltip:"Search space bound for alt-ergo prover" ~packing:(addcontrol 1 4) Wp_parameters.Depth.get Wp_parameters.Depth.set demon ; Gtk_form.label ~text:"Timeout" ~packing:(addcontrol 2 1) () ; Gtk_form.spinner ~lower:0 ~upper:100000 ~tooltip:"Timeout for proving one proof obligation" ~packing:(addcontrol 2 2) Wp_parameters.Timeout.get Wp_parameters.Timeout.set demon ; Gtk_form.label ~text:"Process" ~packing:(addcontrol 2 3) () ; Gtk_form.spinner ~lower:1 ~upper:32 ~tooltip:"Maximum number of parallel running provers" ~packing:(addcontrol 2 4) Wp_parameters.Procs.get (fun n -> Wp_parameters.Procs.set n ; ignore (ProverTask.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 = ProverTask.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 update () ; 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) ; Task.on_server_stop server update ; begin "WP" , vbox#coerce , Some (Gtk_form.refresh demon) ; end let register ~main ~available_provers ~enabled_provers ~configure_provers = main#register_panel (fun main -> wp_panel ~main ~available_provers ~enabled_provers ~configure_provers) (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/Cvalues.mli0000644000175000017500000001047512155630215017326 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Lifting Operations over Memory Values --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Ctypes open Memory open Lang.F (** {2 Int-As-Boolans} *) val bool_eq : binop val bool_lt : binop val bool_neq : binop val bool_leq : binop val bool_and : binop val bool_or : binop val is_true : pred -> term (** [p ? 1 : 0] *) val is_false : pred -> term (** [p ? 0 : 1] *) (** {2 Null Values} *) val null : (term -> pred) Context.value (** test for null pointer value *) val is_null : c_object -> term -> pred (** {2 Typing and Sub-Typing for C and ACSL Types} *) val is_object : c_object -> 'a value -> pred val has_ctype : typ -> term -> pred val has_ltype : logic_type -> term -> pred val cdomain : typ -> (term -> pred) option val ldomain : logic_type -> (term -> pred) option (** {2 ACSL Equality} *) val equal_object : c_object -> term -> term -> pred val equal_comp : compinfo -> term -> term -> pred val equal_array : Matrix.matrix -> term -> term -> pred (** {2 C and ACSL Constants} *) val constant : constant -> term val logic_constant : logic_constant -> term val constant_exp : exp -> term val constant_term : Cil_types.term -> term (** {2 Lifting Operations over Memory Values} *) val map_sloc : ('a -> 'b) -> 'a Memory.sloc -> 'b Memory.sloc val map_value : ('a -> 'b) -> 'a Memory.value -> 'b Memory.value val map_logic : ('a -> 'b) -> 'a Memory.logic -> 'b Memory.logic (** {2 ACSL Utilities} *) module Logic(M : Memory.Model) : sig open M type logic = M.loc Memory.logic (** {3 Projections} *) val value : logic -> term val loc : logic -> loc val vset : logic -> Vset.set val sloc : logic -> loc sloc list val rdescr : loc sloc -> var list * loc * pred (** {3 Morphisms} *) val map : unop -> logic -> logic val map_opp : logic -> logic val map_loc : (loc -> loc) -> logic -> logic val map_l2t : (loc -> term) -> logic -> logic val map_t2l : (term -> loc) -> logic -> logic val apply : binop -> logic -> logic -> logic val apply_add : logic -> logic -> logic val apply_sub : logic -> logic -> logic (** {3 Locations} *) val field : logic -> fieldinfo -> logic val shift : logic -> c_object -> ?size:int64 -> logic -> logic val load : Sigma.t -> c_object -> logic -> logic (** {3 Sets of loc-or-values} *) val union : logic_type -> logic list -> logic val inter : logic_type -> logic list -> logic (** {3 Regions} *) type region = loc sloc list val separated : (c_object * region) list -> pred val included : c_object -> region -> c_object -> region -> pred val valid : Sigma.t -> acs -> c_object -> region -> pred end frama-c-Fluorine-20130601/src/wp/Model.mli0000644000175000017500000000667412155630215016772 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Registration *) module S : Datatype.S_with_collections type t = S.t type model = S.t type tuning = (unit -> unit) val repr : model val register : id:string -> ?descr:string -> ?tuning:tuning list -> unit -> model val get_id : model -> string val get_descr : model -> string val get_emitter : model -> Emitter.t val find : id:string -> model val iter : (model -> unit) -> unit val with_model : model -> ('a -> 'b) -> 'a -> 'b val on_model : model -> (unit -> unit) -> unit val get_model : unit -> model (** Current model *) val directory : unit -> string (** Current model in ["-wp-out"] directory *) module type Entries = sig type key type data val name : string val compare : key -> key -> int val pretty : Format.formatter -> key -> unit end module type Registry = sig type key type data val mem : key -> bool val find : key -> data val get : key -> data option val define : key -> data -> unit (** no redefinition ; circularity protected *) val update : key -> data -> unit (** set current value, with no protection *) val memoize : (key -> data) -> key -> data (** with circularity protection *) val compile : (key -> data) -> key -> unit (** with circularity protection *) val callback : (key -> data -> unit) -> unit val iter : (key -> data -> unit) -> unit val iter_sorted : (key -> data -> unit) -> unit end module Index(E : Entries) : Registry with type key = E.key and type data = E.data module type Key = sig type t val compare : t -> t -> int val pretty : Format.formatter -> t -> unit end module type Data = sig type key type data val name : string val compile : key -> data end module type Generator = sig type key type data val get : key -> data end module Generator(K : Key)(D : Data with type key = K.t) : Generator with type key = D.key and type data = D.data frama-c-Fluorine-20130601/src/wp/ProverErgo.mli0000644000175000017500000000361712155630215020016 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Task open VCS (* -------------------------------------------------------------------------- *) (* --- Alt-Ergo Theorem Prover --- *) (* -------------------------------------------------------------------------- *) val prove : Wpo.t -> interactive:bool -> result task frama-c-Fluorine-20130601/src/wp/proof.mli0000644000175000017500000000752312155630215017051 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 delete_script : string -> unit 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 update_hints_for_goal : string -> string list -> unit (** Update the hints for one specific goal. The script file will be saved if hints are different. *) val find_script_with_hints : string list -> string list -> (int * string * string) list (** Retrieve matchable script files for w.r.t provided required and hints keywords. Most suitable scripts comes first, with format [(n,g,p)] where [p] is a script matching [n] hints from possibly deprecated goal [g]. *) 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 is_empty : string -> bool 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]. *) (* -------------------------------------------------------------------------- *) (** Proof Script Interaction *) (* -------------------------------------------------------------------------- *) open WpPropId val script_for : pid:prop_id -> gid:string -> string option val script_for_ide : pid:prop_id -> gid:string -> string val hints_for : pid:prop_id -> (string * string) list frama-c-Fluorine-20130601/src/wp/why3_session.ml0000644000175000017500000001771312155630215020212 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2013 -- INRIA - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Format module S = Datatype.String module Xml = Why3_xml type goal = { goal_name : string; goal_parent : theory; mutable goal_verified : bool; } and theory = { theory_name : string; theory_parent : file; theory_goals : goal Datatype.String.Hashtbl.t; mutable theory_verified : bool; } and file = { file_name : string; file_format : string option; file_parent : session; file_theories: theory Datatype.String.Hashtbl.t; (** Not mutated after the creation *) mutable file_verified : bool; } and session = { session_files : file Datatype.String.Hashtbl.t; session_dir : string; } (** 2 Create a session *) let db_filename = "why3session.xml" let session_dir_for_save = ref "." let empty_session dir = { session_files = S.Hashtbl.create 3; session_dir = dir; } (* [raw_add_goal parent name expl sum t] adds a goal to the given parent DOES NOT record the new goal in its parent, thus this should not be exported *) let raw_add_no_task parent name = let goal = { goal_name = name; goal_parent = parent; goal_verified = false; } in S.Hashtbl.replace parent.theory_goals name goal; goal let raw_add_theory mfile thname = let mth = { theory_name = thname; theory_parent = mfile; theory_goals = S.Hashtbl.create 10; theory_verified = false; } in S.Hashtbl.replace mfile.file_theories thname mth; mth let raw_add_file session f fmt = let mfile = { file_name = f; file_format = fmt; file_theories = S.Hashtbl.create 10; file_verified = false; file_parent = session; } in S.Hashtbl.replace session.session_files f mfile; mfile (****************************) (* session opening *) (****************************) exception LoadError let bool_attribute field r def = try match List.assoc field r.Xml.attributes with | "true" -> true | "false" -> false | _ -> assert false with Not_found -> def let int_attribute_def field r def = try int_of_string (List.assoc field r.Xml.attributes) with Not_found | Invalid_argument _ -> def let int_attribute field r = try int_of_string (List.assoc field r.Xml.attributes) with Not_found | Invalid_argument _ -> Wp_parameters.failure "[Why3ide] missing required attribute '%s' from element '%s'@." field r.Xml.name; raise LoadError let string_attribute_def field r def= try List.assoc field r.Xml.attributes with Not_found -> def let string_attribute field r = try List.assoc field r.Xml.attributes with Not_found -> Wp_parameters.failure "[Why3ide] missing required attribute '%s' from element '%s'@." field r.Xml.name; raise LoadError let load_option attr g = try Some (List.assoc attr g.Xml.attributes) with Not_found -> None let load_ident elt = let name = string_attribute "name" elt in name let rec load_goal parent g = match g.Xml.name with | "goal" -> let gname = load_ident g in let verified = bool_attribute "proved" g false in let mg = raw_add_no_task parent gname in mg.goal_verified <- verified | "label" -> () | s -> Wp_parameters.debug "[Why3ide] Session.load_goal: unexpected element '%s'@." s let load_theory mf th = match th.Xml.name with | "theory" -> let thname = load_ident th in let verified = bool_attribute "verified" th false in let mth = raw_add_theory mf thname in List.iter (load_goal mth) th.Xml.elements; mth.theory_verified <- verified | s -> Wp_parameters.debug "[Why3ide] Session.load_theory: unexpected element '%s'@." s let load_file session f = match f.Xml.name with | "file" -> let fn = string_attribute "name" f in let fmt = load_option "format" f in let verified = bool_attribute "verified" f false in let mf = raw_add_file session fn fmt in List.iter (load_theory mf) f.Xml.elements; mf.file_verified <- verified | "prover" -> () | s -> Wp_parameters.debug "[Why3ide] Session.load_file: unexpected element '%s'@." s let load_session session xml = match xml.Xml.name with | "why3session" -> (* dprintf debug "[Info] load_session: shape version is %d@\n" shape_version; *) (* just to keep the old_provers somewhere *) List.iter (load_file session) xml.Xml.elements; (* dprintf debug "[Info] load_session: done@\n" *) | s -> Wp_parameters.debug "[Why3ide] Session.load_session: unexpected element '%s'@." s type notask = unit let read_session dir = if not (Sys.file_exists dir && Sys.is_directory dir) then begin Wp_parameters.error "[Why3ide] %s is not an existing directory" dir; raise LoadError end; let xml_filename = Filename.concat dir db_filename in let session = empty_session dir in (** If the xml is present we read it, otherwise we consider it empty *) if Sys.file_exists xml_filename then begin try let xml = Xml.from_file xml_filename in try load_session session xml.Xml.content; with Sys_error msg -> failwith ("Open session: sys error " ^ msg) with | Sys_error _msg -> (* xml does not exist yet *) Wp_parameters.failure "[Why3ide] Can't open %s" xml_filename | Xml.Parse_error s -> Wp_parameters.failure "[Why3ide] XML database corrupted, ignored (%s)@." s; (* failwith ("Open session: XML database corrupted (%s)@." ^ s) *) raise LoadError end; session frama-c-Fluorine-20130601/src/wp/clabels.mli0000644000175000017500000000650112155630215017324 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 *) val equal : c_label -> c_label -> bool module T : sig type t = c_label val compare : t -> t -> int end module LabelMap : Map.S with type key = c_label module LabelSet : Set.S with type elt = c_label (** @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 open Cil_types val lookup_name : c_label -> string 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]. *) frama-c-Fluorine-20130601/src/wp/Letify.mli0000644000175000017500000000573612155630215017164 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Letifications --- *) (* -------------------------------------------------------------------------- *) open Lang.F module Sigma : sig type t val equal : t -> t -> bool val pretty : string -> Format.formatter -> t -> unit val e_apply : t -> term -> term val p_apply : t -> pred -> pred val empty : t val add : var -> term -> t -> t val assume : t -> pred -> t val find : var -> t -> term val iter : (var -> term -> unit) -> t -> unit val domain : t -> Vars.t val codomain : t -> Vars.t end module Defs : sig type t val empty : t val merge : t -> t -> t val extract : pred -> t val domain : t -> Vars.t end val bind : Sigma.t -> Defs.t -> Vars.t -> Sigma.t (** [bind sigma defs xs] select definitions in [defs] targeting variables [xs]. The result is a new substitution that potentially augment [sigma] with definitions for [xs] (and others). *) val add_definitions : Sigma.t -> Defs.t -> Vars.t -> pred list -> pred list (** [add_definitions sigma defs xs ps] keep all definitions of variables [xs] from [sigma] that comes from [defs]. They are added to [ps]. *) module Split : sig type occur val create : unit -> occur val add : occur -> pred -> unit val select : occur -> (pred * int) list end frama-c-Fluorine-20130601/src/wp/RefUsage.ml0000644000175000017500000003254512155630215017256 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Variable Analysis --- *) (* -------------------------------------------------------------------------- *) open Ctypes open Cil_types open Cil_datatype (* -------------------------------------------------------------------------- *) (* --- Var Info Accesses --- *) (* -------------------------------------------------------------------------- *) type var = Result | Cvar of varinfo | Lvar of logic_var module Var = struct type t = var let hash = function | Result -> 0 | Cvar x -> 2 * x.vid | Lvar x -> 3 * x.lv_id let compare x y = match x,y with | Result , Result -> 0 | Result , _ -> (-1) | _ , Result -> 1 | Cvar x , Cvar y -> Varinfo.compare x y | Lvar x , Lvar y -> Logic_var.compare x y | Cvar _ , Lvar _ -> (-1) | Lvar _ , Cvar _ -> 1 let equal x y = (compare x y = 0) let pretty fmt = function | Result -> Format.fprintf fmt "\\result" | Cvar x -> Format.fprintf fmt "C%d:%s" x.vid x.vname | Lvar x -> Format.fprintf fmt "L%d:%s" x.lv_id x.lv_name end type access = | NoAccess | ByAddr (* The expression ["&x"] *) | ByValue (* The expression ["x"], equal to [load(&x)] *) | ByArray (* The expression ["x[_]"], equal to [load(shift(load(&x),_))] *) | ByRef (* The expression ["*x"], equal to [load(load(&x))] *) module Access : sig type t = access (* val is_bot : t -> bool *) (* unused for now *) (*val leq : t -> t -> bool*) (* unused for now *) val cup : t -> t -> t (* val pretty : var -> Format.formatter -> t -> unit *) (* unused for now *) end = struct type t = access (* unused for now *) (* let is_bot = function NoAccess -> true | _ -> false *) (* unused for now *) (* let pretty x fmt = function | NoAccess -> Format.fprintf fmt "-" | ByValue -> Var.pretty fmt x | ByAddr -> Format.fprintf fmt "&%a" Var.pretty x | ByRef -> Format.fprintf fmt "*%a" Var.pretty x | ByArray -> Format.fprintf fmt "%a[_]" Var.pretty x *) let rank = function | NoAccess -> 0 | ByRef -> 1 | ByArray -> 2 | ByValue -> 3 | ByAddr -> 4 (* let leq a b = (rank a) <= (rank b)*) (* unused for now *) let cup a b = if rank a < rank b then b else a end (* -------------------------------------------------------------------------- *) (* --- Expressions & Memory Model --- *) (* -------------------------------------------------------------------------- *) module E : sig type t val bot : t val cup : t -> t -> t (* val leq : t -> t -> bool *) (* unused for now *) (* val lcup : t list -> t *) (* unused for now *) val fcup : ('a -> t) -> 'a list -> t val get : var -> t -> access val access : var -> access -> t -> t val bind : logic_var list -> t -> t end = struct module Xmap = Qed.Mergemap.Make(Var) type t = access Xmap.t let bot = Xmap.empty let cup = Xmap.union (fun _ -> Access.cup) (* unused for now *) (* let leq = Xmap.subset (fun _ -> Access.leq) *) (* unused for now *) (* let rec lcup = function [] -> bot | [x] -> x | x::xs -> cup x (lcup xs)*) let rec fcup f = function [] -> bot | [x] -> f x | x::xs -> cup (f x) (fcup f xs) let get x e = try Xmap.find x e with Not_found -> NoAccess let access x u e = Xmap.add x (try Access.cup (Xmap.find x e) u with Not_found -> u) e let rec bind xs e = match xs with | [] -> e | x::xs -> bind xs (Xmap.remove (Lvar x) e) end type value = E.t type model = | L (* Logic, same as E.bot *) | E of value (* E *) | Loc_var of varinfo (* &x *) | Loc_shift of varinfo * value (* &x.[...] *) | Val_var of var (* x *) | Val_shift of var * value (* (x + E) *) let vcup a b = E (E.cup a b) (* let lcup xs = E (E.lcup xs) *) (* unused for now *) let fcup f xs = E (E.fcup f xs) let value = function | Loc_var x -> E.access (Cvar x) ByAddr E.bot | Loc_shift(x,e) -> E.access (Cvar x) ByAddr e | Val_var x -> E.access x ByValue E.bot | Val_shift(x,e) -> E.access x ByValue e | E e -> e | L -> E.bot let cvar x = Loc_var x let shift (l:model) (k:value) = match l with | Loc_var x -> Loc_shift(x,k) | Val_var x -> Val_shift(x,k) | Loc_shift(x,e) -> Loc_shift(x,E.cup e k) | Val_shift(x,e) -> Val_shift(x,E.cup e k) | E e -> E (E.cup e k) | L -> E k let field (l:model) = match l with | Loc_var x -> Loc_shift(x,E.bot) | Loc_shift _ -> l | Val_var x -> E (E.access x ByValue E.bot) | Val_shift(x,e) -> E (E.access x ByValue e) | E _ | L -> l let load = function | Loc_var x -> Val_var (Cvar x) | Loc_shift(x,e) -> E (E.access (Cvar x) ByValue e) | Val_var x -> E (E.access x ByRef E.bot) | Val_shift(x,e) -> E (E.access x ByArray e) | (E _ | L) as m -> m (* for \\valid and \\separated : no variable escape, excepts for shifts *) let reference = function | L | Loc_var _ | Val_var _ -> E.bot | E e | Loc_shift(_,e) | Val_shift(_,e) -> e (* -------------------------------------------------------------------------- *) (* --- Casts --- *) (* -------------------------------------------------------------------------- *) type cast = | Identity | Convert | Cast let cast cv e = match cv with | Identity -> e | Convert | Cast -> E (value e) let cast_obj tgt src = match tgt , src with | (C_int _ | C_float _) , (C_int _ | C_float _) -> Convert | C_pointer tr , C_pointer te -> let obj_r = Ctypes.object_of tr in let obj_e = Ctypes.object_of te in if Ctypes.compare obj_r obj_e = 0 then Identity else Cast | _ -> if Ctypes.equal tgt src then Identity else Cast let cast_ctyp tgt src = cast_obj (Ctypes.object_of tgt) (Ctypes.object_of src) let cast_ltyp tgt src = match Logic_utils.unroll_type src with | Ctype src -> cast_ctyp tgt src | _ -> Cast (* -------------------------------------------------------------------------- *) (* --- Call --- *) (* -------------------------------------------------------------------------- *) let param a m = match a with | NoAccess | ByAddr -> E.bot (* should never arise *) | ByValue -> value m | ByRef -> value (load m) | ByArray -> value (load (shift m E.bot)) let rec call f xs ms = match xs , ms with | [] , _ | _ , [] -> E.bot | x::xs , m::ms -> let a = E.get x f in E.cup (param a m) (call f xs ms) type context = { mutable locals : Logic_var.Set.t ; mutable logic : E.t Logic_info.Map.t ; mutable spec : E.t Kernel_function.Map.t ; mutable code : E.t Kernel_function.Map.t ; mutable w_kf : Kernel_function.Set.t ; mutable w_lg : Logic_info.Set.t ; } let call_kf context kf ms = try context.w_kf <- Kernel_function.Set.add kf context.w_kf ; let phi = Kernel_function.Map.find kf context.spec in let xs = List.map (fun x -> Cvar x) (Kernel_function.get_formals kf) in call phi xs ms with Not_found -> E.bot let call_lg context f ms = try context.w_lg <- Logic_info.Set.add f context.w_lg ; let phi = Logic_info.Map.find f context.logic in let xs = List.map (fun x -> Lvar x) f.l_profile in call phi xs ms with Not_found -> E.bot (* -------------------------------------------------------------------------- *) (* --- Compilation of C-Expressions --- *) (* -------------------------------------------------------------------------- *) let rec vexpr e = value (expr e) and expr (e:Cil_types.exp) : model = match e.enode with (* Logics *) | Const _ | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> L (* Unary *) | UnOp((Neg|BNot|LNot),e,_) | Info(e,_) -> expr e (* Binary *) | BinOp( (MinusPP|PlusA|MinusA|Mult|Div|Mod |Shiftlt|Shiftrt|BAnd|BXor|BOr|LAnd|LOr |Lt|Gt|Le|Ge|Eq|Ne), a,b,_ ) -> vcup (vexpr a) (vexpr b) (* Shifts *) | BinOp((PlusPI|IndexPI|MinusPI),a,b,_) -> shift (expr a) (vexpr b) (* Casts *) | CastE(ty_tgt,e) -> cast (cast_ctyp ty_tgt (Cil.typeOf e)) (expr e) (* Address *) | AddrOf lval | StartOf lval -> lvalue lval (* Load *) | Lval lval -> load (lvalue lval) and lvalue (h,ofs) = offset (host h) ofs and host = function | Var x -> cvar x | Mem e -> expr e and offset (l:model) = function | NoOffset -> l | Field(_,ofs) -> offset (field l) ofs | Index(e,ofs) -> offset (shift l (vexpr e)) ofs (* -------------------------------------------------------------------------- *) (* --- Compilation of ACSL-Terms --- *) (* -------------------------------------------------------------------------- *) let rec vterm (env:context) t = value (term env t) and vtermopt (env:context) = function None -> E.bot | Some t -> vterm env t and term (env:context) (t:term) : model = match t.term_node with (* Logics *) | TConst _ | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ | Ttypeof _ | Ttype _ -> L (* Unary *) | TUnOp((Neg|BNot|LNot),t) -> term env t (* Binary *) | TBinOp( (MinusPP|PlusA|MinusA|Mult|Div|Mod |Shiftlt|Shiftrt|BAnd|BXor|BOr|LAnd|LOr |Lt|Gt|Le|Ge|Eq|Ne), a,b ) -> vcup (vterm env a) (vterm env b) (* Shifts *) | TBinOp((PlusPI|IndexPI|MinusPI),a,b) -> shift (term env a) (vterm env b) (* Casts *) | TCastE(ty_tgt,t) -> cast (cast_ltyp ty_tgt t.term_type) (term env t) (* Term L-Values *) | TLval tlv -> term_lval env tlv | TAddrOf tlv | TStartOf tlv -> addr_lval env tlv | TUpdate(s,ofs,t) -> let v = vterm env s in let e = vterm env t in let k = value (term_indices env L ofs) in E (E.cup v (E.cup e k)) (* Call *) | Tapp(phi,_,ts) -> E (call_lg env phi (List.map (term env) ts)) (* Operators *) | TDataCons(_,ts) -> fcup (vterm env) ts | Tif(e,a,b) -> fcup (vterm env) [e;a;b] | Trange(a,b) -> fcup (vtermopt env) [a;b] | Tat(t,_) -> term env t | Toffset(_,t) | Tbase_addr(_,t) -> E (vterm env t) | Tnull | Tempty_set -> L | Tunion ts | Tinter ts -> fcup (vterm env) ts (* Binders *) | Tlambda(xs,b) -> E (E.bind xs (vterm env b)) | Tcomprehension(t,xs,None) -> E (E.bind xs (vterm env t)) | Tcomprehension(t,xs,Some p) -> E (E.bind xs (E.cup (vterm env t) (pred env p))) (* Jessie *) | TCoerce _ | TCoerceE _ -> Wp_parameters.fatal "Jessie Coercions" | _ -> assert false and term_lval env (h,ofs) = match h with | TResult _ -> term_indices env (Val_var Result) ofs | TVar( {lv_origin=None} as x ) -> term_indices env (Val_var (Lvar x)) ofs | TVar( {lv_origin=Some x} ) -> load (term_offset env (Loc_var x) ofs) | TMem t -> load (term_offset env (load (term env t)) ofs) and term_indices env m = function | TNoOffset -> m | TModel(_,ofs) | TField(_,ofs) -> term_indices env (E (value m)) ofs | TIndex(e,ofs) -> term_indices env (vcup (vterm env e) (value m)) ofs and term_offset env (l:model) = function | TNoOffset -> l | TField(_,ofs) -> term_offset env (field l) ofs | TIndex(e,ofs) -> term_offset env (shift l (vterm env e)) ofs | TModel _ -> Wp_parameters.not_yet_implemented "Model fields" and addr_lval env (h,ofs) = match h with | TResult _ -> Wp_parameters.fatal "Address of \\result" | TMem t -> term_offset env (term env t) ofs | TVar( {lv_origin=Some x} ) -> term_offset env (Loc_var x) ofs | TVar( {lv_origin=None} as x ) -> Wp_parameters.fatal "Address of logic variable (%a)" Logic_var.pretty x and pred (_:context) _ = E.bot (* and body (_:context) _ = E.bot *) (* -------------------------------------------------------------------------- *) (* --- OCaml 4.0 Warnings (module under dev.) --- *) (* -------------------------------------------------------------------------- *) let _ = reference let _ = call_kf let _ = call_lg let _ = expr let _ = term let _ = pred frama-c-Fluorine-20130601/src/wp/Sigma.mli0000644000175000017500000000373212155630215016762 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Generic Sigma Factory --- *) (* -------------------------------------------------------------------------- *) module Make (C : Memory.Chunk) (H : Qed.Collection.S with type t = C.t) : Memory.Sigma with type chunk = C.t and type domain = H.set frama-c-Fluorine-20130601/src/wp/wpPropId.ml0000644000175000017500000007310212155630215017313 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 let source_of_id p = fst (Property.location 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_prop kind prop = { p_kind=kind ; p_prop=prop ; p_part=None } let mk_annot_id kf stmt ca = Property.ip_of_code_annot_single kf stmt ca let mk_annot_ids kf stmt ca = Property.ip_of_code_annot kf stmt ca let mk_code_annot_ids kf s ca = List.map (mk_prop PKProp) (mk_annot_ids 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_lemma_id l = mk_prop PKProp (LogicUsage.ip_lemma l) 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 (*----------------------------------------------------------------------------*) let kind_order = function | PKProp -> 0 | PKPre _ -> 1 | PKEstablished -> 2 | PKPreserved -> 3 | PKVarPos -> 4 | PKVarDecr -> 5 | PKPropLoop -> 6 | PKAFctOut -> 7 | PKAFctExit -> 8 let compare_kind k1 k2 = match k1, k2 with PKPre (kf1, ki1, p1), PKPre (kf2, ki2, p2) -> let cmp = Kernel_function.compare kf1 kf2 in if cmp <> 0 then cmp else let cmp = Stmt.compare ki1 ki2 in if cmp <> 0 then cmp else Property.compare p1 p2 | _,_ -> Pervasives.compare (kind_order k1) (kind_order k2) let compare_prop_id pid1 pid2 = (* This order of comparison groups together prop_pids with same properties *) let p1 = property_of_id pid1 in let p2 = property_of_id pid2 in let cmp = Description.full_compare p1 p2 in if cmp <> 0 then cmp else let cmp = compare_kind pid2.p_kind pid1.p_kind in if cmp <> 0 then cmp else Pervasives.compare pid1.p_part pid2.p_part module PropId = Datatype.Make_with_collections( 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 let hash pid = Property.hash pid.p_prop let compare = compare_prop_id let equal pid1 pid2 = compare_prop_id pid1 pid2 = 0 let copy = Datatype.undefined let rehash = Datatype.identity let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let mem_project = Datatype.never_any_project let varname = Datatype.undefined end) module Names = struct module NamesTbl = State_builder.Hashtbl(Datatype.String.Hashtbl)(Datatype.Int) (struct let name = "WpPropertyNames" let dependencies = [ ] let size = 97 end) module IndexTbl = State_builder.Hashtbl(PropId.Hashtbl)(Datatype.String) (struct let name = "WpPropertyIndex" let dependencies = [ Ast.self; NamesTbl.self; Globals.Functions.self; Annotations.code_annot_state; Annotations.funspec_state; Annotations.global_state ] let size = 97 end) let base_id_prop_txt = Property.Names.get_prop_name_id let basename_of_prop_id p = match p.p_kind , p.p_prop with | PKProp , p -> base_id_prop_txt p | PKPropLoop , p -> base_id_prop_txt p | PKEstablished , p -> base_id_prop_txt p ^ "_established" | PKPreserved , p -> base_id_prop_txt p ^ "_preserved" | PKVarDecr , p -> base_id_prop_txt p ^ "_decrease" | PKVarPos , p -> base_id_prop_txt p ^ "_positive" | PKAFctOut , p -> base_id_prop_txt p ^ "_normal" | PKAFctExit , p -> base_id_prop_txt p ^ "_exit" | PKPre(_kf,stmt,pre) , _ -> let kf_name_of_stmt = Kernel_function.get_name (Kernel_function.find_englobing_kf stmt) in Printf.sprintf "%s_call_%s" kf_name_of_stmt (base_id_prop_txt pre) (** function used to normanize basename *) let normalize_basename s = let max_len = 60 in (* truncating basename in order to limit length of file name *) if String.length s > max_len then (String.sub s 0 (max_len - 3)) ^ "___" else s (** returns the name that should be returned by the function [get_prop_name_id] if the given property has [name] as basename. That name is reserved so that [get_prop_name_id prop] can never return an identical name. *) let reserve_name_id basename = let basename = normalize_basename basename in try let speed_up_start = NamesTbl.find basename in (* this basename is already reserved *) let n,unique_name = Extlib.make_unique_name NamesTbl.mem ~sep:"_" ~start:speed_up_start basename in NamesTbl.replace basename (succ n) ; (* to speed up Extlib.make_unique_name for next time *) unique_name with Not_found -> (* first time that basename is reserved *) NamesTbl.add basename 2 ; basename (** returns the basename of the property. *) let get_prop_id_basename p = let basename = normalize_basename (basename_of_prop_id p) in match p.p_part with | None -> basename | Some(k,n) -> if n < 10 then Printf.sprintf "%s_part%d" basename (succ k) else if n < 100 then Printf.sprintf "%s_part%02d" basename (succ k) else if n < 1000 then Printf.sprintf "%s_part%03d" basename (succ k) else Printf.sprintf "%s_part%06d" basename (succ k) (** returns a unique name identifying the property. This name is built from the basename of the property. *) let get_prop_id_name pid = try IndexTbl.find pid with Not_found -> (* first time we are asking for a name for that [ip] *) let basename = get_prop_id_basename pid in let unique_name = reserve_name_id basename in IndexTbl.add pid unique_name ; unique_name end let get_propid = Names.get_prop_id_name (** Name related to a property PO *) let pp_propid fmt pid = Format.fprintf fmt "%s" (get_propid pid) let pp_names fmt l = match l with [] -> () | _ -> Format.fprintf fmt "_%a" (Wp_error.pp_string_list ~empty:"" ~sep:"_") l let ident_names names = List.filter (function "" -> true | _ as n -> '\"' <> (String.get n 0) ) names let code_annot_names ca = match ca.annot_content with | AAssert (_, named_pred) -> "@assert"::(ident_names named_pred.name) | AInvariant (_,_,named_pred) -> "@invariant"::(ident_names named_pred.name) | AVariant (term, _) -> "@variant"::(ident_names 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 (kind,_,_,idp) -> let kind_name = Pretty_utils.sfprintf "%c%a" '@' Property.pretty_predicate_kind kind in kind_name::idp.ip_name | Property.IPCodeAnnot (_,_, ca) -> code_annot_names ca | Property.IPComplete (_, _, lb) -> let kind_name = "@complete_behaviors" in let name = Pretty_utils.sfprintf "complete_behaviors%a" pp_names lb in kind_name::[name] | Property.IPDisjoint (_, _, lb) -> let kind_name = "@disjoint_behaviors" in let name = Pretty_utils.sfprintf "disjoint_behaviors%a" pp_names lb in kind_name::[name] | Property.IPAssigns (_, _, _, l) -> let kind_name = "@assigns" in List.fold_left (fun acc (t,_) -> (ident_names t.it_content.term_name) @ acc) [kind_name] l | Property.IPFrom _ -> ["@from"] (* TODO: steal term names from assigns? *) | Property.IPDecrease (_,_, Some ca,_) -> let kind_name = "@decreases" in kind_name::code_annot_names ca | Property.IPDecrease _ -> let kind_name = "@decreases" in kind_name::[] (*TODO: add more names ? *) | Property.IPLemma (a,_,_,l,_) -> let names = "@lemma"::a::(ident_names l.name) in begin match LogicUsage.section_of_lemma a with | LogicUsage.Toplevel _ -> names | LogicUsage.Axiomatic ax -> ax.LogicUsage.ax_name::names end | Property.IPAllocation _ (* TODO *) | Property.IPAxiomatic _ | Property.IPAxiom _ | Property.IPBehavior _ | Property.IPReachable _ | Property.IPOther _ -> [] let string_of_termination_kind = function Normal -> "post" | Exits -> "exits" | Breaks -> "breaks" | Continues -> "continues" | Returns -> "returns" 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 module Pretty = struct open Format let pp_part fmt p = match p.p_part with | None -> () | Some(k,n) -> fprintf fmt " (%d/%d)" (succ k) n let pp_subprop fmt p = match p.p_kind with | PKProp | PKPropLoop -> () | PKEstablished -> pp_print_string fmt " (established)" | PKPreserved -> pp_print_string fmt " (preserved)" | PKVarDecr -> pp_print_string fmt " (decrease)" | PKVarPos -> pp_print_string fmt " (positive)" | PKAFctOut -> pp_print_string fmt " (return)" | PKAFctExit -> pp_print_string fmt " (exit)" | PKPre(kf,_,_) -> fprintf fmt " (call '%s')" (Kernel_function.get_name kf) let pp_prop fmt p = Description.pp_localized ~kf:`Never ~ki:false ~kloc:false fmt p.p_prop let pp_local fmt p = begin pp_prop fmt p ; pp_subprop fmt p ; pp_part fmt p ; end end let pretty_local = Pretty.pp_local (* -------------------------------------------------------------------------- *) (* --- Hints --- *) (* -------------------------------------------------------------------------- *) type hints = { mutable required : string list ; mutable hints : string list ; } let add_hint hs x = if not (List.mem x hs.hints) then hs.hints <- x :: hs.hints let add_required hs x = if not (List.mem x hs.required) then hs.required <- x :: hs.required let stmt_hints hs s = List.iter (fun label -> match label with | Label(a,_,src) -> if src then add_hint hs a | Default _ -> add_hint hs "default" | Case(e,_) -> match Ctypes.get_int e with | Some k -> add_hint hs ("case-" ^ Int64.to_string k) | None -> () ) s.labels let kinstr_hints hs = function | Kstmt s -> stmt_hints hs s | Kglobal -> () let propid_hints hs p = match p.p_kind , p.p_prop with | PKProp , Property.IPAssigns (_ , Kstmt _, _, _) -> add_required hs "stmt-assigns" | PKProp , Property.IPAssigns (_ , Kglobal, _, _) -> add_required hs "fct-assigns" | PKPropLoop , Property.IPAssigns _ -> add_required hs "loop-assigns" | PKPropLoop , _ -> add_required hs "invariant" | PKProp , _ -> add_required hs "property" | PKEstablished , _ -> add_required hs "established" | PKPreserved , _ -> add_required hs "preserved" | PKVarDecr , _ -> add_required hs "decrease" | PKVarPos , _ -> add_required hs "positive" | PKAFctOut , _ -> add_required hs "return" | PKAFctExit , _ -> add_required hs "exit" | PKPre(kf,st,_) , _ -> add_required hs ("precond-" ^ Kernel_function.get_name kf) ; stmt_hints hs st let rec term_hints hs t = match t.term_node with | TLval(lv,_) -> lval_hints hs lv | TAddrOf(lv,_) -> lval_hints hs lv | TCastE(_,t) -> term_hints hs t | TBinOp((PlusPI|IndexPI|MinusPI),a,_) -> term_hints hs a | Tlet(_,t) -> term_hints hs t | _ -> () and lval_hints hs = function | TVar { lv_origin=Some { vorig_name=x } } | TVar { lv_name=x } -> add_hint hs x | TResult _ -> add_hint hs "result" | TMem t -> add_hint hs "*" ; term_hints hs t let assigns_hints hs froms = List.iter (fun ({it_content=t},_) -> term_hints hs t) froms let annot_hints hs = function | AAssert(bs,ipred) | AInvariant(bs,_,ipred) -> List.iter (add_hint hs) (ident_names ipred.name) ; List.iter (add_hint hs) bs | AAssigns(bs,Writes froms) -> List.iter (add_hint hs) bs ; assigns_hints hs froms | AAllocation _ | AAssigns(_,WritesAny) | AStmtSpec _ | AVariant _ | APragma _ -> () let property_hints hs = function | Property.IPAxiom (s,_,_,p,_) | Property.IPLemma (s,_,_,p,_) -> List.iter (add_required hs) (s::p.name) | Property.IPBehavior _ -> () | Property.IPComplete(_,_,ps) | Property.IPDisjoint(_,_,ps) -> List.iter (add_required hs) ps | Property.IPPredicate(_,_,_,ipred) -> List.iter (add_hint hs) ipred.ip_name | Property.IPCodeAnnot(_,_,ca) -> annot_hints hs ca.annot_content | Property.IPAssigns(_,_,_,froms) -> assigns_hints hs froms | Property.IPAllocation _ (* TODO *) | Property.IPFrom _ | Property.IPDecrease _ | Property.IPReachable _ | Property.IPAxiomatic _ | Property.IPOther _ -> () let prop_id_keys p = begin let hs = { hints=[] ; required=[] } in let opt add f = function None -> () | Some x -> add hs (f x) in propid_hints hs p ; property_hints hs p.p_prop ; opt add_required Kernel_function.get_name (Property.get_kf p.p_prop) ; opt add_required (fun b -> if Cil.is_default_behavior b then "default" else b.b_name) (Property.get_behavior p.p_prop) ; opt add_hint (fun (k,_) -> Printf.sprintf "part-%d" k) p.p_part ; kinstr_hints hs (Property.get_kinstr p.p_prop) ; List.sort String.compare hs.required , List.sort String.compare hs.hints end (*----------------------------------------------------------------------------*) (* 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 ~ki:true ~kloc:true fmt pid.p_prop ; pp_goal_part fmt pid.p_part ; end (*----------------------------------------------------------------------------*) (* Comparison *) (*----------------------------------------------------------------------------*) 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 is_loop_preservation p = match p.p_kind with | PKPreserved -> begin match Property.get_kinstr p.p_prop with | Kglobal -> Wp_parameters.fatal "Loop Preservation ? (%a)" Property.pretty p.p_prop | Kstmt st -> Some st end | _ -> None let select_by_name asked_names 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 is_minus s = try s.[0] = '-' with _ -> false in let is_plus s = try s.[0] = '+' with _ -> false in let remove_first s = String.sub s 1 ((String.length s) -1) in let eval acc asked = let is_minus,a = match acc with | None -> if is_minus asked then true,true else false,false | Some a -> (is_minus asked),a in let eval () = let asked = if is_minus || (is_plus asked) then remove_first asked else asked in List.mem asked names in Some (if is_minus then a && (not (eval ())) else a || (eval ())) in match List.fold_left eval None asked_names with | Some false -> false | _ -> true let select_call_pre s_call asked_pre pid = match pid.p_kind with | PKPre (_, p_stmt, p_prop) -> Stmt.equal s_call p_stmt && (match asked_pre with | None -> true | Some asked_pre -> Property.equal p_prop asked_pre) | _ -> false (*----------------------------------------------------------------------------*) (* About assigns identification *) (*----------------------------------------------------------------------------*) type a_kind = LoopAssigns | StmtAssigns type effect_source = FromCode | FromCall | FromReturn type assigns_desc = { a_label : Cil_types.logic_label ; a_stmt : Cil_types.stmt option ; 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_stmt = Some s ; a_kind = LoopAssigns ; a_assigns = Writes assigns } let mk_stmt_assigns_desc s assigns = { a_label = Clabels.mk_logic_label s ; a_stmt = Some s ; 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_stmt = None ; 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) = Printer.pp_predicate_named fmt p let pp_pred_info fmt (id, p) = Format.fprintf fmt "(@[%a:@ %a@])" pp_propid id Printer.pp_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_stmt = Some s ; a_kind = StmtAssigns ; a_assigns = WritesAny ; } in AssignsAny a let mk_kf_any_assigns_info () = let a = { a_label = Logic_const.pre_label ; a_stmt = None ; 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_stmt = Some s ; a_kind = LoopAssigns ; a_assigns = WritesAny ; } in AssignsAny a (* let pp_assigns_id (id, _a) = pp_propid 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 axiom_info = prop_id * LogicUsage.logic_lemma let mk_axiom_info lemma = let id = mk_lemma_id lemma in (id, lemma) let pp_axiom_info fmt (id,thm) = Format.fprintf fmt "(@[%a:@ %a@])" pp_propid id Printer.pp_predicate_named thm.LogicUsage.lem_property (* -------------------------------------------------------------------------- *) (* --- 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 = mk_part pid (!k,n) in incr k ; job pid_k g) goals (*----------------------------------------------------------------------------*) (** 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) frama-c-Fluorine-20130601/src/wp/Cfloat.mli0000644000175000017500000000442512155630215017132 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Floatting Arithmetic Model *) (* -------------------------------------------------------------------------- *) open Ctypes open Lang.F type model = Real | Float val model : model Context.value val code_lit : float -> term val acsl_lit : Cil_types.logic_real -> term val real_of_int : unop val float_of_int : c_float -> unop val fconvert : c_float -> unop val frange : c_float -> term -> pred val ropp : unop val radd : binop val rsub : binop val rmul : binop val rdiv : binop val fopp : c_float -> unop val fadd : c_float -> binop val fsub : c_float -> binop val fmul : c_float -> binop val fdiv : c_float -> binop frama-c-Fluorine-20130601/src/wp/rformat.ml0000444000175000017500000013277712155634033017237 0ustar mehdimehdi# 27 "src/wp/rformat.mll" (* -------------------------------------------------------------------------- *) (* --- Time Utilities --- *) (* -------------------------------------------------------------------------- *) let epsilon = 0.0005 let get_time ladder t = let rec dicho ladder t i j = let k = (i+j)/2 in if i=k then j else let d = ladder.(k) in if t < d then dicho ladder t i k else if t > d then dicho ladder t k j else k in if t <= ladder.(0) then 0 else let n = Array.length ladder in if t > ladder.(n-1) then n else dicho ladder t 0 (n-1) let rdiv t n = let d = floor (t /. n) in let r = t -. d *. n in d , r let pp_time fmt t = if t < 1.0 then Format.fprintf fmt "%dms" (truncate (t *. 1000.0 +. 0.5)) else if t < 60.0 then let dt = t -. floor t in if dt < 0.1 then Format.fprintf fmt "%.0fs" t else Format.fprintf fmt "%.1fs" t else if t < 3600.0 then let minutes,seconds = rdiv t 60.0 in if seconds < 1.0 then Format.fprintf fmt "%d'" (truncate minutes) else Format.fprintf fmt "%d'%ds" (truncate minutes) (truncate seconds) else let hours,seconds = rdiv t 3600.0 in let minutes,_ = rdiv seconds 60.0 in if minutes < 1.0 then Format.fprintf fmt "%dh" (truncate hours) else Format.fprintf fmt "%dh%d'" (truncate hours) (truncate minutes) let pp_time_range ladder fmt t = let k = get_time ladder t in let n = Array.length ladder in if k > n then Format.fprintf fmt ">%a" pp_time ladder.(n-1) else pp_time fmt ladder.(k) (* -------------------------------------------------------------------------- *) (* --- Formatters Syntax --- *) (* -------------------------------------------------------------------------- *) type command = | CMD of string | ARG of string * string | TEXT type console = { env : (Format.formatter -> string -> string -> unit) ; line : Buffer.t ; mutable spaces : int ; fline : Format.formatter ; foutput : Format.formatter ; } let spaces = String.make 80 ' ' let rec add_spaces buffer n = if n > 0 then if n < 80 then Buffer.add_substring buffer spaces 0 n else ( Buffer.add_string buffer spaces ; add_spaces buffer (n-80) ) let spaces console = begin Format.pp_print_flush console.fline () ; if console.spaces > 0 then ( add_spaces console.line console.spaces ; console.spaces <- 0 ) ; end let flush console = begin spaces console ; Format.pp_print_string console.foutput (Buffer.contents console.line) ; Buffer.clear console.line ; end let write console text = spaces console ; Buffer.add_string console.line text let env console cmd arg = spaces console ; console.env console.fline cmd arg # 100 "src/wp/rformat.ml" let __ocaml_lex_tables = { Lexing.lex_base = "\000\000\247\255\002\000\088\000\253\255\254\255\255\255\098\000\ \252\255\250\255\112\000\192\000\251\255\014\001\248\255\092\001\ \170\001\249\255\248\001\070\002\031\000\253\255\148\002\002\000\ \226\002\032\000\084\003\010\000\027\000\003\000"; Lexing.lex_backtrk = "\255\255\255\255\008\000\008\000\255\255\255\255\255\255\255\255\ \255\255\255\255\007\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\006\000\255\255\255\255\002\000\002\000\ \255\255\255\255\000\000\000\000\255\255\001\000"; Lexing.lex_default = "\001\000\000\000\255\255\255\255\000\000\000\000\000\000\255\255\ \000\000\000\000\255\255\255\255\000\000\255\255\000\000\255\255\ \255\255\000\000\255\255\255\255\021\000\000\000\255\255\255\255\ \255\255\255\255\255\255\255\255\028\000\255\255"; Lexing.lex_trans = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\005\000\025\000\029\000\000\000\000\000\000\000\ \000\000\000\000\000\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\ \004\000\000\000\025\000\029\000\000\000\002\000\003\000\012\000\ \023\000\025\000\027\000\000\000\028\000\000\000\000\000\010\000\ \000\000\000\000\010\000\010\000\010\000\010\000\010\000\010\000\ \010\000\010\000\010\000\010\000\000\000\029\000\000\000\023\000\ \025\000\000\000\024\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\010\000\000\000\000\000\022\000\ \024\000\000\000\000\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\010\000\011\000\008\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ \007\000\007\000\007\000\007\000\009\000\010\000\000\000\000\000\ \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ \010\000\010\000\018\000\000\000\000\000\000\000\000\000\000\000\ \000\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\010\000\000\000\000\000\000\000\000\000\000\000\ \000\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\010\000\000\000\000\000\013\000\000\000\000\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\000\000\000\000\000\000\000\000\000\000\000\000\ \006\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\255\255\000\000\000\000\000\000\255\255\ \000\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\000\000\000\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \015\000\000\000\000\000\000\000\000\000\000\000\000\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\000\000\000\000\000\000\000\000\000\000\000\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\016\000\000\000\014\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\000\000\ \000\000\000\000\000\000\000\000\000\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \000\000\000\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\000\000\000\000\000\000\ \000\000\000\000\000\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\019\000\000\000\017\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\000\000\000\000\000\000\000\000\000\000\ \000\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\000\000\000\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\000\000\000\000\000\000\000\000\000\000\000\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\026\000\000\000\000\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ \000\000\000\000\000\000\000\000\000\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \000\000\000\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\000\000\000\000\000\000\ \000\000\000\000\000\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\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\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\026\000\000\000\000\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ \000\000\000\000\000\000\000\000\000\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\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\255\255\000\000\023\000\029\000\255\255\255\255\255\255\ \255\255\255\255\255\255\027\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\ \000\000\255\255\023\000\029\000\255\255\000\000\000\000\002\000\ \020\000\025\000\027\000\255\255\027\000\255\255\255\255\002\000\ \255\255\255\255\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\255\255\028\000\255\255\020\000\ \025\000\255\255\023\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\255\255\255\255\020\000\ \025\000\255\255\255\255\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\003\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ \003\000\003\000\007\000\007\000\007\000\007\000\007\000\007\000\ \007\000\007\000\007\000\007\000\007\000\010\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\255\255\255\255\255\255\255\255\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\255\255\255\255\255\255\255\255\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\255\255\255\255\011\000\255\255\255\255\ \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\255\255\255\255\ \000\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\011\000\028\000\255\255\255\255\255\255\020\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\013\000\255\255\255\255\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\255\255\255\255\255\255\255\255\255\255\255\255\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\255\255\255\255\255\255\255\255\255\255\255\255\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\015\000\255\255\013\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\255\255\ \255\255\255\255\255\255\255\255\255\255\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\016\000\ \255\255\255\255\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\255\255\255\255\255\255\ \255\255\255\255\255\255\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\018\000\255\255\016\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\255\255\255\255\255\255\255\255\255\255\ \255\255\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\019\000\255\255\255\255\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\255\255\255\255\255\255\255\255\255\255\255\255\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\022\000\255\255\255\255\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\255\255\ \255\255\255\255\255\255\255\255\255\255\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\024\000\ \255\255\255\255\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\255\255\255\255\255\255\ \255\255\255\255\255\255\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\026\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\026\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\026\000\255\255\255\255\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\255\255\ \255\255\255\255\255\255\255\255\255\255\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\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\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 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\079\000\157\000\000\000\235\000\011\000\057\001\ \135\001\027\000\213\001\035\002\000\000\000\000\113\002\027\000\ \191\002\028\000\013\003\000\000\025\000\000\000"; Lexing.lex_backtrk_code = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\011\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\000\ \000\000\000\000\036\000\036\000\000\000\046\000"; Lexing.lex_default_code = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\024\000\000\000"; Lexing.lex_trans_code = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\041\000\000\000\000\000\001\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\006\000\000\000\000\000\ \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ \006\000\006\000\000\000\000\000\000\000\000\000\000\000\000\000\ \001\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\001\000\001\000\000\000\000\000\000\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\001\000\016\000\000\000\000\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\021\000\000\000\000\000\000\000\000\000\000\000\000\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\006\000\000\000\000\000\006\000\006\000\006\000\ \006\000\006\000\006\000\006\000\006\000\006\000\006\000\000\000\ \000\000\000\000\000\000\000\000\000\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\ \000\000\000\000\000\000\000\000\000\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\ \016\000\000\000\000\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\021\000\000\000\000\000\ \000\000\000\000\000\000\000\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\000\000\000\000\ \000\000\000\000\000\000\000\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\024\000\000\000\ \000\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\000\000\000\000\000\000\000\000\ \000\000\000\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\000\000\000\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\000\000\000\000\000\000\000\000\000\000\000\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\000\000\000\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \000\000\000\000\000\000\000\000\000\000\000\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\000\000\000\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\000\000\000\000\ \000\000\000\000\000\000\000\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\006\000\000\000\ \000\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ \006\000\006\000\006\000\000\000\000\000\000\000\000\000\000\000\ \000\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\000\000\000\000\000\000\000\000\ \000\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\006\000\000\000\000\000\006\000\ \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ \006\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\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\006\000\000\000\000\000\006\000\006\000\006\000\ \006\000\006\000\006\000\006\000\006\000\006\000\006\000\000\000\ \000\000\000\000\000\000\000\000\000\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\ \000\000\000\000\000\000\000\000\000\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\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\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_code = "\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\027\000\255\255\255\255\000\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\002\000\255\255\255\255\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\255\255\028\000\255\255\255\255\255\255\255\255\ \020\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\023\000\025\000\255\255\255\255\255\255\ \255\255\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ \002\000\002\000\002\000\002\000\010\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\255\255\255\255\255\255\255\255\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\255\255\255\255\255\255\255\255\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\011\000\255\255\255\255\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\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\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\ \013\000\028\000\255\255\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\255\255\255\255\ \255\255\255\255\255\255\255\255\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\255\255\255\255\ \255\255\255\255\255\255\255\255\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ \013\000\013\000\013\000\013\000\013\000\013\000\015\000\255\255\ \255\255\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\255\255\255\255\255\255\255\255\ \255\255\255\255\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\015\000\ \015\000\015\000\015\000\015\000\016\000\255\255\255\255\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\255\255\255\255\255\255\255\255\255\255\255\255\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\018\000\255\255\255\255\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \255\255\255\255\255\255\255\255\255\255\255\255\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ \019\000\255\255\255\255\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\255\255\255\255\ \255\255\255\255\255\255\255\255\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ \019\000\019\000\019\000\019\000\019\000\019\000\022\000\255\255\ \255\255\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\255\255\255\255\255\255\255\255\ \255\255\255\255\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\024\000\255\255\255\255\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\255\255\255\255\255\255\255\255\255\255\255\255\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\026\000\255\255\255\255\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \255\255\255\255\255\255\255\255\255\255\255\255\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\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\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_code = "\255\005\255\004\255\255\007\255\006\255\255\001\005\000\006\255\ \006\255\007\255\255\008\255\255\009\255\255\003\004\002\007\001\ \008\000\009\255\000\004\001\006\255\009\255\008\255\255\000\005\ \001\007\002\008\003\009\255"; } let rec word console lexbuf = lexbuf.Lexing.lex_mem <- Array.create 10 (-1) ; __ocaml_lex_word_rec console lexbuf 0 and __ocaml_lex_word_rec console lexbuf __ocaml_lex_state = match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 132 "src/wp/rformat.mll" ( flush console ) # 688 "src/wp/rformat.ml" | 1 -> # 135 "src/wp/rformat.mll" ( flush console ; Format.pp_print_newline console.foutput () ; word console lexbuf ) # 693 "src/wp/rformat.ml" | 2 -> # 138 "src/wp/rformat.mll" ( console.spaces <- succ console.spaces ; word console lexbuf ) # 698 "src/wp/rformat.ml" | 3 -> # 140 "src/wp/rformat.mll" ( write console "&" ; word console lexbuf ) # 703 "src/wp/rformat.ml" | 4 -> # 141 "src/wp/rformat.mll" ( write console "%" ; word console lexbuf ) # 708 "src/wp/rformat.ml" | 5 -> let # 143 "src/wp/rformat.mll" arg # 714 "src/wp/rformat.ml" = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) (lexbuf.Lexing.lex_curr_pos + -1) in # 144 "src/wp/rformat.mll" ( Format.pp_print_flush console.fline () ; add_spaces console.line (int_of_string arg - Buffer.length console.line) ; console.spaces <- 0 ; word console lexbuf ) # 723 "src/wp/rformat.ml" | 6 -> let # 151 "src/wp/rformat.mll" cmd # 729 "src/wp/rformat.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(3) lexbuf.Lexing.lex_mem.(2) and # 151 "src/wp/rformat.mll" arg # 734 "src/wp/rformat.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(1) lexbuf.Lexing.lex_mem.(0) in # 154 "src/wp/rformat.mll" ( env console cmd arg ; word console lexbuf ) # 738 "src/wp/rformat.ml" | 7 -> let # 156 "src/wp/rformat.mll" cmd # 744 "src/wp/rformat.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(1) lexbuf.Lexing.lex_mem.(0) in # 159 "src/wp/rformat.mll" ( env console cmd "" ; word console lexbuf ) # 748 "src/wp/rformat.ml" | 8 -> # 161 "src/wp/rformat.mll" ( write console (Lexing.lexeme lexbuf) ; word console lexbuf ) # 753 "src/wp/rformat.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_word_rec console lexbuf __ocaml_lex_state and command lexbuf = lexbuf.Lexing.lex_mem <- Array.create 10 (-1) ; __ocaml_lex_command_rec lexbuf 20 and __ocaml_lex_command_rec lexbuf __ocaml_lex_state = match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> let # 164 "src/wp/rformat.mll" cmd # 765 "src/wp/rformat.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) lexbuf.Lexing.lex_mem.(1) in # 164 "src/wp/rformat.mll" ( CMD cmd ) # 769 "src/wp/rformat.ml" | 1 -> let # 165 "src/wp/rformat.mll" cmd # 775 "src/wp/rformat.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) lexbuf.Lexing.lex_mem.(1) and # 165 "src/wp/rformat.mll" arg # 780 "src/wp/rformat.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(2) lexbuf.Lexing.lex_mem.(3) in # 165 "src/wp/rformat.mll" ( ARG(cmd,arg) ) # 784 "src/wp/rformat.ml" | 2 -> # 166 "src/wp/rformat.mll" ( TEXT ) # 789 "src/wp/rformat.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_command_rec lexbuf __ocaml_lex_state ;; # 168 "src/wp/rformat.mll" let pretty env fmt msg = let lexbuf = Lexing.from_string msg in let line = Buffer.create 80 in word { line = line ; fline = Format.formatter_of_buffer line ; foutput = fmt ; env = env ; spaces = 0 ; } lexbuf let command msg = let lexbuf = Lexing.from_string msg in command lexbuf # 814 "src/wp/rformat.ml" frama-c-Fluorine-20130601/src/wp/Partitioning.mli0000644000175000017500000000412612155630215020367 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Variables Cleaning --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Lang open Lang.F type partition type classeq val create : unit -> partition val collect : partition -> F.pred -> unit val classes : partition -> classeq list val filter_hyp : classeq -> F.pred -> F.pred val filter_goal : classeq -> F.pred -> F.pred frama-c-Fluorine-20130601/src/wp/GuiSource.mli0000644000175000017500000000506312155630215017626 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Source Interaction for WP --- *) (* -------------------------------------------------------------------------- *) open Cil_types type selection = | S_none | S_fun of Kernel_function.t | S_prop of Property.t | S_call of call and call = { s_caller : Kernel_function.t ; s_called : Kernel_function.t ; s_stmt : stmt ; } class popup : unit -> object method on_click : (selection -> unit) -> unit method on_prove : (selection -> unit) -> unit method register : GMenu.menu GMenu.factory -> Design.main_window_extension_points -> button:int -> Pretty_source.localizable -> unit end class highlighter : Design.main_window_extension_points -> object method set : Wpo.t option -> unit method update : unit method highlight : GSourceView2.source_buffer -> Pretty_source.localizable -> start:int -> stop:int -> unit end frama-c-Fluorine-20130601/src/wp/prover.ml0000644000175000017500000001564112155630215017070 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 VCS (* -------------------------------------------------------------------------- *) (* --- Prover Implementation against Task API --- *) (* -------------------------------------------------------------------------- *) open Task open Wpo let dispatch wpo ~interactive prover = begin match prover with | AltErgo -> ProverErgo.prove wpo ~interactive | Coq -> ProverCoq.prove wpo ~interactive | Why3 prover -> ProverWhy3.prove ~prover wpo | _ -> Task.failed "Prover '%a' not available" VCS.pp_prover prover end let qed_time wpo = match wpo.po_formula with | GoalLemma _ -> 0.0 | GoalAnnot vcq -> GOAL.qed_time vcq.VC_Annot.goal let signal ?callin wpo prover = match callin with | None -> () | Some f -> f wpo prover let update ?callback wpo prover result = Wpo.set_result wpo prover result ; match callback with | None -> () | Some f -> f wpo prover result let run_prover wpo ~interactive ?callback prover = dispatch wpo ~interactive prover >>> fun status -> let result = match status with | Task.Result r -> r | Task.Canceled -> VCS.no_result | Task.Timeout -> VCS.timeout | Task.Failed exn -> VCS.failed (error exn) in let result = { result with solver_time = qed_time wpo } in update ?callback wpo prover result ; Task.return (Wpo.is_valid result) let resolve wpo = match wpo.po_formula with | GoalAnnot vcq -> VC_Annot.resolve vcq | GoalLemma vca -> VC_Lemma.is_trivial vca let simplify ?callin ?callback wpo prover = Task.call (fun wpo -> signal ?callin wpo prover ; if resolve wpo then let time = qed_time wpo in let result = VCS.result ~time VCS.Valid in (update ?callback wpo VCS.Qed result ; true) else false) wpo let prove wpo ?(interactive=false) ?callin ?callback prover = simplify ?callin ?callback wpo prover >>= fun succeed -> if succeed then Task.return true else (run_prover wpo ~interactive ?callback prover) let spawn wpo ?callin ?callback provers = ProverTask.spawn begin List.map (fun (interactive,prover) -> prove wpo ~interactive ?callin ?callback prover) provers end (* ------------------------------------------------------------------------ *) (* --- Why3ide --- *) (* ------------------------------------------------------------------------ *) module String = Datatype.String (** Different instance of why3ide can't be run simultanely *) let why3ide_running = ref false (** Update Wpo from Sessions *) let update_wpo_from_session ?callback ~goals ~session:filename_session () = let open ProverWhy3 in let open Why3_session in let module HStr = String.Hashtbl in let session = read_session filename_session in Wpo.S.Hashtbl.iter (fun wpo g -> match g with | None -> (* proved by QED *) let time = qed_time wpo in let result = VCS.result ~time VCS.Valid in update ?callback wpo VCS.Qed result; update ?callback wpo VCS.Why3ide (VCS.result VCS.NoResult) | Some g -> try let filename = Sysutil.relativize_filename filename_session g.gfile in let file = HStr.find session.session_files filename in let theory = HStr.find file.file_theories g.gtheory in let goal = HStr.find theory.theory_goals g.ggoal in let result = VCS.result (if goal.goal_verified then VCS.Valid else VCS.NoResult) in update ?callback wpo VCS.Why3ide result with Not_found -> if Wp_parameters.has_dkey "prover" then Wp_parameters.feedback "[WP.Why3ide] a goal normally present in generated file \ is not present in the session: %s %s %s@." g.gfile g.gtheory g.ggoal; update ?callback wpo VCS.Why3ide (VCS.result VCS.NoResult) ) goals; why3ide_running := false let wp_why3ide ?callback iter = let includes = String.Hashtbl.create 2 in let files = String.Hashtbl.create 5 in let goals = Wpo.S.Hashtbl.create 24 in let on_goal wpo = match ProverWhy3.assemble_wpo wpo with | None -> Wpo.S.Hashtbl.add goals wpo None; | Some (incs,goal) -> Wpo.S.Hashtbl.add goals wpo (Some goal); List.iter (fun f -> String.Hashtbl.replace includes f ()) incs; String.Hashtbl.replace files goal.ProverWhy3.gfile () in iter on_goal; let dir = Wp_parameters.get_output () in let session = Format.sprintf "%s/project.session" dir in let get_value h = String.Hashtbl.fold_sorted (fun s () acc -> s::acc) h [] in let includes = get_value includes in let files = get_value files in if files = [] then (why3ide_running := false; Task.nop) else begin ProverWhy3.call_ide ~includes ~files ~session >>= fun ok -> begin if ok then begin try update_wpo_from_session ?callback ~goals ~session () with Why3_session.LoadError -> Wp_parameters.error "[WP] why3session: can't import back why3 results because of \ previous error" end; Task.return () end end let wp_why3ide ?callback iter = if !why3ide_running then begin Wp_parameters.feedback "Why3ide is already running. Close it before \ starting other tasks for it."; Task.nop end else begin why3ide_running := true; wp_why3ide ?callback iter end frama-c-Fluorine-20130601/src/wp/wpFroms.ml0000644000175000017500000005664112155630215017215 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 = Wp_parameters.register_category "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_global fname ltype in let mk_in_lvar t = Cil_const.make_logic_var_formal "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 | TModel (m, off) -> TModel (m, mk_at_off 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" Printer.pp_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 fresh variable. * This is intended since several calls shouldn't share the same variable ! **) let v = Cil_const.make_logic_var_quant 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 = match a.annot_content with | AAssigns (b_list, Writes assigns) when annot_for_asked_bhv b_list asked_bhv -> Some (a,assigns) | _ -> acc in Annotations.fold_code_annot 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 = match a.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.fold_code_annot 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 = Annotations.funspec 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 Kernel_function.get_called fct with | Some kf -> let spec = Annotations.funspec 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@]" Printer.pp_location (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 (Annotations.funspec 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 = Annotations.behavior_names_of_stmt_in_kf kf in if stmt_bhvs <> [] then Wp_parameters.warning "Not implemented: prove local \\from properties (skip)"; (* TODO: \\from in loops. *) let spec = Annotations.funspec 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 frama-c-Fluorine-20130601/src/wp/ctypes.ml0000644000175000017500000004216412155630215017062 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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_bits = function | UInt8 | SInt8 -> 8 | UInt16 | SInt16 -> 16 | UInt32 | SInt32 -> 32 | UInt64 | SInt64 -> 64 let i_bytes = function | UInt8 | SInt8 -> 1 | UInt16 | SInt16 -> 2 | UInt32 | SInt32 -> 4 | UInt64 | SInt64 -> 8 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 is_char = function | UInt8 -> Cil.theMachine.Cil.theMachine.char_is_unsigned | SInt8 -> not Cil.theMachine.Cil.theMachine.char_is_unsigned | UInt16 | SInt16 | UInt32 | SInt32 | UInt64 | SInt64 -> false 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 Qed.Z.zero, Qed.Z.of_string "256" | SInt8 -> Qed.Z.of_string "-128", Qed.Z.of_string "128" | UInt16 -> Qed.Z.zero, Qed.Z.of_string "65536" | SInt16 -> Qed.Z.of_string "-32768", Qed.Z.of_string "32768" | UInt32 -> Qed.Z.zero, Qed.Z.of_string "4294967296" | SInt32 -> Qed.Z.of_string "-2147483648", Qed.Z.of_string "2147483648" | UInt64 -> Qed.Z.zero, Qed.Z.of_string "18446744073709551616" | SInt64 -> Qed.Z.of_string "-9223372036854775808", Qed.Z.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_bits t1 <= i_bits t2 else (not(signed t1) && (i_bits t1 < i_bits t2)) type c_float = | Float32 | Float64 let compare_c_float : c_float -> c_float -> _ = Extlib.compare_basic let f_bytes = function | Float32 -> 4 | Float64 -> 8 let f_bits = function | Float32 -> 32 | Float64 -> 64 let make_c_float = function | 4 -> Float32 | 8 -> Float64 | size -> WpLog.not_yet_implemented "%d-bits floats" (8*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_bits f1 <= f_bits 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 | Float32 -> 0 | Float64 -> 1 let fmemo f = let m = Array.create 2 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_bits i) let pp_float fmt f = Format.fprintf fmt "float%d" (f_bits 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,_,_) -> Integer.to_int64 k | _ -> WpLog.fatal "char-const-to-int" let constant e = match (Cil.constFold true e).enode with | Const(CInt64(k,_,_)) -> Integer.to_int64 k | Const(CChr c) -> char c | _ -> WpLog.fatal "Non-constant expression (%a)" Printer.pp_exp e let get_int e = match (Cil.constFold true e).enode with | Const(CInt64(k,_,_)) -> Some (Integer.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_pointer = function | C_pointer _ -> true | C_int _ | C_float _ | C_array _ | C_comp _ -> false 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 _ -> C_pointer (TVoid []) | 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.warning ~current:true "void object" ; C_int (c_int IInt) | TNamed _ -> WpLog.fatal "non-unrolled named type (%a)" Printer.pp_typ 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 ~current:true "object_of_array_elem called on non-array %a." pp_object o let rec object_of_logic_type t = match Logic_utils.unroll_type t with | Ctype ty -> object_of ty | Ltype({lt_name="set"},[t]) -> object_of_logic_type t | t -> Wp_parameters.fatal ~current:true "@[c-object of logic type@ (%a)@]" Printer.pp_logic_type t let rec object_of_logic_pointed t = match Logic_utils.unroll_type t with | Ctype ty -> object_of_pointed (object_of ty) | Ltype({lt_name="set"},[t]) -> object_of_logic_pointed t | t -> Wp_parameters.fatal ~current:true "@[pointed of logic type@ (%a)@]" Printer.pp_logic_type t 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 rec array_dimensions a = let te = object_of a.arr_element in let d = match a.arr_flat with None -> None | Some f -> Some f.arr_size in match te with | C_array a -> let te,ds = array_dimensions a in te , d::ds | _ -> te , [d] let array_size typ = match object_of typ with | C_array { arr_flat=Some { arr_size=s } } -> Some s | _ -> None let dimension_of_object = function | C_int _ | C_float _ | C_pointer _ | C_comp _ | C_array { arr_flat=None } -> None | C_array { arr_flat=Some a } -> Some (a.arr_dim , a.arr_cell_nbr) 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_bytes i) | C_float f -> Int64.of_int (f_bytes f) | C_pointer _ty -> Int64.of_int (i_bytes (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_typ f.ftype)) Int64.zero cinfo.cfields | C_array ainfo -> begin match ainfo.arr_flat with | Some a -> Int64.mul (sizeof_typ a.arr_cell) a.arr_cell_nbr | None -> if WpLog.ExternArrays.get () then Int64.max_int else WpLog.fatal ~current:true "Sizeof unknown-size array" end and sizeof_typ t = sizeof_object (object_of t) 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_typ 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_bits t1 < i_bits t2 then t2 else t1 let f_convert t1 t2 = if f_bits t1 < f_bits 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 --- *) (* ------------------------------------------------------------------------ *) let hsh = ref (fun _ -> assert false) (* Recursive call to hash *) let cmp = ref (fun _ _ -> assert false) (* Recursive call to compare *) module AinfoComparable = struct type t = arrayinfo let hash a = !hsh (object_of a.arr_element) let equal a b = let obj_a = object_of a.arr_element in let obj_b = object_of b.arr_element in (!cmp obj_a obj_b = 0) && (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 obj_a = object_of a.arr_element in let obj_b = object_of b.arr_element in let c = !cmp obj_a obj_b 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 compare a b = if a==b then 0 else match a,b with | C_int i, C_int i' -> compare_c_int i i' | C_int _ , _ -> (-1) | _ , C_int _ -> 1 | C_float f , C_float f' -> compare_c_float f f' | C_float _ , _ -> (-1) | _ , C_float _ -> 1 | C_pointer te , C_pointer te' -> Typ.compare te te' | C_pointer _ , _ -> (-1) | _ , C_pointer _ -> 1 | C_comp c , C_comp c' -> Compinfo.compare c c' | C_comp _ , _ -> (-1) | _ , C_comp _ -> 1 | C_array a , C_array a' -> AinfoComparable.compare a a' let () = begin hsh := hash ; cmp := compare ; end let merge a b = match a,b with | C_int i, C_int i' -> if sub_c_int i' i then a else b | C_float f , C_float f' -> if sub_c_float f' f then a else b | _ -> assert (equal a b) ; a 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 ty -> Format.fprintf fmt "%a*" Printer.pp_typ ty | 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) frama-c-Fluorine-20130601/src/wp/Splitter.ml0000644000175000017500000001632512155630215017361 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Base Type for Splitting --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Cil_datatype type tag = | MARK of stmt | THEN of stmt | ELSE of stmt | CASE of stmt * int64 list | DEFAULT of stmt | ASSERT of identified_predicate * int * int (* part *) let pretty fmt = function | MARK _ -> Format.fprintf fmt "Stmt" | THEN _ -> Format.fprintf fmt "Then" | ELSE _ -> Format.fprintf fmt "Else" | CASE(_,[]) -> Format.fprintf fmt "Case(s)" | CASE(_,[k]) -> Format.fprintf fmt "Case %s" (Int64.to_string k) | CASE(_,k::ks) -> Format.fprintf fmt "@[Cases %s" (Int64.to_string k) ; List.iter (fun k -> Format.fprintf fmt ",@,%s" (Int64.to_string k)) ks ; Format.fprintf fmt "@]" | DEFAULT _ -> Format.fprintf fmt "Default" | ASSERT(_,k,n) -> Format.fprintf fmt "Disjunction (%d/%d)" k n let loc = function | THEN s | ELSE s | MARK s | CASE(s,_) | DEFAULT s -> Stmt.loc s | ASSERT(p,_,_) -> p.ip_loc let compare p q = if p == q then 0 else match p,q with | MARK s , MARK t -> Stmt.compare s t | MARK _ , _ -> (-1) | _ , MARK _ -> 1 | THEN s , THEN t -> Stmt.compare s t | THEN _ , _ -> (-1) | _ , THEN _ -> 1 | ELSE s , ELSE t -> Stmt.compare s t | ELSE _ , _ -> (-1) | _ , ELSE _ -> 1 | CASE(s1,k1) , CASE(s2,k2) -> let c = Stmt.compare s1 s2 in if c = 0 then Pervasives.compare k1 k2 else c | CASE _ , _ -> (-1) | _ , CASE _ -> 1 | DEFAULT s , DEFAULT t -> Stmt.compare s t | DEFAULT _ , _ -> (-1) | _ , DEFAULT _ -> 1 | ASSERT(ip1,k1,_) , ASSERT(ip2,k2,_) -> let c = Pervasives.compare ip1.ip_id ip2.ip_id in if c = 0 then k1 - k2 else c (* -------------------------------------------------------------------------- *) (* --- Assertion Disjunction --- *) (* -------------------------------------------------------------------------- *) let rec disjunction p = try unwrap p with Exit -> [p] and unwrap p = match p.content with | Por(a,b) -> disjunction a @ disjunction b | Plet(f,a) -> List.map (fun q -> { p with content = Plet(f,q) }) (unwrap a) | Pexists(qs,p) -> List.map (fun q -> { p with content = Pexists(qs,q) }) (unwrap p) | Pat(p,l) -> List.map (fun q -> { p with content = Pat(q,l) }) (unwrap p) | _ -> raise Exit let predicate ip = { name = ip.ip_name ; loc = ip.ip_loc ; content = ip.ip_content } let rec enumerate ip k n = function | [] -> [] | p::ps -> (ASSERT(ip,k,n),p) :: enumerate ip (succ k) n ps let cases ip = try let ps = unwrap (predicate ip) in Some (enumerate ip 1 (List.length ps) ps) with Exit -> None (* -------------------------------------------------------------------------- *) (* --- Switch Cases --- *) (* -------------------------------------------------------------------------- *) let switch_cases stmt ks = CASE(stmt,ks) let switch_default stmt = DEFAULT stmt let if_then stmt = THEN stmt let if_else stmt = ELSE stmt let mark stmt = MARK stmt (* -------------------------------------------------------------------------- *) (* --- Switch Cases --- *) (* -------------------------------------------------------------------------- *) module Tags = Qed.Listset.Make (struct type t = tag let compare = compare let equal x y = (compare x y = 0) end) module M = Qed.Listmap.Make(Tags) module I = Map.Make(Tags) type 'a t = 'a M.t let rec compact merge = function | ([] | [_]) as m -> m | ( (k1,v1) as e )::(( (k2,v2)::r ) as m) -> if Tags.compare k1 k2 = 0 then collect merge k1 [v2;v1] r else e :: compact merge m and collect merge k vs = function | [] -> [k,merge vs] | ((k',v')::r) as m -> if Tags.compare k k' = 0 then collect merge k (v'::vs) r else (k,merge vs) :: compact merge m let bytags (k,_) (k',_) = Tags.compare k k' let group tag merge m = let compaction = ref false in let m = List.sort bytags (List.map (fun (tgs,v) -> if not !compaction && Tags.mem tag tgs then compaction := true ; Tags.add tag tgs , v) m) in if !compaction then compact merge m else m (* let filter phi m = M.filter (fun key _ -> phi key) m *) let length = List.length let empty = [] let singleton e = [[],e] let union merge m1 m2 = M.union (fun _ -> merge) m1 m2 let rec merge ~left ~both ~right m1 m2 = match m1 , m2 with | [],[] -> [] | _,[] -> List.map (fun (k,v) -> k , left v) m1 | [],_ -> List.map (fun (k,v) -> k , right v) m2 | (k1,v1)::w1 , (k2,v2)::w2 -> let cmp = Tags.compare k1 k2 in if cmp < 0 then (k1 , left v1) :: merge ~left ~both ~right w1 m2 else if cmp > 0 then (k2 , right v2) :: merge ~left ~both ~right m1 w2 else (k1 , both v1 v2) :: merge ~left ~both ~right w1 w2 let merge_all merge = function | [] -> [] | [m] -> m | [m1;m2] -> M.union (fun _ u v -> merge [u;v]) m1 m2 | ms -> let t = ref I.empty in List.iter (List.iter (fun (k,v) -> try let r = (I.find k !t) in r := v :: !r with Not_found -> t := I.add k (ref [v]) !t)) ms ; I.fold (fun k r m -> match !r with | [] -> m | [v] -> (k,v)::m | vs -> (k,merge vs)::m) !t [] let map = M.map let iter = M.iter let fold = M.fold let exists f xs = List.exists (fun (_,x) -> f x) xs let for_all f xs = List.for_all (fun (_,x) -> f x) xs let filter f xs = List.filter (fun (_,x) -> f x) xs frama-c-Fluorine-20130601/src/wp/Lang.ml0000644000175000017500000005416112155630215016434 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Cil_types open Cil_datatype open Ctypes open Qed open Qed.Logic (* -------------------------------------------------------------------------- *) let basename def name = let rec lookup def s k n = if k < n then let c = s.[k] in if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') then String.sub s k 1 else lookup def s (succ k) n else def in lookup def name 0 (String.length name) (* -------------------------------------------------------------------------- *) (* Naming Prefixes Names starting with a lower-case character belong to logic language or external model(s). 'pointer' Pointer type 'Lit_' String Literal Values 'Str_' String Literal Pointers 'S_' Structure 'U_' Union 'F__' Field in compound 'A_' ACSL Logic type 'C_' ACSL Constructor 'P_

    ' ACSL Predicate

    (see LogicUsage.get_name) 'L_' ACSL Logic function (see LogicUsage.get_name) 'FixP_

    ' ACSL Recursive Predicate

    (see LogicUsage.get_name) 'FixL_' ACSL Recursive Logic function (see LogicUsage.get_name) 'Q_' ACSL Lemma or Axiom 'S_' Set comprehension predicate 'Is' Typing predicate for type 'Null' Null value for type *) let avoid_leading_backlash s = if s.[0]='\\' then let s = String.copy s in s.[0]<-'_'; s else s let comp_id c = if c.cstruct then Printf.sprintf "S_%s" c.cname else Printf.sprintf "U_%s" c.cname let field_id f = Printf.sprintf "F_%s_%s" f.fcomp.cname f.fname let type_id l = Printf.sprintf "A_%s" l.lt_name let logic_id f = let name = avoid_leading_backlash (LogicUsage.get_name f) in if f.l_type = None then Printf.sprintf "P_%s" name else Printf.sprintf "L_%s" name let ctor_id c = Printf.sprintf "C_%s" (avoid_leading_backlash c.ctor_name) let lemma_id l = Printf.sprintf "Q_%s" (avoid_leading_backlash l) (* -------------------------------------------------------------------------- *) type theory = string type adt = | Mtype of mdt (* Model type *) | Mrecord of mdt * fields (* Model record-type *) | Atype of logic_type_info (* Logic Type *) | Comp of compinfo (* C-code struct or union *) and mdt = { mdt_link : string ; mdt_theory : theory ; } and fields = { mutable fields : field list } and field = | Mfield of mdt * fields * string * tau | Cfield of fieldinfo and tau = (field,adt) Logic.datatype let pointer = Context.create "Lang.pointer" (* -------------------------------------------------------------------------- *) (* --- Sorting & Typing --- *) (* -------------------------------------------------------------------------- *) let sort_of_object = function | C_int _ -> Logic.Sint | C_float _ -> Logic.Sreal | C_pointer _ | C_comp _ | C_array _ -> Logic.Sdata let sort_of_ctype t = sort_of_object (Ctypes.object_of t) let sort_of_ltype t = match Logic_utils.unroll_type t with | Ctype typ -> sort_of_ctype typ | Ltype _ | Lvar _ | Larrow _ -> Logic.Sdata | Linteger -> Logic.Sint | Lreal -> Logic.Sreal let tau_of_comp c = Logic.Data(Comp c,[]) let array a = Logic.Array(Logic.Int,a) let farray a b = Logic.Array(a,b) let rec tau_of_object = function | C_int _ -> Logic.Int | C_float _ -> Logic.Real | C_pointer t -> Context.get pointer t | C_comp c -> tau_of_comp c | C_array { arr_element = typ } -> array (tau_of_ctype typ) and tau_of_ctype typ = tau_of_object (Ctypes.object_of typ) let poly = Context.create "Wp.Lang.poly" let rec varpoly k x = function | [] -> Warning.error "Unbound type parameter <%s>" x | y::ys -> if x = y then k else varpoly (succ k) x ys let builtins = Hashtbl.create 131 let rec tau_of_ltype t = match Logic_utils.unroll_type t with | Linteger -> Logic.Int | Lreal -> Logic.Real | Ctype typ -> tau_of_ctype typ | Lvar x -> Logic.Tvar (varpoly 1 x (Context.get poly)) | Larrow _ -> Warning.error "array type non-supported(%a)" Printer.pp_logic_type t | Ltype _ as b when Logic_const.is_boolean_type b -> Logic.Bool | Ltype(lt,ps) -> try let mdt = Hashtbl.find builtins lt.lt_name in assert (ps = []) ; Logic.Data(Mtype mdt,[]) with Not_found -> Logic.Data(Atype lt,List.map tau_of_ltype ps) let tau_of_return l = match l.l_type with | None -> Logic.Prop | Some t -> tau_of_ltype t (* -------------------------------------------------------------------------- *) (* --- Datatypes --- *) (* -------------------------------------------------------------------------- *) module ADT = struct type t = adt let basename = function | Mtype a -> basename "M" a.mdt_link | Mrecord(r,_) -> basename "R" r.mdt_link | Comp c -> basename (if c.cstruct then "S" else "U") c.corig_name | Atype lt -> basename "A" lt.lt_name let id = function | Mtype a -> a.mdt_link | Mrecord(a,_) -> a.mdt_link | Comp c -> comp_id c | Atype lt -> type_id lt let hash = function | Mtype a | Mrecord(a,_) -> Hashtbl.hash a | Comp c -> Compinfo.hash c | Atype lt -> Logic_type_info.hash lt let compare a b = if a==b then 0 else match a,b with | Mtype a , Mtype b -> String.compare a.mdt_link b.mdt_link | Mtype _ , _ -> (-1) | _ , Mtype _ -> 1 | Mrecord(a,_) , Mrecord(b,_) -> String.compare a.mdt_link b.mdt_link | Mrecord _ , _ -> (-1) | _ , Mrecord _ -> 1 | Comp a , Comp b -> Compinfo.compare a b | Comp _ , _ -> (-1) | _ , Comp _ -> 1 | Atype a , Atype b -> Logic_type_info.compare a b let equal a b = (compare a b = 0) let pretty fmt a = Format.pp_print_string fmt (id a) end (* -------------------------------------------------------------------------- *) (* --- Datatypes --- *) (* -------------------------------------------------------------------------- *) let atype t = try Mtype(Hashtbl.find builtins t.lt_name) with Not_found -> Atype t let builtin ~name ~link ~theory = let m = { mdt_link = link ; mdt_theory = theory } in Hashtbl.add builtins name m let datatype ~link ~theory = let m = { mdt_link = link ; mdt_theory = theory } in Mtype m let record ~link ~theory fts = let m = { mdt_link = link ; mdt_theory = theory } in let r = { fields = [] } in let fs = List.map (fun (f,t) -> Mfield(m,r,f,t)) fts in r.fields <- fs ; Mrecord(m,r) let field t f = match t with | Mrecord(_,r) -> begin try List.find (function Mfield(_,_,g,_) -> f = g | _ -> false) r.fields with Not_found -> Wp_parameters.fatal "No field <%s> in record" f end | _ -> Wp_parameters.fatal "No field <%s> in type '%a'" f ADT.pretty t let comp c = Comp c let fields_of_tau = function | Record _ -> assert false | Data(Mrecord(_,r),_) -> r.fields | Data(Comp c,_) -> List.map (fun f -> Cfield f) c.cfields | _ -> [] let fields_of_field = function | Mfield(_,r,_,_) -> r.fields | Cfield f -> List.map (fun f -> Cfield f) f.fcomp.cfields let tau_of_field = function | Mfield(_,_,_,t) -> t | Cfield f -> tau_of_ctype f.ftype let tau_of_record = function | Mfield(mdt,fs,_,_) -> Logic.Data(Mrecord(mdt,fs),[]) | Cfield f -> tau_of_comp f.fcomp module Field = struct type t = field let id = function | Mfield(_,_,f,_) -> f | Cfield f -> field_id f let hash = function | Mfield(_,_,f,_) -> Hashtbl.hash f | Cfield f -> Fieldinfo.hash f let compare f g = if f==g then 0 else match f , g with | Mfield(_,_,f,_) , Mfield(_,_,g,_) -> String.compare f g | Mfield _ , Cfield _ -> (-1) | Cfield _ , Mfield _ -> 1 | Cfield f , Cfield g -> Fieldinfo.compare f g let equal f g = (compare f g = 0) let pretty fmt f = Format.pp_print_string fmt (id f) let sort = function | Mfield(_,_,_,s) -> Qed.Kind.of_tau s | Cfield f -> sort_of_object (Ctypes.object_of f.ftype) end (* -------------------------------------------------------------------------- *) (* --- Functions & Predicates --- *) (* -------------------------------------------------------------------------- *) type scope = External of string | Generated type lfun = | Function of lfunction | Predicate of lpredicate | ACSL of logic_info | CTOR of logic_ctor_info and lfunction = { f_scope : scope ; f_link : Engine.link ; f_category : lfun category ; f_params : sort list ; f_result : sort ; } and lpredicate = { p_scope : scope ; p_params : sort list ; p_prop : string ; p_bool : string ; } let tau_of_lfun = function | ACSL f -> tau_of_return f | CTOR c -> if c.ctor_type.lt_params = [] then Logic.Data(Atype c.ctor_type,[]) else raise Not_found | Predicate _ -> Prop | Function f -> match f.f_result with | Sint -> Int | Sreal -> Real | Sbool -> Bool | _ -> raise Not_found type balance = Nary | Left | Right let symbolf ~scope ?(balance=Nary) ?(category=Logic.Function) ?(params=[]) ?(result=Logic.Sdata) name = let buffer = Buffer.create 80 in Format.kfprintf (fun fmt -> Format.pp_print_flush fmt () ; let name = Buffer.contents buffer in let link = match balance with | Nary -> Engine.F_call name | Left -> Engine.F_left("?",name) | Right -> Engine.F_right("?",name) in Function { f_scope = scope ; f_link = link ; f_category = category ; f_params = params ; f_result = result ; } ) (Format.formatter_of_buffer buffer) name let extern_s ~theory ?(balance=Nary) ?category ?params ?result name = symbolf ~scope:(External theory) ~balance ?category ?params ?result "%s" name let extern_f ~theory ?(balance=Nary) ?category ?params ?result name = symbolf ~scope:(External theory) ~balance ?category ?params ?result name let extern_p ~theory ~prop ~bool ?(params=[]) () = Predicate { p_scope = External theory ; p_params = params ; p_prop = prop ; p_bool = bool ; } let extern_fp ~theory ?(params=[]) phi = Function { f_scope = External theory ; f_link = Engine.F_call phi ; f_category = Logic.Function ; f_params = params ; f_result = Logic.Sprop ; } let generated_f ?category ?params ?result name = symbolf ~scope:Generated ?category ?params ?result name let generated_p name = Function { f_scope = Generated ; f_link = Engine.F_call name ; f_category = Logic.Function ; f_params = [] ; f_result = Logic.Sprop ; } let constructor ct = CTOR ct let logic_info lf = ACSL lf module Fun = struct type t = lfun let id = function | Function f -> Export.link_name f.f_link | Predicate p -> p.p_prop | ACSL f -> logic_id f | CTOR c -> ctor_id c let link cmode = function | Function f -> f.f_link | ACSL f -> Engine.F_call (logic_id f) | CTOR c -> Engine.F_call (ctor_id c) | Predicate p -> Engine.F_call (match cmode with Engine.Cprop -> p.p_prop | Engine.Cterm -> p.p_bool) let theory = function | Function { f_scope=s } | Predicate { p_scope=s } -> (match s with Generated -> "generated" | External t -> t) | ACSL _ -> "ACSL" | CTOR _ -> "CTOR" let hash = function | Function f -> Hashtbl.hash f.f_link | Predicate p -> Hashtbl.hash p.p_prop | ACSL f -> Logic_info.hash f | CTOR c -> Logic_ctor_info.hash c let compare f g = if f==g then 0 else match f , g with | Function { f_link = f } , Function { f_link = g } -> String.compare (Export.link_name f) (Export.link_name g) | Function _ , _ -> (-1) | _ , Function _ -> 1 | Predicate { p_prop = f } , Predicate { p_prop = g } -> String.compare f g | Predicate _ , _ -> (-1) | _ , Predicate _ -> 1 | ACSL f , ACSL g -> Logic_info.compare f g | ACSL _ , _ -> (-1) | _ , ACSL _ -> 1 | CTOR c , CTOR d -> Logic_ctor_info.compare c d let equal f g = (compare f g = 0) let pretty fmt f = Format.pp_print_string fmt (id f) let category = function | Function f -> f.f_category | Predicate _ | ACSL _ -> Logic.Function | CTOR _ -> Logic.Constructor let sort = function | Function f -> f.f_result | Predicate _ | ACSL { l_type=None } -> Logic.Sprop | ACSL { l_type=Some t } -> sort_of_ltype t | CTOR _ -> Logic.Sdata let params = function | Function f -> f.f_params | Predicate p -> p.p_params | ACSL lt -> if lt.l_labels=[] then List.map (fun x -> sort_of_ltype x.lv_type) lt.l_profile else [] | CTOR ct -> List.map sort_of_ltype ct.ctor_params end let link = Fun.link let theory = Fun.theory (* -------------------------------------------------------------------------- *) (* --- Terms --- *) (* -------------------------------------------------------------------------- *) module F = struct module T = Qed.Term.Make(ADT)(Field)(Fun) module Pretty = Qed.Pretty.Make(T) include T (* -------------------------------------------------------------------------- *) (* --- Term Extensions --- *) (* -------------------------------------------------------------------------- *) type unop = term -> term type binop = term -> term -> term let e_zero = e_zint Z.zero let e_one = e_zint Z.one let e_minus_one = e_zint Z.minus_one let e_zero_real = e_real (R.of_string "0.0") let hex_of_float f = Pretty_utils.to_string (Floating_point.pretty_normal ~use_hex:true) f let e_int64 z = e_zint (Z.of_string (Int64.to_string z)) let e_fact k e = e_times (Z.of_string (Int64.to_string k)) e let e_bigint z = e_zint (Z.of_string (Integer.to_string z)) let e_range a b = e_sum [b;e_one;e_opp a] let e_mthfloat f = T.e_real (R.of_string (string_of_float f)) let e_hexfloat f = T.e_real (R.of_string (hex_of_float f)) let e_setfield r f v = (*TODO:NUPW: check for UNIONS *) let r = List.map (fun g -> g,if Field.equal f g then v else e_getfield r g) (fields_of_field f) in e_record r (* -------------------------------------------------------------------------- *) (* --- Predicates --- *) (* -------------------------------------------------------------------------- *) type pred = term type cmp = term -> term -> pred let p_bool t = t let e_prop t = t let p_bools xs = xs let e_props xs = xs let lift f x = f x let is_zero e = match T.repr e with | Kint z -> Qed.Z.null z | _ -> false let eqp = equal let comparep = compare let is_ptrue = is_true let is_pfalse = is_false let is_equal a b = is_true (e_eq a b) let p_equal = e_eq let p_neq = e_neq let p_leq = e_leq let p_lt = e_lt let p_positive e = e_leq e_zero e let p_true = e_true let p_false = e_false let p_not = e_not let p_bind = e_bind let p_forall = e_forall let p_exists = e_exists let p_subst = e_subst let p_and p q = e_and [p;q] let p_or p q = e_or [p;q] let p_imply h p = e_imply [h] p let p_hyps hs p = e_imply hs p let p_equiv = e_equiv let p_if = e_if let p_conj = e_and let p_disj = e_or let p_all f xs = e_and (List.map f xs) let p_any f xs = e_or (List.map f xs) let p_call = e_fun let p_close p = p_forall (Vars.elements (vars p)) p let occurs x t = Vars.mem x (vars t) let intersect a b = Vars.intersect (vars a) (vars b) let occursp = occurs let intersectp = intersect let varsp = vars let pred = repr let idp = id let pp_term fmt e = if Wp_parameters.has_dkey "pretty" then T.debug fmt e else Pretty.pp_term Pretty.empty fmt e let pp_pred fmt p = if Wp_parameters.has_dkey "pretty" then T.debug fmt p else Pretty.pp_term Pretty.empty fmt p let pp_var fmt x = pp_term fmt (e_var x) let pp_vars fmt xs = begin Format.fprintf fmt "@[{" ; Vars.iter (fun x -> Format.fprintf fmt "@ %a" pp_var x) xs ; Format.fprintf fmt " }@]" ; end let debugp = T.debug type env = Pretty.env let empty = Pretty.empty let closed = Pretty.closed let marker = Pretty.marks let mark_e = T.mark let mark_p = T.mark let define f env m = List.fold_left (fun env t -> let x,env_x = Pretty.fresh env t in f env x t ; env_x) env (T.defs m) let pp_eterm = Pretty.pp_term let pp_epred = Pretty.pp_term module Pmap = Tmap module Pset = Tset module P = Qed.Pattern.Make(T) type pattern = P.pattern let rewrite ~name ~vars pattern eval = let open Qed.Pattern in match pattern with | Pfun(f,ps) -> if Wp_parameters.has_dkey "rules" then begin let pool = T.pool () in let s = Array.map (fun t -> e_var (T.fresh pool t)) vars in Wp_parameters.result "@[Rule %S:@ %a ==>@ %t" name pp_term (P.instance s pattern) (fun fmt -> (try pp_term fmt (eval s) with Not_found -> Format.pp_print_string fmt "<...>") ; Format.fprintf fmt "@]@." ; ) ; end ; add_builtin f (fun es -> eval (P.pmatch_all ps es)) | _ -> () let add_builtin_1 f r = add_builtin f (function [e] -> r e | _ -> raise Not_found) let add_builtin_2 f r = add_builtin f (function [a;b] -> r a b | _ -> raise Not_found) let add_builtin_peq = add_builtin_eq end open F (* -------------------------------------------------------------------------- *) (* --- Fresh Variables & Local Assumptions --- *) (* -------------------------------------------------------------------------- *) type gamma = { mutable hyps : pred list ; mutable vars : var list ; } (* -------------------------------------------------------------------------- *) let cpool = Context.create "Lang.pool" let cgamma = Context.create "Lang.gamma" let apool = function None -> F.pool () | Some p -> p let agamma = function None -> { hyps=[] ; vars=[] } | Some g -> g let new_pool = F.pool let new_gamma ?copy () = match copy with | None -> { hyps=[] ; vars=[] } | Some g -> { hyps = g.hyps ; vars = g.vars } let get_pool () = Context.get cpool let get_gamma () = Context.get cgamma let freshvar ?basename tau = F.fresh (Context.get cpool) ?basename tau let freshen x = F.alpha (Context.get cpool) x let local ?pool ?gamma f = Context.bind cpool (apool pool) (Context.bind cgamma (agamma gamma) f) (* -------------------------------------------------------------------------- *) (* --- Hypotheses --- *) (* -------------------------------------------------------------------------- *) let masked = ref false let without_assume job x = if !masked then job x else try masked := true ; let y = job x in masked := false ; y with err -> masked := false ; raise err let assume p = if p != p_true && not !masked then let d = Context.get cgamma in d.hyps <- p :: d.hyps let epsilon ?basename t phi = let d = Context.get cgamma in let x = freshvar ?basename t in let e = e_var x in d.hyps <- phi e :: d.hyps ; d.vars <- x :: d.vars ; e let hypotheses g = g.hyps let variables g = List.rev g.vars let get_hypotheses () = (Context.get cgamma).hyps let get_variables () = (Context.get cgamma).vars (* -------------------------------------------------------------------------- *) (* --- Alpha Conversion --- *) (* -------------------------------------------------------------------------- *) module Alpha = struct module Vmap = Map.Make(Var) type t = { mutable vars : var Vmap.t ; mutable cache : term Tmap.t ; } let create () = { vars = Vmap.empty ; cache = Tmap.empty } let get w x = try Vmap.find x w.vars with Not_found -> let y = freshen x in w.vars <- Vmap.add x y w.vars ; y let iter f w = Vmap.iter f w.vars let rec convert w e = try Tmap.find e w.cache with Not_found -> let a = match F.repr e with | Logic.Var x -> e_var (get w x) | Logic.Bind(q,x,t) -> let v_temp = w.vars in let c_temp = w.cache in let y = freshen x in w.vars <- Vmap.add x y w.vars ; let b = convert w t in w.vars <- if Vmap.mem x v_temp then Vmap.add x (Vmap.find x v_temp) w.vars else Vmap.remove x w.vars ; w.cache <- c_temp ; F.e_bind q y b | _ -> e_map (convert w) e in w.cache <- Tmap.add e a w.cache ; a let convertp = convert end (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/register.ml0000644000175000017500000004012012155630215017365 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Factory let job_key= Wp_parameters.register_category "trace-job" (* --------- Command Line ------------------- *) let cmdline () : setup = begin match Wp_parameters.Model.get () with | ["Runtime"] -> Wp_parameters.abort "Model 'Runtime' is no more available.@\nIt will be reintroduced \ in a future release." | ["Logic"] -> Wp_parameters.warning ~once:true "Deprecated 'Logic' model.@\nUse 'Typed' with option '-wp-ref' \ instead." ; { mheap = Factory.Typed MemTyped.Fits ; mvar = Factory.Ref ; cint = Cint.Natural ; cfloat = Cfloat.Real ; } | ["Store"] -> Wp_parameters.warning ~once:true "Deprecated 'Store' model.@\nUse 'Typed' instead." ; { mheap = Factory.Typed MemTyped.Fits ; mvar = Factory.Var ; cint = Cint.Natural ; cfloat = Cfloat.Real ; } | spec -> Factory.parse spec end let set_model (s:setup) = Wp_parameters.Model.set [Factory.id s] (* --------- WP Computer -------------------- *) let computer () = Driver.load_drivers () ; if Wp_parameters.Model.get () = ["Dump"] then CfgDump.create () else Factory.computer (cmdline ()) (* ------------------------------------------------------------------------ *) (* --- 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_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) let do_wp_report () = let rfiles = Wp_parameters.Report.get () in if rfiles <> [] then begin let stats = WpReport.fcstat () in List.iter (WpReport.export stats) rfiles ; end (* ------------------------------------------------------------------------ *) (* --- Wp Results --- *) (* ------------------------------------------------------------------------ *) let already_valid goal = List.exists (fun (_,r) -> Wpo.is_valid r) (Wpo.get_results goal) let pp_result wpo fmt r = VCS.pp_result fmt r ; match r.VCS.verdict with | VCS.Unknown | VCS.Timeout | VCS.Stepout -> let ws = Wpo.warnings wpo in if ws <> [] then let n = List.length ws in let s = List.exists (fun w -> w.Warning.severe) ws in begin match s , n with | true , 1 -> Format.fprintf fmt " (Degenerated)" | true , _ -> Format.fprintf fmt " (Degenerated, %d warnings)" n | false , 1 -> Format.fprintf fmt " (Stronger)" | false , _ -> Format.fprintf fmt " (Stronger, %d warnings)" n end | _ -> () let do_wpo_start goal prover = if Wp_parameters.has_dkey "prover" then Wp_parameters.feedback "[%a] Goal %s preprocessing" VCS.pp_prover prover (Wpo.get_gid goal) let do_wpo_feedback goal prover result = if Wpo.is_verdict result then begin Wp_parameters.feedback "[%a] Goal %s : %a" VCS.pp_prover prover (Wpo.get_gid goal) (pp_result goal) result; if Wp_parameters.ProofTrace.get () || Wp_parameters.UnsatModel.get () then Log.print_on_output begin fun fmt -> let logout = Wpo.get_file_logout goal prover in let logerr = Wpo.get_file_logerr goal prover in if Sys.file_exists logout then Command.pp_from_file fmt logout ; if Sys.file_exists logerr then Command.pp_from_file fmt logerr ; end end let wp_why3ide_launch task = let server = ProverTask.server () in (** Do on_server_stop save why3 session *) Task.spawn server task; Task.launch server (* ------------------------------------------------------------------------ *) (* --- Checking prover printing --- *) (* ------------------------------------------------------------------------ *) let do_wp_check_iter iter_on_goals = let provers = [VCS.Coq; VCS.AltErgo; VCS.Why3 "altergo"] in let provers = List.map (fun p -> (false,p)) provers in Wp_parameters.WhyFlags.add "--type-only"; Wp_parameters.AltErgoFlags.add "-type-only"; let server = ProverTask.server () in ignore (Wp_parameters.Share.dir ()); (* To prevent further errors *) let do_wpo_feedback goal prover result = match result.VCS.verdict with | VCS.Computing _ -> () | VCS.Timeout | VCS.Stepout | VCS.Failed -> Wp_parameters.feedback "[%a] Type error %s : %a" VCS.pp_prover prover (Wpo.get_gid goal) (pp_result goal) result; | VCS.NoResult | VCS.Invalid | VCS.Unknown | VCS.Valid when Wp_parameters.has_dkey "prover" -> Wp_parameters.feedback "[%a] Type ok %s : %a" VCS.pp_prover prover (Wpo.get_gid goal) (pp_result goal) result; | VCS.NoResult | VCS.Invalid | VCS.Unknown | VCS.Valid -> () in iter_on_goals (fun goal -> if not (already_valid goal) then Prover.spawn goal ~callin:do_wpo_start ~callback:do_wpo_feedback provers ) ; Task.launch server let do_wp_check () = if Wp_parameters.wpcheck () then do_wp_check_iter (fun f -> Wpo.iter ~on_goal:f ()) let do_wp_check_for goals = if Wp_parameters.wpcheck () then do_wp_check_iter (fun f -> Bag.iter f goals) (* ------------------------------------------------------------------------ *) (* --- Proving --- *) (* ------------------------------------------------------------------------ *) let do_wpo_display goal = let result = if Wpo.is_trivial goal then "trivial" else "not tried" in Wp_parameters.feedback "Goal %s : %s" (Wpo.get_gid goal) result let do_wp_proofs_iter ~provers iter_on_goals = if provers <> [] then begin let server = ProverTask.server () in ignore (Wp_parameters.Share.dir ()); (* To prevent further errors *) if not (Wp_parameters.has_dkey "no-goals-info") then begin let n = ref 0 in iter_on_goals (fun goal -> if not (already_valid goal) then incr n) ; if !n > 1 then Wp_parameters.feedback "%d goals scheduled" !n else Wp_parameters.feedback "%d goal scheduled" !n ; end ; iter_on_goals (fun goal -> if not (already_valid goal) then Prover.spawn goal ~callin:do_wpo_start ~callback:do_wpo_feedback provers ) ; Task.launch server end else if not (Wp_parameters.Print.get ()) then iter_on_goals (fun goal -> if not (already_valid goal) then do_wpo_display goal) let do_wp_proofs_iter iter = let do_why3_ide = ref false in let provers = List.fold_right (fun pname pvs -> match Wpo.prover_of_name pname with | None -> pvs | Some VCS.Why3ide -> do_why3_ide := true; pvs | Some prover -> (VCS.is_interactive pname , prover) :: pvs) (match Wp_parameters.Provers.get () with [] -> [ "alt-ergo" ] | pvs -> pvs) [] in begin if !do_why3_ide then wp_why3ide_launch (Prover.wp_why3ide ~callback:do_wpo_feedback iter) ; do_wp_proofs_iter ~provers iter ; end let do_wp_proofs () = do_wp_proofs_iter (fun f -> Wpo.iter ~on_goal:f ()) let do_wp_proofs_for goals = do_wp_proofs_iter (fun f -> Bag.iter f goals) (* ------------------------------------------------------------------------ *) (* --- Secondary Entry Points --- *) (* ------------------------------------------------------------------------ *) (* Registered entry point in Dynamic. *) let wp_compute_deprecated kf bhv ipopt = Wp_parameters.warning ~once:true "Dynamic 'wp_compute' is now deprecated." ; let model = computer () in let goals = match ipopt with | None -> Generator.compute_kf model ?kf ~bhv () | Some ip -> Generator.compute_ip model ip in do_wp_proofs_for goals let wp_compute_kf kf bhv prop = let model = computer () in do_wp_proofs_for (Generator.compute_kf model ?kf ~bhv ~prop ()) let wp_compute_ip ip = let model = computer () in do_wp_proofs_for (Generator.compute_ip model ip) let wp_compute_call stmt = do_wp_proofs_for (Generator.compute_call (computer ()) stmt) let wp_clear () = Wpo.clear () (* ------------------------------------------------------------------------ *) (* --- Command-line Entry Points --- *) (* ------------------------------------------------------------------------ *) let cmdline_run () = let wp_main fct = Wp_parameters.feedback "Running WP plugin..."; Ast.compute (); if Wp_parameters.has_dkey "logicusage" then begin LogicUsage.compute (); LogicUsage.dump (); end ; if Wp_parameters.has_dkey "varusage" then begin VarUsage.compute (); VarUsage.dump (); end ; if Wp_parameters.has_dkey "builtins" then begin LogicBuiltins.dump (); end ; Variables_analysis.precondition_compute (); let bhv = Wp_parameters.Behaviors.get () in let prop = Wp_parameters.Properties.get () in let computer = computer () in if Wp_parameters.Froms.get () then Generator.compute_froms computer ~fct () else Generator.compute_selection computer ~fct ~bhv ~prop () in match Wp_parameters.job () with | Wp_parameters.WP_None -> () | Wp_parameters.WP_All -> begin ignore (wp_main Generator.F_All); do_wp_proofs (); do_wp_print (); do_wp_report (); do_wp_check (); end | jb -> let fct = let open Wp_parameters in match jb with | WP_None -> Generator.F_List [] | WP_All -> Generator.F_All | WP_Fct fs -> Generator.F_List fs | WP_SkipFct fs -> Generator.F_Skip fs in begin let goals = wp_main fct in do_wp_proofs_for goals ; do_wp_print_for goals ; do_wp_report () ; do_wp_check_for goals; end (* ------------------------------------------------------------------------ *) (* --- Register external functions --- *) (* ------------------------------------------------------------------------ *) (* DEPRECATED *) 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_deprecated let wp_compute_kf = let module OKF = Datatype.Option(Kernel_function) in let module OLS = Datatype.List(Datatype.String) in Dynamic.register ~plugin:"Wp" "wp_compute_kf" (Datatype.func3 OKF.ty OLS.ty OLS.ty Datatype.unit) ~journalize:true wp_compute_kf let wp_compute_ip = Dynamic.register ~plugin:"Wp" "wp_compute_ip" (Datatype.func Property.ty Datatype.unit) ~journalize:false (*LC: Because of Property is not journalizable. *) wp_compute_ip let wp_compute_call = Dynamic.register ~plugin:"Wp" "wp_compute_call" (Datatype.func Cil_datatype.Stmt.ty Datatype.unit) ~journalize:true (*LC: Because of Property is not journalizable. *) wp_compute_call let wp_clear = Dynamic.register ~plugin:"Wp" "wp_clear" (Datatype.func Datatype.unit Datatype.unit) ~journalize:false (*LC: To be consistent with Wp_Compute *) wp_clear let run = Dynamic.register ~plugin:"Wp" "run" (Datatype.func Datatype.unit Datatype.unit) ~journalize:true cmdline_run (* ------------------------------------------------------------------------ *) (* --- Tracing WP Invocation --- *) (* ------------------------------------------------------------------------ *) let pp_wp_parameters fmt = begin Format.pp_print_string fmt "# frama-c -wp" ; if Wp_parameters.RTE.get () then Format.pp_print_string fmt " -wp-rte" ; let spec = Wp_parameters.Model.get () in if spec <> [] && spec <> ["Typed"] then ( let descr = Factory.descr (Factory.parse spec) in Format.fprintf fmt " -wp-model '%s'" descr ) ; if not (Wp_parameters.Let.get ()) then Format.pp_print_string fmt " -wp-no-let" ; if Wp_parameters.Let.get () && not (Wp_parameters.Prune.get ()) then Format.pp_print_string fmt " -wp-no-prune" ; if Wp_parameters.Split.get () then Format.pp_print_string fmt " -wp-split" ; let tm = Wp_parameters.Timeout.get () in if tm > 10 then Format.fprintf fmt " -wp-timeout %d" tm ; let st = Wp_parameters.Steps.get () in if tm > 10 then Format.fprintf fmt " -wp-steps %d" st ; let dp = Wp_parameters.Depth.get () in if dp > 0 then Format.fprintf fmt " -wp-depth %d" dp ; Format.pp_print_string fmt " [...]" ; Format.pp_print_newline fmt () ; end let () = Cmdline.run_after_setting_files (fun _ -> if Wp_parameters.has_dkey "shell" then Log.print_on_output pp_wp_parameters) let do_prover_detect () = if not !Config.is_gui && Wp_parameters.Detect.get () then ProverWhy3.detect_why3 begin function | None -> Wp_parameters.error ~current:false "Why3 not found" | Some dps -> List.iter (fun dp -> let open ProverWhy3 in Wp_parameters.result "Prover %10s %-10s [%s]" dp.dp_name dp.dp_version dp.dp_prover ) dps end (* ------------------------------------------------------------------------ *) (* --- Main Entry Point --- *) (* ------------------------------------------------------------------------ *) let do_finally job1 job2 () = if Wp_parameters.has_dkey "raised" then begin job1 () ; job2 () ; end else 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 , _ -> raise e1 | None , Some e2 -> raise e2 let (&&&) = do_finally let rec sequence jobs = match jobs with | [] -> fun () -> () | head::tail -> head &&& sequence tail let tracelog () = if Datatype.String.Set.is_empty (Wp_parameters.Debug_category.get ()) then Wp_parameters.debug "Logging keys : %s." (Wp_parameters.Debug_category.get_set()) let main = sequence [ (fun () -> Wp_parameters.debug ~dkey:job_key "Start WP plugin...@.") ; do_prover_detect ; cmdline_run ; tracelog ; Wp_parameters.reset ; (fun () -> Wp_parameters.debug ~dkey:job_key "Stop WP plugin...@.") ; ] let () = Db.Main.extend main frama-c-Fluorine-20130601/src/wp/Passive.mli0000644000175000017500000000355212155630215017334 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Lang.F (** Passive Forms *) type t val empty : t val union : t -> t -> t val bind : fresh:var -> bound:var -> t -> t val join : var -> var -> t -> t val conditions : t -> (var -> bool) -> pred list val apply : t -> pred -> pred val pretty : Format.formatter -> t -> unit frama-c-Fluorine-20130601/src/wp/ctypes.mli0000644000175000017500000001172712155630215017234 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 = | Float32 | Float64 (** 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 val object_of_pointed: c_object -> c_object val object_of_array_elem : c_object -> c_object val object_of_logic_type : logic_type -> c_object val object_of_logic_pointed : logic_type -> c_object (** {2 Utilities} *) val imemo : (c_int -> 'a) -> c_int -> 'a val fmemo : (c_float -> 'a) -> c_float -> 'a val is_char : c_int -> bool 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 is_pointer : c_object -> 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 -> Qed.Z.t * Qed.Z.t (** All sizes are in bits *) val sub_c_int: c_int -> c_int -> bool val sub_c_float : c_float -> c_float -> bool val sizeof_typ : typ -> int64 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 array_size : typ -> int64 option val array_dimensions : arrayinfo -> c_object * int64 option list (** Returns the list of dimensions the array consists of. None-dimension means undefined one. *) val dimension_of_object : c_object -> (int * int64) option (** Returns None for 1-dimension objects, and Some(d,N) for d-matrix with N cells *) 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 merge : c_object -> c_object -> c_object 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 frama-c-Fluorine-20130601/src/wp/wp_parameters.ml0000644000175000017500000005140412155630215020421 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 STRING = String let () = Plugin.is_share_visible () include Plugin.Register (struct let name = "WP" let shortname = "wp" let help = "Weakest Preconditions Calculus\n\ WP 0.7 for " ^ Config.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 Log = StringSet (struct let option_name = "-wp-log" let arg_name = "..." let help = "Log Specific informations" end) let has_dkey k = Datatype.String.Set.mem k (Log.get()) || Datatype.String.Set.mem k (Debug_category.get()) (* ------------------------------------------------------------------------ *) (* --- 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 = "Generates proof obligations for all (selected) properties." 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 = "selects properties of given functions (defaults to all functions)" end) let () = on_reset Functions.clear let () = Plugin.set_group wp_generation let () = Plugin.do_not_save () module SkipFunctions = StringList (struct let option_name = "-wp-skip-fct" let arg_name = "f,..." let help = "skip the specified functions (defaults to none)" end) let () = on_reset SkipFunctions.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 = "selects properties of the given behaviors (defaults to all behaviors) of the selected functions." end) let () = on_reset Behaviors.clear let () = Plugin.set_group wp_generation let () = Plugin.do_not_save () module Properties = StringList (struct let option_name = "-wp-prop" let arg_name = "p,..." let help = "selects properties having the one of the given tagnames (defaults to all properties).\n\ You may also replace the tagname by '@category' for the selection of all properties of the given category.\n\ Accepted categories are: lemmas, requires, assigns, ensures, exits, complete_behaviors, disjoint_behaviors assert, invariant, variant, breaks, continues, returns.\n\ Starts by a minus character to remove properties from the selection." end) let () = on_reset Properties.clear type job = | WP_None | WP_All | WP_SkipFct of string list | WP_Fct of string list let job () = let nonempty p = p () <> [] in if WP.get () || nonempty Functions.get || nonempty Behaviors.get || nonempty Properties.get then let fct = Functions.get () in let skp = SkipFunctions.get () in match fct , skp with | [] , [] -> WP_All | _ , [] -> WP_Fct fct | [] , _ -> WP_SkipFct skp | _ , _ -> WP_Fct (List.filter (fun f -> not (List.mem f skp)) fct) else WP_None 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)" 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)" 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)" 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)" end) (* ------------------------------------------------------------------------ *) (* --- Froms --- *) (* ------------------------------------------------------------------------ *) let () = Plugin.set_group wp_generation module Froms = False(struct let option_name = "-wp-froms" let help = "Undocumented (dot not use)." end) (* ------------------------------------------------------------------------ *) (* --- Memory Models --- *) (* ------------------------------------------------------------------------ *) let wp_model = add_group "Model Selection" let () = Plugin.set_group wp_model module Model = StringList (struct let option_name = "-wp-model" let arg_name = "model+..." let help = "Memory model selection. Available selectors:\n \ * 'Hoare' logic variables only\n \ * 'Typed' typed pointers only\n \ * '+nocast' no pointer cast\n \ * '+cast' unsafe pointer casts\n \ * '+raw' no logic variable\n \ * '+ref' by-reference-style pointers detection\n \ * '+nat/+cint' natural or machine integers arithmetics\n \ * '+real/+float' real or IEEE floatting point arithmetics" end) let () = Plugin.set_group wp_model module ExternArrays = False(struct let option_name = "-wp-extern-arrays" let help = "Put some default size for extern arrays" end) let () = Plugin.set_group wp_model module ExtEqual = False(struct let option_name = "-wp-extensional" let help = "Use extensional equality on compounds (hypotheses only)" end) let () = Plugin.set_group wp_model module Literals = False(struct let option_name = "-wp-literals" let help = "Export content of string literals (not by default)" end) (* ------------------------------------------------------------------------ *) (* --- 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" end) let () = Plugin.set_group wp_strategy module Simpl = True(struct let option_name = "-wp-simpl" let help = "Simplify constant terms and predicates." end) let () = Plugin.set_group wp_strategy module Let = True(struct let option_name = "-wp-let" let help = "Use variable elimination (by default)." end) let () = Plugin.set_group wp_strategy module Prune = True(struct let option_name = "-wp-pruning" let help = "Prune trivial branches (by default)." end) let () = Plugin.set_group wp_strategy module Clean = True(struct let option_name = "-wp-clean" let help = "Use variable filtering (by default)." end) let () = Plugin.set_group wp_strategy module Invariants = False(struct let option_name = "-wp-invariants" let help = "Handle generalized invariants inside loops." end) let () = Plugin.set_group wp_strategy module Split = False(struct let option_name = "-wp-split" let help = "Split conjunctions into sub-goals." end) (* ------------------------------------------------------------------------ *) (* --- Prover Interface --- *) (* ------------------------------------------------------------------------ *) let wp_prover = add_group "Prover Interface" let () = Plugin.set_group wp_prover module Provers = StringList (struct let option_name = "-wp-prover" let arg_name = "dp,..." let help = "Submit proof obligations to external prover(s):\n\ - 'none' to skip provers\n\ Directly supported provers:\n\ - 'alt-ergo' (default)\n\ - 'altgr-ergo' (gui)\n\ - 'coq', 'coqide' (see also -wp-script)\n\ - 'why3:' or '' (why3 prover, see -wp-detect)\n\ - 'why3ide' (why3 gui)" end) let () = Provers.add_aliases [ "-wp-proof" ] (* Deprecated *) let () = Plugin.set_group wp_prover module Generate = False (struct let option_name = "-wp-gen" let help = "Only generate prover files (default: no)." end) let () = on_reset Generate.clear let () = Plugin.set_group wp_prover module Detect = Action (struct let option_name = "-wp-detect" let help = "List installed provers." end) let () = on_reset Detect.clear let () = Plugin.set_group wp_prover module Drivers = StringList (struct let option_name = "-wp-driver" let arg_name = "file,..." let help = "Load drivers for linking to external libraries" end) let () = Plugin.set_group wp_prover module Depth = Int(struct let option_name = "-wp-depth" let default = 0 let arg_name = "p" let help = "Set depth of exploration for provers." end) let () = Plugin.set_group wp_prover module Steps = Int(struct let option_name = "-wp-steps" let default = 0 let arg_name = "n" let help = "Set number of steps for provers." 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 end) let () = Plugin.set_group wp_prover module CoqTimeout = Int(struct let option_name = "-wp-coq-timeout" let default = 30 let arg_name = "n" let help = Printf.sprintf "Set the timeout (in seconds) for Coq (default: %d)." default 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 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)" end) let () = Plugin.set_group wp_prover module UnsatModel = False (struct let option_name = "-wp-unsat-model" let help = "Keeps output of provers for unknown POs (default: no)" end) (* ------------------------------------------------------------------------ *) (* --- Prover Libraries --- *) (* ------------------------------------------------------------------------ *) let wp_proverlibs = add_group "Prover Libraries" let () = Plugin.set_group wp_proverlibs module Script = String(struct let option_name = "-wp-script" let arg_name = "f.script" let default = "" let help = "Set user's file for Coq proofs." end) let () = Plugin.set_group wp_proverlibs module UpdateScript = True(struct let option_name = "-wp-update-script" let help = "If turned off, do not save or modify user's proofs." end) let () = Plugin.set_group wp_proverlibs module CoqTactic = String (struct let option_name = "-wp-tactic" let arg_name = "proof" let default = "auto with zarith" let help = "Default tactic for Coq" end) let () = Plugin.set_group wp_proverlibs module TryHints = False (struct let option_name = "-wp-tryhints" let help = "Try scripts from other goals (see also -wp-hints)" end) let () = Plugin.set_group wp_proverlibs module Hints = Int (struct let option_name = "-wp-hints" let arg_name = "n" let default = 3 let help = "Maximum number of proposed Coq scripts (default 3)" end) let () = Plugin.set_group wp_proverlibs module Includes = StringList (struct let option_name = "-wp-include" let arg_name = "dir,..." let help = "Directory where to find extensions for provers" end) let () = Plugin.set_group wp_proverlibs module CoqLibs = StringList (struct let option_name = "-wp-coq-lib" let arg_name = "*.v,*.vo" let help = "Additional libraries for Coq." end) let () = Plugin.set_group wp_proverlibs module WhyLibs = StringList (struct let option_name = "-wp-why-lib" let arg_name = "*.why" let help = "Additional libraries for Why" end) let () = Plugin.set_group wp_proverlibs module WhyFlags = StringList (struct let option_name = "-wp-why-opt" let arg_name = "option,..." let help = "Additional options for Why3" end) let () = Plugin.set_group wp_proverlibs module AltErgoLibs = StringList (struct let option_name = "-wp-alt-ergo-lib" let arg_name = "*.mlw" let help = "Additional library file for Alt-Ergo" end) let () = Plugin.set_group wp_proverlibs module AltErgoFlags = StringList (struct let option_name = "-wp-alt-ergo-opt" let arg_name = "option,..." let help = "Additional options for Alt-Ergo" end) let () = Plugin.set_group wp_proverlibs module AltErgoLightInt = False (struct let option_name = "-wp-alt-ergo-lightint" let help = "Use lightweight machine integer library for Alt-Ergo" 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." end) let () = on_reset Print.clear let () = Plugin.set_group wp_po let () = Plugin.do_not_save () module Report = StringList(struct let option_name = "-wp-report" let arg_name = "report,..." let help = "Report specification file(s)" end) let () = Plugin.set_group wp_po let () = Plugin.do_not_save () module ReportName = String(struct let option_name = "-wp-report-basename" let arg_name = "file" let default = "wp-report" let help = Printf.sprintf "Basename of generated reports (default %S)" default end) 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." end) let () = Plugin.set_group wp_po let () = Plugin.do_not_save () module Check = Action(struct let option_name = "-wp-check" let help = "check the syntax and type of the produced file against \n\ alt-ergo, why3 and coq when the environnement variable WPCHECK=YES." end) let () = on_reset Print.clear let wpcheck () = Check.get () && try Sys.getenv "WPCHECK" = "YES" with Not_found -> false (* -------------------------------------------------------------------------- *) (* --- OS environment variables --- *) (* -------------------------------------------------------------------------- *) let dkey = register_category "env" let get_env ?default var = try let varval = Sys.getenv var in debug ~dkey "ENV %s=%S" var varval ; varval with Not_found -> debug ~dkey "ENV %s not set." var ; match default with | Some varval -> debug ~dkey "ENV %s default(%S)" var varval ; varval | None -> debug ~dkey "ENV %s undefined." var ; raise Not_found let dkey = register_category "out" let is_out () = !Config.is_gui || OutputDir.get() <> "" 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 ; end else begin try Unix.mkdir dir 0o770 ; debug ~dkey "Created output directory '%s'" dir with e -> debug ~dkey "System error '%s'" (Printexc.to_string e) ; abort "Can not create output directory '%s'" dir end (*[LC] Do not projectify this reference : it is common to all projects *) let unique_tmp = ref None let make_tmp_dir () = match !unique_tmp with | None -> let tmp = try Extlib.temp_dir_cleanup_at_exit "wp" with Extlib.Temp_file_error s -> abort "cannot create temporary file: %s" s in unique_tmp := Some tmp ; tmp | Some tmp -> tmp let make_gui_dir () = try let home = try Sys.getenv "USERPROFILE" (*Win32*) with Not_found -> try Sys.getenv "HOME" (*Unix like*) with Not_found -> "." in let dir = Filename.concat home ".frama-c-wp" in if Sys.file_exists dir && Sys.is_directory dir then Extlib.safe_remove_dir dir; make_output_dir dir ; dir with _ -> make_tmp_dir () (** call the construction of the directory only once *) let base_output = ref None let base_output () = match !base_output with | None -> let output = match OutputDir.get () with | "" -> if !Config.is_gui then make_gui_dir () else make_tmp_dir () | dir -> make_output_dir dir ; dir in base_output := Some output; output | Some output -> output let get_output () = let base = base_output () in let project = Project.current () in let name = Project.get_unique_name project in if name = "default" then base else let dir = Filename.concat base name in make_output_dir dir ; dir let get_output_dir d = let base = get_output () in let path = Printf.sprintf "%s/%s" base d in make_output_dir path ; path let dkey = register_category "includes" let find_db = ref false let find_lib file = if Sys.file_exists file then file else let rec lookup file = function | [] -> abort "File '%s' not found (see -wp-include)" file | dir::dirs -> let path = Printf.sprintf "%s/%s" dir file in if Sys.file_exists path then path else lookup file dirs in let includes = List.map (fun d -> if STRING.get d 0 = '+' then Printf.sprintf "%s/%s" (Kernel.Share.dir ()) (STRING.sub d 1 (STRING.length d - 1)) else d) (Includes.get ()) in let shared = try [Share.dir ~error:false ()] with Share.No_dir -> [] in let drivers = List.map Filename.dirname (Drivers.get ()) in let directories = includes @ drivers @ shared in if not !find_db && has_dkey "includes" then begin find_db := true ; debug ~dkey "Included directories:%t" (fun fmt -> List.iter (fun d -> Format.fprintf fmt "@\n - '%s'" d) directories ) end ; lookup file directories frama-c-Fluorine-20130601/src/wp/cil2cfg.ml0000644000175000017500000013753412155630215017072 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 = Wp_parameters.register_category "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 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 : node_id = 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 "" | VfctIn -> Format.fprintf fmt "" | VfctOut -> Format.fprintf fmt "" | Vend -> Format.fprintf fmt "" | Vexit -> Format.fprintf fmt "" | VblkIn (bk,_) -> Format.fprintf fmt "" pp_bkind bk | VblkOut (bk,_) -> Format.fprintf fmt "" pp_bkind bk | Vcall (s, _, _, _) -> Format.fprintf fmt "" s.sid | Vstmt s -> Format.fprintf fmt "" s.sid | Vtest (b, s, _) -> Format.fprintf fmt "" (if b then "In" else "Out") s.sid | Vswitch (s,_) -> Format.fprintf fmt "" s.sid | Vloop (_, s) -> Format.fprintf fmt "" s.sid | Vloop2 (_, n) -> Format.fprintf fmt "" 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 (a,b) = (node_id v) in a*17 + b let equal v v' = same_node v v' let compare v v' = Extlib.compare_basic (node_id v) (node_id v') 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:", " Printer.pp_exp) l | Enext -> "(next)" in Format.fprintf fmt "%s" txt end (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (** {2 Graph} *) module PMAP(X: Graph.Sig.COMPARABLE) = struct module M = Map.Make(X) type 'a t = 'a M.t ref type key = X.t type 'a return = unit let empty = () (* never called and not visible for the user thanks to signature constraints *) let create ?size () = ignore size ; ref M.empty let create_from h = ignore h ; ref M.empty let is_empty h = M.is_empty !h let clear h = h := M.empty let add k v h = h := M.add k v !h ; h let remove k h = h := M.remove k !h ; h let find k h = M.find k !h let mem k h = M.mem k !h let find_and_raise k t s = try find k t with Not_found -> invalid_arg s let fold f h init = M.fold f !h init let map f h = ref (M.fold (fun k v m -> let (k,v) = f k v in M.add k v m) !h M.empty) let iter f h = M.iter f !h let copy h = ref !h end (** the CFG is an ocamlgraph, but be careful to use it through the cfg function * because some edges don't have the same meaning as some others... *) module MyGraph = Graph.Blocks.Make(PMAP) module CFG: Graph.Sig.I with type V.t = VL.t and type V.label = VL.t and type E.t = VL.t * EL.t * VL.t and type E.label = EL.t = struct include MyGraph.Digraph.ConcreteBidirectionalLabeled(VL)(EL) let add_vertex g v = ignore (add_vertex g v) let add_edge g v1 v2 = ignore (add_edge g v1 v2) let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) let remove_edge_e g e = ignore (remove_edge_e g e) let add_edge_e g e = ignore (add_edge_e g e) let remove_vertex g v = if HM.mem v g then begin ignore (HM.remove v g); let remove v = S.filter (fun (v2,_) -> not (V.equal v v2)) in HM.iter (fun k (s1, s2) -> ignore (HM.add k (remove v s1, remove v s2) g)) g end end (** 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 *) type t = { kernel_function : kernel_function; graph : CFG.t; spec_only : bool; stmt_node : ((int*int), CFG.V.t) Hashtbl.t; 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; 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 is_back_edge e = match (edge_type e) with | Eback | EbackThen | EbackElse -> true | Enone | Ethen | Eelse | Ecase _ | Enext -> false let is_next_edge e = match (edge_type e) with | Enext -> true | Eback | EbackThen | EbackElse | Enone | Ethen | Eelse | Ecase _ -> false let pred_e cfg n = try let edges = CFG.pred_e cfg.graph n in List.filter (fun e -> not (is_next_edge e)) 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 -> not (is_next_edge e)) edges with Invalid_argument _ -> (Wp_parameters.warning "[cfg.succ_e] pb with node %a" pp_node n; []) 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 = if is_next_edge e then () else f e in CFG.iter_edges_e f (cfg.graph) let iter_succ f cfg n = let f e = if is_next_edge e then () else 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 = if is_next_edge e then acc else 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 = if is_next_edge e then acc else f (CFG.E.src e) acc in try CFG.fold_pred_e f (cfg.graph) n acc with Invalid_argument s -> (Wp_parameters.warning "[cfg.fold_pred] pb with node %a: %s" pp_node n s; acc) let _iter_succ_e f cfg n = let f e = if is_next_edge e then () else 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 = if is_next_edge e then () else 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 = if is_next_edge e then acc else 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 = if is_next_edge e then acc else 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 is_next_edge 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 is_next_edge 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 = debug "[get_exit_edges] look at %a@." pp_node n; 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 match node_type n with | Vstart -> (* In it is a problem a domination which is not solved here *) Wp_parameters.warning "[cfg] Forget exits clause of node %a" pp_node src; raise Exit | _ -> fold_succ_e add_exit cfg n acc in let rec do_node_and_preds n (seen, edges as acc) = if Nset.mem n seen then acc (* Don't loop over the same node. *) else begin let edges = do_node n edges in if CFG.V.compare src n = 0 then (seen, edges) else do_preds n (Nset.add n seen, edges) end and do_preds n acc = fold_pred do_node_and_preds cfg n acc in let edges = try let edge = next_edge cfg src in if false || is_next_edge edge then (* needs to look at all node between the next node and the source *) snd (do_preds (edge_dst edge) (Nset.empty, [])) else do_node src [] with Exit -> [] 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 = debug "[blocks_closed_by_edge] for %a...@." pp_edge 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,_) -> ignore (Ast.get ()); (* Since CIL Cfg computation is required and Ast.get () have to do this well. *) begin match s.succs with | [s'] -> (try Kernel_function.blocks_closed_by_edge s s' with Not_found as e -> debug "[blocks_closed_by_edge] not found sid:%d -> sid:%d@." s.sid s'.sid; raise e) | [] | _ :: _ -> 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; try Kernel_function.blocks_closed_by_edge s s' with Invalid_argument _ -> [] 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 = ((int*int), 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 n; let n = CFG.V.create n in Hashtbl.add env.stmt_node id n; n let change_node_kind env n t = let id = node_id n in let id' = node_type_id t in let n' = { n with kind = t } in debug "change node kind from %a to %a" VL.pretty n VL.pretty n'; let n' = CFG.V.create n' in Hashtbl.remove env.stmt_node id; Hashtbl.add env.stmt_node id' n'; let preds = CFG.fold_pred_e (fun e acc -> e::acc) env.graph n [] in let succs = CFG.fold_succ_e (fun e acc -> e::acc) env.graph n [] in CFG.remove_vertex env.graph n; List.iter (fun e -> let e' = CFG.E.create (CFG.E.src e) (CFG.E.label e) n' in debug "replace edge %a %a %a" VL.pretty (CFG.E.src e) EL.pretty !(CFG.E.label e) VL.pretty n'; CFG.add_edge_e env.graph e') preds; List.iter (fun e -> let e' = CFG.E.create n' (CFG.E.label e) (CFG.E.dst e) in debug "replace edge %a %a %a" VL.pretty n' EL.pretty !(CFG.E.label e) VL.pretty (CFG.E.dst e) ; CFG.add_edge_e env.graph e') succs; 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 (** Setup the preconditions at all the call points of [e_kf], when possible *) let setup_preconditions_proxies e_kf = match e_kf.enode with | Lval (Var vkf, NoOffset) -> let kf = Globals.Functions.get vkf in Statuses_by_call.setup_all_preconditions_proxies kf | _ -> () (* call through function pointer *) (** 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 (_, f, _, _)) -> setup_preconditions_proxies f; 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 *) 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 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); change_node_kind cfg h (Vloop (Some is_natural, h_stmt)) | _ -> 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" Printer.pp_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 Printer.pp_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 ) () (* ------------------------------------------------------------------------ *) (** {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; !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; 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 size = 17 end) let get kf = KfCfg.memo create kf (* ------------------------------------------------------------------------ *) frama-c-Fluorine-20130601/src/wp/Region.ml0000644000175000017500000002242712155630215016776 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Path and Regions --- *) (* -------------------------------------------------------------------------- *) open Qed.Logic open Lang open Lang.F open Vset type path = offset list and offset = | Oindex of term | Ofield of field let rec access e = function | [] -> e | Oindex k :: path -> access (e_get e k) path | Ofield f :: path -> access (e_getfield e f) path let rec update e path v = match path with | [] -> v | Oindex k :: tail -> let e_k = update (e_get e k) tail v in e_set e k e_k | Ofield f :: tail -> let e_f = update (e_getfield e f) tail v in e_setfield e f e_f (* -------------------------------------------------------------------------- *) (* --- Region --- *) (* -------------------------------------------------------------------------- *) type rpath = roffset list and roffset = | Rindex of set | Rfield of field type region = | Empty | Full | Fields of (field * region) list (* SORTED, DEFAULT : empty *) | Indices of set * ( set * region ) list (* Indices for FULL region. Then indices for non-FULL and non-EMPTY regions *) let empty = Empty let full = Full let rec path = function | [] -> Full | Oindex k :: tail -> let r = path tail in let s = Vset.singleton k in begin match r with (* never Empty *) | Full -> Indices(s,[]) | _ -> Indices(Vset.empty,[s,r]) end | Ofield f :: tail -> Fields [f,path tail] let rec rpath = function | [] -> Full | Rindex s :: tail -> let r = rpath tail in begin match r with (* never Empty *) | Full -> Indices(s,[]) | _ -> Indices(Vset.empty,[s,r]) end | Rfield f :: tail -> Fields [f,rpath tail] let rec merge a b = match a , b with | Full , _ | _ , Full -> Full | Empty , c | c , Empty -> c | Fields fxs , Fields gys -> Fields (merge_fields fxs gys) | Indices(s1,kxs) , Indices(s2,kys) -> Indices(Vset.union s1 s2,kxs @ kys) | Fields _ , Indices _ | Indices _ , Fields _ -> assert false and merge_fields fxs gys = match fxs , gys with | [] , w | w , [] -> w | (f,x)::fxstail , (g,y)::gystail -> let c = Field.compare f g in if c < 0 then (f,x)::merge_fields fxstail gys else if c > 0 then (g,y)::merge_fields fxs gystail else (f,merge x y) :: merge_fields fxstail gystail (* -------------------------------------------------------------------------- *) (* --- Disjonction --- *) (* -------------------------------------------------------------------------- *) let rec disjoint a b = match a , b with | Empty , _ | _ , Empty -> p_true | Full , _ | _ , Full -> p_false | Fields fxs , Fields gys -> p_conj (disjoint_fields fxs gys) | Indices(s,xs) , Indices(t,ts) -> p_conj (disjoint_indices [Vset.disjoint s t] xs ts) | Fields _ , Indices _ | Indices _ , Fields _ -> assert false and disjoint_fields frs grs = match frs , grs with | [] , _ | _ , [] -> [] | (f,r)::ftail , (g,s)::gtail -> let c = Field.compare f g in if c < 0 then disjoint_fields ftail grs else if c > 0 then disjoint_fields frs gtail else disjoint r s :: disjoint_fields ftail gtail and disjoint_indices w sr1 sr2 = List.fold_left (fun w (s1,r1) -> List.fold_left (fun w (s2,r2) -> (p_or (Vset.disjoint s1 s2) (disjoint r1 r2)) :: w ) w sr2 ) w sr1 (* -------------------------------------------------------------------------- *) (* --- Region Inclusion --- *) (* -------------------------------------------------------------------------- *) let rec subset r1 r2 = match r1 , r2 with | _ , Full -> p_true | Empty , _ -> p_true | _ , Empty -> p_false | Full , _ -> p_false | Fields frs , Fields grs -> subset_fields frs grs | Indices(s1,ks1) , Indices(s2,ks2) -> p_and (Vset.subset s1 s2) (* because FULL never appears in ks2 *) (p_all (fun (s1,r1) -> subset_indices s1 r1 ks2) ks1) | Fields _ , Indices _ | Indices _ , Fields _ -> assert false and subset_fields frs grs = match frs , grs with | [] , _ -> p_true | _ , [] -> p_false | (f,r)::ftail , (g,s)::gtail -> let c = Field.compare f g in if c < 0 then p_false (* only f is present *) else if c > 0 then subset_fields frs gtail (* g is not present *) else (* f=g *) p_and (subset r s) (subset_fields ftail gtail) (* All path (k,p) in (s1,r1) are in ks2 = AND (k in s1 -> p in r1 -> (k,p) in ks2 = AND (k in s1 -> p in r1 -> (OR (k in s2 and p in r2) for (s2,r2) in r2) = AND (k in s1 -> OR (k in s2 and r1 in r2) for (s2,r2) in r2) = AND (k in s1 -> subset_index k r1 ks2) *) and subset_indices s1 r1 ks2 = p_all (fun w -> let xs,e,p = Vset.descr w in p_forall xs (p_imply p (subset_index e r1 ks2)) ) s1 (* OR (k in s2 and r1 in r2) for (s2,r2) in r2) *) and subset_index e r1 ks2 = p_any (fun (s2,r2) -> p_and (Vset.member e s2) (subset r1 r2) ) ks2 (* -------------------------------------------------------------------------- *) (* --- Equality outside a Region --- *) (* -------------------------------------------------------------------------- *) let rec equal_but t r a b = match t , r with | _ , Full -> p_true | _ , Empty -> p_equal a b | _ , Fields grs -> let fs = List.sort Field.compare (fields_of_tau t) in p_conj (equal_but_fields a b fs grs) | Array(ta,tb) , Indices(s,krs) -> let x = freshvar ta in let k = e_var x in let a_k = e_get a k in let b_k = e_get b k in p_forall [x] (p_conj (equal_but_index tb k a_k b_k s krs)) | _ -> assert false and equal_but_fields a b fts grs = match fts , grs with | [] , _ -> [] | _ , [] -> List.map (fun f -> p_equal (e_getfield a f) (e_getfield b f)) fts | f::ftail , (g,r)::gtail -> let c = Field.compare f g in if c < 0 then let eqf = p_equal (e_getfield a f) (e_getfield b f) in eqf :: equal_but_fields a b ftail grs else if c > 0 then (* field g does not appear *) equal_but_fields a b fts gtail else let tf = tau_of_field f in let eqf = equal_but tf r (e_getfield a f) (e_getfield b f) in eqf :: equal_but_fields a b ftail gtail and equal_but_index tb k a_k b_k s krs = List.map (fun (s,r) -> p_or (Vset.member k s) (equal_but tb r a_k b_k)) ((s,Full)::krs) (* -------------------------------------------------------------------------- *) (* --- Utils --- *) (* -------------------------------------------------------------------------- *) let rec occurs x = function | Empty | Full -> false | Fields frs -> List.exists (fun (_,r) -> occurs x r) frs | Indices(s,srs) -> Vset.occurs x s || List.exists (occurs_idx x) srs and occurs_idx x (s,r) = Vset.occurs x s || occurs x r let rec vars = function | Empty | Full -> Vars.empty | Fields frs -> List.fold_left (fun xs (_,r) -> Vars.union xs (vars r)) Vars.empty frs | Indices(s,srs) -> List.fold_left (fun xs (s,r) -> Vars.union xs (Vars.union (Vset.vars s) (vars r))) (Vset.vars s) srs (* -------------------------------------------------------------------------- *) (* --- Pretty --- *) (* -------------------------------------------------------------------------- *) let pretty fmt = function | Empty -> Format.fprintf fmt "empty" | Full -> Format.fprintf fmt "full" | Fields _ -> Format.fprintf fmt "fields" (*TODO*) | Indices _ -> Format.fprintf fmt "indices" (*TODO*) frama-c-Fluorine-20130601/src/wp/variables_analysis.mli0000644000175000017500000000777212155630215021605 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 frama-c-Fluorine-20130601/src/wp/wp_parameters.mli0000644000175000017500000000714112155630215020571 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 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_SkipFct of string list | WP_Fct of string list val job : unit -> job (** {2 Model Selection} *) val has_dkey : string -> bool module Model : Plugin.String_list module ExternArrays: Plugin.Bool module ExtEqual : Plugin.Bool module Literals : Plugin.Bool (** {2 Computation Strategies} *) module RTE: Plugin.Bool module Simpl: Plugin.Bool module Let: Plugin.Bool module Prune: Plugin.Bool module Clean: Plugin.Bool module Split: Plugin.Bool module Invariants: Plugin.Bool (** {2 Prover Interface} *) module Detect: Plugin.Bool module Generate:Plugin.Bool module Provers: Plugin.String_list module Drivers: Plugin.String_list module Includes: Plugin.String_list module Script: Plugin.String module UpdateScript: Plugin.Bool module Timeout: Plugin.Int module CoqTimeout: Plugin.Int module Depth: Plugin.Int module Steps: Plugin.Int module Procs: Plugin.Int module ProofTrace: Plugin.Bool module UnsatModel: Plugin.Bool module CoqLibs: Plugin.String_list module CoqTactic: Plugin.String module Hints: Plugin.Int module TryHints: Plugin.Bool module WhyLibs: Plugin.String_list module WhyFlags: Plugin.String_list module AltErgoLibs: Plugin.String_list module AltErgoLightInt: Plugin.Bool module AltErgoFlags: Plugin.String_list (** {2 Proof Obligations} *) module Print: Plugin.Bool module Report: Plugin.String_list module ReportName: Plugin.String module Check: Plugin.Bool val wpcheck: unit -> bool (** {2 Experimental} *) module Froms: Plugin.Bool (** {2 Environment Variables} *) val get_env : ?default:string -> string -> string val is_out : unit -> bool (* -wp-out

    positionned *) val get_output : unit -> string val get_output_dir : string -> string val find_lib : string -> string frama-c-Fluorine-20130601/src/wp/VarUsage.mli0000644000175000017500000000466512155630215017445 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** Usage Variable Analysis *) open Cil_types exception NoSize val degree_of_type : typ -> int (** Dimensions in the type (0 for non-array) *) val alloc_for_type : typ -> int list (** Size of dimensions in the type (0 for unknown size) *) val cells_in_type : typ -> Integer.t (** Number of cells in the type (raise NoSize for unknown size) *) val type_of_cells : typ -> typ (** Type of multi-dimensional array cells *) type usage = | NotUsed | ByValue | ByAddress | ByReference | ByArray of int list (** Dimension *) | ByRefArray of int list (** Dimension *) val compute : unit -> unit val of_cvar : varinfo -> usage val of_formal : varinfo -> usage val of_lvar : logic_var -> usage val validated_lvar : logic_var -> bool val validated_cvar : varinfo -> bool val dump : unit -> unit val pretty : name:string -> Format.formatter -> usage -> unit frama-c-Fluorine-20130601/src/wp/Factory.mli0000644000175000017500000000422512155630215017327 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Factory --- *) (* -------------------------------------------------------------------------- *) type mheap = Hoare | Typed of MemTyped.pointer type mvar = Raw | Var | Ref type setup = { mvar : mvar ; mheap : mheap ; cint : Cint.model ; cfloat : Cfloat.model ; } val id : setup -> string val descr : setup -> string val model : setup -> Model.t val computer : setup -> Generator.computer val parse : string list -> setup frama-c-Fluorine-20130601/src/wp/rformat.mli0000644000175000017500000000422512155630215017372 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 val epsilon : float val get_time : float array -> float -> int (** [get_time T t] returns [k] such that [T[k-1] <= t <= T[k]], [T] is extended with [T[-1]=0] and [T[N]=+oo]. *) val pp_time : formatter -> float -> unit (** Pretty print time in hour, minutes, seconds, or milliseconds, as appropriate *) val pp_time_range : float array -> formatter -> float -> unit type command = | CMD of string | ARG of string * string | TEXT val command : string -> command val pretty : (formatter -> string -> string -> unit) -> formatter -> string -> unit frama-c-Fluorine-20130601/src/wp/cfgDump.ml0000644000175000017500000002077212155630215017141 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 = "cfgdump" (* debugging key *) module VC = struct let fc = ref None let out = ref Format.std_formatter let knode = ref 0 let node () = incr knode ; !knode let init kf bhv = begin let name = match bhv with | None -> Kernel_function.get_name kf | Some bname -> Kernel_function.get_name kf ^ "_" ^ bname in let file = Filename.concat (Wp_parameters.get_output ()) name in Wp_parameters.feedback "CFG %a -> %s@." Kernel_function.pretty kf name ; let fout = open_out (file ^ ".dot") in fc := Some (fout,file) ; out := Format.formatter_of_out_channel fout ; Format.fprintf !out "digraph %a {@\n" Kernel_function.pretty kf ; Format.fprintf !out " rankdir = TB ;@\n" ; Format.fprintf !out " node [ style = filled, shape = box ] ;@\n" ; Format.fprintf !out " N000 [ color = red, shape = circle, label = \"*\" ] ;@\n" ; end let flush () = begin Format.fprintf !out "}@." ; out := Format.std_formatter ; match !fc with | None -> () | Some (fout,file) -> close_out fout ; ignore (Sys.command (Printf.sprintf "dot -Tpdf %s.dot > %s.pdf" file file)) end (* -------------------------------------------------------------------------- *) (* --- MCFG Interface --- *) (* -------------------------------------------------------------------------- *) type t_prop = int (* current node *) let pretty fmt k = Format.fprintf fmt "N%03d" k let link a b = if b =0 then Format.fprintf !out " %a -> %a [ style=dotted ];@." pretty a pretty b else Format.fprintf !out " %a -> %a ;@." pretty a pretty b let merge _env k1 k2 = if k1=0 then k2 else if k2=0 then k1 else let u = node () in Format.fprintf !out " %a [ label=\"\" , shape=circle ] ;@." pretty u ; link u k1 ; link u k2 ; u let empty = 0 type t_env = Kernel_function.t let new_env ?lvars kf : t_env = ignore lvars ; kf let add_axiom _p _l = () let add_hyp _env (pid,_) k = let u = node () in Format.fprintf !out " %a [ color=green , label=\"Assume %a\" ] ;@." pretty u WpPropId.pp_propid pid ; link u k ; u let add_goal env (pid,_) k = let u = node () in Format.fprintf !out " %a [ color=red , label=\"Prove %a\" ] ;@." pretty u WpPropId.pp_propid pid ; Format.fprintf !out " %a -> %a [ style=dotted ] ;@." pretty u pretty k ; merge env u k let add_assigns env (pid,_) k = let u = node () in Format.fprintf !out " %a [ color=red , label=\"Assigns %a\" ] ;@." pretty u WpPropId.pp_propid pid ; merge env u k let use_assigns _env _stmt region _ k = let u = node () in begin match region with | None -> Format.fprintf !out " %a [ color=orange , label=\"Havoc All\" ] ;@." pretty u | Some pid -> Format.fprintf !out " %a [ color=orange , label=\"Havoc %a\" ] ;@." pretty u WpPropId.pp_propid pid end ; link u k ; u let label _env label k = if label = Clabels.Here then k else let u = node () in Format.fprintf !out " %a [ label=\"Label %a\" ] ;@." pretty u Clabels.pretty label ; link u k ; u let assign _env _stmt x e k = let u = node () in Format.fprintf !out " %a [ color=orange , label=\"%a := %a\" ] ;@." pretty u Printer.pp_lval x Printer.pp_exp e ; link u k ; u let return _env _stmt r k = let u = node () in begin match r with | None -> Format.fprintf !out " %a [ color=orange , label=\"Return\" ] ;@." pretty u | Some e -> Format.fprintf !out " %a [ color=orange , label=\"Return %a\" ] ;@." pretty u Printer.pp_exp e end ; link u k ; u let test _env _stmt e k1 k2 = let u = node () in Format.fprintf !out " %a [ color=cyan , label=\"If %a\" ] ;@." pretty u Printer.pp_exp e ; link u k1 ; link u k2 ; u let switch _env _stmt e cases def = let u = node () in Format.fprintf !out " %a [ color=cyan , label=\"Switch %a\" ] ;@." pretty u Printer.pp_exp e ; List.iter (fun (_,k) -> link u k) cases ; link u def ; u let init_value _ _ _ _ k = k let init_range _ _ _ _ _ k = k let tag s k = let u = node () in Format.fprintf !out " %a [ color=cyan , label=\"Tag %s\" ] ;@." pretty u s ; link u k ; u let loop_entry w = tag "BeforeLoop" w let loop_step w = tag "InLoop" w let call_goal_precond env _stmt kf _es ~pre k = let u = node () in Format.fprintf !out " %a [ color=red , label=\"Prove PreCond %a\" ] ;@." pretty u Kernel_function.pretty kf ; ignore pre ; merge env u k let call _env _stmt _r kf _es ~pre ~post ~pexit ~assigns ~p_post ~p_exit = let u = node () in Format.fprintf !out " %a [ color=orange , label=\"Call %a\" ] ;@." pretty u Kernel_function.pretty kf ; ignore pre ; ignore post ; ignore pexit ; ignore assigns ; link u p_post ; link u p_exit ; u let pp_scope sc fmt xs = let title = match sc with | Mcfg.SC_Global -> "Global" | Mcfg.SC_Function_in -> "F-in" | Mcfg.SC_Function_frame -> "F-frame" | Mcfg.SC_Function_out -> "F-out" | Mcfg.SC_Block_in -> "B-in" | Mcfg.SC_Block_out -> "B-out" in begin Format.fprintf fmt "%s {" title ; List.iter (fun x -> Format.fprintf fmt " %a" Printer.pp_varinfo x) xs ; Format.fprintf fmt " }" ; end let scope _kfenv xs scope k = let u = node () in Format.fprintf !out " %a [ color=lightblue , label=\"%a\" ] ;@." pretty u (pp_scope scope) xs ; link u k ; u let close kfenv k = let u = node () in Format.fprintf !out " %a [ color=cyan , label=\"Function %a\" ] ;@." pretty u Kernel_function.pretty kfenv ; link u k ; u let build_prop_of_from _env _ps _k = 0 end module WP = Calculus.Cfg(VC) (* ------------------------------------------------------------------------ *) (* --- Proof Obilgation Generation --- *) (* ------------------------------------------------------------------------ *) class computer = object val mutable wptasks = [] method lemma = true method add_lemma (_ : LogicUsage.logic_lemma) = () method add_strategy strategy = wptasks <- strategy :: wptasks method compute : Wpo.t Bag.t = begin (* Generates Wpos and accumulate exported goals *) List.iter (fun strategy -> let cfg = WpStrategy.cfg_of_strategy strategy in let kf = Cil2cfg.cfg_kf cfg in let bhv = WpStrategy.behavior_name_of_strategy strategy in VC.init kf bhv ; try ignore (WP.compute cfg strategy) ; VC.flush () with err -> VC.flush () ; raise err ) wptasks ; wptasks <- [] ; Bag.empty end (* method compute *) end (* class computer *) let create () = (new computer :> Generator.computer) frama-c-Fluorine-20130601/src/wp/Cint.ml0000644000175000017500000002121512155630215016442 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Arithmetics Model --- *) (* -------------------------------------------------------------------------- *) open Qed open Qed.Logic open Lang open Lang.F (* -------------------------------------------------------------------------- *) (* --- Library Cint --- *) (* -------------------------------------------------------------------------- *) let theory = "cint" let make_fun_int op i = Lang.extern_f ~theory ~result:Logic.Sint "%s_%a" op Ctypes.pp_int i let make_pred_int op i = Lang.extern_f ~theory ~result:Logic.Sprop "%s_%a" op Ctypes.pp_int i (* let fun_int op = Ctypes.imemo (make_fun_int op) *) (* unused for now *) (* let pred_int op = Ctypes.imemo (make_pred_int op) *) (* unused for now *) (* is_ : int -> prop *) let p_is_int = Ctypes.imemo (fun iota -> let f = make_pred_int "is" iota in let simplify = function | [e] -> begin match F.repr e with | Logic.Kint k -> let vmin,vmax = Ctypes.c_int_bounds iota in F.e_bool (Z.leq vmin k && Z.lt k vmax) | Logic.If(p,b,c) -> F.e_if p (e_fun f [b]) (e_fun f [c]) | _ -> raise Not_found end | _ -> raise Not_found in F.add_builtin f simplify ; f) let f_to_int = Ctypes.imemo (fun iota -> let f = make_fun_int "to" iota in let simplify = function | [e] -> begin match F.repr e with | Logic.Kint value -> let vmin,vmax = Ctypes.c_int_bounds iota in let v = Z.cast_max ~max:vmax ~signed:(Z.lt vmin Z.zero) ~value in F.e_zint v | _ -> raise Not_found end | _ -> raise Not_found in F.add_builtin f simplify ; f) let f_of_real = extern_f ~theory:"qed" ~result:Logic.Sint "int_of_real" (* Signature int,int -> int over Z *) let result = Logic.Sint let ac = { associative = true ; commutative = true ; idempotent = false ; inversible = false ; neutral = E_none ; absorbant = E_none ; } (* -------------------------------------------------------------------------- *) (* --- Library Cbits --- *) (* -------------------------------------------------------------------------- *) let theory = "cbits" let balance = Lang.Left let op_lxor = { ac with neutral = E_int 0 ; inversible = true } let op_lor = { ac with neutral = E_int 0 ; absorbant = E_int (-1); idempotent = true } let op_land = { ac with neutral = E_int (-1); absorbant = E_int 0 ; idempotent = true } let f_lnot = Lang.extern_f ~theory ~result "lnot" let f_lor = Lang.extern_f ~theory ~result ~category:(Operator op_lor) ~balance "lor" let f_land = Lang.extern_f ~theory ~result ~category:(Operator op_land) ~balance "land" let f_lxor = Lang.extern_f ~theory ~result ~category:(Operator op_lxor) ~balance "lxor" let f_lsl = Lang.extern_f ~theory ~result "lsl" let f_lsr = Lang.extern_f ~theory ~result "lsr" (* -------------------------------------------------------------------------- *) (* --- Conversion Symbols --- *) (* -------------------------------------------------------------------------- *) let of_real i a = e_fun (f_to_int i) [e_fun f_of_real [a]] let irange i a = p_call (p_is_int i) [a] let iconvert i a = e_fun (f_to_int i) [a] let iconvert_unsigned i x = if Ctypes.signed i then x else iconvert i x type model = | Natural (** Integer arithmetics *) | Machine (** Modulo arithmetics *) let model = Context.create ~default:Natural "Cint.model" let ibinop f i x y = let z = f x y in match Context.get model with Natural -> z | Machine -> iconvert i z let iunop f i x = let z = f x in match Context.get model with Natural -> z | Machine -> iconvert i z (* -------------------------------------------------------------------------- *) (* --- Arithmetics --- *) (* -------------------------------------------------------------------------- *) (* C Code Semantics *) let iopp = iunop e_opp let iadd = ibinop e_add let isub = ibinop e_sub let imul = ibinop e_mul let idiv = ibinop e_div let imod = ibinop e_mod (* -------------------------------------------------------------------------- *) (* --- Bits --- *) (* -------------------------------------------------------------------------- *) let op1 f smp = let once = ref false in fun e -> begin if not !once then begin F.add_builtin f smp ; once := true ; end ; e_fun f [e] end let op2 f smp = let once = ref false in fun a b -> begin if not !once then begin F.add_builtin f smp ; once := true ; end ; e_fun f [a;b] end let smp1 zf = (* f(c1) ~> zf(c1) *) function | [e] -> begin match F.repr e with | Logic.Kint c1 -> e_zint (zf c1) | _ -> raise Not_found end | _ -> raise Not_found let smp2 f zf = (* f(c1,c2) ~> zf(c1,c2), f(c1,c2,...) ~> f(zf(c1,c2),...) *) function | e1::e2::others -> begin match (F.repr e1), (F.repr e2) with (* integers should be at the begining of the list *) | Logic.Kint c1, Logic.Kint c2 -> let z12 = ref (zf c1 c2) in let rec smp2 = function (* look at the other integers *) | [] -> [] | (e::r) as l -> begin match (F.repr e) with | Logic.Kint c -> z12 := zf !z12 c; smp2 r | _ -> l end in let others = smp2 others in let c12 = e_zint !z12 in if others = [] || F.is_absorbant f c12 then c12 else if F.is_neutral f c12 then match others with | [x] -> x | _ -> e_funraw f others else e_funraw f (c12::others) | _ -> raise Not_found end | _ -> raise Not_found let smp_shift zf = (* f(e1,0)~>e1, c2>0==>f(c1,c2)~>zf(c1,c2) *) function | [e1;e2] -> begin match (F.repr e1), (F.repr e2) with | _, Logic.Kint c2 when (Qed.Z.null c2) -> e1 | Logic.Kint c1, Logic.Kint c2 (* undefined when c2 is negative *) when (Qed.Z.positive c2) -> e_zint (zf c1 c2) | _ -> raise Not_found end | _ -> raise Not_found (* ACSL Semantics *) let l_not = op1 f_lnot (smp1 Qed.Z.bitwise_not) let l_xor = op2 f_lxor (smp2 f_lxor Qed.Z.bitwise_xor) let l_or = op2 f_lor (smp2 f_lor Qed.Z.bitwise_or) let l_and = op2 f_land (smp2 f_land Qed.Z.bitwise_and) (* shift as mult: (0<0 is invalid in ACSL when y is negative *) let l_lsl = op2 f_lsl (smp_shift Qed.Z.bitwise_shift_left) (* shift as div: (0>>y)~>0, (-1>>y)~>-1 are invalid in ACSL when y is negative *) let l_lsr = op2 f_lsr (smp_shift Qed.Z.bitwise_shift_right) (* C Code Semantics *) let bnot i x = iconvert_unsigned i (l_not x) let bxor i x y = iconvert_unsigned i (l_xor x y) let bor _i = l_or (* no needs of range conversion *) let band _i = l_and (* no needs of range conversion *) let blsl i x y = iconvert i (l_lsl x y) let blsr _i = l_lsr (* no needs of range conversion *) (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/cfgWP.ml0000644000175000017500000013341412155630215016560 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Calculus --- *) (* -------------------------------------------------------------------------- *) open LogicUsage open Cil_types open Cil_datatype open WpPropId open Clabels open Qed open Lang open Lang.F open Memory open Wpo module WpLog = Wp_parameters module VC( M : Memory.Model ) = struct open M module V = Vars module P = WpPropId.PropId module C = CodeSemantics.Make(M) module L = LogicSemantics.Make(M) module A = LogicAssigns.Make(M)(C)(L) type target = | Gprop of P.t | Geffect of P.t * Stmt.t * effect_source | Gposteffect of P.t module TARGET = struct type t = target let hsrc = function | FromCode -> 1 | FromCall -> 2 | FromReturn -> 3 let hash = function | Gprop p | Gposteffect p -> P.hash p | Geffect(p,s,e) -> P.hash p * 37 + 41 * Stmt.hash s + hsrc e let compare g1 g2 = if g1 == g2 then 0 else match g1,g2 with | Gprop p1 , Gprop p2 -> P.compare p1 p2 | Gprop _ , _ -> (-1) | _ , Gprop _ -> 1 | Geffect(p1,s1,e1) , Geffect(p2,s2,e2) -> let c = P.compare p1 p2 in if c <> 0 then c else let c = Stmt.compare s1 s2 in if c <> 0 then c else hsrc e1 - hsrc e2 | Geffect _ , _ -> (-1) | _ , Geffect _ -> 1 | Gposteffect p1 , Gposteffect p2 -> P.compare p1 p2 let equal g1 g2 = (compare g1 g2 = 0) let prop_id = function Gprop p | Gposteffect p | Geffect(p,_,_) -> p let source = function Gprop _ | Gposteffect _ -> None | Geffect(_,s,e) -> Some(s,e) let pretty fmt = function | Gprop p -> WpPropId.pretty fmt p | Geffect(p,s,FromCode) -> Format.fprintf fmt "%a at sid:%d" WpPropId.pretty p s.sid | Geffect(p,s,FromCall) -> Format.fprintf fmt "Call %a at sid:%d" WpPropId.pretty p s.sid | Geffect(p,s,FromReturn) -> Format.fprintf fmt "Return %a at sid:%d" WpPropId.pretty p s.sid | Gposteffect p -> Format.fprintf fmt "%a post-effect" WpPropId.pretty p end type effect = { e_pid : P.t ; (* Assign Property *) e_kind : a_kind ; (* Requires post effects (in case of loop-assigns) *) e_label : c_label ; (* scope for collection *) e_valid : L.sigma ; (* sigma where locations are filtered for validity *) e_region : A.region ; (* expected from spec *) e_warn : Warning.Set.t ; (* from translation *) } module EFFECT = struct type t = effect let compare e1 e2 = P.compare e1.e_pid e2.e_pid end module G = Qed.Collection.Make(TARGET) module W = Warning.Set module D = Property.Set module S = Stmt.Set module Eset = Set.Make(EFFECT) module Gset = G.Set module Gmap = G.Map type vc = { hyps : Conditions.bundle ; goal : F.pred ; vars : Vars.t ; (* the variables of effects/goal to collect *) warn : W.t ; deps : D.t ; path : S.t ; } (* -------------------------------------------------------------------------- *) (* --- MCFG Interface --- *) (* -------------------------------------------------------------------------- *) type t_env = { frame : L.frame ; main : L.env ; } type t_prop = { sigma : L.sigma option ; effects : Eset.t ; vcs : vc Splitter.t Gmap.t ; } (* -------------------------------------------------------------------------- *) (* --- MCFG Pretty --- *) (* -------------------------------------------------------------------------- *) let pp_vc fmt vc = Format.fprintf fmt "%a@ @[Prove %a@]" Conditions.dump vc.hyps F.pp_pred vc.goal let pp_vcs fmt vcs = let k = ref 0 in Splitter.iter (fun tags vc -> incr k ; begin match tags with | [] -> () | t::ts -> Format.fprintf fmt " (%a" Splitter.pretty t ; List.iter (fun t -> Format.fprintf fmt ",%a" Splitter.pretty t) ts ; Format.fprintf fmt ")@\n" ; end ; Format.fprintf fmt "@[ (%d) %a@]@\n" !k pp_vc vc) vcs let pp_gvcs fmt gvcs = Gmap.iter_sorted (fun goal vcs -> let n = Splitter.length vcs in Format.fprintf fmt "Goal %a: (%d)@\n" TARGET.pretty goal n ; pp_vcs fmt vcs ; ) gvcs let pretty fmt wp = begin (match wp.sigma with None -> () | Some s -> Format.fprintf fmt "Sigma:@[%a@]@\n" Sigma.pretty s) ; pp_gvcs fmt wp.vcs ; end (* -------------------------------------------------------------------------- *) (* --- Utilities --- *) (* -------------------------------------------------------------------------- *) let empty_vc = { hyps = Conditions.empty ; goal = p_true ; vars = V.empty ; warn = W.empty ; deps = D.empty ; path = S.empty ; } let sigma_opt = function None -> Sigma.create () | Some s -> s let sigma_at w = sigma_opt w.sigma let sigma_any w = match w.sigma with | None -> Sigma.create () | Some s -> Sigma.havoc_any s let sigma_union s1 s2 = match s1 , s2 with | None , s | s , None -> sigma_opt s , Passive.empty , Passive.empty | Some s1 , Some s2 -> Sigma.merge s1 s2 let merge_sigma s1 s2 = match s1 , s2 with | None , s | s , None -> s , Passive.empty , Passive.empty | Some s1 , Some s2 -> let s,p1,p2 = Sigma.merge s1 s2 in Some s,p1,p2 let join_with s = function None -> Passive.empty | Some s' -> Sigma.join s s' let occurs_vc vc x = Vars.mem x vc.vars || Conditions.occurs x vc.hyps let intersect_vc vc p = Vars.intersect (F.varsp p) vc.vars || Conditions.intersect p vc.hyps let assume_vc ~descr ?hpid ?stmt ?warn hs vc = if hs = [] && warn = None then vc else let path = match stmt with | None -> vc.path | Some s -> S.add s vc.path in let deps = match hpid with | None -> [] | Some p -> [WpPropId.property_of_id p] in let dset = List.fold_right D.add deps vc.deps in let wrns = match warn with | None -> vc.warn | Some w -> Warning.Set.union w vc.warn in { hyps = Conditions.assume ~descr ?stmt ?warn ~deps (F.p_conj hs) vc.hyps ; goal = vc.goal ; vars = vc.vars ; warn = wrns ; deps = dset ; path = path ; } let passify_vc pa vc = let hs = Passive.conditions pa (occurs_vc vc) in assume_vc ~descr:"Control Flow" hs vc (* -------------------------------------------------------------------------- *) (* --- Branching --- *) (* -------------------------------------------------------------------------- *) let branch_vc ~stmt cond vc1 vc2 = let hyps , goal = if F.eqp vc1.goal vc2.goal then begin Conditions.branch ~descr:"Conditional" ~stmt cond vc1.hyps vc2.hyps , vc1.goal end else let k = F.e_var (Lang.freshvar ~basename:"K" Logic.Bool) in let p = F.p_equal k F.e_true in let q = F.p_equal k F.e_false in let h1 = Conditions.assume ~descr:"Then Case" p vc1.hyps in let h2 = Conditions.assume ~descr:"Else Case" q vc2.hyps in (Conditions.branch ~descr:"Conditional" ~stmt cond h1 h2 , F.p_if p vc1.goal vc2.goal) in { hyps = hyps ; goal = goal ; vars = V.union vc1.vars vc2.vars ; deps = D.union vc1.deps vc2.deps ; warn = W.union vc1.warn vc2.warn ; path = S.union vc1.path vc2.path ; } (* -------------------------------------------------------------------------- *) (* --- Merging --- *) (* -------------------------------------------------------------------------- *) let merge_vc vc1 vc2 = let hyps , goal = if F.eqp vc1.goal vc2.goal then Conditions.merge [vc1.hyps;vc2.hyps] , vc1.goal else let k = F.e_var (Lang.freshvar ~basename:"K" Logic.Bool) in let p = F.p_equal k F.e_true in let q = F.p_equal k F.e_false in let h1 = Conditions.assume ~descr:"Case A" p vc1.hyps in let h2 = Conditions.assume ~descr:"Case B" q vc2.hyps in (Conditions.merge [h1 ; h2] , F.p_if p vc1.goal vc2.goal) in { hyps = hyps ; goal = goal ; vars = V.union vc1.vars vc2.vars ; deps = D.union vc1.deps vc2.deps ; warn = W.union vc1.warn vc2.warn ; path = S.union vc1.path vc2.path ; } let merge_vcs = function | [] -> empty_vc | [vc] -> vc | vcs -> let hyps = Conditions.merge (List.map (fun vc -> vc.hyps) vcs) in let goal = p_all (fun vc -> vc.goal) vcs in let vars = List.fold_left (fun d vc -> V.union d vc.vars) V.empty vcs in let deps = List.fold_left (fun d vc -> D.union d vc.deps) D.empty vcs in let warn = List.fold_left (fun d vc -> W.union d vc.warn) W.empty vcs in let path = List.fold_left (fun d vc -> S.union d vc.path) S.empty vcs in { hyps = hyps ; goal = goal ; vars = vars ; deps = deps ; warn = warn ; path = path } (* -------------------------------------------------------------------------- *) (* --- Merging and Branching with Splitters --- *) (* -------------------------------------------------------------------------- *) let gmerge = Gmap.union (fun _gid -> Splitter.union merge_vc) let gmap phi vcs = Gmap.map (Splitter.map phi) vcs let gbranch ~left ~both ~right vcs1 vcs2 = Gmap.merge (fun _g w1 w2 -> match w1 , w2 with | None , None -> None | Some vcs1 , None -> Some (Splitter.map left vcs1) | None , Some vcs2 -> Some (Splitter.map right vcs2) | Some vcs1 , Some vcs2 -> Some (Splitter.merge ~left ~both ~right vcs1 vcs2) ) vcs1 vcs2 (* -------------------------------------------------------------------------- *) (* --- Merge for Calculus --- *) (* -------------------------------------------------------------------------- *) let empty = { sigma = None ; effects = Eset.empty ; vcs = Gmap.empty ; } let merge wenv wp1 wp2 = L.in_frame wenv.frame (fun () -> let sigma,pa1,pa2 = merge_sigma wp1.sigma wp2.sigma in let effects = Eset.union wp1.effects wp2.effects in let vcs1 = gmap (passify_vc pa1) wp1.vcs in let vcs2 = gmap (passify_vc pa2) wp2.vcs in let vcs = gmerge vcs1 vcs2 in { sigma = sigma ; vcs = vcs ; effects = effects } ) () (* -------------------------------------------------------------------------- *) (* --- Environment --- *) (* -------------------------------------------------------------------------- *) let new_env ?(lvars=[]) kf = let frame = L.frame kf in let env = L.in_frame frame L.new_env lvars in { frame = frame ; main = env } let in_wenv (wenv:t_env) (wp:t_prop) (phi:L.env -> t_prop -> 'a) : 'a = L.in_frame wenv.frame (fun wp -> match wp.sigma with | None -> let s = sigma_at wp in phi (L.move wenv.main s) { wp with sigma = Some s } | Some s -> phi (L.move wenv.main s) wp) wp (* -------------------------------------------------------------------------- *) (* --- Compilation of Goals --- *) (* -------------------------------------------------------------------------- *) let rec intros hs p = match F.pred p with | Logic.Bind(Logic.Forall,_,p) -> intros hs p | Logic.Imply(hs2,p) -> intros (hs @ hs2) p | _ -> hs , p let introduction pred = let hs , goal = intros [] pred in let xs = List.fold_left (fun xs h -> Vars.union xs (F.varsp h)) (F.varsp goal) hs in xs , hs , goal let add_vc target ?(warn=Warning.Set.empty) pred vcs = let xs , hs , goal = introduction pred in let hyps = Conditions.intros hs Conditions.empty in let vc = { empty_vc with goal=goal ; vars=xs ; hyps=hyps ; warn=warn } in Gmap.add target (Splitter.singleton vc) vcs (* ------------------------------------------------------------------------ *) (* --- Compilation of Effects --- *) (* ------------------------------------------------------------------------ *) let cc_effect env pid (ainfo:WpPropId.assigns_desc) : effect option = let from = Clabels.c_label ainfo.WpPropId.a_label in let sigma = L.mem_frame from in let region = L.assigns (match ainfo.a_kind with | StmtAssigns -> L.move env sigma | LoopAssigns -> env) ainfo.a_assigns in match region with | None -> None | Some r -> Some { e_pid = pid ; e_kind = ainfo.a_kind ; e_label = from ; e_valid = sigma ; e_region = r ; e_warn = Warning.Set.empty ; } let cc_posteffect e vcs = match e.e_kind with | StmtAssigns -> vcs | LoopAssigns -> let vc = { empty_vc with vars = A.vars e.e_region } in Gmap.add (Gposteffect e.e_pid) (Splitter.singleton vc) vcs (* -------------------------------------------------------------------------- *) (* --- WP RULES : adding axioms, hypotheses and goals --- *) (* -------------------------------------------------------------------------- *) let add_axiom _id _l = () let add_hyp wenv (hpid,predicate) wp = in_wenv wenv wp (fun env wp -> let descr = Pretty_utils.to_string WpPropId.pretty hpid in let outcome = Warning.catch ~severe:false ~effect:"Skip hypothesis" (L.pred ~positive:false env) predicate in let warn,hs = match outcome with | Warning.Result(warn,p) -> warn , [p] | Warning.Failed warn -> warn , [] in let vcs = gmap (assume_vc ~hpid ~descr ~warn hs) wp.vcs in { wp with vcs = vcs }) let add_goal wenv (gpid,predicate) wp = in_wenv wenv wp (fun env wp -> let outcome = Warning.catch ~severe:true ~effect:"Degenerated goal" (L.pred ~positive:true env) predicate in let warn,goal = match outcome with | Warning.Result(warn,goal) -> warn,goal | Warning.Failed warn -> warn,F.p_false in let vcs = add_vc (Gprop gpid) ~warn goal wp.vcs in { wp with vcs = vcs }) let add_assigns wenv (gpid,ainfo) wp = in_wenv wenv wp begin fun env wp -> let outcome = Warning.catch ~severe:true ~effect:"Degenerated goal" (cc_effect env gpid) ainfo in match outcome with | Warning.Result (_,None) -> wp | Warning.Result (warn,Some e) -> let e = { e with e_warn = warn } in let effects = Eset.add e wp.effects in let vcs = cc_posteffect e wp.vcs in { wp with effects = effects ; vcs = vcs } | Warning.Failed warn -> let vcs = add_vc (Gprop gpid) ~warn p_false wp.vcs in { wp with vcs = vcs } end let add_warnings wrns vcs = gmap (fun vc -> { vc with warn = W.union wrns vc.warn }) vcs (* -------------------------------------------------------------------------- *) (* --- WP RULE : use assigns clause --- *) (* -------------------------------------------------------------------------- *) let assigns_condition (region : A.region) (e:effect) : F.pred = p_all (fun (obj1,r1) -> p_imply (L.valid e.e_valid RD obj1 r1) (p_any (fun (obj2,r2) -> L.included obj1 r1 obj2 r2) e.e_region)) region exception COLLECTED let is_collected vcs p = try Gmap.iter (fun target vcs -> let q = TARGET.prop_id target in if P.equal p q && Splitter.length vcs > 0 then raise COLLECTED ) vcs ; false with COLLECTED -> true let check_nothing effects vcs = Eset.fold (fun e vcs -> if is_collected vcs e.e_pid then vcs else Gmap.add (Gprop e.e_pid) (Splitter.singleton empty_vc) vcs ) effects vcs let check_assigns sloc source ?(warn=Warning.Set.empty) region effects vcs = Eset.fold (fun e vcs -> let xs,hs,goal = introduction (assigns_condition region e) in let warn = Warning.Set.union warn e.e_warn in let setup vc = { vc with warn = warn ; hyps = Conditions.intros hs vc.hyps ; goal = goal ; vars = xs } in let group = match e.e_kind with | StmtAssigns -> Splitter.singleton (setup empty_vc) | LoopAssigns -> try Splitter.map setup (Gmap.find (Gposteffect e.e_pid) vcs) with Not_found -> Wp_parameters.fatal "Missing post-effect for %a" WpPropId.pretty e.e_pid in let target = match sloc with | None -> Gprop e.e_pid | Some stmt -> Geffect(e.e_pid,stmt,source) in Gmap.add target group vcs ) effects vcs let do_assigns ~descr ?stmt ~source ?hpid ?warn sequence region effects vcs = let vcs = check_assigns stmt source ?warn region effects vcs in let eqmem = A.assigned sequence region in gmap (assume_vc ~descr ?hpid ?stmt ?warn eqmem) vcs let do_assigns_everything ?stmt ?warn effects vcs = Eset.fold (fun e vcs -> let target = match stmt with | None -> Gprop e.e_pid | Some s -> Geffect(e.e_pid,s,FromCode) in add_vc target ?warn F.p_false vcs) effects vcs let cc_assigned env kind froms = let dummy = Sigma.create () in let r0 = A.domain (L.assigns_from (L.move env dummy) froms) in let s1 = L.sigma env in let s0 = Sigma.havoc s1 r0 in let sref = match kind with | StmtAssigns -> s0 | LoopAssigns -> s1 in let assigned = L.assigns_from (L.move env sref) froms in let sequence = { pre=s0 ; post=s1 } in sequence , assigned let use_assigns wenv stmt hpid ainfo wp = in_wenv wenv wp begin fun env wp -> match ainfo.a_assigns with | WritesAny -> let sigma = Sigma.havoc_any (L.sigma env) in let vcs = do_assigns_everything ?stmt wp.effects wp.vcs in { sigma = Some sigma ; vcs=vcs ; effects = wp.effects } | Writes froms -> let kind = ainfo.WpPropId.a_kind in let outcome = Warning.catch ~severe:true ~effect:"Assigns everything" (cc_assigned env kind) froms in match outcome with | Warning.Result(warn,(sequence,assigned)) -> let vcs = do_assigns ~source:FromCode ~descr:"Call Assigns" ?hpid ?stmt ~warn sequence assigned wp.effects wp.vcs in { sigma = Some sequence.pre ; vcs=vcs ; effects = wp.effects } | Warning.Failed warn -> let sigma = Sigma.havoc_any (L.sigma env) in let vcs = do_assigns_everything ?stmt ~warn wp.effects wp.vcs in { sigma = Some sigma ; vcs=vcs ; effects = wp.effects } end (* -------------------------------------------------------------------------- *) (* --- WP RULE : label --- *) (* -------------------------------------------------------------------------- *) let is_stopeffect l e = Clabels.equal l e.e_label let not_posteffect es target _vcs = match target with | Gposteffect p -> not (Eset.exists (fun e -> P.equal p e.e_pid) es) | _ -> true let label wenv labl wp = match labl , wp.sigma with | Clabels.Here , _ | _ , None -> wp | _ -> in_wenv wenv wp (fun env wp -> let s_here = L.sigma env in let s_labl = L.mem_frame labl in let pa = Sigma.join s_here s_labl in let stop,effects = Eset.partition (is_stopeffect labl) wp.effects in let vcs = Gmap.filter (not_posteffect stop) wp.vcs in let vcs = gmap (passify_vc pa) vcs in let vcs = check_nothing stop vcs in { sigma = Some s_here ; vcs=vcs ; effects=effects }) (* -------------------------------------------------------------------------- *) (* --- WP RULE : assignation --- *) (* -------------------------------------------------------------------------- *) let cc_lval env lv = let obj = Ctypes.object_of (Cil.typeOfLval lv) in let dummy = Sigma.create () in let l0 = C.lval dummy lv in let s2 = L.sigma env in let domain = M.domain obj l0 in let s1 = Sigma.havoc s2 domain in let loc = C.lval s1 lv in let seq = { pre=s1 ; post=s2 } in obj , domain , seq , loc let cc_stored seq loc obj expr = match expr.enode with | Lval lv -> M.copied seq obj loc (C.lval seq.pre lv) | _ -> M.stored seq obj loc (C.val_of_exp seq.pre expr) let assign wenv stmt lv expr wp = in_wenv wenv wp begin fun env wp -> let outcome = Warning.catch ~severe:true ~effect:"Assigns everything (unknown l-value)" (cc_lval env) lv in match outcome with | Warning.Failed warn -> (* L-Value is unknown *) let sigma = Sigma.havoc_any (L.sigma env) in let vcs = do_assigns_everything ~stmt ~warn wp.effects wp.vcs in { sigma = Some sigma ; vcs=vcs ; effects = wp.effects } | Warning.Result(l_warn,(obj,dom,seq,loc)) -> (* L-Value has been translated *) let region = [obj,[Sloc loc]] in let outcome = Warning.catch ~severe:false ~effect:"Havoc l-value (unknown r-value)" (cc_stored seq loc obj) expr in match outcome with | Warning.Failed r_warn -> (* R-Value is unknown *) let warn = Warning.Set.union l_warn r_warn in let vcs = do_assigns ~descr:"Assignment" ~source:FromCode ~stmt ~warn seq region wp.effects wp.vcs in { sigma = Some seq.pre ; vcs=vcs ; effects = wp.effects } | Warning.Result(r_warn,stored) -> (* R-Value and effects has been translated *) let warn = Warning.Set.union l_warn r_warn in let ft = M.Heap.Set.fold (fun chunk ft -> M.Sigma.get seq.post chunk :: ft) dom [] in let update vc = if List.exists (occurs_vc vc) ft then assume_vc ~descr:"Assignment" ~stmt ~warn stored vc else vc in let vcs = gmap update wp.vcs in let vcs = check_assigns (Some stmt) FromCode region wp.effects vcs in { sigma = Some seq.pre ; vcs=vcs ; effects = wp.effects } end (* -------------------------------------------------------------------------- *) (* --- WP RULE : return statement --- *) (* -------------------------------------------------------------------------- *) let return wenv stmt result wp = match result with | None -> wp | Some exp -> in_wenv wenv wp (fun env wp -> let xr = L.result () in let tr = L.return () in let sigma = L.sigma env in let returned = p_equal (e_var xr) (C.return sigma tr exp) in let vcs = gmap (assume_vc ~descr:"Return" ~stmt [returned]) wp.vcs in { wp with vcs = vcs }) (* -------------------------------------------------------------------------- *) (* --- WP RULE : conditional --- *) (* -------------------------------------------------------------------------- *) let condition ~descr ?stmt ?warn pa h vc = passify_vc pa (assume_vc ?stmt ?warn ~descr h vc) let mark m = function | None -> Splitter.empty | Some s -> Splitter.group m merge_vcs s let random () = let v = Lang.freshvar ~basename:"cond" Logic.Bool in F.p_bool (F.e_var v) let pp_opt pp fmt = function None -> Format.fprintf fmt "none" | Some e -> pp fmt e let test wenv stmt exp wp1 wp2 = L.in_frame wenv.frame (fun () -> let sigma,pa1,pa2 = sigma_union wp1.sigma wp2.sigma in let warn,cond = match Warning.catch ~source:"Condition" ~severe:false ~effect:"Skip condition value" (C.cond sigma) exp with | Warning.Result(warn,cond) -> warn,cond | Warning.Failed(warn) -> warn , random () in let effects = Eset.union wp1.effects wp2.effects in let vcs = if Wp_parameters.Split.get () then let cneg = p_not cond in let vcs1 = gmap (condition pa1 ~stmt ~warn ~descr:"Then" [cond]) wp1.vcs in let vcs2 = gmap (condition pa2 ~stmt ~warn ~descr:"Else" [cneg]) wp2.vcs in Gmap.merge (fun _g w1 w2 -> let s1 = mark (Splitter.if_then stmt) w1 in let s2 = mark (Splitter.if_else stmt) w2 in Some (Splitter.union (merge_vc) s1 s2) ) vcs1 vcs2 else let vcs1 = gmap (passify_vc pa1) wp1.vcs in let vcs2 = gmap (passify_vc pa2) wp2.vcs in gbranch ~left:(assume_vc ~descr:"Then" ~stmt [cond]) ~right:(assume_vc ~descr:"Else" ~stmt [p_not cond]) ~both:(branch_vc ~stmt cond) vcs1 vcs2 in { sigma = Some sigma ; vcs=vcs ; effects=effects }) () (* -------------------------------------------------------------------------- *) (* --- WP RULE : switch --- *) (* -------------------------------------------------------------------------- *) let rec cc_case_values ks vs sigma = function | [] -> ks , vs | e::es -> match Ctypes.get_int e with | Some k -> cc_case_values (k::ks) (F.e_int64 k::vs) sigma es | None -> cc_case_values ks (C.val_of_exp sigma e::vs) sigma es let cc_group_case stmt warn descr tag pa cond vcs : vc Splitter.t Gmap.t = Gmap.map (fun s -> Splitter.map (condition ~descr ~warn ~stmt pa cond) (Splitter.group tag merge_vcs s) ) vcs let cc_case stmt warn sigma v (es,wp) = let ks,vs = cc_case_values [] [] sigma es in let pa = join_with sigma wp.sigma in let eq = p_any (p_equal v) vs in vs , cc_group_case stmt warn "Case" (Splitter.switch_cases stmt ks) pa [eq] wp.vcs let cc_default stmt sigma neq default = let pa = join_with sigma default.sigma in cc_group_case stmt W.empty "Default" (Splitter.switch_default stmt) pa neq default.vcs let get_vcs goal vcs = try Gmap.find goal vcs with Not_found -> Splitter.empty let switch wenv stmt exp cases default = L.in_frame wenv.frame (fun () -> let sigma = Sigma.create () in let warn,value = match Warning.catch ~source:"Switch" ~severe:false ~effect:"Skip switched value" (C.val_of_exp sigma) exp with | Warning.Result(warn,value) -> warn,value | Warning.Failed(warn) -> let tau = Lang.tau_of_ctype (Cil.typeOf exp) in warn,e_var (Lang.freshvar tau) in let vcs_cases = List.map (cc_case stmt warn sigma value) cases in let neq = List.map (fun (vs,_) -> p_all (p_neq value) vs) vcs_cases in let vcs_default = cc_default stmt sigma neq default in let targets = List.fold_left (fun ds (_,vcs) -> Gset.union ds (Gmap.domain vcs)) (Gmap.domain vcs_default) vcs_cases in let vcs = Gset.mapping (fun goal -> Splitter.merge_all merge_vcs (get_vcs goal vcs_default :: List.map (fun (_,vcs) -> get_vcs goal vcs) vcs_cases)) targets in let effects = List.fold_left (fun es (_,wp) -> Eset.union es wp.effects) default.effects cases in { sigma = Some sigma ; effects = effects ; vcs = vcs }) () (* -------------------------------------------------------------------------- *) (* --- WP RULES : initial values --- *) (* -------------------------------------------------------------------------- *) let init_value wenv lv typ init wp = in_wenv wenv wp (fun env wp -> let sigma = L.sigma env in let obj = Ctypes.object_of typ in let outcome = Warning.catch ~severe:false ~effect:"Skip initializer" (fun () -> let l = C.lval sigma lv in match init with | Some e -> let v = M.load sigma obj l in p_equal (C.val_of_exp sigma e) (C.cval v) | None -> C.is_zero sigma obj l ) () in let warn,hyp = match outcome with | Warning.Failed warn -> warn , F.p_true | Warning.Result(warn , hyp) -> warn , hyp in let vcs = gmap (assume_vc ~descr:"Initializer" ~warn [hyp]) wp.vcs in { wp with vcs = vcs }) let init_range wenv lv typ a b wp = in_wenv wenv wp (fun env wp -> let sigma = L.sigma env in let obj = Ctypes.object_of typ in let outcome = Warning.catch ~severe:false ~effect:"Skip initializer" (fun () -> let l = C.lval sigma lv in C.is_zero_range sigma l obj (e_int64 a) (e_int64 b) ) () in let warn,hyp = match outcome with | Warning.Failed warn -> warn , F.p_true | Warning.Result(warn , hyp) -> warn , hyp in let vcs = gmap (assume_vc ~descr:"Initializer" ~warn [hyp]) wp.vcs in { wp with vcs = vcs }) (* -------------------------------------------------------------------------- *) (* --- WP RULE : tag --- *) (* -------------------------------------------------------------------------- *) let loop_step wp = wp let loop_entry wp = wp (* -------------------------------------------------------------------------- *) (* --- WP RULE : call precondition --- *) (* -------------------------------------------------------------------------- *) let call_goal_precond wenv _stmt kf es ~pre wp = in_wenv wenv wp (fun env wp -> let sigma = L.sigma env in let outcome = Warning.catch ~severe:true ~effect:"Can not prove call preconditions" (List.map (C.exp sigma)) es in match outcome with | Warning.Failed warn -> let vcs = List.fold_left (fun vcs (gid,_) -> add_vc (Gprop gid) ~warn p_false vcs) wp.vcs pre in { wp with vcs = vcs } | Warning.Result(warn,vs) -> let call_e = L.call sigma in let call_f = L.call_pre kf vs sigma in let vcs = List.fold_left (fun vcs (gid,p) -> let outcome = Warning.catch ~severe:true ~effect:"Can not prove call precondition" (L.in_frame call_f (L.pred ~positive:false call_e)) p in match outcome with | Warning.Result(warn2,goal) -> let warn = W.union warn warn2 in add_vc (Gprop gid) ~warn goal vcs | Warning.Failed warn2 -> let warn = W.union warn warn2 in add_vc (Gprop gid) ~warn p_false vcs ) wp.vcs pre in { wp with vcs = vcs }) (* -------------------------------------------------------------------------- *) (* --- WP RULE : call postcondition --- *) (* -------------------------------------------------------------------------- *) type callenv = { sigma_pre : sigma ; seq_post : sigma sequence ; seq_exit : sigma sequence ; seq_result : sigma sequence ; loc_result : (typ * Ctypes.c_object * loc) option ; frame_pre : L.frame ; frame_post : L.frame ; frame_exit : L.frame ; } (* --- Computing Call Memory States --- *) let cc_result_domain = function | Some lv -> let dummy = Sigma.create () in let tr = Cil.typeOfLval lv in let lr = C.lval dummy lv in Some (M.domain (Ctypes.object_of tr) lr) | None -> Some (M.Heap.Set.empty) let cc_call_domain env0 kf es = function | WritesAny -> None | Writes froms -> let dummy = Sigma.create () in let vs = List.map (C.exp dummy) es in let env = L.move env0 dummy in let frame = L.call_pre kf vs dummy in Some (A.domain (L.in_frame frame (L.assigns_from env) froms)) let cc_havoc d s = match d with | None -> { pre = Sigma.havoc_any s ; post = s } | Some domain -> { pre = Sigma.havoc s domain ; post = s } let cc_callenv env0 lvr kf es assigns wpost wexit = let dom_call = cc_call_domain env0 kf es assigns in let dom_vret = cc_result_domain lvr in (* Sequences to be considered *) let seq_result = cc_havoc dom_vret (sigma_at wpost) in let seq_post = cc_havoc dom_call seq_result.pre in let seq_exit = cc_havoc dom_call (sigma_at wexit) in (* Pre-State *) let sigma_pre, _, _ = Sigma.merge seq_post.pre seq_exit.pre in let formals = List.map (C.exp sigma_pre) es in let result = match lvr with | None -> None | Some lv -> let tr = Cil.typeOfLval lv in let obj = Ctypes.object_of tr in let loc = C.lval sigma_pre lv in Some (tr,obj,loc) in { sigma_pre = sigma_pre ; seq_post = seq_post ; seq_exit = seq_exit ; seq_result = seq_result ; loc_result = result ; frame_pre = L.call_pre kf formals sigma_pre ; frame_post = L.call_post kf formals seq_post ; frame_exit = L.call_post kf formals seq_exit ; } type call_vcs = { vcs_post : vc Splitter.t Gmap.t ; vcs_exit : vc Splitter.t Gmap.t ; } let cc_call_effects stmt cenv env0 assigns wpost wexit = match assigns with | WritesAny -> { vcs_post = do_assigns_everything ~stmt wpost.effects wpost.vcs ; vcs_exit = do_assigns_everything ~stmt wexit.effects wexit.vcs ; } | Writes froms -> let env = L.move env0 cenv.sigma_pre in let call_region = L.in_frame cenv.frame_pre (L.assigns_from env) froms in let vcs_post = do_assigns ~descr:"Call Effects" ~source:FromCall ~stmt cenv.seq_post call_region wpost.effects wpost.vcs in let vcs_exit = do_assigns ~descr:"Exit Effects" ~source:FromCall ~stmt cenv.seq_exit call_region wexit.effects wexit.vcs in let vcs_result = match cenv.loc_result with | None -> vcs_post (* no result *) | Some(_,obj,loc) -> let res_region = [obj,[Sloc loc]] in do_assigns ~descr:"Return Effects" ~source:FromReturn ~stmt cenv.seq_result res_region wpost.effects vcs_post in { vcs_post = vcs_result ; vcs_exit = vcs_exit } (* --- Compiling Contracts --- *) let cc_contract_hyp frame env contract = L.in_frame frame (List.map (fun (_,p) -> L.pred ~positive:false env p)) contract (* --- Binding Result --- *) let cc_result call = match call.loc_result with | None -> [] | Some(tr,obj,loc) -> (* [LC,VP] : the C left unspecified where to compute the lv *) (* [LC,BY] : lv computed before, like in Value Analysis *) let vr = M.load call.seq_result.post obj loc in let re = L.in_frame call.frame_post L.result () in let te = L.in_frame call.frame_post L.return () in [ C.equal_typ tr vr (C.cast tr te (Val (e_var re))) ] let cc_status f_caller f_callee = p_equal (e_var (L.in_frame f_caller L.status ())) (e_var (L.in_frame f_callee L.status ())) (* --- Call Rule --- *) let call_proper wenv stmt lvr kf es ~pre ~post ~pexit ~assigns ~p_post ~p_exit () = let call = cc_callenv wenv.main lvr kf es assigns p_post p_exit in let env_pre = L.move wenv.main call.sigma_pre in let env_post = L.move wenv.main call.seq_post.post in let env_exit = L.move wenv.main call.seq_exit.post in (* Compiling specifications *) let hs_pre = cc_contract_hyp call.frame_pre env_pre pre in let hs_post = cc_contract_hyp call.frame_post env_post post in let hs_exit = cc_contract_hyp call.frame_exit env_exit pexit in (* Binding result/status *) let hs_post = cc_result call @ hs_post in let hs_exit = cc_status wenv.frame call.frame_exit :: hs_exit in (* Checking effects (assigns and result) *) let ceff = cc_call_effects stmt call wenv.main assigns p_post p_exit in (* Applying specifications *) let fname = Kernel_function.get_name kf in let apply outcome pa hs vcs = let descr = Printf.sprintf "%s '%s'" outcome fname in gmap (condition ~descr ~stmt pa hs) vcs in let pa_post = Sigma.join call.sigma_pre call.seq_post.pre in let pa_exit = Sigma.join call.sigma_pre call.seq_exit.pre in let cond_post = apply "Call" pa_post (hs_pre @ hs_post) ceff.vcs_post in let cond_exit = apply "Exit" pa_exit (hs_pre @ hs_exit) ceff.vcs_exit in (* Final vcs *) let vcs = gmerge cond_post cond_exit in let effects = Eset.union p_post.effects p_exit.effects in { sigma = Some call.sigma_pre ; effects=effects ; vcs=vcs } let call wenv stmt lvr kf es ~pre ~post ~pexit ~assigns ~p_post ~p_exit = L.in_frame wenv.frame (fun () -> let outcome = Warning.catch ~severe:true ~effect:"Call assigns everything" (call_proper wenv stmt lvr kf es ~pre ~post ~pexit ~assigns ~p_post ~p_exit) () in match outcome with | Warning.Result(warn , wp) -> { wp with vcs = add_warnings warn wp.vcs } | Warning.Failed warn -> let v_post = do_assigns_everything ~stmt ~warn p_post.effects p_exit.vcs in let v_exit = do_assigns_everything ~stmt ~warn p_exit.effects p_exit.vcs in let effects = Eset.union p_post.effects p_exit.effects in let vcs = gmerge v_post v_exit in let sigma = Sigma.create () in { sigma = Some sigma ; vcs = vcs ; effects = effects } ) () (* -------------------------------------------------------------------------- *) (* --- WP RULE : scope --- *) (* -------------------------------------------------------------------------- *) let scope wenv xs sc wp = in_wenv wenv wp (fun env wp -> let sigma,hs = M.scope (L.sigma env) sc xs in let descr = match sc with | Mcfg.SC_Global -> "Heap" | Mcfg.SC_Function_frame -> "Function Frame" | Mcfg.SC_Function_in -> "Function Entry" | Mcfg.SC_Function_out -> "Function Exit" | Mcfg.SC_Block_in -> "Block In" | Mcfg.SC_Block_out -> "Block Out" in let vcs = gmap (assume_vc ~descr hs) wp.vcs in { wp with sigma = Some sigma ; vcs = vcs }) (* -------------------------------------------------------------------------- *) (* --- WP RULE : close --- *) (* -------------------------------------------------------------------------- *) let close wenv wp = let guards = L.guards wenv.frame in let vcs = gmap (fun vc -> let gdom = List.filter (intersect_vc vc) guards in let hyps = Conditions.domain gdom vc.hyps in { vc with hyps = hyps ; vars = Vars.empty } ) wp.vcs in { wp with vcs = vcs } (* -------------------------------------------------------------------------- *) (* --- WP RULE : froms --- *) (* -------------------------------------------------------------------------- *) let cc_from deps hs vc = let guards = Lang.get_hypotheses () in let hyps = Conditions.assume ~descr:"Bisimulation" (p_conj guards) vc.hyps in let p = F.p_hyps (Conditions.extract hyps) vc.goal in let alpha = Alpha.create () in let a_hs = List.map (Alpha.convertp alpha) hs in let a_p = Alpha.convertp alpha p in let p = p_hyps a_hs a_p in { vc with goal = p ; vars = F.varsp p ; hyps = Conditions.empty ; deps = D.union deps vc.deps ; } let build_prop_of_from wenv preconds wp = in_wenv wenv wp (fun env wp -> let sigma = L.mem_frame Pre in let env_pre = L.move env sigma in let hs = List.map (fun (_,p) -> L.pred ~positive:false env_pre p) preconds in let ds = List.fold_left (fun ds (pid,_) -> D.add (WpPropId.property_of_id pid) ds) D.empty preconds in let vcs = gmap (cc_from ds hs) wp.vcs in { sigma = Some sigma ; effects = Eset.empty ; vcs=vcs }) (* -------------------------------------------------------------------------- *) (* --- WPO Builder --- *) (* -------------------------------------------------------------------------- *) let is_trivial vc = F.eqp vc.goal F.p_true let is_empty vc = is_trivial vc && D.is_empty vc.deps && S.is_empty vc.path && W.is_empty vc.warn let make_vcqs target tags vc = let vcq = { VC_Annot.effect = TARGET.source target ; VC_Annot.goal = GOAL.dummy ; VC_Annot.tags = tags ; VC_Annot.deps = vc.deps ; VC_Annot.path = vc.path ; VC_Annot.warn = W.elements vc.warn ; } in let hyps = Conditions.freeze vc.hyps in let goal g = { vcq with VC_Annot.goal = GOAL.make hyps g } in match F.pred vc.goal with | Logic.And gs when Wp_parameters.Split.get () -> Bag.list (List.map goal gs) | _ -> Bag.elt (goal vc.goal) let make_trivial vc = { VC_Annot.effect = None ; VC_Annot.goal = GOAL.trivial ; VC_Annot.tags = [] ; VC_Annot.deps = vc.deps ; VC_Annot.path = vc.path ; VC_Annot.warn = W.elements vc.warn ; } let make_oblig index pid emitter vcq = { po_model = Model.get_model () ; po_pid = pid ; po_gid = "" ; po_name = "" ; po_idx = index ; po_updater = emitter ; po_formula = GoalAnnot vcq ; } (* -------------------------------------------------------------------------- *) (* --- WPO Grouper --- *) (* -------------------------------------------------------------------------- *) module PMAP = Map.Make(P) type group = { mutable verifs : VC_Annot.t Bag.t ; mutable trivial : vc ; } let group_vc groups target tags vc = let pid = TARGET.prop_id target in let group = try PMAP.find pid !groups with Not_found -> let g = { verifs = Bag.empty ; trivial = empty_vc } in groups := PMAP.add pid g !groups ; g in if is_trivial vc then group.trivial <- merge_vc group.trivial vc else group.verifs <- Bag.concat group.verifs (make_vcqs target tags vc) let compile collection index (wp : t_prop) = let groups = ref PMAP.empty in Gmap.iter_sorted (fun target -> Splitter.iter (group_vc groups target)) wp.vcs ; let model = Model.get_model () in let emitter = Model.get_emitter model in PMAP.iter begin fun pid group -> let trivial_wpo = let vcq = make_trivial group.trivial in Bag.elt (make_oblig index pid emitter vcq) in let provers_wpo = Bag.map (make_oblig index pid emitter) group.verifs in let mid = Model.get_id model in let group = if is_empty group.trivial then if Bag.is_empty provers_wpo then trivial_wpo else provers_wpo else Bag.concat trivial_wpo provers_wpo in WpAnnot.split begin fun pid wpo -> let gid = Wpo.gid ~propid:pid ~model:mid in let name = Pretty_utils.to_string WpPropId.pretty pid in let wpo = { wpo with po_pid = pid ; po_gid = gid ; po_name = name } in Wpo.add wpo ; collection := Bag.append !collection wpo ; end pid group end !groups (* -------------------------------------------------------------------------- *) (* --- WPO Lemmas --- *) (* -------------------------------------------------------------------------- *) let compile_lemma l = ignore (L.lemma l) let prove_lemma collection l = if not l.lem_axiom then begin let id = WpPropId.mk_lemma_id l in let def = L.lemma l in let model = Model.get_model () in let vca = { Wpo.VC_Lemma.depends = l.lem_depends ; Wpo.VC_Lemma.lemma = def ; } in let index = match LogicUsage.section_of_lemma l.lem_name with | LogicUsage.Toplevel _ -> Wpo.Axiomatic None | LogicUsage.Axiomatic a -> Wpo.Axiomatic (Some a.ax_name) in let wpo = { Wpo.po_model = model ; Wpo.po_gid = Wpo.gid ~model:(Model.get_id model) ~propid:id ; Wpo.po_name = Printf.sprintf "Lemma '%s'" l.lem_name ; Wpo.po_idx = index ; Wpo.po_pid = id ; Wpo.po_updater = Model.get_emitter model ; Wpo.po_formula = Wpo.GoalLemma vca ; } in Wpo.add wpo ; collection := Bag.append !collection wpo ; end end (* -------------------------------------------------------------------------- *) (* --- WPO Computer --- *) (* -------------------------------------------------------------------------- *) module Computer(M : Memory.Model) = struct module VCG = VC(M) module WP = Calculus.Cfg(VCG) class thecomputer (m:Model.t) = object val mutable lemmas : LogicUsage.logic_lemma Bag.t = Bag.empty val mutable annots : WpStrategy.strategy Bag.t = Bag.empty method lemma = true method add_lemma lemma = lemmas <- Bag.append lemmas lemma method add_strategy strategy = annots <- Bag.append annots strategy method compute : Wpo.t Bag.t = begin let collection = ref Bag.empty in Model.on_model m (fun () -> LogicUsage.iter_lemmas VCG.compile_lemma ; Bag.iter (VCG.prove_lemma collection) lemmas ; Bag.iter (fun strategy -> let cfg = WpStrategy.cfg_of_strategy strategy in let kf = WpStrategy.get_kf strategy in let names = WpAnnot.missing_rte kf in let bhv = WpStrategy.get_bhv strategy in let index = Wpo.Function( kf , bhv ) in if names <> [] then Wp_parameters.warning ~current:false ~once:true "Missing RTE guards" ; try let (results,_) = WP.compute cfg strategy in List.iter (VCG.compile collection index) results with Warning.Error(source,reason) -> Wp_parameters.failure ~current:false "From %s: %s" source reason ) annots) ; lemmas <- Bag.empty ; annots <- Bag.empty ; !collection end end let create m = (new thecomputer m :> Generator.computer) end frama-c-Fluorine-20130601/src/wp/ProverWhy3.ml0000644000175000017500000004717112155630215017606 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Why3 Interface --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Qed open Lang open Definitions let dkey = Wp_parameters.register_category "prover" let why3_goal_name = "WP" (* -------------------------------------------------------------------------- *) (* --- Making Goal File --- *) (* -------------------------------------------------------------------------- *) let cluster_file c = let dir = Model.directory () in let base = cluster_id c in Printf.sprintf "%s/%s.why" dir base let theory_name_of_cluster c = let base = cluster_id c in String.capitalize base let theory_name_of_pid fmt pid = Format.fprintf fmt "VC%s" (WpPropId.get_propid pid) (* -------------------------------------------------------------------------- *) (* --- Exporting Formulae to Why3 --- *) (* -------------------------------------------------------------------------- *) type depend = | D_file of string | D_cluster of cluster module TYPES = Model.Index (struct type key = adt type data = tau let name = "ProverWhy3.TYPES" let compare = ADT.compare let pretty = ADT.pretty end) let engine = let module E = Qed.Export_why3.Make(Lang.F) in object(self) inherit E.engine method datatype x = self#basename (ADT.id x) method field x = self#basename (Field.id x) method link e f = match Lang.link e f with | Engine.F_call s -> Engine.F_call (self#basename s) | Engine.F_left (s1, s2) -> Engine.F_left (self#basename s1, self#basename s2) | Engine.F_right (s1, s2) -> Engine.F_right (self#basename s1, self#basename s2) | Engine.F_assoc s -> Engine.F_assoc (self#basename s) method set_typedef = TYPES.define method get_typedef = TYPES.get method typeof_call = Lang.tau_of_lfun method typeof_getfield = Lang.tau_of_field method typeof_setfield = Lang.tau_of_record end class visitor fmt c = object(self) inherit Definitions.visitor c inherit ProverTask.printer fmt (cluster_title c) val mutable deps = [] (* --- Managing Formatter --- *) method flush = begin Format.pp_print_newline fmt () ; List.rev deps end (* --- Files, Theories and Clusters --- *) method add_dfile f = let df = D_file f in if not (List.mem df deps) then deps <- df :: deps method add_import (file,thy) = self#lines ; Format.fprintf fmt "use import %s.%s@\n" file thy ; method on_cluster c = self#lines ; let name = (cluster_id c) in Format.fprintf fmt "use import %s.%s@\n" name (String.capitalize name) ; deps <- (D_cluster c) :: deps method on_theory = function | "qed" | "driver" -> () | "cint" -> self#add_import ("cint","Cint") | "cbits" -> self#add_import ("cint","Cint") | "cfloat" -> self#add_import ("cfloat","Cfloat") | "vset" -> self#add_import ("vset","Vset") | "memory" -> self#add_import ("memory","Memory") | "cmath" -> self#add_import ("cmath","Cmath") | thy -> Wp_parameters.fatal ~current:false "No builtin theory '%s' for why3" thy method add_library path thy = self#add_import (thy,String.capitalize thy) ; self#add_dfile path method add_extlib file = let name = Filename.basename file in let thy = try Filename.chop_extension name with Invalid_argument _ -> name in let path = Wp_parameters.find_lib file in self#add_library path thy method on_library thy = let path = Wp_parameters.find_lib (thy ^ ".why") in self#add_library path thy method on_type lt def = begin self#lines ; engine#declare_type fmt (Lang.atype lt) (List.length lt.lt_params) def ; end method on_comp c fts = begin (*TODO:NUPW: manage UNIONS *) self#lines ; engine#declare_type fmt (Lang.comp c) 0 (Qed.Engine.Trec fts) ; end method on_dlemma l = begin self#paragraph ; let kind = if l.l_assumed then "axiom" else "lemma" in engine#declare_prop ~kind fmt (Lang.lemma_id l.l_name) l.l_forall l.l_triggers (F.e_prop l.l_lemma) end method on_dfun d = begin self#paragraph ; match d.d_definition with | Logic t -> engine#declare_signature fmt d.d_lfun (List.map F.tau_of_var d.d_params) t ; | Value(t,mu,v) -> let pp = match mu with | Rec -> engine#declare_fixpoint ~prefix:"fix_" | Def -> engine#declare_definition in pp fmt d.d_lfun d.d_params t v | Predicate(mu,p) -> let pp = match mu with | Rec -> engine#declare_fixpoint ~prefix:"fix_" | Def -> engine#declare_definition in pp fmt d.d_lfun d.d_params Logic.Prop (F.e_prop p) | Inductive _ -> engine#declare_signature fmt d.d_lfun (List.map F.tau_of_var d.d_params) Logic.Prop end end let write_cluster c = let f = cluster_file c in Wp_parameters.debug ~dkey "Generate '%s'" f ; Command.print_file f begin fun fmt -> let v = new visitor fmt c in let name = theory_name_of_cluster c in v#printf "@[theory %s@\n" name; v#lines ; (** TODO add them only when needed *) v#add_import ("bool","Bool") ; v#add_import ("int","Int") ; v#add_import ("int","ComputerDivision") ; v#add_import ("real","RealInfix") ; v#add_import ("qed","Arith") ; v#add_import ("map","Map") ; v#vself ; v#printf "@]@\nend@\n"; v#flush ; end (* -------------------------------------------------------------------------- *) (* --- File Assembly --- *) (* -------------------------------------------------------------------------- *) module CLUSTERS = Model.Index (struct type key = cluster type data = int * depend list let name = "ProverWhy3.CLUSTERS" let compare = cluster_compare let pretty = pp_cluster end) let assemble_cluster e = let rec assemble = function | D_cluster c -> assemble_cluster c | D_file path -> assemble_userlib path and assemble_cluster c = let (age,deps) = try CLUSTERS.find c with Not_found -> (-1,[]) in let deps = if age < cluster_age c then let deps = write_cluster c in CLUSTERS.update c (cluster_age c , deps) ; deps else deps in List.iter assemble deps and assemble_userlib source = let tgtdir = Model.directory () in let coqsrc = Filename.basename source in let target = Printf.sprintf "%s/%s" tgtdir coqsrc in Command.copy source target in assemble e (* -------------------------------------------------------------------------- *) (* --- Assembling Goal --- *) (* -------------------------------------------------------------------------- *) open Cil_datatype let assemble_goal ~title ~id ~pid ~axioms prop fmt = (** Also create the directory *) let goal = cluster ~id ~title () in let deps = let v = new visitor fmt goal in v#printf "@[theory %a@\n" theory_name_of_pid pid; v#add_import ("bool","Bool") ; v#add_import ("int","Int") ; v#add_import ("int","ComputerDivision") ; v#add_import ("real","RealInfix") ; v#add_import ("qed","Arith") ; v#add_import ("map","Map") ; v#vgoal axioms prop ; let libs = Wp_parameters.WhyLibs.get () in if libs <> [] then begin v#section "Additional Libraries" ; List.iter v#add_extlib libs ; v#hline ; end ; v#paragraph ; engine#global begin fun () -> v#printf "@[goal %s \"expl:%s\":@ %a@]@\n@\n" why3_goal_name title engine#pp_prop (F.e_prop prop) ; end ; v#printf "end@]@."; v#flush in List.iter assemble_cluster deps module FunFile = Model.Index (struct type key = kernel_function type data = int (* age *) let name = "ProverWhy3.FunFile" let compare = Kernel_function.compare let pretty = Kernel_function.pretty end) type goal_id = { gfile : string; gtheory : string; ggoal : string; } let assemble_wpo wpo = let dir = Model.directory () in let shared = Wp_parameters.Share.dir () in let index = Wpo.get_index wpo in let file = match index with | Wpo.Axiomatic _ -> begin match wpo.Wpo.po_formula with | Wpo.GoalAnnot _ -> assert false | Wpo.GoalLemma vca -> let lemma = vca.Wpo.VC_Lemma.lemma in assemble_cluster (D_cluster lemma.l_cluster); let file = cluster_file lemma.l_cluster in {gfile = file; gtheory = theory_name_of_cluster lemma.l_cluster; ggoal = (Lang.lemma_id lemma.l_name); } end | Wpo.Function (kf,_behv) -> let model = Model.get_model () in let file = Wpo.DISK.file_kf ~kf ~model ~prover:VCS.Why3ide in let age = try FunFile.find kf with Not_found -> -1 in begin if age < Wpo.age wpo then let age_max = ref (-1) in let on_goal fmt wpo = (** iter on all the goal of a kf unfortunately not just the one of the current model *) let pid = wpo.Wpo.po_pid in let model = Model.get_model () in if Model.S.equal wpo.Wpo.po_model model then begin age_max := max (!age_max) (Wpo.age wpo); match wpo.Wpo.po_formula with | Wpo.GoalAnnot vcq -> let prop = Wpo.GOAL.compute_proof vcq.Wpo.VC_Annot.goal in if Lang.F.p_true != prop then let id = WpPropId.get_propid pid in let title = Pretty_utils.to_string WpPropId.pretty pid in let axioms = None in assemble_goal ~pid ~id ~title ~axioms prop fmt | Wpo.GoalLemma _vca -> assert false end in Command.print_file file (fun fmt -> let fun_index = Wpo.Function(kf,None) in Wpo.iter ~index:fun_index ~on_goal:(on_goal fmt) ()); assert (!age_max >= Wpo.age wpo); FunFile.update kf (!age_max); end; let pid = wpo.Wpo.po_pid in { gfile = file; gtheory = Pretty_utils.to_string theory_name_of_pid pid; ggoal = why3_goal_name; } in [dir;shared], file let assemble_wpo wpo = match wpo.Wpo.po_formula with | Wpo.GoalAnnot vcq when Lang.F.p_true == Wpo.GOAL.compute_proof vcq.Wpo.VC_Annot.goal -> (** The wpo is trivial *) None | _ -> Some (Model.with_model wpo.Wpo.po_model assemble_wpo wpo) (* -------------------------------------------------------------------------- *) (* --- Running Why3 --- *) (* -------------------------------------------------------------------------- *) open ProverTask let p_goal = p_until_space ^ " " ^ p_until_space ^ " " ^ p_until_space ^ " : " let p_valid = p_goal ^ "Valid (" ^ p_float ^ "s)" let p_unknown = p_goal ^ "Unknown (" ^ p_float ^ "s)" let p_limit = p_goal ^ "Timeout" let p_error = "File " ^ p_string ^ ", line " ^ p_int ^ ", characters " ^ p_int ^ "-" ^ p_int ^ ":\n\\(warning:\\)?" let re_valid = Str.regexp p_valid let re_unknown = Str.regexp p_unknown let re_limit = Str.regexp p_limit let re_error = Str.regexp p_error type error = | Error_No | Error_Prover of string | Error_Generated of Lexing.position * string let rec split spec i = try let j = String.index_from spec i ':' in if j > i then String.sub spec i (j-i) :: split spec (succ j) else split spec (succ j) with Not_found -> let n = String.length spec - i in if n > 0 then [ String.sub spec i n ] else [] let chop_version spec = match split spec 0 with | [] | [_] -> spec | [a;b] -> Printf.sprintf "%s,%s," a b | a::b::c::_ -> Printf.sprintf "%s,%s,%s" a b c class why3 ~prover ~pid ~file ~includes ~logout ~logerr = object(why) inherit ProverTask.command "why3" val mutable files = [] val mutable error = Error_No val mutable valid = false val mutable limit = false val mutable time = 0.0 method private time t = time <- t method private error (a : pattern) = try let _warning = a#get_string 5 in () with Not_found -> let lpos = ProverTask.location (a#get_string 1) (a#get_int 2) in error <- Error_Generated ( lpos , a#get_after ~offset:1 4 ) method private unknown_prover (a : pattern) = error <- Error_Prover (a#get_string 0) method private valid (a : pattern) = begin valid <- true ; time <- a#get_float 4 ; end method private limit (_a : pattern) = begin limit <- true ; end method result r = if r = 0 && not valid && Wp_parameters.UnsatModel.get () then begin let message = Pretty_utils.sfprintf "Model for %a" WpPropId.pretty pid in ProverTask.pp_file ~message ~file:logout ; end ; match error with | Error_Prover message -> Wp_parameters.error "Why3:@\n%s" message; VCS.failed message | Error_Generated(pos,message) -> Wp_parameters.error ~source:pos "Why3 error:@\n%s" message ; VCS.failed ~pos message | Error_No -> if r = 0 then let verdict = if valid then VCS.Valid else if limit then VCS.Timeout else VCS.Unknown in VCS.result ~time verdict else begin ProverTask.pp_file ~message:"Why3 (stdout)" ~file:logout ; ProverTask.pp_file ~message:"Why3 (stderr)" ~file:logerr ; VCS.failed (Printf.sprintf "Why3 exits with status [%d]" r) end method prove = let time = Wp_parameters.Timeout.get () in why#add (Wp_parameters.WhyFlags.get ()) ; why#add [ file.gfile ] ; why#add ["-P";chop_version prover]; why#add ["-T";file.gtheory]; why#add ["-G";file.ggoal]; why#add_positive ~name:"-t" ~value:time ; (* [VP] This also keeps temp files. To be changed with FB's new option when it is implemented. *) if Wp_parameters.ProofTrace.get () || Wp_parameters.UnsatModel.get () then why#add ["--debug"; "call_prover"]; why#timeout time ; why#add_list ~name:"-I" includes; why#validate_time why#time ; (* The order is important. Warning are detected as error which they are not. *) why#validate_pattern ~logs:`OUT re_limit why#limit ; why#validate_pattern ~logs:`ERR re_error why#error ; why#validate_pattern ~logs:`OUT re_valid why#valid ; why#run ~logout ~logerr end open VCS open Wpo open Task let prove_file ~prover ~pid ~file ~includes ~logout ~logerr = let why = new why3 ~prover ~pid ~file ~includes ~logout ~logerr in why#prove () >>> function | Task.Timeout -> Task.return VCS.timeout | Task.Result r -> Task.call why#result r | st -> Task.status (Task.map (fun _ -> assert false) st) let prove_prop ~prover ~wpo = match assemble_wpo wpo with | None -> Task.return VCS.no_result | Some (includes,file) -> if Wp_parameters.Generate.get () then Task.return VCS.no_result else let model = wpo.po_model in let pid = wpo.Wpo.po_pid in let logout = DISK.file_logout ~pid ~model ~prover:(Why3 prover) in let logerr = DISK.file_logerr ~pid ~model ~prover:(Why3 prover) in prove_file ~prover ~pid ~file ~includes ~logout ~logerr let prove wpo ~prover = Task.todo (fun () -> prove_prop ~wpo ~prover) (* -------------------------------------------------------------------------- *) (* --- Why3-Ide --- *) (* -------------------------------------------------------------------------- *) class why3ide ~includes ~files ~session = object(why) inherit ProverTask.command "why3ide" method start () = why#add (Wp_parameters.WhyFlags.get ()) ; why#add_list ~name:"-I" includes; why#add [session]; why#add files; why#run ~echo:true () end let call_ide ~includes ~files ~session = if Wp_parameters.Generate.get () then Task.return false else let why = new why3ide ~includes ~files ~session in Task.todo why#start >>= fun s -> Task.return (s=0) (* -------------------------------------------------------------------------- *) (* --- Why3-Config --- *) (* -------------------------------------------------------------------------- *) type dp = { dp_name : string ; dp_version : string ; dp_prover : string ; } let find name dps = try List.find (fun d -> d.dp_prover = name) dps with Not_found -> let name = String.lowercase name in try List.find (fun d -> String.lowercase d.dp_name = name) dps with Not_found -> { dp_prover = name ; dp_name = name ; dp_version = "default" } let parse spec = try let k = String.index spec ':' in let dp_name = String.sub spec 0 k in let dp_version = String.sub spec (succ k) (String.length spec - k - 1) in for i = 0 to String.length dp_version - 1 do if dp_version.[i] = ':' then dp_version.[i] <- ' ' ; done ; { dp_prover = spec ; dp_name ; dp_version } with Not_found -> { dp_prover = spec ; dp_name = spec ; dp_version = "default" } let pe_prover = Str.regexp "\\([^ ]+\\) (\\([^)]+\\))" class why3detect job = object(why) inherit ProverTask.command "why3" val mutable dps = [] method result st = job (if st = 0 then Some (List.rev dps) else None) method prover p = begin let dp_name = p#get_string 1 in let dp_version = p#get_string 2 in Wp_parameters.debug ~level:1 "Prover %S, version %s detected." dp_name dp_version ; let dp_prover = Printf.sprintf "%s:%s" dp_name dp_version in for i = String.length dp_name + 1 to String.length dp_prover - 1 do match dp_prover.[i] with | ' ' | ',' -> dp_prover.[i] <- ':' | _ -> () done ; dps <- { dp_name ; dp_version ; dp_prover } :: dps end method detect : unit task = begin why#add [ "--list-provers" ] ; why#validate_pattern ~repeat:true ~logs:`OUT pe_prover why#prover ; why#run ~echo:true () >>= Task.call why#result end end let detect_why3 job = Task.run ((new why3detect job)#detect) let detect_provers job = detect_why3 (function None -> job [] | Some dps -> job dps) frama-c-Fluorine-20130601/src/wp/Cstring.ml0000644000175000017500000000763412155630215017167 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Strings --- *) (* -------------------------------------------------------------------------- *) open Definitions open Qed.Logic open Lang type cst = | C_str of string | W_str of int64 list module STR = struct type t = cst let compare = Pervasives.compare (* only comparable types *) let pretty fmt = function | C_str s -> Format.fprintf fmt "%S" s | W_str _ -> Format.fprintf fmt "\"L<...>\"" let hash (c:t) = Hashtbl.hash c land 0xFFFF end let pretty = STR.pretty let cluster () = Definitions.cluster ~id:"cstring" ~title:"String Literals" () module LIT = Model.Generator(STR) (struct type key = cst type data = int * F.term let name = "Cstring.Litterals" let hid = Hashtbl.create 31 let rec lookup id = if id=0 || Hashtbl.mem hid id then lookup (succ id) else (Hashtbl.add hid id () ; id) let export_literal lfun str = let chars = ref [] in let array = F.e_fun lfun [] in let n = String.length str in for i = 0 to n do let a = F.e_get array (F.e_int i) in let c = if i = n then F.e_zero else F.e_int (int_of_char str.[i]) in chars := (F.p_equal a c) :: !chars ; done ; define_lemma { l_name = Lang.Fun.id lfun ^ "_literal" ; l_cluster = cluster () ; l_assumed = true ; l_types = 0 ; l_forall = [] ; l_triggers = [] ; l_lemma = F.p_conj (List.rev !chars) ; } let compile s = let id = lookup (STR.hash s) in let lfun = Lang.generated_f ~result:(Sarray Sint) "Lit_%04X" id in define_symbol { d_lfun = lfun ; d_cluster = cluster () ; d_types = 0 ; d_params = [] ; d_definition = Logic (Array(Int,Int)) ; } ; if Wp_parameters.Literals.get () then begin match s with | C_str str -> export_literal lfun str | W_str _ -> Wp_parameters.warning ~current:false ~once:true "Content of wide string literals not exported." end ; id , F.e_fun lfun [] end) let str_id s = fst (LIT.get s) let str_val s = snd (LIT.get s) let str_len s n = match s with | C_str s -> F.p_equal n (F.e_int (String.length s)) | W_str _ -> F.p_lt F.e_zero n let char_at s k = F.e_get (str_val s) k frama-c-Fluorine-20130601/src/wp/Cint.mli0000644000175000017500000000456512155630215016624 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Arithmetic Model *) (* -------------------------------------------------------------------------- *) open Ctypes open Lang.F val of_real : c_int -> unop val iconvert : c_int -> unop val irange : c_int -> term -> pred type model = Natural | Machine val model : model Context.value val iopp : c_int -> unop val iadd : c_int -> binop val isub : c_int -> binop val imul : c_int -> binop val idiv : c_int -> binop val imod : c_int -> binop val bnot : c_int -> unop val band : c_int -> binop val bxor : c_int -> binop val bor : c_int -> binop val blsl : c_int -> binop val blsr : c_int -> binop val l_not : unop val l_and : binop val l_xor : binop val l_or : binop val l_lsl : binop val l_lsr : binop frama-c-Fluorine-20130601/src/wp/why3_xml.ml0000444000175000017500000014707112155634033017330 0ustar mehdimehdi# 34 "src/wp/why3_xml.mll" type element = { name : string; attributes : (string * string) list; elements : element list; } type t = { version : string; encoding : string; doctype : string; dtd : string; content : element; } let buf = Buffer.create 17 let rec pop_all group_stack element_stack = match group_stack with | [] -> element_stack | (elem,att,elems)::g -> let e = { name = elem; attributes = att; elements = List.rev element_stack; } in pop_all g (e::elems) exception Parse_error of string let parse_error s = raise (Parse_error s) # 35 "src/wp/why3_xml.ml" let __ocaml_lex_tables = { Lexing.lex_base = "\000\000\251\255\000\000\002\000\000\000\000\000\000\000\007\000\ \002\000\003\000\009\000\004\000\005\000\006\000\008\000\011\000\ \013\000\012\000\014\000\016\000\015\000\032\000\018\000\027\000\ \074\000\019\000\023\000\254\255\025\000\028\000\026\000\029\000\ \030\000\033\000\036\000\052\000\031\000\041\000\037\000\065\000\ \055\000\067\000\122\000\132\000\040\000\253\255\252\255\134\000\ \253\255\000\000\014\000\030\000\024\000\045\000\030\000\028\000\ \053\000\069\000\139\000\087\001\201\001\146\000\254\255\084\000\ \178\000\250\255\251\255\021\002\148\000\096\002\171\002\029\003\ \253\255\160\000\143\003\250\255\251\255\000\000\253\255\001\004\ \173\000\254\255\180\000\115\004\252\255\215\000\252\255\253\255\ \254\255\187\000\017\000\248\255\249\255\071\000\255\255\041\000\ \034\000\044\000\046\000\104\000\254\255\106\000\253\255\056\000\ \056\000\117\000\252\255\065\000\070\000\083\000\140\000\251\255\ \142\000\250\255"; Lexing.lex_backtrk = "\255\255\255\255\004\000\000\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\002\000\000\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\003\000\000\000\255\255\001\000\255\255\ \255\255\255\255\255\255\255\255\255\255\004\000\255\255\004\000\ \000\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\000\000\255\255\255\255\255\255\006\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"; Lexing.lex_default = "\001\000\000\000\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\000\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\000\000\000\000\048\000\ \000\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\063\000\000\000\063\000\ \065\000\000\000\000\000\255\255\255\255\255\255\255\255\255\255\ \000\000\255\255\076\000\000\000\000\000\255\255\000\000\255\255\ \255\255\000\000\255\255\255\255\000\000\087\000\000\000\000\000\ \000\000\255\255\092\000\000\000\000\000\255\255\000\000\255\255\ \255\255\255\255\255\255\255\255\000\000\255\255\000\000\255\255\ \255\255\255\255\000\000\255\255\255\255\255\255\255\255\000\000\ \255\255\000\000"; Lexing.lex_trans = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\003\000\003\000\003\000\003\000\000\000\003\000\ \010\000\010\000\010\000\010\000\010\000\000\000\010\000\050\000\ \050\000\000\000\000\000\050\000\000\000\000\000\000\000\000\000\ \003\000\051\000\003\000\000\000\024\000\024\000\000\000\010\000\ \024\000\010\000\000\000\000\000\000\000\000\000\050\000\000\000\ \019\000\000\000\000\000\094\000\023\000\000\000\000\000\093\000\ \000\000\000\000\000\000\024\000\002\000\021\000\084\000\004\000\ \046\000\020\000\008\000\008\000\008\000\008\000\008\000\008\000\ \008\000\018\000\008\000\008\000\008\000\008\000\008\000\008\000\ \022\000\008\000\008\000\024\000\024\000\027\000\036\000\024\000\ \008\000\008\000\008\000\008\000\008\000\008\000\008\000\008\000\ \008\000\035\000\052\000\008\000\008\000\042\000\045\000\053\000\ \008\000\012\000\024\000\039\000\007\000\006\000\040\000\041\000\ \054\000\015\000\055\000\008\000\037\000\056\000\008\000\013\000\ \005\000\014\000\016\000\017\000\029\000\038\000\031\000\011\000\ \008\000\028\000\008\000\043\000\043\000\057\000\032\000\043\000\ \034\000\026\000\058\000\030\000\033\000\043\000\043\000\050\000\ \050\000\043\000\062\000\050\000\059\000\059\000\107\000\103\000\ \059\000\108\000\043\000\061\000\061\000\068\000\068\000\061\000\ \101\000\068\000\099\000\100\000\043\000\102\000\050\000\104\000\ \095\000\073\000\073\000\059\000\105\000\073\000\097\000\025\000\ \106\000\112\000\061\000\098\000\068\000\109\000\080\000\080\000\ \096\000\008\000\080\000\068\000\068\000\082\000\082\000\068\000\ \073\000\082\000\049\000\044\000\089\000\089\000\110\000\111\000\ \089\000\113\000\000\000\000\000\000\000\080\000\000\000\000\000\ \062\000\000\000\068\000\000\000\082\000\000\000\000\000\000\000\ \000\000\000\000\000\000\089\000\000\000\000\000\072\000\000\000\ \089\000\089\000\000\000\000\000\089\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\067\000\000\000\ \000\000\081\000\000\000\000\000\000\000\000\000\000\000\089\000\ \000\000\088\000\000\000\000\000\000\000\000\000\000\000\000\000\ \255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\000\000\255\255\255\255\255\255\255\255\255\255\ \255\255\091\000\255\255\255\255\000\000\000\000\000\000\255\255\ \000\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\000\000\000\000\255\255\255\255\000\000\000\000\ \255\255\255\255\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\255\255\000\000\000\000\255\255\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\255\255\000\000\255\255\000\000\000\000\000\000\000\000\ \000\000\000\000\255\255\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\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\ \059\000\059\000\000\000\000\000\059\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\059\000\ \000\000\000\000\255\255\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\255\255\000\000\255\255\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\000\000\255\255\000\000\000\000\000\000\000\000\000\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\066\000\000\000\000\000\000\000\060\000\000\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\061\000\061\000\000\000\000\000\061\000\086\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\061\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\000\000\000\000\000\000\000\000\ \060\000\000\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\069\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \000\000\000\000\000\000\000\000\070\000\000\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\000\000\000\000\000\000\000\000\071\000\ \000\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\000\000\000\000\ \000\000\000\000\070\000\000\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\073\000\073\000\ \000\000\000\000\073\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\073\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\000\000\ \000\000\000\000\000\000\072\000\000\000\000\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \000\000\000\000\000\000\000\000\071\000\000\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \080\000\080\000\000\000\000\000\080\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\080\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\077\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\000\000\000\000\000\000\000\000\078\000\000\000\000\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\000\000\000\000\000\000\000\000\079\000\000\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\082\000\082\000\000\000\000\000\082\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\082\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\000\000\000\000\000\000\081\000\000\000\ \000\000\000\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\000\000\000\000\000\000\000\000\ \083\000\000\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\082\000\082\000\000\000\000\000\ \082\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\075\000\ \000\000\000\000\000\000\082\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\000\000\000\000\000\000\ \081\000\000\000\000\000\000\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\000\000\000\000\ \000\000\000\000\083\000\000\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \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\003\000\003\000\000\000\255\255\003\000\ \007\000\007\000\010\000\010\000\007\000\255\255\010\000\050\000\ \050\000\255\255\255\255\050\000\255\255\255\255\255\255\255\255\ \000\000\049\000\003\000\255\255\023\000\023\000\255\255\007\000\ \023\000\010\000\255\255\255\255\255\255\255\255\050\000\255\255\ \018\000\255\255\255\255\090\000\022\000\255\255\255\255\090\000\ \255\255\255\255\255\255\023\000\000\000\020\000\077\000\002\000\ \008\000\019\000\009\000\011\000\012\000\013\000\007\000\014\000\ \010\000\017\000\015\000\017\000\016\000\018\000\020\000\019\000\ \021\000\022\000\025\000\024\000\024\000\026\000\035\000\024\000\ \028\000\030\000\023\000\029\000\031\000\032\000\036\000\021\000\ \033\000\034\000\051\000\034\000\038\000\041\000\044\000\052\000\ \037\000\011\000\024\000\038\000\006\000\005\000\039\000\040\000\ \053\000\014\000\054\000\035\000\036\000\055\000\040\000\012\000\ \004\000\013\000\015\000\016\000\028\000\037\000\030\000\010\000\ \039\000\025\000\041\000\042\000\042\000\056\000\031\000\042\000\ \033\000\024\000\057\000\029\000\032\000\043\000\043\000\047\000\ \047\000\043\000\063\000\047\000\058\000\058\000\095\000\096\000\ \058\000\095\000\042\000\061\000\061\000\068\000\068\000\061\000\ \097\000\068\000\098\000\099\000\043\000\101\000\047\000\103\000\ \093\000\073\000\073\000\058\000\104\000\073\000\093\000\024\000\ \105\000\107\000\061\000\093\000\068\000\108\000\080\000\080\000\ \093\000\042\000\080\000\064\000\064\000\082\000\082\000\064\000\ \073\000\082\000\047\000\043\000\089\000\089\000\109\000\110\000\ \089\000\112\000\255\255\255\255\255\255\080\000\255\255\255\255\ \061\000\255\255\064\000\255\255\082\000\255\255\255\255\255\255\ \255\255\255\255\255\255\089\000\255\255\255\255\073\000\255\255\ \085\000\085\000\255\255\255\255\085\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\064\000\255\255\ \255\255\082\000\255\255\255\255\255\255\255\255\255\255\085\000\ \255\255\085\000\255\255\255\255\255\255\255\255\255\255\255\255\ \000\000\255\255\008\000\009\000\011\000\012\000\013\000\007\000\ \014\000\010\000\255\255\015\000\017\000\016\000\018\000\020\000\ \019\000\090\000\022\000\025\000\255\255\255\255\255\255\026\000\ \255\255\028\000\030\000\023\000\029\000\031\000\032\000\036\000\ \021\000\033\000\255\255\255\255\034\000\038\000\255\255\255\255\ \044\000\037\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\035\000\255\255\255\255\040\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\039\000\255\255\041\000\255\255\255\255\255\255\255\255\ \255\255\255\255\024\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\063\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \059\000\059\000\255\255\255\255\059\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\059\000\ \255\255\255\255\042\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\043\000\255\255\047\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\255\255\061\000\255\255\255\255\255\255\255\255\255\255\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\064\000\255\255\255\255\255\255\059\000\255\255\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\060\000\060\000\255\255\255\255\060\000\085\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\060\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\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\255\255\255\255\255\255\255\255\ \060\000\255\255\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \255\255\255\255\255\255\255\255\067\000\255\255\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\255\255\255\255\255\255\255\255\069\000\ \255\255\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\255\255\255\255\ \255\255\255\255\070\000\255\255\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\070\000\070\000\ \070\000\070\000\070\000\070\000\070\000\070\000\071\000\071\000\ \255\255\255\255\071\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\071\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\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\255\255\ \255\255\255\255\255\255\071\000\255\255\255\255\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \255\255\255\255\255\255\255\255\071\000\255\255\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \074\000\074\000\255\255\255\255\074\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\074\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\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\255\255\255\255\255\255\255\255\074\000\255\255\255\255\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\255\255\255\255\255\255\255\255\074\000\255\255\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\079\000\079\000\255\255\255\255\079\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\079\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\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\255\255\255\255\255\255\079\000\255\255\ \255\255\255\255\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\255\255\255\255\255\255\255\255\ \079\000\255\255\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\083\000\083\000\255\255\255\255\ \083\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\074\000\ \255\255\255\255\255\255\083\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\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\255\255\255\255\255\255\ \083\000\255\255\255\255\255\255\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\255\255\255\255\ \255\255\255\255\083\000\255\255\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\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\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 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\002\000\077\000\000\000\007\000\000\000\ \000\000\000\000\000\000\000\000\000\000\152\000\000\000\227\000\ \015\000\000\000\046\001\000\000\000\000\000\000\000\000\121\001\ \000\000\015\000\000\000\196\001\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\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_backtrk_code = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\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_default_code = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\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_trans_code = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\001\000\001\000\001\000\001\000\001\000\000\000\001\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \001\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\000\000\000\000\000\000\ \000\000\004\000\000\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \000\000\000\000\000\000\000\000\004\000\000\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\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\012\000\000\000\000\000\000\000\000\000\012\000\ \000\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\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\012\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\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\012\000\000\000\000\000\ \000\000\000\000\012\000\000\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\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\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\ \012\000\000\000\000\000\000\000\000\000\012\000\000\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\ \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\012\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\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\012\000\000\000\000\000\000\000\000\000\ \012\000\000\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\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\012\000\012\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\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\012\000\000\000\ \000\000\000\000\000\000\012\000\000\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\012\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\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_code = "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\058\000\058\000\059\000\059\000\058\000\255\255\059\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\ \058\000\255\255\059\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\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\255\255\255\255\255\255\ \255\255\059\000\255\255\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ \059\000\059\000\059\000\059\000\059\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \255\255\255\255\255\255\255\255\060\000\255\255\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\255\255\255\255\255\255\255\255\069\000\ \255\255\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\069\000\069\000\069\000\ \069\000\069\000\069\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\255\255\255\255\ \255\255\255\255\071\000\255\255\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\071\000\071\000\ \071\000\071\000\071\000\071\000\071\000\071\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\255\255\255\255\255\255\255\255\074\000\255\255\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ \074\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\255\255\255\255\255\255\255\255\ \079\000\255\255\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\079\000\079\000\079\000\079\000\ \079\000\079\000\079\000\079\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\255\255\ \255\255\255\255\255\255\083\000\255\255\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\000\083\000\ \083\000\083\000\083\000\083\000\083\000\083\000\083\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\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_code = "\255\002\255\255\003\255\255\000\002\001\003\255\001\255\255\000\ \001\255"; } let rec xml_prolog lexbuf = __ocaml_lex_xml_prolog_rec lexbuf 0 and __ocaml_lex_xml_prolog_rec lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 79 "src/wp/why3_xml.mll" ( xml_prolog lexbuf ) # 677 "src/wp/why3_xml.ml" | 1 -> # 81 "src/wp/why3_xml.mll" ( xml_doctype "1.0" "" lexbuf ) # 682 "src/wp/why3_xml.ml" | 2 -> # 83 "src/wp/why3_xml.mll" ( xml_doctype "1.0" "" lexbuf ) # 687 "src/wp/why3_xml.ml" | 3 -> # 85 "src/wp/why3_xml.mll" ( (* dprintf debug "[Xml warning] prolog ignored@."; *) xml_doctype "1.0" "" lexbuf ) # 693 "src/wp/why3_xml.ml" | 4 -> # 88 "src/wp/why3_xml.mll" ( parse_error "wrong prolog" ) # 698 "src/wp/why3_xml.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_xml_prolog_rec lexbuf __ocaml_lex_state and xml_doctype version encoding lexbuf = lexbuf.Lexing.lex_mem <- Array.create 4 (-1) ; __ocaml_lex_xml_doctype_rec version encoding lexbuf 47 and __ocaml_lex_xml_doctype_rec version encoding lexbuf __ocaml_lex_state = match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 92 "src/wp/why3_xml.mll" ( xml_doctype version encoding lexbuf ) # 709 "src/wp/why3_xml.ml" | 1 -> let # 93 "src/wp/why3_xml.mll" doctype # 715 "src/wp/why3_xml.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) lexbuf.Lexing.lex_mem.(1) in # 94 "src/wp/why3_xml.mll" ( match elements [] [] lexbuf with | [x] -> { version = version; encoding = encoding; doctype = doctype; dtd = ""; content = x; } | _ -> parse_error "there should be exactly one root element" ) # 728 "src/wp/why3_xml.ml" | 2 -> # 105 "src/wp/why3_xml.mll" ( parse_error "wrong DOCTYPE" ) # 733 "src/wp/why3_xml.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_xml_doctype_rec version encoding lexbuf __ocaml_lex_state and elements group_stack element_stack lexbuf = lexbuf.Lexing.lex_mem <- Array.create 2 (-1) ; __ocaml_lex_elements_rec group_stack element_stack lexbuf 64 and __ocaml_lex_elements_rec group_stack element_stack lexbuf __ocaml_lex_state = match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 109 "src/wp/why3_xml.mll" ( elements group_stack element_stack lexbuf ) # 744 "src/wp/why3_xml.ml" | 1 -> let # 110 "src/wp/why3_xml.mll" elem # 750 "src/wp/why3_xml.ml" = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) lexbuf.Lexing.lex_curr_pos in # 111 "src/wp/why3_xml.mll" ( attributes group_stack element_stack elem [] lexbuf ) # 754 "src/wp/why3_xml.ml" | 2 -> let # 112 "src/wp/why3_xml.mll" _celem # 760 "src/wp/why3_xml.ml" = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 2) lexbuf.Lexing.lex_mem.(0) in # 113 "src/wp/why3_xml.mll" ( match group_stack with | [] -> (* dprintf debug *) (* "[Xml warning] unexpected closing Xml element `%s'@." *) (* celem; *) elements group_stack element_stack lexbuf | (elem,att,stack)::g -> (* if celem <> elem then *) (* dprintf debug *) (* "[Xml warning] Xml element `%s' closed by `%s'@." *) (* elem celem; *) let e = { name = elem; attributes = att; elements = List.rev element_stack; } in elements g (e::stack) lexbuf ) # 781 "src/wp/why3_xml.ml" | 3 -> # 132 "src/wp/why3_xml.mll" ( (* dprintf debug "[Xml warning] unexpected '<'@."; *) elements group_stack element_stack lexbuf ) # 787 "src/wp/why3_xml.ml" | 4 -> # 135 "src/wp/why3_xml.mll" ( match group_stack with | [] -> element_stack | (_elem,_,_)::_ -> (* dprintf debug "[Xml warning] unclosed Xml element `%s'@." elem; *) pop_all group_stack element_stack ) # 798 "src/wp/why3_xml.ml" | 5 -> let # 142 "src/wp/why3_xml.mll" c # 804 "src/wp/why3_xml.ml" = Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in # 143 "src/wp/why3_xml.mll" ( parse_error ("invalid element starting with " ^ String.make 1 c) ) # 808 "src/wp/why3_xml.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_elements_rec group_stack element_stack lexbuf __ocaml_lex_state and attributes groupe_stack element_stack elem acc lexbuf = lexbuf.Lexing.lex_mem <- Array.create 2 (-1) ; __ocaml_lex_attributes_rec groupe_stack element_stack elem acc lexbuf 74 and __ocaml_lex_attributes_rec groupe_stack element_stack elem acc lexbuf __ocaml_lex_state = match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 147 "src/wp/why3_xml.mll" ( attributes groupe_stack element_stack elem acc lexbuf ) # 819 "src/wp/why3_xml.ml" | 1 -> let # 148 "src/wp/why3_xml.mll" key # 825 "src/wp/why3_xml.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_mem.(0) in # 149 "src/wp/why3_xml.mll" ( let v = value lexbuf in attributes groupe_stack element_stack elem ((key,v)::acc) lexbuf ) # 830 "src/wp/why3_xml.ml" | 2 -> # 152 "src/wp/why3_xml.mll" ( elements ((elem,acc,element_stack)::groupe_stack) [] lexbuf ) # 835 "src/wp/why3_xml.ml" | 3 -> # 154 "src/wp/why3_xml.mll" ( let e = { name = elem ; attributes = acc; elements = [] } in elements groupe_stack (e::element_stack) lexbuf ) # 844 "src/wp/why3_xml.ml" | 4 -> let # 159 "src/wp/why3_xml.mll" c # 850 "src/wp/why3_xml.ml" = Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in # 160 "src/wp/why3_xml.mll" ( parse_error ("'>' expected, got " ^ String.make 1 c) ) # 854 "src/wp/why3_xml.ml" | 5 -> # 162 "src/wp/why3_xml.mll" ( parse_error "unclosed element, `>' expected" ) # 859 "src/wp/why3_xml.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_attributes_rec groupe_stack element_stack elem acc lexbuf __ocaml_lex_state and value lexbuf = __ocaml_lex_value_rec lexbuf 85 and __ocaml_lex_value_rec lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 166 "src/wp/why3_xml.mll" ( value lexbuf ) # 870 "src/wp/why3_xml.ml" | 1 -> # 168 "src/wp/why3_xml.mll" ( Buffer.clear buf; string_val lexbuf ) # 876 "src/wp/why3_xml.ml" | 2 -> let # 170 "src/wp/why3_xml.mll" c # 882 "src/wp/why3_xml.ml" = Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in # 171 "src/wp/why3_xml.mll" ( parse_error ("invalid value starting with " ^ String.make 1 c) ) # 886 "src/wp/why3_xml.ml" | 3 -> # 173 "src/wp/why3_xml.mll" ( parse_error "unterminated keyval pair" ) # 891 "src/wp/why3_xml.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_value_rec lexbuf __ocaml_lex_state and string_val lexbuf = __ocaml_lex_string_val_rec lexbuf 90 and __ocaml_lex_string_val_rec lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 177 "src/wp/why3_xml.mll" ( Buffer.contents buf ) # 902 "src/wp/why3_xml.ml" | 1 -> # 179 "src/wp/why3_xml.mll" ( Buffer.add_char buf '<'; string_val lexbuf ) # 908 "src/wp/why3_xml.ml" | 2 -> # 182 "src/wp/why3_xml.mll" ( Buffer.add_char buf '>'; string_val lexbuf ) # 914 "src/wp/why3_xml.ml" | 3 -> # 185 "src/wp/why3_xml.mll" ( Buffer.add_char buf '"'; string_val lexbuf ) # 920 "src/wp/why3_xml.ml" | 4 -> # 188 "src/wp/why3_xml.mll" ( Buffer.add_char buf '\''; string_val lexbuf ) # 926 "src/wp/why3_xml.ml" | 5 -> # 191 "src/wp/why3_xml.mll" ( Buffer.add_char buf '&'; string_val lexbuf ) # 932 "src/wp/why3_xml.ml" | 6 -> let # 193 "src/wp/why3_xml.mll" c # 938 "src/wp/why3_xml.ml" = Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in # 194 "src/wp/why3_xml.mll" ( Buffer.add_char buf c; string_val lexbuf ) # 943 "src/wp/why3_xml.ml" | 7 -> # 197 "src/wp/why3_xml.mll" ( parse_error "unterminated string" ) # 948 "src/wp/why3_xml.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_string_val_rec lexbuf __ocaml_lex_state ;; # 199 "src/wp/why3_xml.mll" let from_file f = let c = open_in f in let lb = Lexing.from_channel c in let t = xml_prolog lb in close_in c; t # 965 "src/wp/why3_xml.ml" frama-c-Fluorine-20130601/src/wp/Cleaning.mli0000644000175000017500000000412112155630215017433 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Variables Cleaning --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Lang open Lang.F type usage val create : unit -> usage val as_atom : usage -> pred -> unit val as_type : usage -> pred -> unit val as_have : usage -> pred -> unit val filter_type : usage -> pred -> pred val filter_pred : usage -> pred -> pred frama-c-Fluorine-20130601/src/wp/Lang.mli0000644000175000017500000002112112155630215016573 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Qed open Qed.Logic (** Logic Language based on Qed *) (** {2 Naming} Unique identifiers. *) val comp_id : compinfo -> string val field_id : fieldinfo -> string val type_id : logic_type_info -> string val logic_id : logic_info -> string val lemma_id : string -> string (** {2 Theory} *) type theory = string (** {2 Symbols} *) type adt = private | Mtype of mdt (** External type *) | Mrecord of mdt * fields (** External record-type *) | Atype of logic_type_info (** Logic Type *) | Comp of compinfo (** C-code struct or union *) and mdt = { mdt_link : string ; mdt_theory : theory ; } and fields = { mutable fields : field list } and field = | Mfield of mdt * fields * string * tau | Cfield of fieldinfo and tau = (field,adt) Logic.datatype type scope = External of theory | Generated type lfun = | Function of lfunction | Predicate of lpredicate | ACSL of logic_info | CTOR of logic_ctor_info and lfunction = { f_scope : scope ; f_link : Engine.link ; f_category : lfun category ; f_params : sort list ; f_result : sort ; } and lpredicate = { p_scope : scope ; p_params : sort list ; p_prop : string ; p_bool : string ; } val builtin : name:string -> link:string -> theory:string -> unit val datatype : link:string -> theory:string -> adt val record : link:string -> theory:string -> (string * tau) list -> adt val atype : logic_type_info -> adt val comp : compinfo -> adt val field : adt -> string -> field val fields_of_tau : tau -> field list val fields_of_field : field -> field list type balance = Nary | Left | Right val extern_s : theory:theory -> ?balance:balance -> ?category:lfun category -> ?params:sort list -> ?result:sort -> string -> lfun val extern_f : theory:theory -> ?balance:balance -> ?category:lfun category -> ?params:sort list -> ?result:sort -> ('a,Format.formatter,unit,lfun) format4 -> 'a val extern_p : theory:theory -> prop:string -> bool:string -> ?params:sort list -> unit -> lfun val extern_fp : theory:theory -> ?params:sort list -> string -> lfun val generated_f : ?category:lfun category -> ?params:sort list -> ?result:sort -> ('a,Format.formatter,unit,lfun) format4 -> 'a val generated_p : string -> lfun val link : Engine.cmode -> lfun -> Engine.link val theory : lfun -> string (** {2 Sorting and Typing} *) val tau_of_comp : compinfo -> tau val tau_of_object : c_object -> tau val tau_of_ctype : typ -> tau val tau_of_ltype : logic_type -> tau val tau_of_return : logic_info -> tau val tau_of_lfun : lfun -> tau val tau_of_field : field -> tau val tau_of_record : field -> tau val array : tau -> tau val farray : tau -> tau -> tau val pointer : (typ -> tau) Context.value (** type of pointers *) val poly : string list Context.value (** polymorphism *) (** {2 Logic Formulae} *) module ADT : Logic.Data with type t = adt module Field : Logic.Field with type t = field module Fun : Logic.Function with type t = lfun module F : sig (** {3 Expressions} *) include Logic.Term with module ADT = ADT and module Field = Field and module Fun = Fun type unop = term -> term type binop = term -> term -> term val e_zero : term val e_one : term val e_minus_one : term val e_zero_real : term val e_int64 : int64 -> term val e_fact : int64 -> term -> term val e_bigint : Integer.t -> term val e_mthfloat : float -> term val e_hexfloat : float -> term val e_setfield : term -> field -> term -> term val e_range : term -> term -> term (** e_range a b = b+1-a *) val is_zero : term -> bool (** {3 Predicates} *) type pred type cmp = term -> term -> pred val p_true : pred val p_false : pred val p_equal : term -> term -> pred val p_neq : term -> term -> pred val p_leq : term -> term -> pred val p_lt : term -> term -> pred val p_positive : term -> pred val is_ptrue : pred -> Logic.maybe val is_pfalse : pred -> Logic.maybe val is_equal : term -> term -> Logic.maybe val eqp : pred -> pred -> bool val comparep : pred -> pred -> int val p_bool : term -> pred val e_prop : pred -> term val p_bools : term list -> pred list val e_props : pred list -> term list val lift : (term -> term) -> pred -> pred val p_not : pred -> pred val p_and : pred -> pred -> pred val p_or : pred -> pred -> pred val p_imply : pred -> pred -> pred val p_equiv : pred -> pred -> pred val p_hyps : pred list -> pred -> pred val p_if : pred -> pred -> pred -> pred val p_conj : pred list -> pred val p_disj : pred list -> pred val p_any : ('a -> pred) -> 'a list -> pred val p_all : ('a -> pred) -> 'a list -> pred val p_call : lfun -> term list -> pred val p_forall : var list -> pred -> pred val p_exists : var list -> pred -> pred val p_bind : binder -> var -> pred -> pred val p_subst : ?pool:pool -> var -> term -> pred -> pred val p_close : pred -> pred val idp : pred -> int val varsp : pred -> Vars.t val occurs : var -> term -> bool val occursp : var -> pred -> bool val intersect : term -> term -> bool val intersectp : pred -> pred -> bool val pp_var : Format.formatter -> var -> unit val pp_vars : Format.formatter -> Vars.t -> unit val pp_term : Format.formatter -> term -> unit val pp_pred : Format.formatter -> pred -> unit val debugp : Format.formatter -> pred -> unit type env val empty : env val closed : Vars.t -> env val marker : env -> marks val mark_e : marks -> term -> unit val mark_p : marks -> pred -> unit val define : (env -> string -> term -> unit) -> env -> marks -> env val pp_eterm : env -> Format.formatter -> term -> unit val pp_epred : env -> Format.formatter -> pred -> unit val pred : pred -> (field,lfun,var,pred) Logic.term_repr module Pmap : Qed.Idxmap.S with type key = pred module Pset : Qed.Idxset.S with type elt = pred type pattern = Fun.t Qed.Pattern.fpattern val rewrite : name:string -> vars:tau array -> pattern -> (term array -> term) -> unit val add_builtin_1 : lfun -> (term -> term) -> unit val add_builtin_2 : lfun -> (term -> term -> term) -> unit val add_builtin_peq : lfun -> (term -> term -> pred) -> unit end (** {2 Fresh Variables and Constraints} *) open F type gamma val new_pool : ?copy:pool -> unit -> pool val new_gamma : ?copy:gamma -> unit -> gamma val local : ?pool:pool -> ?gamma:gamma -> ('a -> 'b) -> 'a -> 'b val freshvar : ?basename:string -> tau -> var val freshen : var -> var val assume : pred -> unit val without_assume : ('a -> 'b) -> 'a -> 'b val epsilon : ?basename:string -> tau -> (term -> pred) -> term val hypotheses : gamma -> pred list val variables : gamma -> var list val get_pool : unit -> pool val get_gamma : unit -> gamma val get_hypotheses : unit -> pred list val get_variables : unit -> var list (** {2 Alpha Conversion} *) module Alpha : sig type t val create : unit -> t val get : t -> var -> var val iter : (var -> var -> unit) -> t -> unit val convert : t -> term -> term val convertp : t -> pred -> pred end (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/VCS.mli0000644000175000017500000000662212155630215016356 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Verification Conditions Database *) (* -------------------------------------------------------------------------- *) (** {2 Prover} *) type prover = | Why3 of string (* Prover via WHY *) | Why3ide | AltErgo (* Alt-Ergo *) | Coq (* Coq and Coqide *) | Qed (* Qed Solver *) type language = | L_why3 | L_coq | L_altergo (* -------------------------------------------------------------------------- *) (* --- Prover Names --- *) (* -------------------------------------------------------------------------- *) val language_of_prover : prover -> language val language_of_name : string -> language option val name_of_prover : prover -> string val filename_for_prover : prover -> string val prover_of_name : string -> prover option val language_of_prover_name: string -> language option val is_interactive : string -> bool val pp_prover : Format.formatter -> prover -> unit val pp_language : Format.formatter -> language -> unit val cmp_prover : prover -> prover -> int (** {2 Results} *) type verdict = | NoResult | Invalid | Unknown | Timeout | Stepout | Computing of (unit -> unit) (* kill function *) | Valid | Failed type result = { verdict : verdict ; solver_time : float ; prover_time : float ; prover_steps : int ; prover_errpos : Lexing.position option ; prover_errmsg : string ; } val no_result : result val valid : result val invalid : result val unknown : result val timeout : result val stepout : result val computing : (unit -> unit) -> result val failed : ?pos:Lexing.position -> string -> result val result : ?solver:float -> ?time:float -> ?steps:int -> verdict -> result val pp_result : Format.formatter -> result -> unit frama-c-Fluorine-20130601/src/wp/ProverTask.ml0000644000175000017500000002257512155630215017657 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Library for Running Provers --- *) (* -------------------------------------------------------------------------- *) open Task (* -------------------------------------------------------------------------- *) (* --- Export Printer --- *) (* -------------------------------------------------------------------------- *) class printer fmt title = let bar = String.make 50 '-' in object(self) val mutable lastpar = true initializer begin Format.fprintf fmt "(* ----%s---- *)@\n" bar ; Format.fprintf fmt "(* --- %-50s --- *)@\n" title ; Format.fprintf fmt "(* ----%s---- *)@\n" bar ; end method paragraph = Format.pp_print_newline fmt () ; lastpar <- true method lines = if lastpar then Format.pp_print_newline fmt () ; lastpar <- false method hline = self#paragraph ; Format.fprintf fmt "(* %s *)@\n" bar method section s = self#paragraph ; Format.fprintf fmt "(* --- %-20s --- *)@\n" s method printf : 'a. ('a,Format.formatter,unit) format -> 'a = fun msg -> Format.fprintf fmt msg end (* -------------------------------------------------------------------------- *) (* --- Buffer Validation --- *) (* -------------------------------------------------------------------------- *) class type pattern = object method get_after : ?offset:int -> int -> string method get_string : int -> string method get_int : int -> int method get_float : int -> float end class group text = object method search re pos = ignore (Str.search_forward re text pos) method next = Str.match_end () method get_after ?(offset=0) k = try let n = String.length text in let p = Str.group_end k + offset + 1 in if p >= n then "" else String.sub text p (n-p) with Not_found -> "" method get_string k = try Str.matched_group k text with Not_found -> "" method get_int k = try int_of_string (Str.matched_group k text) with Not_found | Failure _ -> 0 method get_float k = try float_of_string (Str.matched_group k text) with Not_found | Failure _ -> 0.0 end let rec validate_pattern ((re,all,job) as p) group pos = group#search re pos ; job (group :> pattern) ; if all then validate_pattern p group group#next let validate_buffer buffer validers = let text = Buffer.contents buffer in let group = new group text in List.iter (fun pattern -> try validate_pattern pattern group 0 with Not_found -> () ) validers let dump_buffer buffer = function | None -> () | Some log -> let n = Buffer.length buffer in if n > 0 then Command.write_file log (fun out -> Buffer.output_buffer out buffer) else if Wp_parameters.is_out () then Extlib.safe_remove log let echo_buffer buffer = let n = Buffer.length buffer in if n > 0 then Log.print_on_output (fun fmt -> Format.pp_print_string fmt (Buffer.contents buffer) ; Format.pp_print_flush fmt () ; ) let location file line = { Lexing.pos_fname = file ; Lexing.pos_lnum = line ; Lexing.pos_bol = 0 ; Lexing.pos_cnum = 0 ; } let pp_file ~message ~file = if Sys.file_exists file then Log.print_on_output begin fun fmt -> let bar = String.make 60 '-' in Format.fprintf fmt "%s@\n" bar ; Format.fprintf fmt "--- %s :@\n" message ; Format.fprintf fmt "%s@\n" bar ; Command.pp_from_file fmt file ; Format.fprintf fmt "%s@\n" bar ; end (* -------------------------------------------------------------------------- *) (* --- Prover Task --- *) (* -------------------------------------------------------------------------- *) let p_group p = Printf.sprintf "\\(%s\\)" p let p_int = "\\([0-9]+\\)" let p_float = "\\([0-9.]+\\)" let p_string = "\"\\([^\"]*\\)\"" let p_until_space = "\\([^ \t\n]*\\)" type logs = [ `OUT | `ERR | `BOTH ] let is_out = function `OUT | `BOTH -> true | `ERR -> false let is_err = function `ERR | `BOTH -> true | `OUT -> false class command name = object val mutable once = true val mutable cmd = name val mutable param : string list = [] val mutable timeout = 0 val mutable validout = [] val mutable validerr = [] val mutable timers = [] val stdout = Buffer.create 256 val stderr = Buffer.create 256 method set_command name = cmd <- name method add args = param <- param @ args method add_parameter ~name phi = if phi () then param <- param @ [name] method add_int ~name ~value = param <- param @ [ name ; string_of_int value ] method add_positive ~name ~value = if value > 0 then param <- param @ [ name ; string_of_int value ] method add_float ~name ~value = param <- param @ [ name ; string_of_float value ] method add_list ~name values = List.iter (fun v -> param <- param @ [ name ; v ]) values method timeout t = timeout <- t method validate_pattern ?(logs=`BOTH) ?(repeat=false) regexp (handler : pattern -> unit) = begin let v = [regexp,repeat,handler] in if is_out (logs:logs) then validout <- validout @ v ; if is_out (logs:logs) then validerr <- validerr @ v ; end method validate_time phi = timers <- timers @ [phi] method run ?(echo=false) ?logout ?logerr () : int Task.task = assert once ; once <- false ; let time = ref 0.0 in let args = Array.of_list param in Buffer.clear stdout ; Buffer.clear stderr ; Task.command ~timeout ~time ~stdout ~stderr cmd args >>? begin fun st -> (* finally *) if Wp_parameters.has_dkey "prover" then Log.print_on_output begin fun fmt -> Format.fprintf fmt "@[RUN '%s" cmd ; Array.iter (fun p -> Format.fprintf fmt "@ %s" p) args ; Format.fprintf fmt "'@]@." ; Format.fprintf fmt "RESULT %a@." (Task.pretty Format.pp_print_int) st ; Format.fprintf fmt "OUT:@\n%s" (Buffer.contents stdout) ; Format.fprintf fmt "ERR:@\n%sEND@." (Buffer.contents stderr) ; end ; dump_buffer stdout logout ; dump_buffer stderr logerr ; if echo then begin match st with | Task.Result 0 | Task.Canceled | Task.Timeout -> () | Task.Result s -> Wp_parameters.error "%s exit with status [%d]@." cmd s ; echo_buffer stdout ; echo_buffer stderr ; | Task.Failed exn -> Wp_parameters.error "%s fails: %s@." cmd (Task.error exn) ; echo_buffer stdout ; echo_buffer stderr ; end ; let t = !time in List.iter (fun phi -> phi t) timers ; validate_buffer stderr validerr ; validate_buffer stdout validout ; Buffer.clear stdout ; Buffer.clear stderr ; end end (* -------------------------------------------------------------------------- *) (* --- Task Server --- *) (* -------------------------------------------------------------------------- *) 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 (* -------------------------------------------------------------------------- *) (* --- Task Composition --- *) (* -------------------------------------------------------------------------- *) let spawn jobs = let pool = ref [] in let canceled = ref false in let callback r = if not !canceled && r then begin canceled := true ; List.iter Task.cancel !pool ; end in let server = server () in pool := List.map (fun t -> t >>= Task.call callback) jobs ; List.iter (Task.spawn server) !pool frama-c-Fluorine-20130601/src/wp/GuiGoal.ml0000644000175000017500000001430112155630215017072 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- PO Details View --- *) (* -------------------------------------------------------------------------- *) type prover_state = | PS_nogoal | PS_click_to_play of Wpo.t | PS_click_to_log of Wpo.t | PS_click_to_stop of Wpo.t * (unit -> unit) type display_state = | DSP_nogoal | DSP_goal of Wpo.t * VCS.prover option let icon = function | VCS.NoResult -> `REMOVE | VCS.Failed -> `DIALOG_WARNING | VCS.Valid -> `YES | VCS.Unknown | VCS.Invalid -> `NO | VCS.Computing _ -> `EXECUTE | VCS.Timeout | VCS.Stepout -> `CUT class prover prv = let label = VCS.name_of_prover prv in let button = new Toolbox.button ~label () in object(self) val mutable state = PS_nogoal val mutable run = (fun _ _ -> ()) val mutable log = (fun _ _ -> ()) method widget = (button :> Toolbox.widget) method set_display = function | DSP_nogoal -> begin state <- PS_nogoal ; button#set_relief false ; button#set_icon None ; button#set_enabled false ; end | DSP_goal (w,p) -> button#set_enabled true ; let v = (Wpo.get_result w prv).VCS.verdict in begin match v with | VCS.NoResult -> begin state <- PS_click_to_play w ; button#set_relief true ; button#set_icon (Some `MEDIA_PLAY) ; end | VCS.Computing kill -> let me = match p with None -> false | Some p -> p=prv in if me then begin state <- PS_click_to_stop(w,kill) ; button#set_relief true ; button#set_icon (Some `MEDIA_STOP) ; end else begin state <- PS_click_to_log w ; button#set_relief false ; button#set_icon (Some `EXECUTE) ; end | _ -> let me = match p with None -> false | Some p -> p=prv in if me then begin state <- PS_click_to_play w ; button#set_relief true ; button#set_icon (Some (icon v)) ; end else begin state <- PS_click_to_log w ; button#set_relief false ; button#set_icon (Some (icon v)) ; end end method on_run f = run <- f method on_log f = log <- f method click = match state with | PS_nogoal -> () | PS_click_to_log w -> log w prv | PS_click_to_play w -> run w prv | PS_click_to_stop(w,kill) -> kill () ; log w prv initializer begin self#set_display DSP_nogoal ; button#connect (fun () -> self#click) ; end end class pane () = let goal = new Toolbox.button ~tooltip:"Proof Obligation" ~icon:`FILE () in let title = GMisc.label ~xalign:0.0 ~text:"Goal" () in let text = new Toolbox.text () in let hbox = GPack.hbox ~show:true () in let vbox = GPack.vbox ~show:true () in let provers = List.map (new prover) [VCS.AltErgo ; VCS.Coq ; VCS.Why3ide] in object(self) val mutable state = DSP_nogoal val mutable run = fun _ _ -> () val mutable src = fun (_:Wpo.t option) -> () initializer begin hbox#pack ~expand:false goal#coerce ; hbox#pack ~padding:3 ~expand:true ~fill:true title#coerce ; let tabs = List.map (fun p -> p#widget) provers in let rack = new Toolbox.rack tabs in hbox#pack ~expand:false rack#coerce ; vbox#pack ~expand:false hbox#coerce ; vbox#pack ~expand:true ~fill:true text#coerce ; (* Connections *) goal#connect (fun () -> self#goal) ; List.iter (fun p -> p#on_log self#log) provers ; List.iter (fun p -> p#on_run self#run) provers ; end method private goal = match state with | DSP_nogoal | DSP_goal(_,None) -> () | DSP_goal(w,Some _) -> state <- DSP_goal(w,None) ; self#update method private log w p = begin state <- DSP_goal(w,Some p) ; self#update ; end method private run w p = begin state <- DSP_goal(w,Some p) ; run w p ; self#update ; end method on_run f = run <- f method on_src f = src <- f method select = function | None -> state <- DSP_nogoal ; self#update | Some w -> state <- DSP_goal(w,None) ; self#update method update = text#clear ; begin List.iter (fun p -> p#set_display state) provers ; match state with | DSP_nogoal -> begin title#set_text "No Goal" ; end | DSP_goal(w,None) -> begin title#set_text (Pretty_utils.to_string Wpo.pp_title w) ; Wpo.pp_goal text#fmt w ; Format.pp_print_flush text#fmt () ; end | DSP_goal(w,Some p) -> begin title#set_text (Pretty_utils.to_string Wpo.pp_title w) ; Wpo.pp_logfile text#fmt w p ; Format.pp_print_flush text#fmt () ; end end method coerce = vbox#coerce end frama-c-Fluorine-20130601/src/wp/MemVar.ml0000644000175000017500000006776312155630215016756 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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-Aliasing Memory Model --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Cil_datatype open Ctypes open Lang open Lang.F open Memory type param = ByValue | ByRef | InHeap module type VarUsage = sig val datatype : string val param : varinfo -> param end module Make(V : VarUsage)(M : Memory.Model) = struct let datatype = "MemVar." ^ V.datatype ^ M.datatype let configure = M.configure (* -------------------------------------------------------------------------- *) (* --- Chunk --- *) (* -------------------------------------------------------------------------- *) type chunk = | Var of varinfo | Alloc of varinfo | Mem of M.Chunk.t module VAR = struct type t = varinfo let self = "var" let hash = Varinfo.hash let equal = Varinfo.equal let compare = Varinfo.compare let pretty = Varinfo.pretty let typ_of_param x = match V.param x with | ByValue | InHeap -> x.vtype | ByRef -> Cil.typeOf_pointed x.vtype let tau_of_chunk x = Lang.tau_of_ctype (typ_of_param x) let basename_of_chunk = LogicUsage.basename end module VALLOC = struct type t = varinfo let self = "alloc" let hash = Varinfo.hash let compare = Varinfo.compare let equal = Varinfo.equal let pretty = Varinfo.pretty let tau_of_chunk _x = Qed.Logic.Bool let basename_of_chunk x = match V.param x with | ByRef -> "ra_" ^ LogicUsage.basename x | ByValue | InHeap -> "ta_" ^ LogicUsage.basename x end module Chunk = struct type t = chunk let self = "varmem" let hash = function | Var x -> 3 * Varinfo.hash x | Alloc x -> 5 * Varinfo.hash x | Mem m -> 7 * M.Chunk.hash m let compare c1 c2 = if c1 == c2 then 0 else match c1 , c2 with | Var x , Var y | Alloc x , Alloc y -> Varinfo.compare x y | Mem p , Mem q -> M.Chunk.compare p q | Var _ , _ -> (-1) | _ , Var _ -> 1 | Alloc _ , _ -> (-1) | _ , Alloc _ -> 1 let equal c1 c2 = (compare c1 c2 = 0) let pretty fmt = function | Var x -> Varinfo.pretty fmt x | Alloc x -> Format.fprintf fmt "alloc(%a)" Varinfo.pretty x | Mem m -> M.Chunk.pretty fmt m let tau_of_chunk = function | Var x -> VAR.tau_of_chunk x | Alloc x -> VALLOC.tau_of_chunk x | Mem m -> M.Chunk.tau_of_chunk m let basename_of_chunk = function | Var x -> VAR.basename_of_chunk x | Alloc x -> VALLOC.basename_of_chunk x | Mem m -> M.Chunk.basename_of_chunk m end (* -------------------------------------------------------------------------- *) (* --- Sigma --- *) (* -------------------------------------------------------------------------- *) module HEAP = Qed.Collection.Make(VAR) module TALLOC = Qed.Collection.Make(VALLOC) module SIGMA = Sigma.Make(VAR)(HEAP) module ALLOC = Sigma.Make(VALLOC)(TALLOC) module Heap = Qed.Collection.Make(Chunk) type sigma = { mem : M.Sigma.t ; vars : SIGMA.t ; alloc : ALLOC.t ; } module Sigma = struct type t = sigma type chunk = Chunk.t type domain = Heap.set let create () = { vars = SIGMA.create () ; alloc = ALLOC.create () ; mem = M.Sigma.create () ; } let copy s = { vars = SIGMA.copy s.vars ; alloc = ALLOC.copy s.alloc ; mem = M.Sigma.copy s.mem ; } let merge s1 s2 = let s,pa1,pa2 = SIGMA.merge s1.vars s2.vars in let a,ta1,ta2 = ALLOC.merge s1.alloc s2.alloc in let m,qa1,qa2 = M.Sigma.merge s1.mem s2.mem in { vars = s ; alloc = a ; mem = m } , Passive.union (Passive.union pa1 ta1) qa1 , Passive.union (Passive.union pa2 ta2) qa2 let join s1 s2 = Passive.union (Passive.union (SIGMA.join s1.vars s2.vars) (ALLOC.join s1.alloc s2.alloc)) (M.Sigma.join s1.mem s2.mem) let get s = function | Var x -> SIGMA.get s.vars x | Alloc x -> ALLOC.get s.alloc x | Mem m -> M.Sigma.get s.mem m let mem s = function | Var x -> SIGMA.mem s.vars x | Alloc x -> ALLOC.mem s.alloc x | Mem m -> M.Sigma.mem s.mem m let value s c = e_var (get s c) let iter f s = begin SIGMA.iter (fun x -> f (Var x)) s.vars ; ALLOC.iter (fun x -> f (Alloc x)) s.alloc ; M.Sigma.iter (fun m -> f (Mem m)) s.mem ; end let iter2 f s t = begin SIGMA.iter2 (fun x a b -> f (Var x) a b) s.vars t.vars ; ALLOC.iter2 (fun x a b -> f (Alloc x) a b) s.alloc t.alloc ; M.Sigma.iter2 (fun m p q -> f (Mem m) p q) s.mem t.mem ; end let domain_partition r = begin let xs = ref HEAP.Set.empty in let ts = ref TALLOC.Set.empty in let ms = ref M.Heap.Set.empty in Heap.Set.iter (function | Var x -> xs := HEAP.Set.add x !xs | Alloc x -> ts := TALLOC.Set.add x !ts | Mem c -> ms := M.Heap.Set.add c !ms ) r ; !xs , !ts , !ms end let domain_var xs = HEAP.Set.fold (fun x s -> Heap.Set.add (Var x) s) xs Heap.Set.empty let domain_alloc ts = TALLOC.Set.fold (fun x s -> Heap.Set.add (Alloc x) s) ts Heap.Set.empty let domain_mem ms = M.Heap.Set.fold (fun m s -> Heap.Set.add (Mem m) s) ms Heap.Set.empty let assigned s1 s2 w = let w_vars , w_alloc , w_mem = domain_partition w in let h_vars = SIGMA.assigned s1.vars s2.vars w_vars in let h_alloc = ALLOC.assigned s1.alloc s2.alloc w_alloc in let h_mem = M.Sigma.assigned s1.mem s2.mem w_mem in Bag.ulist [h_vars;h_alloc;h_mem] let havoc s r = let rvar , ralloc , rmem = domain_partition r in { vars = SIGMA.havoc s.vars rvar ; alloc = ALLOC.havoc s.alloc ralloc ; mem = M.Sigma.havoc s.mem rmem ; } let havoc_chunk s = function | Var x -> { s with vars = SIGMA.havoc_chunk s.vars x } | Alloc x -> { s with alloc = ALLOC.havoc_chunk s.alloc x } | Mem m -> { s with mem = M.Sigma.havoc_chunk s.mem m } let havoc_any s = { alloc = s.alloc ; vars = SIGMA.havoc_any s.vars ; mem = M.Sigma.havoc_any s.mem ; } let domain s = Heap.Set.union (Heap.Set.union (domain_var (SIGMA.domain s.vars)) (domain_alloc (ALLOC.domain s.alloc))) (domain_mem (M.Sigma.domain s.mem)) let pretty fmt s = Format.fprintf fmt "@[{X:@[%a@]@ T:@[%a@]@ M:@[%a@]}@]" SIGMA.pretty s.vars ALLOC.pretty s.alloc M.Sigma.pretty s.mem end let get_var s x = SIGMA.get s.vars x let get_term s x = e_var (get_var s x) (* -------------------------------------------------------------------------- *) (* --- Location --- *) (* -------------------------------------------------------------------------- *) type loc = | Mloc of M.loc | Fref of varinfo (* by-reference *) | Fval of varinfo * ofs list (* in logic *) | Mval of varinfo * ofs list (* in heap *) and ofs = Field of fieldinfo | Index of c_object * term type segment = loc rloc let rec pp_ofs fmt = function | [] -> () | Field f :: ofs -> Format.fprintf fmt ".%s" f.fname ; pp_ofs fmt ofs | Index(_,k) :: ofs -> Format.fprintf fmt "[%a]" F.pp_term k ; pp_ofs fmt ofs let pretty fmt = function | Mloc l -> Format.fprintf fmt "ptr(%a)" M.pretty l | Fref x -> Format.fprintf fmt "ref(%a)" VAR.pretty x | Fval(x,ofs) -> Format.fprintf fmt "@[var(%a)%a@]" VAR.pretty x pp_ofs ofs | Mval(x,ofs) -> Format.fprintf fmt "@[mem(%a)%a@]" VAR.pretty x pp_ofs ofs let rec ofs_vars xs = function | [] -> xs | Field _ :: ofs -> ofs_vars xs ofs | Index(_,k) :: ofs -> ofs_vars (Vars.union xs (F.vars k)) ofs let vars = function | Mloc l -> M.vars l | Fref _ -> Vars.empty | Fval(_,ofs) | Mval(_,ofs) -> ofs_vars Vars.empty ofs let rec ofs_occurs x = function | [] -> false | Field _ :: ofs -> ofs_occurs x ofs | Index(_,k) :: ofs -> Vars.mem x (F.vars k) || ofs_occurs x ofs let occurs x = function | Mloc l -> M.occurs x l | Fref _ -> false | Fval(_,ofs) | Mval(_,ofs) -> ofs_occurs x ofs (* -------------------------------------------------------------------------- *) (* --- Location Constructors --- *) (* -------------------------------------------------------------------------- *) let null = Mloc M.null let literal ~eid cst = Mloc (M.literal ~eid cst) let cvar x = match V.param x with | ByRef -> Fref x | ByValue -> Fval(x,[]) | InHeap -> Mval(x,[]) let mloc x ofs = List.fold_left (fun l d -> match d with | Field f -> M.field l f | Index(e,k) -> M.shift l e k) (M.cvar x) ofs let mloc_of_loc = function | Mloc l -> l | Fref _ -> (* x should never be ByRef when its address is taken *) Wp_parameters.fatal "Addr of ref-var" | Fval(x,ofs) | Mval(x,ofs) -> mloc x ofs let pointer_loc p = Mloc (M.pointer_loc p) let pointer_val l = M.pointer_val (mloc_of_loc l) let field l f = match l with | Mloc l -> Mloc (M.field l f) | Fref _ -> Wp_parameters.fatal "Field of ref-var" | Fval(x,ofs) -> Fval(x,ofs @ [Field f]) | Mval(x,ofs) -> Mval(x,ofs @ [Field f]) let rec index ofs obj k = match ofs with | [] -> [Index(obj,k)] | [Index(elt,i)] when Ctypes.equal elt obj -> [Index(elt,e_add i k)] | delta :: ofs -> delta :: index ofs obj k let shift l obj k = match l with | Mloc l -> Mloc (M.shift l obj k) | Fref _ -> Wp_parameters.fatal "Index of ref-var" | Fval(x,ofs) -> Fval(x,index ofs obj k) | Mval(x,ofs) -> Mval(x,index ofs obj k) let base_addr = function | Mloc l -> Mloc (M.base_addr l) | Fref _ -> Wp_parameters.fatal "Base-addr of ref-var" | Fval(x,_) -> Fval(x,[]) | Mval(x,_) -> Mval(x,[]) let block_length sigma obj = function | Mloc l -> M.block_length sigma.mem obj l | Fref _ -> Wp_parameters.fatal "Block-length of ref-var" | Fval(x,_) | Mval(x,_) -> F.e_int64 (Ctypes.sizeof_typ (VAR.typ_of_param x)) let cast obj l = Mloc(M.cast obj (mloc_of_loc l)) let loc_of_int e a = Mloc(M.loc_of_int e a) let int_of_loc i l = M.int_of_loc i (mloc_of_loc l) (* -------------------------------------------------------------------------- *) (* --- Memory Load --- *) (* -------------------------------------------------------------------------- *) let rec access a = function | [] -> a | Field f :: ofs -> access (e_getfield a (Cfield f)) ofs | Index(_,k) :: ofs -> access (e_get a k) ofs let rec update a ofs v = match ofs with | [] -> v | Field f :: ofs -> let phi = Cfield f in let a_f = F.e_getfield a phi in let a_f_v = update a_f ofs v in F.e_setfield a phi a_f_v | Index(_,k) :: ofs -> let a_k = F.e_get a k in let a_k_v = update a_k ofs v in F.e_set a k a_k_v let mload sigma obj l = Cvalues.map_value (fun l -> Mloc l) (M.load sigma.mem obj l) let load sigma obj = function | Fref x -> Loc (Fval(x,[])) | Fval(x,ofs) -> Val (access (get_term sigma x) ofs) | (Mloc _ | Mval _) as l -> mload sigma obj (mloc_of_loc l) (* -------------------------------------------------------------------------- *) (* --- Memory Store --- *) (* -------------------------------------------------------------------------- *) let mstored seq obj l v = M.stored { pre = seq.pre.mem ; post = seq.post.mem } obj l v let stored seq obj l v = match l with | Fref _ -> Wp_parameters.fatal "Write to ref-var" | Fval(x,ofs) -> let v1 = get_term seq.pre x in let v2 = get_term seq.post x in [ F.p_equal v2 (update v1 ofs v) ] | (Mloc _ | Mval _) as l -> mstored seq obj (mloc_of_loc l) v let copied seq obj l1 l2 = let v = match load seq.pre obj l2 with | Val r -> r | Loc l -> pointer_val l in stored seq obj l1 v (* -------------------------------------------------------------------------- *) (* --- Pointer Comparison --- *) (* -------------------------------------------------------------------------- *) let is_null = function | Mloc l -> M.is_null l | Fref _ | Fval _ | Mval _ -> F.p_false let rec offset = function | [] -> e_zero | Field f :: ofs -> e_add (e_int64 (Ctypes.field_offset f)) (offset ofs) | Index(obj,k)::ofs -> e_add (e_fact (Ctypes.sizeof_object obj) k) (offset ofs) let loc_diff obj a b = match a , b with | Mloc l1 , Mloc l2 -> M.loc_diff obj l1 l2 | Fref x , Fref y when Varinfo.equal x y -> e_zero | (Fval(x,p)|Mval(x,p)) , (Fval(y,q)|Mval(y,q)) when Varinfo.equal x y -> e_div (e_sub (offset p) (offset q)) (e_int64 (Ctypes.sizeof_object obj)) | Mval _ , _ | _ , Mval _ | Fval _ , _ | _ , Fval _ | Fref _ , _ | _ , Fref _ -> Warning.error ~source:"Reference Variable Model" "Uncomparable locations %a and %a" pretty a pretty b let loc_compare lcmp icmp same a b = match a , b with | Mloc l1 , Mloc l2 -> lcmp l1 l2 | Fref x , Fref y -> if Varinfo.equal x y then same else p_not same | (Fval(x,p)|Mval(x,p)) , (Fval(y,q)|Mval(y,q)) -> if Varinfo.equal x y then icmp (offset p) (offset q) else p_not same | (Fval _|Mval _|Mloc _) , (Fval _|Mval _|Mloc _) -> lcmp (mloc_of_loc a) (mloc_of_loc b) | Fref _ , _ | _ , Fref _ -> p_not same let loc_eq = loc_compare M.loc_eq F.p_equal F.p_true let loc_lt = loc_compare M.loc_lt F.p_lt F.p_false let loc_leq = loc_compare M.loc_leq F.p_leq F.p_true let loc_neq = loc_compare M.loc_neq F.p_neq F.p_false (* -------------------------------------------------------------------------- *) (* --- Validity --- *) (* -------------------------------------------------------------------------- *) let size_of_array_type typ = match object_of typ with | C_int _ | C_float _ | C_pointer _ | C_comp _ -> assert false | C_array { arr_flat=None } -> if not (Wp_parameters.ExternArrays.get ()) then Wp_parameters.warning ~once:true "Validity of unsized array not implemented yet (considered valid)." ; None | C_array { arr_flat=Some s } -> Some (e_int64 s.arr_size) (* offset *) let first_index = Some e_zero let range_offset typ k = match size_of_array_type typ with | None -> p_positive k | Some s -> p_and (p_positive k) (p_lt k s) let rec valid_offset typ = function | [] -> p_true | Field f :: ofs -> valid_offset f.ftype ofs | Index(_,k) :: ofs -> let h = range_offset typ k in p_and h (valid_offset (Cil.typeOf_array_elem typ) ofs) let rec valid_offsetrange typ p a b = match p with | Field f :: ofs -> valid_offsetrange f.ftype ofs a b | [Index(obj,k)] -> let te = Cil.typeOf_array_elem typ in let elt = Ctypes.object_of te in if Ctypes.equal elt obj then let n = size_of_array_type typ in let a = Vset.bound_shift a k in let b = Vset.bound_shift b k in let p_inf = Vset.ordered ~limit:true ~strict:false first_index a in let p_sup = Vset.ordered ~limit:true ~strict:true b n in p_and p_inf p_sup else let rg = range_offset typ k in let te = Cil.typeOf_array_elem typ in p_and rg (valid_offsetrange te [] a b) | Index(_,k) :: ofs -> let rg = range_offset typ k in let te = Cil.typeOf_array_elem typ in p_and rg (valid_offsetrange te ofs a b) | [] -> let n = size_of_array_type typ in let p_inf = Vset.ordered ~limit:true ~strict:false first_index a in let p_sup = Vset.ordered ~limit:true ~strict:true b n in p_and p_inf p_sup (* varinfo + offset *) let valid_base sigma x = if x.vglob then p_true else p_bool (ALLOC.value sigma.alloc x) let valid_path sigma x t ofs = p_and (valid_base sigma x) (valid_offset t ofs) let valid_pathrange sigma x t ofs a b = p_and (valid_base sigma x) (p_imply (Vset.ordered ~limit:true ~strict:false a b) (valid_offsetrange t ofs a b)) (* segment *) let valid_loc sigma acs obj = function | Fref _ -> p_true | Fval(x,p) | Mval(x,p) -> valid_path sigma x (VAR.typ_of_param x) p | Mloc _ as l -> M.valid sigma.mem acs (Rloc(obj,mloc_of_loc l)) let valid_range sigma acs l obj a b = match l with | Fref _ -> Wp_parameters.fatal "range of ref-var" | Fval(x,p) | Mval(x,p) -> valid_pathrange sigma x (VAR.typ_of_param x) p a b | Mloc _ as l -> M.valid sigma.mem acs (Rrange(mloc_of_loc l,obj,a,b)) let valid_array sigma acs l obj s = match l with | Fref _ -> Wp_parameters.fatal "range of ref-var" | Fval(x,p) | Mval(x,p) -> valid_path sigma x (VAR.typ_of_param x) p | Mloc _ as l -> let a = Some e_zero in let b = Some (e_int64 (Int64.pred s)) in M.valid sigma.mem acs (Rrange(mloc_of_loc l,obj,a,b)) let valid sigma acs = function | Rloc(obj,l) -> valid_loc sigma acs obj l | Rarray(l,obj,s) -> valid_array sigma acs l obj s | Rrange(l,obj,a,b) -> valid_range sigma acs l obj a b (* -------------------------------------------------------------------------- *) (* --- Scope --- *) (* -------------------------------------------------------------------------- *) let is_mem x = match V.param x with InHeap -> true | ByRef | ByValue -> false let is_ref x = match V.param x with ByRef -> true | ByValue | InHeap -> false let alloc_var ta xs v = TALLOC.Set.fold (fun x hs -> p_equal (ALLOC.value ta x) v :: hs) xs [] let allocates ta_out xs valid (* of introduced variables *) = let xs = List.filter (fun x -> not (is_ref x)) xs in if xs = [] then ta_out , [] else let xs_all = List.fold_right TALLOC.Set.add xs TALLOC.Set.empty in let ta_in = ALLOC.havoc ta_out xs_all in let h_out = alloc_var ta_out xs_all (if valid then e_false else e_true) in let h_in = alloc_var ta_in xs_all (if valid then e_true else e_false) in begin ta_in , h_in @ h_out end let scope_vars ta sc xs = match sc with | Mcfg.SC_Global | Mcfg.SC_Function_in -> ta , [] | Mcfg.SC_Function_frame | Mcfg.SC_Block_in -> allocates ta xs false | Mcfg.SC_Function_out | Mcfg.SC_Block_out -> allocates ta xs true let scope sigma sc xs = let xmem = List.filter is_mem xs in let smem , hmem = M.scope sigma.mem sc xmem in let ta , hvars = scope_vars sigma.alloc sc xs in { vars = sigma.vars ; alloc = ta ; mem = smem } , hvars @ hmem (* -------------------------------------------------------------------------- *) (* --- Segment --- *) (* -------------------------------------------------------------------------- *) type seq = | Rseg of varinfo | Fseg of varinfo * delta list | Mseg of M.loc rloc * varinfo * delta list | Lseg of M.loc rloc and delta = | Dfield of fieldinfo | Drange of term option * term option let dofs = function | Field f -> Dfield f | Index(_,k) -> let u = Some k in Drange(u,u) let delta ofs = List.map dofs ofs let rec range ofs obj a b = match ofs with | [] -> [ Drange(a,b) ] | [Index(elt,k)] when Ctypes.equal elt obj -> [ Drange( Vset.bound_shift a k , Vset.bound_shift b k ) ] | d :: ofs -> dofs d :: range ofs obj a b let dsize s = Drange(Some (e_int 0) , Some (e_int64 (Int64.pred s))) let rsize ofs s = delta ofs @ [ dsize s ] let locseg = function | Rloc(_,Fref x) -> Rseg x | Rarray(Fref _,_,_) | Rrange(Fref _,_,_,_) -> Wp_parameters.fatal "range of ref-var" | Rloc(obj,Mloc l) -> Lseg (Rloc(obj,l)) | Rloc(_,Fval(x,ofs)) -> Fseg(x,delta ofs) | Rarray(Mloc l,obj,s) -> Lseg (Rarray(l,obj,s)) | Rarray(Fval(x,ofs),_,s) -> Fseg(x,rsize ofs s) | Rrange(Mloc l,obj,a,b) -> Lseg (Rrange(l,obj,a,b)) | Rrange(Fval(x,ofs),obj,a,b) -> Fseg(x,range ofs obj a b) (* in M: *) | Rloc(obj,Mval(x,ofs)) -> Mseg(Rloc(obj,mloc x ofs),x,delta ofs) | Rarray(Mval(x,ofs),obj,s) -> Mseg(Rarray(mloc x ofs,obj,s),x,rsize ofs s) | Rrange(Mval(x,ofs),obj,a,b) -> Mseg(Rrange(mloc x ofs,obj,a,b),x,range ofs obj a b) (* -------------------------------------------------------------------------- *) (* --- Segment Inclusion --- *) (* -------------------------------------------------------------------------- *) let rec included_delta d1 d2 = match d1 , d2 with | _ , [] -> p_true | [] , _ -> p_false | u :: d1 , v :: d2 -> match u , v with | Dfield f , Dfield g when Fieldinfo.equal f g -> included_delta d1 d2 | Dfield _ , _ | _ , Dfield _ -> p_false | Drange(a1,b1) , Drange(a2,b2) -> p_conj [ Vset.ordered ~strict:false ~limit:true a2 a1 ; Vset.ordered ~strict:false ~limit:true b1 b2 ; included_delta d1 d2 ] let included s1 s2 = match locseg s1 , locseg s2 with | Rseg x , Rseg y -> if Varinfo.equal x y then p_true else p_false | Rseg _ , _ | _ , Rseg _ -> p_false | Fseg(x1,d1) , Fseg(x2,d2) | Mseg(_,x1,d1) , Mseg(_,x2,d2) -> if Varinfo.equal x1 x2 then included_delta d1 d2 else p_false | Fseg _ , _ | _ , Fseg _ -> p_false | (Lseg s1|Mseg(s1,_,_)) , (Lseg s2|Mseg(s2,_,_)) -> M.included s1 s2 (* -------------------------------------------------------------------------- *) (* --- Segment Separation --- *) (* -------------------------------------------------------------------------- *) let rec separated_delta d1 d2 = match d1 , d2 with | [] , _ | _ , [] -> p_false | u :: d1 , v :: d2 -> match u , v with | Dfield f , Dfield g when Fieldinfo.equal f g -> separated_delta d1 d2 | Dfield _ , _ | _ , Dfield _ -> p_true | Drange(a1,b1) , Drange(a2,b2) -> p_disj [ Vset.ordered ~strict:true ~limit:false b1 a2 ; Vset.ordered ~strict:true ~limit:false b2 a1 ; separated_delta d1 d2 ] let separated r1 r2 = match locseg r1 , locseg r2 with | Rseg x , Rseg y -> if Varinfo.equal x y then p_false else p_true | Rseg _ , _ | _ , Rseg _ -> p_true | Fseg(x1,d1) , Fseg(x2,d2) | Mseg(_,x1,d1) , Mseg(_,x2,d2) -> if Varinfo.equal x1 x2 then separated_delta d1 d2 else p_true | Fseg _ , _ | _ , Fseg _ -> p_true | (Lseg s1|Mseg(s1,_,_)) , (Lseg s2|Mseg(s2,_,_)) -> M.separated s1 s2 (* -------------------------------------------------------------------------- *) (* --- Segment Assignation --- *) (* -------------------------------------------------------------------------- *) let sloc_descr = function | Sloc l -> [],l,p_true | Sdescr(xs,l,p) -> xs,l,p | Sarray(l,obj,s) -> let x = Lang.freshvar ~basename:"k" Qed.Logic.Int in let k = e_var x in [x],shift l obj k,Vset.in_size k s | Srange(l,obj,a,b) -> let x = Lang.freshvar ~basename:"k" Qed.Logic.Int in let k = e_var x in [x],shift l obj k,Vset.in_range k a b let floc_path = function | Mloc _ | Mval _ -> assert false (* Filtered in assigned *) | Fref _ -> Wp_parameters.fatal "assigned of ref-var" | Fval(x,ofs) -> x,ofs let rec assigned_path (hs : pred list) (* collector of properties *) (xs : var list) (* variable quantifying by the assigned location *) (ys : var list) (* variable quantifying others locations *) (a : term) (* pre-term for root + current offset *) (b : term) (* post-term for root + current offset *) = function | [] -> hs (*TODO: optimized version for terminal [Field _] and [Index _] *) | Field f :: ofs -> let cf = Cfield f in let af = e_getfield a cf in let bf = e_getfield b cf in let hs = assigned_path hs xs ys af bf ofs in List.fold_left (fun hs g -> if Fieldinfo.equal f g then hs else let cg = Cfield f in let ag = e_getfield a cg in let bg = e_getfield b cg in let eqg = p_forall ys (p_equal ag bg) in eqg :: hs ) hs f.fcomp.cfields | Index(_,e) :: ofs -> let y = Lang.freshvar ~basename:"k" Qed.Logic.Int in let k = e_var y in let ak = e_get a k in let bk = e_get b k in if List.exists (fun x -> F.occurs x e) xs then (* index [e] is covered by [xs]: must explore deeper the remaining path. *) assigned_path hs xs (y::ys) ak bk ofs else (* index [e] is not covered by [xs]: any indice different from e is disjoint. explore also deeply with index [e]. *) let ae = e_get a e in let be = e_get b e in let ek = p_neq e k in let eqk = p_forall (y::ys) (p_imply ek (p_equal ak bk)) in assigned_path (eqk :: hs) xs ys ae be ofs let assigned s obj = function (* Optimisation for functional updates in one variable *) | Sloc(Fval(_,_::_) as loc) -> let v = Lang.freshvar ~basename:"v" (Lang.tau_of_object obj) in stored s obj loc (e_var v) (* Optimisation for full update of one array variable *) | Sarray(Fval(_,[]),_,_) -> [] | Sarray(Fval(x,ofs),_,_) -> let a = get_term s.pre x in let b = get_term s.post x in assigned_path [] [] [] a b ofs | sloc -> (* Transfer the job to memory model M if sloc is in M *) try let sloc = Cvalues.map_sloc (function | (Mloc _ | Mval _) as l -> mloc_of_loc l | Fval _ | Fref _ -> raise Exit ) sloc in M.assigned { pre=s.pre.mem ; post=s.post.mem } obj sloc with Exit -> (* Otherwize compute a set of equalities for each sub-path of the assigned location *) let xs,l,p = sloc_descr sloc in let x,ofs = floc_path l in let a = get_term s.pre x in let b = get_term s.post x in let a_ofs = access a ofs in let b_ofs = access b ofs in let p_sloc = p_forall xs (p_imply (p_not p) (p_equal a_ofs b_ofs)) in assigned_path [p_sloc] xs [] a b ofs (* -------------------------------------------------------------------------- *) (* --- Domain --- *) (* -------------------------------------------------------------------------- *) let domain obj = function | (Mloc _ | Mval _) as l -> M.Heap.Set.fold (fun m s -> Heap.Set.add (Mem m) s) (M.domain obj (mloc_of_loc l)) Heap.Set.empty | Fref x | Fval(x,_) -> Heap.Set.singleton (Var x) (* -------------------------------------------------------------------------- *) end frama-c-Fluorine-20130601/src/wp/qed/0000755000175000017500000000000012155634040015763 5ustar mehdimehdiframa-c-Fluorine-20130601/src/wp/qed/src/0000755000175000017500000000000012155634040016552 5ustar mehdimehdiframa-c-Fluorine-20130601/src/wp/qed/src/numbers.mli0000644000175000017500000000556512155630203020740 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** Parsing of Integer and Real Constants *) type base = Dec | Hex type sign = Pos | Neg type cst = { base : base ; sign : sign ; man : string ; com : string ; exp : int ; } (** The parser recognizes hexadecimal and decimal numbers with the following formats: - [sign? "0d"? dec* ["." dec*]? ["e|E" sign? dec+]?] {i Decimal} - [sign? "0x"? hex* ["." hex*]? ["p|P" sign? dec+]?] {i Hexadecimal} In the above regular expressions, [sign=[+|-]], [dec=[0..9]] are decimal digits, [hex=[0..9 a..f A..F]] are hexadecimal ones. Notice that, unless a [base] argument is specified, some entries can be ambiguous, like "3e2" that can be either hexadecimal or decimal. In such cases, decimal format takes the precedence. *) val parse : ?base:base -> string -> cst val pretty : Format.formatter -> cst -> unit val is_zero : cst -> bool val big_int_of_hex : string -> Big_int.big_int (** Returns [0] on empty string *) val dec_of_hex : string -> string (** Returns empty string on empty string *) val power_of_two : int -> string (** Returns a decimal. Only positive powers. *) val power_of_ten : int -> string (** Returns a decimal. Only positive powers. *) val significant : cst -> string * int (** Returns all significant digits with a shifted exponent. *) frama-c-Fluorine-20130601/src/wp/qed/src/ast.mli0000644000175000017500000000377512155630203020055 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Utilities for [Syntax]. *) (* -------------------------------------------------------------------------- *) open Syntax val range : e -> position val raise_at : e -> exn -> 'b val error_at : e -> ('a,Format.formatter,unit,'b) format4 -> 'a val reset : unit -> unit val fresh : unit -> int frama-c-Fluorine-20130601/src/wp/qed/src/export_coq.ml0000644000175000017500000003237612155630203021277 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Exportation Engine for Coq --- *) (* -------------------------------------------------------------------------- *) open Logic open Format open Plib open Linker open Engine open Export module Make(T : Term) = struct module T = T module E = Export.Make(T) open T type tau = (Field.t,ADT.t) datatype type record = (Field.t * term) list type trigger = (var,Fun.t) ftrigger type typedef = (tau,Field.t,Fun.t) ftypedef let libraries = [ "Bool" ; "ZArith" ; "Reals" ; "Qed" ; "Cdiv" ; ] class virtual engine = object(self) inherit E.engine initializer begin self#declare_all ["Z";"Real";"bool";"Prop";"array";"farray"] ; for i=1 to 26 do let c = int_of_char 'A' + i - 1 in self#declare (Printf.sprintf "%c" (char_of_int c)) done ; self#declare_all ["true";"false";"True";"False"] ; self#declare_all ["IZT"] ; end (* -------------------------------------------------------------------------- *) (* --- Types --- *) (* -------------------------------------------------------------------------- *) method t_int = "Z" method t_real = "R" method t_bool = "bool" method t_prop = "Prop" method t_atomic = function | Int | Real | Bool | Prop | Tvar _ -> true | Array _ -> false | Data(_,[]) -> true | Data _ -> false | Record _ -> true method pp_array fmt t = fprintf fmt "array %a" self#pp_subtau t method pp_farray fmt a b = fprintf fmt "farray %a %a" self#pp_subtau a self#pp_subtau b method pp_tvar fmt k = if 1 <= k && k <= 26 then let c = int_of_char 'A' + (k-1) in pp_print_char fmt (char_of_int c) else fprintf fmt "A%d" k method virtual datatype : T.ADT.t -> string method pp_datatype adt fmt = function | [] -> pp_print_string fmt (self#datatype adt) | ts -> Plib.pp_call_apply (self#datatype adt) self#pp_subtau fmt ts (* -------------------------------------------------------------------------- *) (* --- Primitives --- *) (* -------------------------------------------------------------------------- *) method callstyle = CallApply method op_scope = function Aint -> Some "%Z" | Areal -> Some "%R" method pp_int _amode fmt z = Z.pretty fmt z method pp_cst fmt cst = let open Numbers in let man,exp = significant cst in let sign = match cst.sign with Pos -> "" | Neg -> "-" in match cst.base with | Dec -> fprintf fmt "(real_dec (%s%s) (%d))" sign man exp | Hex -> fprintf fmt "(real_hex (%s%s) (%d))" sign (dec_of_hex man) exp method e_true = function Cterm -> "true" | Cprop -> "True" method e_false = function Cterm -> "false" | Cprop -> "False" (* -------------------------------------------------------------------------- *) (* --- Arithmetics --- *) (* -------------------------------------------------------------------------- *) method op_add (_:amode) = Assoc "+" method op_sub (_:amode) = Assoc "-" method op_mul (_:amode) = Assoc "*" method op_div = function Aint -> Call "Cdiv" | Areal -> Call "Rdiv" method op_mod = function Aint -> Call "Cmod" | Areal -> Call "Rmod" method op_minus (_:amode) = Op "-" method op_real_of_int = Call "IZR" method op_eq (c:cmode) (a:amode) = match c , a with | Cprop , _ -> Op "=" | Cterm , Aint -> Call "Zeq_bool" | Cterm , Areal -> Call "Req_bool" method op_neq (c:cmode) (a:amode) = match c , a with | Cprop , _ -> Op "<>" | Cterm , Aint -> Call "Zneq_bool" | Cterm , Areal -> Call "Rneq_bool" method op_lt (c:cmode) (a:amode) = match c , a with | Cprop , _ -> Op "<" | Cterm , Aint -> Call "Zlt_bool" | Cterm , Areal -> Call "Rlt_bool" method op_leq (c:cmode) (a:amode) = match c , a with | Cprop , _ -> Op "<=" | Cterm , Aint -> Call "Zle_bool" | Cterm , Areal -> Call "Rle_bool" (* -------------------------------------------------------------------------- *) (* --- Connectives --- *) (* -------------------------------------------------------------------------- *) method op_not = function Cterm -> Call "negb" | Cprop -> Op "~" method op_or = function Cterm -> Call "orb" | Cprop -> Assoc "\\/" method op_and = function Cterm -> Call "andb" | Cprop -> Assoc "/\\" method op_imply = function Cterm -> Call "implb" | Cprop -> Assoc "->" method op_equiv = function Cterm -> Call "eqb" | Cprop -> Op "<->" method op_equal = function Cterm -> Call "Aeq_bool" | Cprop -> Op "=" method op_noteq = function Cterm -> Call "Aneq_bool" | Cprop -> Op "<>" (* -------------------------------------------------------------------------- *) (* --- Conditional --- *) (* -------------------------------------------------------------------------- *) method pp_conditional fmt a b c = match Export.cmode self#mode with | Cprop -> begin fprintf fmt "itep@ %a@ %a@ %a" self#pp_atom a self#pp_atom b self#pp_atom c ; end | Cterm -> begin fprintf fmt "@[if " ; self#with_mode Mterm (fun _ -> self#pp_atom fmt a) ; fprintf fmt "@ then %a" self#pp_atom b ; fprintf fmt "@ else %a" self#pp_atom c ; fprintf fmt "@]" ; end (* -------------------------------------------------------------------------- *) (* --- Arrays --- *) (* -------------------------------------------------------------------------- *) method pp_array_get fmt m k = fprintf fmt "%a@ %a" self#pp_atom m self#pp_atom k method pp_array_set fmt m k v = fprintf fmt "%a.[ %a <- %a ]" self#pp_atom m self#pp_flow k self#pp_flow v (* -------------------------------------------------------------------------- *) (* --- Records --- *) (* -------------------------------------------------------------------------- *) method virtual field : T.Field.t -> string method pp_get_field fmt r f = fprintf fmt "%s@ %a" (self#field f) self#pp_atom r method pp_def_fields fmt fvs = begin fprintf fmt "@[{|" ; Plib.iteri (fun i (f,v) -> match i with | Ifirst | Imiddle -> fprintf fmt "@ @[%s := %a ;@]" (self#field f) self#pp_flow v | Isingle | Ilast -> fprintf fmt "@[%s := %a@]" (self#field f) self#pp_flow v ) fvs ; fprintf fmt "@ |}@]" ; end (* -------------------------------------------------------------------------- *) (* --- Atomicity --- *) (* -------------------------------------------------------------------------- *) method op_spaced = is_ident method is_atomic e = match T.repr e with | Kint z -> Z.positive z | Kreal _ -> true | Apply(_,[]) | Rdef _ -> true | Apply _ | Aset _ | Aget _ | Rget _ -> false | Eq _ | Neq _ | Lt _ | Leq _ | And _ | Or _ | Imply _ | Bind _ | Fun _ | If _ -> false | _ -> T.is_simple e method is_shareable e = not (T.is_prop e) method pp_let fmt x e = fprintf fmt "@[let %s := %a in@]@ " x self#pp_flow e (* -------------------------------------------------------------------------- *) (* --- Higher Order --- *) (* -------------------------------------------------------------------------- *) method pp_apply _cmode e fmt es = begin fprintf fmt "@[(%a" self#pp_atom e ; List.iter (fun a -> fprintf fmt "@ %a" self#pp_atom a) es ; fprintf fmt ")@]" end method private pp_param fmt x = fprintf fmt "(%a : %a)" self#pp_var x self#pp_tau (T.tau_of_var x) method pp_forall tau fmt = function | [] -> () | x::xs -> fprintf fmt "@[forall (%a" self#pp_var x ; List.iter (fun y -> fprintf fmt "@ %a" self#pp_var y) xs ; fprintf fmt "@ : %a),@]" self#pp_tau tau method pp_exists tau fmt = function | [] -> () | x::xs -> fprintf fmt "@[exists %a : %a@]," self#pp_var x self#pp_tau tau ; List.iter (fun x -> fprintf fmt "@ @[exists %a : %a@]," self#pp_var x self#pp_tau tau) xs method pp_lambda fmt xs = Plib.iteri (fun i x -> match i with | Isingle -> fprintf fmt "@[fun %a =>@]@ " self#pp_param x | Ifirst -> fprintf fmt "@[fun %a" self#pp_param x | Imiddle -> fprintf fmt "@ %a" self#pp_param x | Ilast -> fprintf fmt "@ %a =>@]@ " self#pp_param x ) xs (* -------------------------------------------------------------------------- *) (* --- Declarations --- *) (* -------------------------------------------------------------------------- *) method private pp_declare_poly fmt n = if n > 0 then begin fprintf fmt " (" ; for i=1 to n do fprintf fmt "%a " self#pp_tvar i done ; fprintf fmt " : Set)" ; end ; method declare_type fmt adt n = function | Tabs -> begin fprintf fmt "Parameter %s" (self#datatype adt) ; self#pp_declare_poly fmt n ; fprintf fmt " : Set.@\n" end | Tdef def -> begin fprintf fmt "@[Definition %s" (self#datatype adt) ; self#pp_declare_poly fmt n ; fprintf fmt " : Set :=@ %a@].@\n" self#pp_tau def ; end | Trec fts -> begin fprintf fmt "@[Record %s" (self#datatype adt) ; self#pp_declare_poly fmt n ; fprintf fmt " : Set := {@[" ; Plib.iteri (fun idx (f,t) -> match idx with | Ifirst | Imiddle -> fprintf fmt "@ %s : %a ;" (self#field f) self#pp_tau t | Isingle | Ilast -> fprintf fmt "@ %s : %a" (self#field f) self#pp_tau t ) fts ; fprintf fmt "@]@ }@].@\n" ; end | Tsum cases -> begin fprintf fmt "@[Inductive %s" (self#datatype adt) ; self#pp_declare_poly fmt n ; fprintf fmt " : Set :=" ; let result = Data(adt,Kind.type_params n) in List.iter (fun (c,ts) -> fprintf fmt "@ | @[%s : " (self#link_name Cterm c) ; List.iter (fun t -> fprintf fmt "@ %a ->" self#pp_tau t) ts ; fprintf fmt "@ %a.@]" self#pp_tau result ; ) cases ; fprintf fmt ".@]@\n" ; end method declare_signature fmt f ts t = begin let cmode = ctau t in fprintf fmt "@[Parameter %s :" (self#link_name cmode f) ; List.iter (fun t -> fprintf fmt "@ %a ->" self#pp_tau t) ts ; fprintf fmt "@ %a.@]@\n" self#pp_tau t ; end method declare_definition fmt f xs t e = self#global begin fun () -> fprintf fmt "@[Definition %s" (self#link_name (ctau t) f) ; List.iter (fun x -> self#bind x ; let t = T.tau_of_var x in fprintf fmt "@ (%a : %a)" self#pp_var x self#pp_tau t ) xs ; fprintf fmt "@ : %a :=@ " self#pp_tau t ; fprintf fmt "@[%a@]@].@\n" (self#pp_expr t) e ; end method declare_fixpoint ~prefix fmt f xs t e = begin self#declare_signature fmt f (List.map tau_of_var xs) t ; let fix = prefix ^ self#link_name (ctau t) f in self#declare_axiom fmt fix xs [] (e_eq (e_fun f (List.map e_var xs)) e) ; end method declare_axiom fmt lemma xs (_:trigger list list) p = self#global begin fun () -> fprintf fmt "@[Hypothesis %s: %a@].@\n" lemma self#pp_prop (T.e_forall xs p) end end end frama-c-Fluorine-20130601/src/wp/qed/src/r.ml0000644000175000017500000000430312155630203017342 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 t = string let float = string_of_float let of_string s = s let to_string s = s let hash = Hashtbl.hash let equal = (=) let compare = Pervasives.compare type maybe = | Sure_true | Sure_false | Unknown let eq a b = if a = b then Sure_true else Unknown let lt _a _b = Unknown let leq a b = if a = b then Sure_true else Unknown let pretty = Format.pp_print_string let positive a = String.length a <= 0 || a.[0] <> '-' let negative a = String.length a > 0 && a.[0] = '-' let opp a = if String.length a <= 0 then a else if a.[0] = '-' then String.sub a 1 (String.length a - 1) else ("-" ^ a) frama-c-Fluorine-20130601/src/wp/qed/src/export_whycore.ml0000644000175000017500000002204512155630203022165 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Common Exportation Engine for Alt-Ergo and Why3 --- *) (* -------------------------------------------------------------------------- *) open Logic open Format open Plib open Linker open Engine open Export module Make(T : Term) = struct open T module T = T module E = Export.Make(T) type trigger = (T.var,Fun.t) ftrigger type typedef = (tau,Field.t,Fun.t) ftypedef let rec full_trigger = function | TgAny -> false | TgVar _ -> true | TgGet(a,k) -> full_trigger a && full_trigger k | TgSet(a,k,v) -> full_trigger a && full_trigger k && full_trigger v | TgFun(_,xs) | TgProp(_,xs) -> List.for_all full_trigger xs let rec full_triggers = function | [] -> [] | ts :: tgs -> match List.filter full_trigger ts with | [] -> full_triggers tgs | ts -> ts :: full_triggers tgs module TauMap = Map.Make (struct type t = T.tau let compare = Kind.compare_tau T.Field.compare T.ADT.compare end) class virtual engine = object(self) inherit E.engine initializer begin self#declare_all [ "int" ; "real" ; "bool" ; "prop" ] ; end (* -------------------------------------------------------------------------- *) (* --- Types --- *) (* -------------------------------------------------------------------------- *) method t_int = "int" method t_real = "real" method t_bool = "bool" method t_prop = "prop" method pp_tvar fmt k = if 1 <= k && k <= 26 then fprintf fmt "'%c" (char_of_int (int_of_char 'a' + k - 1)) else fprintf fmt "'_%d" k (* -------------------------------------------------------------------------- *) (* --- Scope --- *) (* -------------------------------------------------------------------------- *) method op_scope _ = None method is_shareable e = match T.repr e with | Kint _ | Kreal _ | True | False -> false | Times _ | Add _ | Mul _ | Div _ | Mod _ -> true | Eq _ | Neq _ | Leq _ | Lt _ -> false | Aget _ | Aset _ | Rget _ | Rdef _ -> true | And _ | Or _ | Not _ | Imply _ | If _ -> false | Fun _ -> not (T.is_prop e) | Var _ | Apply _ | Bind _ -> false (* -------------------------------------------------------------------------- *) (* --- Arrays --- *) (* -------------------------------------------------------------------------- *) method pp_array_get fmt a k = fprintf fmt "@[%a[%a]@]" self#pp_atom a self#pp_flow k method pp_array_set fmt a k v = fprintf fmt "@[%a[%a@ <- %a]@]" self#pp_atom a self#pp_atom k self#pp_flow v (* -------------------------------------------------------------------------- *) (* --- Records --- *) (* -------------------------------------------------------------------------- *) method virtual op_record : string * string method pp_get_field fmt r f = fprintf fmt "%a.%s" self#pp_atom r (self#field f) method pp_def_fields fmt fvs = let base,fvs = match T.record_with fvs with | None -> None,fvs | Some(r,fvs) -> Some r,fvs in begin let (left,right) = self#op_record in fprintf fmt "@[%s" left ; Plib.iteri (fun i (f,v) -> ( match i , base with | (Isingle | Ifirst) , Some r -> fprintf fmt "@ %a with" self#pp_flow r | _ -> () ) ; ( match i with | Ifirst | Imiddle -> fprintf fmt "@ @[%s = %a ;@]" (self#field f) self#pp_flow v | Isingle | Ilast -> fprintf fmt "@ @[%s = %a@]" (self#field f) self#pp_flow v ) ) fvs ; fprintf fmt "@ %s@]" right ; end (* -------------------------------------------------------------------------- *) (* --- Higher Order --- *) (* -------------------------------------------------------------------------- *) method pp_apply (_:cmode) (_:term) (_:formatter) (_:term list) = failwith "Qed.Export.Why: higher-order application" (* -------------------------------------------------------------------------- *) (* --- Higher Order --- *) (* -------------------------------------------------------------------------- *) method pp_param fmt x = fprintf fmt "%a:%a" self#pp_var x self#pp_tau (T.tau_of_var x) method pp_lambda (_:formatter) (_:var list) = failwith "Qed.Export.Why : lambda abstraction" (* -------------------------------------------------------------------------- *) (* --- Declarations --- *) (* -------------------------------------------------------------------------- *) method virtual pp_declare_adt : formatter -> ADT.t -> int -> unit method virtual pp_declare_def : formatter -> ADT.t -> int -> tau -> unit method virtual pp_declare_sum : formatter -> ADT.t -> int -> (Fun.t * tau list) list -> unit method declare_type fmt adt n = function | Tabs -> self#pp_declare_adt fmt adt n ; pp_print_newline fmt () | Tdef def -> self#pp_declare_def fmt adt n def ; pp_print_newline fmt () | Tsum cases -> self#pp_declare_sum fmt adt n cases ; pp_print_newline fmt () | Trec fts -> begin Format.fprintf fmt "@[@[" ; self#pp_declare_adt fmt adt n ; let left,right = self#op_record in fprintf fmt " = %s" left ; Plib.iteri (fun index (f,t) -> match index with | Isingle | Ilast -> fprintf fmt "@ @[%s : %a@]" (self#field f) self#pp_tau t | Imiddle | Ifirst -> fprintf fmt "@ @[%s : %a@] ;" (self#field f) self#pp_tau t ) fts ; fprintf fmt "@] %s@]@\n" right ; end method pp_declare_symbol t fmt f = match t with | Cprop -> fprintf fmt "predicate %s" (self#link_name Cprop f) | Cterm -> fprintf fmt "function %s" (self#link_name Cterm f) method virtual pp_trigger : trigger printer method virtual pp_intros : tau -> var list printer (* forall with no separatyor *) method declare_prop ~kind fmt lemma xs tgs (p : term) = self#global begin fun () -> fprintf fmt "@[%s %s:" kind lemma ; let groups = List.fold_left (fun groups x -> self#bind x ; let t = T.tau_of_var x in let xs = try TauMap.find t groups with Not_found -> [] in TauMap.add t (x::xs) groups ) TauMap.empty xs in let order = TauMap.fold (fun t xs order -> (t,List.sort Var.compare xs)::order) groups [] in let tgs = full_triggers tgs in Plib.iteri (fun index (t,xs) -> let do_triggers = match index with | Ifirst | Imiddle -> false | Isingle | Ilast -> tgs<>[] in if do_triggers then begin let pp_or = Plib.pp_listcompact ~sep:"|" in let pp_and = Plib.pp_listcompact ~sep:"," in let pp_triggers = pp_or (pp_and self#pp_trigger) in fprintf fmt "@ @[%a@]" (self#pp_intros t) xs ; fprintf fmt "@ @[[%a].@]" pp_triggers tgs ; end else fprintf fmt "@ @[%a.@]" (self#pp_intros t) xs ) order ; fprintf fmt "@ @[%a@]@]@\n" self#pp_prop p end method declare_axiom = self#declare_prop ~kind:"axiom" end end frama-c-Fluorine-20130601/src/wp/qed/src/export_why3.mli0000644000175000017500000000536112155630203021552 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Logic open Format open Plib open Linker open Engine (** Exportation Engine for Why-3. Provides a full {{:Export.S.engine-c.html}engine} from a {{:Export.S.linker-c.html}linker}. *) module Make(T : Term) : sig open T type trigger = (T.var,Fun.t) ftrigger class virtual engine : object inherit [ADT.t,Field.t,Fun.t,tau,var,term] Engine.engine method op_spaced : string -> bool method op_record : string * string method pp_forall : tau -> var list printer method pp_intros : tau -> var list printer method pp_exists : tau -> var list printer method pp_param : var printer method pp_trigger : (var,Fun.t) ftrigger printer method pp_declare_symbol : cmode -> Fun.t printer method pp_declare_adt : formatter -> ADT.t -> int -> unit method pp_declare_def : formatter -> ADT.t -> int -> tau -> unit method pp_declare_sum : formatter -> ADT.t -> int -> (Fun.t * tau list) list -> unit method declare_prop : kind:string -> formatter -> string -> T.var list -> trigger list list -> term -> unit method declare_fixpoint : prefix:string -> formatter -> Fun.t -> var list -> tau -> term -> unit end end frama-c-Fluorine-20130601/src/wp/qed/src/plib.mli0000644000175000017500000000645712155630203020214 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Utilities. *) (* -------------------------------------------------------------------------- *) open Format (** Message Formatters *) val kprintf : (string -> 'b) -> ('a,Format.formatter,unit,'b) format4 -> 'a val sprintf : ('a,Format.formatter,unit,string) format4 -> 'a val failure : ('a,Format.formatter,unit,'b) format4 -> 'a val to_string : (Format.formatter -> 'a -> unit) -> 'a -> string (** Printy printers *) type 'a printer = Format.formatter -> 'a -> unit type 'a printer2 = Format.formatter -> 'a -> 'a -> unit (** Function calls *) val pp_call_var : f:string -> 'a printer -> 'a list printer val pp_call_void : f:string -> 'a printer -> 'a list printer val pp_call_apply : f:string -> 'a printer -> 'a list printer (** Operators *) val pp_assoc : e:string -> op:string -> 'a printer -> 'a list printer val pp_binop : op:string -> 'a printer -> 'a printer2 val pp_fold_binop : e:string -> op:string -> 'a printer -> 'a list printer val pp_fold_call : e:string -> f:string -> 'a printer -> 'a list printer val pp_fold_apply : e:string -> f:string -> 'a printer -> 'a list printer val pp_fold_call_rev : e:string -> f:string -> 'a printer -> 'a list printer val pp_fold_apply_rev : e:string -> f:string -> 'a printer -> 'a list printer (** Iterations *) type index = Isingle | Ifirst | Ilast | Imiddle val iteri : (index -> 'a -> unit) -> 'a list -> unit val iterk : (int -> 'a -> unit) -> 'a list -> unit val mapk : (int -> 'a -> 'b) -> 'a list -> 'b list val pp_listcompact : sep:string -> 'a printer -> 'a list printer val pp_listsep : sep:string -> 'a printer -> 'a list printer frama-c-Fluorine-20130601/src/wp/qed/src/mergeset.ml0000644000175000017500000000735012155630203020721 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Merging Set Functor --- *) (* -------------------------------------------------------------------------- *) module type Elt = sig type t val hash : t -> int val equal : t -> t -> bool val compare : t -> t -> int end module Make(E : Elt) = struct module Lset = Listset.Make(E) type elt = E.t type t = E.t list Intmap.t let is_empty es = try Intmap.iteri (fun _ s -> if s <> [] then raise Exit) es ; true with Exit -> false let empty = Intmap.empty let add e m = let h = E.hash e in let w = try Lset.add e (Intmap.find h m) with Not_found -> [e] in Intmap.add h w m let singleton e = let h = E.hash e in Intmap.add h [e] Intmap.empty let mem e m = try Lset.mem e (Intmap.find (E.hash e) m) with Not_found -> false let elements m = Intmap.fold (fun w xs -> List.merge E.compare w xs) m [] let iter_sorted f m = List.iter f (elements m) let fold_sorted f m a = List.fold_left (fun acc x -> f x acc) a (elements m) let nonempty = function [] -> None | l -> Some l let filter f m = Intmap.mapf (fun _ l -> nonempty (Lset.filter f l)) m let partition f m = let m0 = Intmap.map (Lset.partition f) m in Intmap.mapf (fun _ (p,_) -> nonempty p) m0 , Intmap.mapf (fun _ (_,q) -> nonempty q) m0 exception BREAK let iter f = Intmap.iter (Lset.iter f) let fold f = Intmap.fold (Lset.fold f) let for_all f m = try iter (fun x -> if not (f x) then raise BREAK) m ; true with BREAK -> false let exists f m = try iter (fun x -> if f x then raise BREAK) m ; false with BREAK -> true let union = Intmap.union (fun _h -> Lset.union) let inter = Intmap.inter (fun _h -> Lset.union) let subset = Intmap.subset (fun _h -> Lset.subset) let intersect m1 m2 = try Intmap.iter2 (fun _h xs ys -> match xs , ys with | None , _ | _ , None -> () | Some w1 , Some w2 -> if Lset.intersect w1 w2 then raise Exit ) m1 m2 ; false with Exit -> true let equal = Intmap.equal E.equal end frama-c-Fluorine-20130601/src/wp/qed/src/syntax.mli0000644000175000017500000000555112155630203020606 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Qed Abstract Syntax *) (* -------------------------------------------------------------------------- *) type position = { p_file : string ; p_line : int ; p_bol : int ; p_start : int ; p_stop : int ; } type id = position * string type t = | T_INT | T_REAL | T_BOOL | T_PROP | T_ALPHA of id | T_ARRAY of t * t | T_SORT of t list * id | T_RECORD of (id * t) list type binop = | ADD | SUB | MUL | DIV | MOD | AND | OR | IMPLY | EQUIV | EQ | NEQ | LEQ | GEQ | LT | GT type unop = | NOT | OPP type e = | E_ANY of position | E_PVAR of id | E_INT of id | E_REAL of id | E_FUN of id * int * e list | E_TRUE of position | E_FALSE of position | E_BIN of e * position * binop * e | E_UNA of position * unop * e | E_LET of id * int * t option * e * e | E_FORALL of id * int * t option * e list * e | E_EXISTS of id * int * t option * e list * e | E_IF of e * int * e * e | A_GET of e * e | A_SET of e * e * e | E_RECORD of position * (id * int * e) list | E_SETFIELD of e * int * (id * int * e) list | E_GETFIELD of e * id * int type arg = id * int * t option frama-c-Fluorine-20130601/src/wp/qed/src/listset.mli0000644000175000017500000000477712155630203020760 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Merging Set Functor *) (* -------------------------------------------------------------------------- *) module type Elt = sig type t val equal : t -> t -> bool val compare : t -> t -> int end module Make(E : Elt) : sig type elt = E.t type t = elt list val equal : t -> t -> bool val compare : t -> t -> int val empty : t val add : elt -> t -> t val mem : elt -> t -> bool val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val filter : (elt -> bool) -> t -> t val partition : (elt -> bool) -> t -> t * t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val subset : t -> t -> bool val intersect : t -> t -> bool val factorize : t -> t -> t * t * t (** Returns (left,common,right) *) val big_union : t list -> t val big_inter : t list -> t end frama-c-Fluorine-20130601/src/wp/qed/src/sigma.mli0000644000175000017500000000521412155630203020354 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** Generalized Substitutions *) module type S = sig type t (** Substitution *) type term (** Terms *) type explain (** Explanations *) exception Contradiction of explain val empty : t val assume : ?explain:explain -> term -> t -> t (** Raises [Contradiction]. *) val rewrite : ?explain:explain -> term -> term -> t -> t (** Raises [Contradiction]. *) val reduce : t -> term -> term * explain (** Produces a normalized form, with its explanation. *) val is_true : t -> term -> explain option (** Checks whether [reduce] returns [e_true] and returns the explanation. *) val is_false : t -> term -> explain option (** Checks whether [reduce] returns [e_false] and returns the explanation. *) val iter : (term -> term -> explain -> unit) -> t -> unit (** Iterates over all core equalities. *) end (** Type of Explanations *) module type Explain = sig type t val bot : t val cup : t -> t -> t end (** Substitution Factory *) module Make(T : Logic.Term)(E : Explain) : S with type term = T.term and type explain = E.t frama-c-Fluorine-20130601/src/wp/qed/src/unify.ml0000644000175000017500000002145212155630203020237 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Datatype Unifier --- *) (* -------------------------------------------------------------------------- *) open Logic module Make(ADT:Data)(Field:Field) = struct type tau = (Field.t,ADT.t) datatype type signature = (Field.t,ADT.t) funtype type domain = | Top | Eqx of int | Type of t and t = | Gvar of int | Gint | Greal | Gbool | Gprop | Garray of t * t | Gnamed of ADT.t * t list | Gabstract of ADT.t * t list | Grecord of (Field.t * t) list let int = Gint let real = Greal let bool = Gbool let prop = Gprop let array a b = Garray(a,b) let record fts = Grecord fts let data a ts = Gnamed(a,ts) let rec typedef gs = function | Int -> Gint | Real -> Greal | Bool -> Gbool | Prop -> Gprop | Tvar k -> gs.(k-1) | Array(a,b) -> Garray(typedef gs a,typedef gs b) | Data(a,ts) -> Gnamed(a,List.map (typedef gs) ts) | Record fts -> Grecord(List.map (fun (f,t) -> f,typedef gs t) fts) type mgu = { datatype : ADT.t -> tau option ; mutable mgu : domain array ; mutable quoted : (string * t) list ; mutable def : tau Intmap.t ; (* for generalized variables *) mutable gen : int ; (* number of generalized variables *) } let create env = { datatype=env ; mgu=[| |] ; quoted=[] ; gen=1 ; def=Intmap.empty } let fresh s = let k = Array.length s.mgu in s.mgu <- Array.append s.mgu [| Top |] ; Gvar k let quoted s a = try List.assoc a s.quoted with Not_found -> let t = fresh s in s.quoted <- (a,t) :: s.quoted ; t let rec shift k = function | Int -> Gint | Real -> Greal | Bool -> Gbool | Prop -> Gprop | Tvar i -> Gvar(k+i) | Array(a,b) -> Garray(shift k a,shift k b) | Data(a,ts) -> Gnamed(a,List.map (shift k) ts) | Record fts -> Grecord(List.map (fun (f,t) -> f,shift k t) fts) let alloc s n = let k = Array.length s.mgu in let m = Array.create n Top in s.mgu <- Array.append s.mgu m ; k-1 let of_tau s t = let k = alloc s (Kind.degree_of_tau t) in shift k t let of_sig s f = let k = alloc s (Kind.degree_of_sig f) in shift k f.result , List.map (shift k) f.params (* union-find algorithm *) let rec find s k = match s.mgu.(k) with | Eqx k0 -> let k1 = find s k0 in if k1 < k0 then s.mgu.(k) <- s.mgu.(k0) ; k1 | _ -> k let rec definition s a gs = match try s.datatype a with Not_found -> None with | Some t -> let g = typedef (Array.of_list gs) t in (match g with Gnamed(a,gs) -> definition s a gs | _ -> g) | None -> Gabstract(a,gs) (* -------------------------------------------------------------------------- *) (* --- Unification --- *) (* -------------------------------------------------------------------------- *) let rec normvar s k = match s.mgu.(k) with | Eqx k0 -> let k1 = find s k0 in if k1 < k0 then s.mgu.(k) <- s.mgu.(k0) ; normvar s k1 | Top -> Gvar k | Type t -> t let norm s = function | Gvar k -> normvar s k | t -> t let fields s t = let rec getfields s = function | Gnamed(a,gs) -> getfields s (definition s a gs) | Grecord fts -> fts | _ -> failwith "not a record type" in getfields s (norm s t) let rec occur s x = function | Gvar y -> if x = find s y then failwith "cyclic type" | Gnamed(_,ts) | Gabstract(_,ts) -> List.iter (occur s x) ts | Grecord fts -> List.iter (fun (_,t) -> occur s x t) fts | Garray(a,b) -> occur s x a ; occur s x b | Gint | Greal | Gbool | Gprop -> () let rec mgu s = function | [] -> () | (a,b)::eqs -> match norm s a , norm s b with | Gvar x , Gvar y -> if x < y then s.mgu.(y) <- Eqx x else if x > y then s.mgu.(x) <- Eqx y ; mgu s eqs | (Gvar x,t) | (t,Gvar x) -> occur s x t ; s.mgu.(x) <- Type t ; mgu s eqs | ( Gnamed(a,ps) | Gabstract(a,ps) ) , ( Gnamed(b,qs) | Gabstract(b,qs) ) when a=b && List.length ps = List.length qs -> mgu s (List.combine ps qs @ eqs) | Gnamed(a,ps) , Gnamed(b,qs) -> mgu s (( definition s a ps , definition s b qs )::eqs) | Gnamed(a,ps) , _ -> mgu s (( definition s a ps , b )::eqs) | _ , Gnamed(b,qs) -> mgu s (( a , definition s b qs )::eqs) | Gint,Gint -> mgu s eqs | Greal,Greal -> mgu s eqs | (Gprop|Gbool),(Gbool|Gprop) -> mgu s eqs | Garray(a,b) , Garray(a',b') -> mgu s ( (a,a')::(b,b')::eqs ) | Grecord fts , Grecord grs -> mgu_record s fts grs eqs | _ -> failwith "incompatible types" and mgu_record s fts grs eqs = match fts,grs with | (f,t)::fts , (g,r)::grs -> if Field.equal f g then mgu_record s fts grs ((t,r)::eqs) else Plib.failure "incompatible fields %a and %a" Field.pretty f Field.pretty g | [] , [] -> mgu s eqs | (f,_)::_ , [] | [] , (f,_)::_ -> Plib.failure "unexpected field %a" Field.pretty f let unify s a b = mgu s [a,b] (* -------------------------------------------------------------------------- *) (* --- Generalization --- *) (* -------------------------------------------------------------------------- *) let rec sort s a = match norm s a with | Gint -> Sint | Greal -> Sreal | Gprop -> Sprop | Gbool -> Sbool | Gvar _ | Gabstract _ | Grecord _ -> Sdata | Garray(_,b) -> Sarray (sort s b) | Gnamed(a,ps) -> sort s (definition s a ps) let rec alpha s k = match s.mgu.(k) with | Eqx k0 -> let k1 = find s k0 in if k1 < k0 then s.mgu.(k) <- s.mgu.(k0) ; alpha s k1 | Type t -> generalize s t | Top -> try Intmap.find k s.def with Not_found -> let x = Tvar s.gen in s.gen <- succ s.gen ; s.def <- Intmap.add k x s.def ; x and generalize s = function | Gvar k -> alpha s k | Gint -> Int | Greal -> Real | Gbool -> Bool | Gprop -> Prop | Garray(a,b) -> Array(generalize s a,generalize s b) | Gnamed(a,ts) | Gabstract(a,ts) -> Data(a,List.map (generalize s) ts) | Grecord fts -> Record(List.map (fun (f,t) -> f,generalize s t) fts) let final_degree s = s.gen (* -------------------------------------------------------------------------- *) (* --- Description --- *) (* -------------------------------------------------------------------------- *) let rec pretty s fmt = function | Gint -> Format.pp_print_string fmt "int" | Greal -> Format.pp_print_string fmt "real" | Gbool -> Format.pp_print_string fmt "bool" | Gprop -> Format.pp_print_string fmt "prop" | Gvar k -> begin match normvar s k with | Gvar k -> Format.fprintf fmt "?%d" k | t -> pretty s fmt t end | Gnamed(a,ts) | Gabstract(a,ts) -> Kind.pp_data ADT.pretty (pretty s) fmt a ts | Grecord fts -> Kind.pp_record Field.pretty (pretty s) fmt fts | Garray(Gint,e) -> Format.fprintf fmt "%a[]" (pretty s) e | Garray(k,e) -> Format.fprintf fmt "%a[%a]" (pretty s) e (pretty s) k end frama-c-Fluorine-20130601/src/wp/qed/src/pool.mli0000644000175000017500000000465612155630203020236 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Variable Manegement --- *) (* -------------------------------------------------------------------------- *) open Hcons open Logic module type Type = sig type t val dummy : t val equal : t -> t -> bool end module Make(T : Type) : sig type var = (** Hashconsed *) private { vid : int ; vbase : string ; vrank : int ; vtau : T.t ; } val dummy : var (** null vid *) val hash : var -> int (** [vid] *) val equal : var -> var -> bool (** [==] *) val compare : var -> var -> int val pretty : Format.formatter -> var -> unit type pool val create : ?copy:pool -> unit -> pool val add : pool -> var -> unit val fresh : pool -> string -> T.t -> var val alpha : pool -> var -> var end frama-c-Fluorine-20130601/src/wp/qed/src/collection.mli0000644000175000017500000001012412155630203021403 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Merging Maps and Sets *) (* -------------------------------------------------------------------------- *) module type T = sig type t val hash : t -> int val equal : t -> t -> bool val compare : t -> t -> int end module type Map = sig type key type 'a t val empty : 'a t val add : key -> 'a -> 'a t -> 'a t val mem : key -> 'a t -> bool val find : key -> 'a t -> 'a val findk : key -> 'a t -> key * 'a val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val mapf : (key -> 'a -> 'b option) -> 'a t -> 'b t val filter : (key -> 'a -> bool) -> 'a t -> 'a t val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val iter_sorted : (key -> 'a -> unit) -> 'a t -> unit val fold_sorted : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val union : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val inter : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val subset : (key -> 'a -> 'b -> bool) -> 'a t -> 'b t -> bool val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iterk : (key -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit val iter2 : (key -> 'a option -> 'b option -> unit) -> 'a t -> 'b t -> unit val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t type domain val domain : 'a t -> domain end module type Set = sig type elt type t val empty : t val add : elt -> t -> t val singleton : elt -> t val elements : t -> elt list val mem : elt -> t -> bool val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val filter : (elt -> bool) -> t -> t val partition : (elt -> bool) -> t -> t * t val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val iter_sorted : (elt -> unit) -> t -> unit val fold_sorted : (elt -> 'a -> 'a) -> t -> 'a -> 'a val union : t -> t -> t val inter : t -> t -> t val subset : t -> t -> bool val intersect : t -> t -> bool type 'a mapping val mapping : (elt -> 'a) -> t -> 'a mapping end module type S = sig type t type set type 'a map val hash : t -> int val equal : t -> t -> bool val compare : t -> t -> int module Map : Map with type 'a t = 'a map and type key = t and type domain = set module Set : Set with type t = set and type elt = t and type 'a mapping = 'a map end module Make(A : T) : S with type t = A.t frama-c-Fluorine-20130601/src/wp/qed/src/MakeOcaml0000755000175000017500000000501712155630203020331 0ustar mehdimehdi########################################################################## # # # This file is part of WP plug-in of Frama-C. # # # # Copyright (C) 2007-2013 # # CEA (Commissariat a l'energie atomique et aux energies # # 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). # # # ########################################################################## help: @cat README.txt depend: $(OCAMLDEP) $(INCLUDES) *.ml *.mli *.mll *.mly > .depend clean:: rm -f *~ *.cmi *.cmo *.cma *.cmx *.o *.a *.so *.cmxa .SUFFIXES: .ml .mli .mll .mly .cmo .cmi .cmx .ml.cmo: $(OCAMLC) $(OPTCMO) -c $(INCLUDES) $< .mli.cmi: $(OCAMLC) $(OPTCMI) -c $(INCLUDES) $< .ml.cmx: $(OCAMLOPT) $(OPTCMX) -c $(INCLUDES) $< .mll.ml: @rm -f $@ $(OCAMLLEX) $< @chmod a-w $@ .mly.ml: $(OCAMLYACC) $< sinclude .depend ####################################################### #OPTC=$(shell if which ocamlc.opt > /dev/null; then echo -n .opt; else echo -n ""; fi) OPTC?=.opt OCAMLC?=$(OCAMLROOT)ocamlc$(OPTC) OCAMLOPT?=$(OCAMLROOT)ocamlopt$(OPTC) # [JS 2013/04/17] fix bug #1385 #OCAMLLEX?=$(OCAMLROOT)ocamllex$(OPTC) OCAMLLEX?=$(OCAMLROOT)ocamllex OCAMLYACC?=$(OCAMLROOT)ocamlyacc OCAMLDOC?=$(OCAMLROOT)ocamldoc OCAMLDEP?=$(OCAMLROOT)ocamldep OCAMLMKLIB?=$(OCAMLROOT)ocamlmklib #OCAMLLIB=$(shell $(OCAMLC) -where) ####################################################### frama-c-Fluorine-20130601/src/wp/qed/src/logic.mli0000644000175000017500000002763112155630203020360 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 First Order Logic Definition} *) (* -------------------------------------------------------------------------- *) type 'a element = | E_none | E_true | E_false | E_int of int | E_const of 'a (** Algebraic properties for user operators. *) type 'a operator = { inversible : bool ; (* x+y = x+z <-> y=z (on both side) *) associative : bool ; (* x+(y+z)=(x+y)+z *) commutative : bool ; (* x+y=y+x *) idempotent : bool ; (* x+x = x *) neutral : 'a element ; absorbant : 'a element ; } (** Algebraic properties for functions. *) type 'a category = | Function (** no reduction rule *) | Constructor (** [f xs = g ys] iff [f=g && xi=yi] *) | Injection (** [f xs = f ys] iff [xi=yi] *) | Constant of Z.t | Operator of 'a operator (** Quantifiers and Binders *) type binder = | Forall | Exists | Lambda type ('f,'a) datatype = | Prop | Bool | Int | Real | Tvar of int (** ranges over [1..arity] *) | Array of ('f,'a) datatype * ('f,'a) datatype | Record of ('f * ('f,'a) datatype) list | Data of 'a * ('f,'a) datatype list type sort = | Sprop | Sbool | Sint | Sreal | Sdata | Sarray of sort type maybe = Yes | No | Maybe (** Ordered, hash-able and pretty-printable symbols *) module type Symbol = sig type t val hash : t -> int val equal : t -> t -> bool val compare : t -> t -> int val pretty : Format.formatter -> t -> unit val id : t -> string (** full, unique, identifier *) end (** {2 Abstract Data Types} *) module type Data = sig include Symbol val basename : t -> string (** hint for generating fresh names *) end (** {2 Field for Record Types} *) module type Field = sig include Symbol val sort : t -> sort (** of field *) end (** {2 User Defined Functions} *) module type Function = sig include Symbol val category : t -> t category val params : t -> sort list (** params ; exceeding params use Sdata *) val sort : t -> sort (** result *) end (** {2 Bound Variables} *) module type Variable = sig include Symbol val sort : t -> sort val basename : t -> string val dummy : t end (** {2 Representation of Patterns, Functions and Terms} *) type ('f,'a) funtype = { result : ('f,'a) datatype ; (** Type of returned value *) params : ('f,'a) datatype list ; (** Type of parameters *) } type ('f,'d,'x,'e) term_repr = | True | False | Kint of Z.t | Kreal of R.t | Times of Z.t * 'e | Add of 'e list | Mul of 'e list | Div of 'e * 'e | Mod of 'e * 'e | Eq of 'e * 'e | Neq of 'e * 'e | Leq of 'e * 'e | Lt of 'e * 'e | Aget of 'e * 'e | Aset of 'e * 'e * 'e | Rget of 'e * 'f | Rdef of ('f * 'e) list | And of 'e list | Or of 'e list | Not of 'e | Imply of 'e list * 'e | If of 'e * 'e * 'e | Fun of 'd * 'e list | Var of 'x | Apply of 'e * 'e list | Bind of binder * 'x * 'e type 'a affine = { constant : Z.t ; factors : (Z.t * 'a) list } (** {2 Formulae} *) module type Term = sig module ADT : Data module Field : Field module Fun : Function module Var : Variable type term (** {3 Variables} *) type var = Var.t type tau = (Field.t,ADT.t) datatype type signature = (Field.t,ADT.t) funtype module Vars : Idxset.S with type elt = var module Vmap : Idxmap.S with type key = var type pool val pool : ?copy:pool -> unit -> pool val add_var : pool -> var -> unit val add_vars : pool -> Vars.t -> unit val add_term : pool -> term -> unit val fresh : pool -> ?basename:string -> tau -> var val alpha : pool -> var -> var val tau_of_var : var -> tau val base_of_var : var -> string (** {3 Terms} *) type 'a symbol = (Field.t,Fun.t,var,'a) term_repr type repr = term symbol type path = int list (** position of a subterm in a term. *) type record = (Field.t * term) list val is_true : term -> maybe (** Constant time *) val is_false : term -> maybe (** Constant time *) val is_prop : term -> bool (** Boolean or Property *) val is_int : term -> bool (** Integer sort *) val is_real : term -> bool (** Real sort *) val is_arith : term -> bool (** Integer or Real sort *) val are_equal : term -> term -> maybe (** Computes equality *) val repr : term -> repr (** Constant time *) val sort : term -> sort (** Constant time *) val vars : term -> Vars.t (** Constant time *) val subterm: term -> path -> term val change_subterm: term -> path -> term -> term (** {3 Basic constructors} *) val e_true : term val e_false : term val e_bool : bool -> term val e_literal : bool -> term -> term val e_int : int -> term val e_zint : Z.t -> term val e_real : R.t -> term val e_var : var -> term val e_opp : term -> term val e_times : Z.t -> term -> term val e_sum : term list -> term val e_prod : term list -> term val e_add : term -> term -> term val e_sub : term -> term -> term val e_mul : term -> term -> term val e_div : term -> term -> term val e_mod : term -> term -> term val e_eq : term -> term -> term val e_neq : term -> term -> term val e_leq : term -> term -> term val e_lt : term -> term -> term val e_imply : term list -> term -> term val e_equiv : term -> term -> term val e_and : term list -> term val e_or : term list -> term val e_not : term -> term val e_if : term -> term -> term -> term val e_get : term -> term -> term val e_set : term -> term -> term -> term val e_getfield : term -> Field.t -> term val e_record : record -> term val e_fun : Fun.t -> term list -> term (** {3 Quantification and Binding} *) val e_forall : var list -> term -> term val e_exists : var list -> term -> term val e_lambda : var list -> term -> term val e_bind : binder -> var -> term -> term val e_subst : ?pool:pool -> var -> term -> term -> term val e_apply : ?pool:pool -> term -> term list -> term (** {3 Recursion Scheme} *) val e_repr : repr -> term val e_map : (term -> term) -> term -> term (** @raise Invalid_argument on Bind constructor *) val e_iter : (term -> unit) -> term -> unit (** Also goes into Bind constructor *) val f_map : (Vars.t -> term -> term) -> Vars.t -> term -> term (** Pass the bound variables in context *) val f_iter : (Vars.t -> term -> unit) -> Vars.t -> term -> unit (** Pass the bound variables in context *) (** {3 Support for Builtins} *) val add_builtin : Fun.t -> (term list -> term) -> unit (** Register a simplifier for function [f]. The computation code may raise [Not_found], in which case the symbol is not interpreted. If [f] is an operator with algebraic rules (see type [operator]), the children are normalized {i before} builtin call. Circularity can be broken using [e_funop] and [e_funraw]. By the way, it is the responsability of the normalization function to returns a properly normalized term. *) val add_builtin_eq : Fun.t -> (term -> term -> term) -> unit (** Register a builtin equality for comparing any term with head-symbol. {b Must} only need comparison for strictly smaller terms. *) val e_funop : Fun.t -> term list -> term (** Variant of [e_fun] that do not invoke builtins. Operator are still normalized, though. {b warning:} should not be used outside a builtin normalization function. *) val e_funraw : Fun.t -> term list -> term (** Variant of [e_fun] that do not invoke builtins, {i nor} operator normalization rules. {b warning:} should not be used outside a builtin normalization function. *) (** {3 Specific Patterns} *) val literal : term -> bool * term val congruence_eq : term -> term -> (term * term) list option (** If [congruence_eq a b] returns [[ai,bi]], [a=b] is equivalent to [And{ai=bi}]. *) val congruence_neq : term -> term -> (term * term) list option (** If [congruence_eq a b] returns [[ai,bi]], [a<>b] is equivalent to [Or{ai<>bi}]. *) val flattenable : term -> bool val flattens : term -> term -> bool (** The comparison flattens *) val flatten : term -> term list (** Returns an equivalent conjunction *) val affine : term -> term affine val record_with : record -> (term * record) option (** {3 Symbol} *) type t = term val id : t -> int (** unique identifier (stored in t) *) val hash : t -> int (** constant access (stored in t) *) val equal : t -> t -> bool (** physical equality *) val compare : t -> t -> int (** atoms are lower than complex terms ; otherwise, sorted by id. *) val pretty : Format.formatter -> t -> unit val weigth : t -> int (** Informal size *) (** {3 Utilities} *) val is_closed : t -> bool (** No bound variables *) val is_simple : t -> bool (** Constants, variables, functions of arity 0 *) val is_atomic : t -> bool (** Constants and variables *) val is_primitive : t -> bool (** Constants only *) val is_neutral : Fun.t -> t -> bool val is_absorbant : Fun.t -> t -> bool val size : t -> int val basename : t -> string val debug : Format.formatter -> t -> unit val pp_id : Format.formatter -> t -> unit (** internal id *) val pp_rid : Format.formatter -> t -> unit (** head symbol with children id's *) val pp_repr : Format.formatter -> repr -> unit (** head symbol with children id's *) module Tset : Idxset.S with type elt = term module Tmap : Idxmap.S with type key = term (** {2 Shared sub-terms} *) val shared : ?shared:(term -> bool) -> ?shareable:(term -> bool) -> ?closed:Vars.t -> term list -> term list (** Computes the sub-terms that appear several times. [shared marked linked e] returns the shared subterms of [e]. The list of shared subterms is consistent with order of definition: each trailing terms only depend on heading ones. The traversal is controled by two optional arguments: - [atomic] those terms are not traversed (considered as atomic) - [shareable] those terms that can be shared (all by default) - [closed] free variables of [t] authorized in sub-terms *) (** Low-level shared primitives: [shared] is actually a combination of building marks, marking terms, and extracting definitions: {[ let m = marks ?... () in List.iter (mark m) es ; defs m ]} *) type marks val marks : ?shared:(term -> bool) -> ?shareable:(term -> bool) -> ?closed:Vars.t -> unit -> marks val mark : marks -> term -> unit val defs : marks -> term list end frama-c-Fluorine-20130601/src/wp/qed/src/term.mli0000644000175000017500000000356612155630203020233 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 expressions *) open Logic module Make ( ADT : Logic.Data ) ( Field : Logic.Field ) ( Fun : Logic.Function ) : sig include Logic.Term with module ADT = ADT and module Field = Field and module Fun = Fun val debug : Format.formatter -> term -> unit end frama-c-Fluorine-20130601/src/wp/qed/src/typechecker.ml0000644000175000017500000003137712155630203021422 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Qed Typechecker --- *) (* -------------------------------------------------------------------------- *) open Logic open Syntax module Make(ADT:Data)(Field:Field) = struct module U = Unify.Make(ADT)(Field) type t = U.t type tau = (Field.t,ADT.t) datatype type signature = (Field.t,ADT.t) funtype type lookup = { make_field : Syntax.id -> sort -> Field.t ; lookup_field : Syntax.id -> Field.t -> bool ; lookup_typedef : Syntax.id -> tau ; lookup_datatype : ADT.t -> tau option ; lookup_signature : Syntax.id -> signature ; } type symbol = | Local of U.t | Global of signature type env = { sigma : U.mgu ; globals : lookup ; mutable params : (string * symbol) list ; mutable bind : t Intmap.t ; (* node bindings *) } let newenv lookup = { sigma = U.create lookup.lookup_datatype ; params = [] ; globals = lookup ; bind = Intmap.empty ; } (* -------------------------------------------------------------------------- *) (* --- Type Compilation --- *) (* -------------------------------------------------------------------------- *) let rec cc_type (env:env) = function | T_INT -> U.int | T_REAL -> U.real | T_PROP -> U.bool | T_BOOL -> U.prop | T_ALPHA a -> U.quoted env.sigma (snd a) | T_ARRAY(a,b) -> U.array (cc_type env a) (cc_type env b) | T_RECORD fts -> U.record (List.map (cc_field env) fts) | T_SORT(ts,x) -> try let t = env.globals.lookup_typedef x in let d = Kind.degree_of_tau t in if d<>List.length ts then Input.error_at (fst x) "type '%s' has arity %d" (snd x) d ; let ts = List.map (cc_type env) ts in U.typedef (Array.of_list ts) t with Not_found -> Input.error_at (fst x) "unknown type '%s'" (snd x) and cc_field (env:env) (f,t) = let u = cc_type env t in let a = env.globals.make_field f (U.sort env.sigma u) in (a,u) (* -------------------------------------------------------------------------- *) (* --- Typing Environment --- *) (* -------------------------------------------------------------------------- *) let lookup env locals x = try List.assoc (snd x) locals with Not_found -> try List.assoc (snd x) env.params with Not_found -> try Global(env.globals.lookup_signature x) with Not_found -> Input.error_at (fst x) "unknown symbol '%s'" (snd x) (* -------------------------------------------------------------------------- *) (* --- Merge Utilities --- *) (* -------------------------------------------------------------------------- *) let set_expression env e te tr = try U.unify env.sigma te tr with Failure msg -> Ast.error_at e "@[Expression has type %a@ but is required to have type %a@ (%s)@]" (U.pretty env.sigma) tr (U.pretty env.sigma) te msg let set_variable env x tx tv = try U.unify env.sigma tx tv with Failure msg -> Input.error_at (fst x) "@[Variable %s is expected to have type %a@ \ but is here bound to value of type %a@ \ (%s)@]" (snd x) (U.pretty env.sigma) tx (U.pretty env.sigma) tv msg let binop_aryth env x tx y ty = match U.sort env.sigma tx , U.sort env.sigma ty with | Sint , Sint -> U.int | (Sreal|Sint) , (Sreal|Sint) -> U.real | _ -> set_expression env x tx U.int ; set_expression env y ty U.int ; U.int let unop_aryth env x tx = match U.sort env.sigma tx with | Sint -> U.int | Sreal -> U.real | _ -> set_expression env x tx U.int ; U.int let binop_rel env pos tx ty = try U.unify env.sigma tx ty with Failure msg -> Input.error_at pos "@[Can not compare expressions with types@ %a and@ %a@ (%s)" (U.pretty env.sigma) tx (U.pretty env.sigma) ty msg let binop_logic env x tx y ty = set_expression env x tx U.bool ; set_expression env y ty U.bool ; match U.sort env.sigma tx , U.sort env.sigma ty with | Sbool , Sbool -> U.bool | _ -> U.prop let unop_logic env x tx = set_expression env x tx U.bool ; tx let rec set_params env ts es vs = match ts with | [] -> () | t::ts -> set_expression env (List.hd es) t (List.hd vs) ; set_params env ts (List.tl es) (List.tl vs) let bind env k t = env.bind <- Intmap.add k t env.bind ; t let final_degree env = U.final_degree env.sigma let final_type env t = U.generalize env.sigma t let final_node env k = U.generalize env.sigma (Intmap.find k env.bind) let final_fields env k = let u = Intmap.find k env.bind in List.map fst (U.fields env.sigma u) (* -------------------------------------------------------------------------- *) (* --- Parameters --- *) (* -------------------------------------------------------------------------- *) let cc_arg env x = function | None -> U.fresh env.sigma | Some t -> try cc_type env t with Failure msg -> Input.error_at (fst x) "incorrect type for parameter '%s' (%s)" (snd x) msg let cc_result env = function | None -> U.fresh env.sigma | Some t -> try cc_type env t with Failure msg -> failwith (Printf.sprintf "incorrect return type (%s)" msg) let cc_local env x k tx = bind env k (cc_arg env x tx) let cc_param env (x,k,tx) = let u = cc_local env x k tx in env.params <- (snd x,Local u)::env.params let pvar env x = try match List.assoc (snd x) env.params with | Local u -> u | Global _ -> Input.error_at (fst x) "parameter '%s' is associated to a signature, not a pattern" (snd x) with Not_found -> let u = U.fresh env.sigma in env.params <- (snd x,Local u)::env.params ; u let check_local x es = if es <> [] then Input.error_at (fst x) "local variable '%s' is not a function, it can not be applied" (snd x) let check_arity x ts es = let nt = List.length ts in let ne = List.length es in if nt<>ne then Input.error_at (fst x) "symbol '%s' has arity %d but is here applied to %d arguments" (snd x) nt ne let get_field env tr fts f k = try let _,tf = List.find (fun (fd,_) -> env.globals.lookup_field f fd) fts in bind env k tf with Not_found -> Input.error_at (fst f) "field '%s' not defined in %a" (snd f) (U.pretty env.sigma) tr (* -------------------------------------------------------------------------- *) (* --- Expressions (and Patterns) --- *) (* -------------------------------------------------------------------------- *) type locals = (string * symbol) list let rec do_typecheck (env:env) (locals:locals) e = try match e with | E_ANY _ -> U.fresh env.sigma | E_PVAR x -> pvar env x | E_INT _ -> U.int | E_REAL _ -> U.real | E_TRUE _ | E_FALSE _ -> U.bool | E_BIN(x,_,(ADD|SUB|MUL|DIV),y) -> let tx = do_typecheck env locals x in let ty = do_typecheck env locals y in binop_aryth env x tx y ty | E_BIN(x,_,MOD,y) -> set_expression env x (do_typecheck env locals x) U.int ; set_expression env y (do_typecheck env locals y) U.int ; U.int | E_BIN(x,_,(LT|GT|LEQ|GEQ),y) -> let tx = do_typecheck env locals x in let ty = do_typecheck env locals y in ignore (binop_aryth env x tx y ty) ; U.bool | E_BIN(x,pos,(EQ|NEQ),y) -> let tx = do_typecheck env locals x in let ty = do_typecheck env locals y in binop_rel env pos tx ty ; U.bool | E_UNA(_,NOT,x) -> unop_logic env x (do_typecheck env locals x) | E_BIN(x,_,(AND|OR|IMPLY|EQUIV),y) -> let tx = do_typecheck env locals x in let ty = do_typecheck env locals y in binop_logic env x tx y ty | E_UNA(_,OPP,x) -> unop_aryth env x (do_typecheck env locals x) | E_FUN(x,k,es) -> begin match lookup env locals x with | Local u -> check_local x es ; bind env k u | Global s -> check_arity x es s.Logic.params ; let (tr,ts) = U.of_sig env.sigma s in let vs = List.map (do_typecheck env locals) es in set_params env ts es vs ; bind env k tr end | E_IF(c,k,a,b) -> set_expression env c (do_typecheck env locals c) U.bool ; let tr = U.fresh env.sigma in let ta = do_typecheck env locals a in let tb = do_typecheck env locals b in begin try U.unify env.sigma tr ta ; U.unify env.sigma tr tb ; bind env k tr with Failure msg -> Ast.error_at e "@[Incompatible types@ %a (then branch)@ %a (else branch)@ (%s)@]" (U.pretty env.sigma) ta (U.pretty env.sigma) tb msg end | A_GET(m,k) -> let tm = do_typecheck env locals m in let tk = do_typecheck env locals k in let tr = U.fresh env.sigma in let ta = U.array tk tr in begin try U.unify env.sigma tm ta ; tr with Failure msg -> Ast.error_at e "@[Incompatible type@ %a with@ %a in array access@ (%s)@]" (U.pretty env.sigma) tm (U.pretty env.sigma) ta msg end | A_SET(m,k,v) -> let tm = do_typecheck env locals m in let tk = do_typecheck env locals k in let tv = do_typecheck env locals v in let ta = U.array tk tv in begin try U.unify env.sigma tm ta ; ta with Failure msg -> Ast.error_at e "@[Incompatible type@ %a with@ %a in array access@ (%s)@]" (U.pretty env.sigma) tm (U.pretty env.sigma) ta msg end | E_GETFIELD(r,f,k) -> let tr = do_typecheck env locals r in let fts = U.fields env.sigma tr in get_field env tr fts f k | E_RECORD(_,fes) -> U.record (List.map (fun (f,k,e) -> let te = do_typecheck env locals e in let se = U.sort env.sigma te in env.globals.make_field f se , bind env k te) fes) | E_SETFIELD(r,k,fes) -> let tr = do_typecheck env locals r in let fts = U.fields env.sigma tr in List.iter (fun (f,k,e) -> let te = do_typecheck env locals e in let tf = get_field env tr fts f k in U.unify env.sigma te tf) fes ; bind env k tr | E_LET(x,k,t,a,b) -> let ta = do_typecheck env locals a in let tx = cc_local env x k t in let locals = (snd x,Local tx)::locals in set_variable env x tx ta ; do_typecheck env locals b | E_FORALL(x,k,t,_,p) | E_EXISTS(x,k,t,_,p) -> let tx = cc_local env x k t in let locals = (snd x,Local tx)::locals in let tp = do_typecheck env locals p in set_expression env p tp U.bool ; U.prop with err -> Ast.raise_at e err let create lookup args = let env = newenv lookup in List.iter (cc_param env) args ; env let typecheck env e tr = let u = do_typecheck env [] e in let v = cc_result env tr in set_expression env e u v ; final_type env u let signature lookup ts t = let env = create lookup [] in let us = List.map (cc_type env) ts in let u = cc_type env t in { Logic.result = final_type env u ; Logic.params = List.map (final_type env) us ; } end (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/qed/src/relation.ml0000644000175000017500000000650112155630203020720 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Relations --- *) (* -------------------------------------------------------------------------- *) module type S = sig type t type elt val empty : t val add : elt -> elt -> t -> t val mem : elt -> elt -> t -> bool val union : t -> t -> t val inter : t -> t -> t val filter : (elt -> elt -> bool) -> t -> t val iter : (elt -> elt -> unit) -> t -> unit val map : (elt -> elt) -> t -> t end module type Elt = sig type t val compare : t -> t -> int val pretty : Format.formatter -> t -> unit end module type Pair = sig type elt type t = elt * elt val pair : elt -> elt -> t val compare : t -> t -> int val pretty : Format.formatter -> t -> unit end module PAIR(E : Elt) : Pair with type elt = E.t = struct type elt = E.t type t = E.t * E.t (* x << y *) let pair x y = (x,y) let compare (a,b) (c,d) = let cmp = E.compare a c in if cmp <> 0 then cmp else E.compare b d let pretty fmt (x,y) = Format.fprintf fmt "(%a,%a)" E.pretty x E.pretty y end module PSYM(E : Elt) : Pair with type elt = E.t = struct include PAIR(E) let pair x y = if E.compare x y > 0 then (y,x) else (x,y) end module REL(P : Pair) : S with type elt = P.elt = struct module S = Set.Make(P) type elt = P.elt type t = S.t let empty = S.empty let union = S.union let inter = S.inter let mem x y s = S.mem (P.pair x y) s let add x y s = S.add (P.pair x y) s let lift f (x,y) = f x y let filter f = S.filter (lift f) let iter f = S.iter (lift f) let map f s = S.fold (fun (x,y) s -> add (f x) (f y) s) s empty end module Rel(E:Elt) = REL(PAIR(E)) module Sym(E:Elt) = REL(PSYM(E)) frama-c-Fluorine-20130601/src/wp/qed/src/relation.mli0000644000175000017500000000456412155630203021100 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Relations --- *) (* -------------------------------------------------------------------------- *) module type S = sig type t type elt val empty : t val add : elt -> elt -> t -> t val mem : elt -> elt -> t -> bool val union : t -> t -> t val inter : t -> t -> t val filter : (elt -> elt -> bool) -> t -> t val iter : (elt -> elt -> unit) -> t -> unit val map : (elt -> elt) -> t -> t end module type Elt = sig type t val compare : t -> t -> int val pretty : Format.formatter -> t -> unit end module Rel(E:Elt) : S with type elt = E.t (** General relation. *) module Sym(E:Elt) : S with type elt = E.t (** Symetrical relation. *) frama-c-Fluorine-20130601/src/wp/qed/src/listmap.mli0000644000175000017500000000562312155630203020731 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Merging List-Association Functor *) (* -------------------------------------------------------------------------- *) module type Key = sig type t val equal : t -> t -> bool val compare : t -> t -> int end module Make(K : Key) : sig type key = K.t type 'a t = (key * 'a) list val empty : 'a t val add : key -> 'a -> 'a t -> 'a t val mem : key -> 'a t -> bool val find : key -> 'a t -> 'a val findk : key -> 'a t -> key * 'a val remove : key -> 'a t -> 'a t val filter : (key -> 'a -> bool) -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val mapf : (key -> 'a -> 'b option) -> 'a t -> 'b t val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val union : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val inter : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val subset : (key -> 'a -> 'b -> bool) -> 'a t -> 'b t -> bool val iterk : (key -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit val iter2 : (key -> 'a option -> 'b option -> unit) -> 'a t -> 'b t -> unit val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool end frama-c-Fluorine-20130601/src/wp/qed/src/pretty.ml0000644000175000017500000003652212155630203020440 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Printer with sharing --- *) (* -------------------------------------------------------------------------- *) open Logic open Format open Plib module Make(T : Term) = struct open T (* -------------------------------------------------------------------------- *) (* --- Types --- *) (* -------------------------------------------------------------------------- *) let pp_tvarn fmt n = fprintf fmt "?%d" n let pp_alpha fmt = function | 0 -> pp_print_string fmt "'a" | 1 -> pp_print_string fmt "'b" | 2 -> pp_print_string fmt "'c" | 3 -> pp_print_string fmt "'d" | 4 -> pp_print_string fmt "'e" | n -> fprintf fmt "?%d" (n-4) let pp_tau fmt t = let n = Kind.degree_of_tau t in if 0<=n && n<5 then Kind.pp_tau pp_alpha Field.pretty ADT.pretty fmt t else Kind.pp_tau pp_tvarn Field.pretty ADT.pretty fmt t (* -------------------------------------------------------------------------- *) (* --- Variables --- *) (* -------------------------------------------------------------------------- *) module Idx = Map.Make(String) module Ids = Set.Make(String) type env = { mutable named : string Tmap.t ; (* named terms *) mutable index : int Idx.t ; (* index names *) mutable known : Ids.t ; (* known names *) mutable closed : Vars.t ; } (* -------------------------------------------------------------------------- *) (* --- Environment --- *) (* -------------------------------------------------------------------------- *) let empty = { named=Tmap.empty ; index=Idx.empty ; known=Ids.empty ; closed=Vars.empty ; } let closed vars = { named=Tmap.empty ; index=Idx.empty ; known=Vars.fold (fun x s -> Ids.add (Plib.to_string Var.pretty x) s) vars Ids.empty ; closed=vars ; } let copy env = { named = env.named ; index = env.index ; known = env.known ; closed = env.closed ; } let bind x t env = let env = copy env in env.named <- Tmap.add t x env.named ; env.known <- Ids.add x env.known ; env (* -------------------------------------------------------------------------- *) (* --- Shareable --- *) (* -------------------------------------------------------------------------- *) let shareable e = match T.repr e with | And _ | Or _ | Not _ | Imply _ | Eq _ | Neq _ | Leq _ | Lt _ -> false | _ -> true (* -------------------------------------------------------------------------- *) (* --- Fresh --- *) (* -------------------------------------------------------------------------- *) let freshid env term ?id base = let rec scan env base k = let a = Printf.sprintf "%s_%d" base k in if Ids.mem a env.known then scan env base (succ k) else (env.index <- Idx.add base (succ k) env.index ; a) in let freshname env base = scan env base (try Idx.find base env.index with Not_found -> 0) in let x = match id with | None -> freshname env base | Some a -> if Ids.mem a env.known then freshname env base else a in env.known <- Ids.add x env.known ; env.named <- Tmap.add term x env.named ; x let marks env = T.marks ~shareable ~shared:(fun t -> Tmap.mem t env.named) ~closed:env.closed () let fresh env t = let env = copy env in let x = freshid env t (T.basename t) in x , env (* -------------------------------------------------------------------------- *) (* --- Bunch of Quantifier --- *) (* -------------------------------------------------------------------------- *) module TauMap = Map.Make (struct type t = T.tau let compare = Kind.compare_tau T.Field.compare T.ADT.compare end) let group_add m x = let t = tau_of_var x in let xs = try TauMap.find t m with Not_found -> [] in TauMap.add t (x::xs) m let rec group_binders = function | [] -> [] | (q,x)::qxs -> let m = TauMap.add (tau_of_var x) [x] TauMap.empty in group_binder q m qxs and group_binder q m = function | (q0,y)::qxs when q0 = q -> group_binder q (group_add m y) qxs | qxs -> (q,m)::group_binders qxs (* -------------------------------------------------------------------------- *) (* --- Output Form --- *) (* -------------------------------------------------------------------------- *) type out = | Atom of string | Hbox of string * term list | Vbox of string * term list | Unop of string * term | Binop of ( term * string * term ) | Cond of ( term * term * term ) | Call of Fun.t * term list | Closure of term * term list | Access of term * term | Update of term * term * term | Abstraction of ( (binder * var) list * term ) | Record of field list | GetField of term * Field.t and field = | With of term | Field of Field.t * term | Last of Field.t * term let rec fields = function | [] -> [] | [f,v] -> [Last(f,v)] | (f,v)::fvs -> Field(f,v)::fields fvs let rec abstraction qxs e = match T.repr e with | Bind(q,x,t) -> abstraction ((q,x)::qxs) t | _ -> Abstraction( List.rev qxs , e ) let out e = match T.repr e with | Var x -> Atom( Plib.to_string Var.pretty x ) | True -> Atom "true" | False -> Atom "false" | Kint z -> Atom (Z.to_string z) | Kreal r -> Atom (R.to_string r) | Times(z,e) when Z.equal z Z.minus_one -> Unop("-",e) | Times(z,e) -> Hbox("*",[e_zint z;e]) | Add es -> Hbox("+",es) | Mul es -> Hbox("*",es) | Div(a,b) -> Binop(a,"div",b) | Mod(a,b) -> Binop(a,"mod",b) | And es -> Vbox("/\\",es) | Or es -> Vbox("\\/",es) | Not e -> Unop("not ",e) | Imply(hs,p) ->Vbox("->",hs@[p]) | Eq(a,b) -> if T.sort e = Sprop then Vbox("<->",[a;b]) else Hbox("=",[a;b]) | Lt(a,b) -> Hbox("<",[a;b]) | Neq(a,b) -> Hbox("!=",[a;b]) | Leq(a,b) -> Hbox("<=",[a;b]) | Fun(a,es) -> Call(a,es) | Apply(e,es) -> Closure(e,es) | If(c,a,b) -> Cond(c,a,b) | Aget(a,b) -> Access(a,b) | Aset(a,b,c) -> Update(a,b,c) | Bind(q,x,t) -> abstraction [q,x] t | Rget(e,f) -> GetField(e,f) | Rdef fvs -> Record begin match T.record_with fvs with | None -> fields fvs | Some(base,fothers) -> With base :: fields fothers end let named_out env e = try Atom(Tmap.find e env.named) with Not_found -> out e (* -------------------------------------------------------------------------- *) (* --- Atom printer --- *) (* -------------------------------------------------------------------------- *) let rec pp_atom (env:env) (fmt:formatter) e = pp_atom_out env fmt (named_out env e) and pp_atom_out env fmt = function | Atom x -> pp_print_string fmt x | Call(f,es) -> pp_call env fmt f es | Hbox(op,es) -> fprintf fmt "@[(%a)@]" (pp_hbox env op) es | Vbox(op,es) -> fprintf fmt "@[(%a)@]" (pp_vbox env op) es | Unop(op,e) -> fprintf fmt "@[(%s%a)@]" op (pp_atom env) e | Binop op -> fprintf fmt "@[(%a)@]" (pp_binop env) op | Cond c -> fprintf fmt "@[(%a)@]" (pp_cond env) c | Closure(e,es) -> pp_closure env fmt e es | Abstraction abs -> fprintf fmt "@[(%a)@]" (pp_abstraction env) abs | Access(a,b) -> fprintf fmt "@[%a@,[%a]@]" (pp_atom env) a (pp_free env) b | Update(a,b,c) -> fprintf fmt "@[%a@,[%a@,->%a]@]" (pp_atom env) a (pp_atom env) b (pp_free env) c | GetField(e,f) -> fprintf fmt "%a.%a" (pp_atom env) e Field.pretty f | Record fs -> pp_fields env fmt fs and pp_free_out env fmt = function | Atom x -> pp_print_string fmt x | Call(f,es) -> pp_call env fmt f es | Hbox(op,es) -> fprintf fmt "@[%a@]" (pp_hbox env op) es | Vbox(op,es) -> fprintf fmt "@[%a@]" (pp_vbox env op) es | Unop(op,e) -> fprintf fmt "@[%s%a@]" op (pp_atom env) e | Binop op -> fprintf fmt "@[%a@]" (pp_binop env) op | Cond c -> fprintf fmt "@[%a@]" (pp_cond env) c | Closure(e,es) -> pp_closure env fmt e es | Abstraction abs -> fprintf fmt "@[%a@]" (pp_abstraction env) abs | (Access _ | Update _ | Record _ | GetField _) as a -> pp_atom_out env fmt a and pp_fields (env:env) (fmt:formatter) fs = fprintf fmt "@[{@[" ; List.iter (function | With r -> fprintf fmt "@ %a with" (pp_atom env) r | Field (f,v) -> fprintf fmt "@ @[%a =@ %a ;@]" Field.pretty f (pp_free env) v | Last (f,v) -> fprintf fmt "@ @[%a =@ %a@]" Field.pretty f (pp_free env) v ) fs ; fprintf fmt "@]@ }@]" (* -------------------------------------------------------------------------- *) (* --- Free printer --- *) (* -------------------------------------------------------------------------- *) and pp_free (env:env) (fmt:formatter) e = pp_free_out env fmt (named_out env e) and pp_freedef (env:env) (fmt:formatter) e = pp_free_out env fmt (out e) (* -------------------------------------------------------------------------- *) (* --- Call printer --- *) (* -------------------------------------------------------------------------- *) and pp_call (env:env) (fmt:formatter) f = function | [] -> Fun.pretty fmt f | es -> fprintf fmt "@[(%a" Fun.pretty f ; List.iter (fun e -> fprintf fmt "@ %a" (pp_atom env) e) es ; fprintf fmt ")@]" (* -------------------------------------------------------------------------- *) (* --- Horizonal Boxes --- *) (* -------------------------------------------------------------------------- *) and pp_hbox (env:env) (sep:string) (fmt:formatter) = function | [] -> () | e::es -> pp_atom env fmt e ; List.iter (fun e -> fprintf fmt "%s@,%a" sep (pp_atom env) e) es (* -------------------------------------------------------------------------- *) (* --- Vertical Boxes --- *) (* -------------------------------------------------------------------------- *) and pp_vbox (env:env) (sep:string) (fmt:formatter) = function | [] -> () | e::es -> pp_atom env fmt e ; List.iter (fun e -> fprintf fmt "@ %s %a" sep (pp_atom env) e) es (* -------------------------------------------------------------------------- *) (* --- Specific Operators --- *) (* -------------------------------------------------------------------------- *) and pp_binop (env:env) (fmt:formatter) (a,op,b) = fprintf fmt "%a@ %s %a" (pp_atom env) a op (pp_atom env) b and pp_cond (env:env) (fmt:formatter) (c,a,b) = fprintf fmt "if %a@ then %a@ else %a" (pp_atom env) c (pp_atom env) a (pp_atom env) b and pp_closure (env:env) (fmt:formatter) e es = fprintf fmt "@[(%a" (pp_atom env) e ; List.iter (fun e -> fprintf fmt "@ %a" (pp_atom env) e) es ; fprintf fmt ")@]" (* -------------------------------------------------------------------------- *) (* --- Abstraction --- *) (* -------------------------------------------------------------------------- *) and pp_abstraction (env:env) (fmt:formatter) (qxs,t) = let groups = group_binders qxs in List.iter (fun (q,m) -> match q with | Forall -> fprintf fmt "@[forall %a.@]@ " (pp_group env) m | Exists -> fprintf fmt "@[exists %a.@]@ " (pp_group env) m | Lambda -> fprintf fmt "@[fun %a ->@]@ " (pp_group env) m ) groups ; pp_share env fmt t and pp_group (env:env) (fmt:formatter) m = let sep = ref false in TauMap.iter (fun t xs -> if !sep then fprintf fmt ",@," ; Plib.iteri (fun idx x -> let id = Plib.to_string Var.pretty x in let a = freshid env (T.e_var x) ~id (Var.basename x) in env.closed <- Vars.add x env.closed ; match idx with | Isingle | Ifirst -> pp_print_string fmt a | Imiddle | Ilast -> fprintf fmt ",@,%s" a ) (List.rev xs) ; fprintf fmt ":%a" pp_tau t ; sep := true ; ) m (* -------------------------------------------------------------------------- *) (* --- Sharing --- *) (* -------------------------------------------------------------------------- *) and pp_share (env:env) (fmt:formatter) t = begin fprintf fmt "@[" ; let ts = T.shared ~shareable ~shared:(fun t -> Tmap.mem t env.named) ~closed:env.closed [t] in List.iter (fun t -> let e0 = copy env in let x = freshid env t (Kind.basename (T.sort t)) in fprintf fmt "@[let %s =@ %a in@]@ " x (pp_atom e0) t ) ts ; pp_free env fmt t ; fprintf fmt "@]" ; end (* -------------------------------------------------------------------------- *) (* --- Entry Point --- *) (* -------------------------------------------------------------------------- *) let pp_term (env:env) (fmt:formatter) t = pp_share (copy env) fmt t let pp_def (env:env) (fmt:formatter) t = pp_freedef (copy env) fmt t end frama-c-Fluorine-20130601/src/wp/qed/src/partition.ml0000644000175000017500000001052612155630203021116 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Partition based on union-find --- *) (* -------------------------------------------------------------------------- *) module type Explain = sig type t val bot : t val cup : t -> t -> t end module Unit = struct type t = unit let bot = () let cup () () = () end module type S = sig type t type elt type explain val empty : t val join : ?explain:explain -> elt -> elt -> t -> t val class_of : t -> elt -> elt val is_equal : t -> elt -> elt -> bool val members : t -> elt -> elt list val repr : t -> elt -> elt * explain val equal : t -> elt -> elt -> explain option val explain : t -> elt -> elt -> explain val iter : (elt -> elt list -> unit) -> t -> unit val map : (elt -> elt) -> t -> t end module MakeExplain(A : Map.OrderedType)(E : Explain) = struct module M = Map.Make(A) type elt = A.t type explain = E.t type t = { mutable color : (A.t * E.t) M.t ; members : A.t list M.t ; (* sorted *) } let empty = { color = M.empty ; members = M.empty } let rec union ca cb = match ca , cb with | [] , r | r , [] -> r | a :: ra , b :: rb -> let cmp = A.compare a b in if cmp < 0 then a :: union ra cb else if cmp > 0 then b :: union ca rb else a :: union ra rb let rec lookup p a = let ((a0,e0) as w0) = M.find a p.color in try let (a1,e1) = lookup p a0 in let w = (a1,E.cup e0 e1) in p.color <- M.add a w p.color ; w with Not_found -> w0 let repr p a = try lookup p a with Not_found -> a,E.bot let class_of p a = try fst (lookup p a) with Not_found -> a let equal t a b = let (a,u) = repr t a in let (b,v) = repr t b in if A.compare a b = 0 then Some (E.cup u v) else None let explain t a b = let (a,u) = repr t a in let (b,v) = repr t b in if A.compare a b = 0 then E.cup u v else E.bot let is_equal t a b = A.compare (class_of t a) (class_of t b) = 0 let k_members p e = try M.find e p.members with Not_found -> [e] let members p e = k_members p (class_of p e) let join ?(explain=E.bot) a b p = let a = class_of p a in let b = class_of p b in let cmp = A.compare a b in if cmp = 0 then p else let c = union (k_members p a) (k_members p b) in if cmp < 0 then { color = M.add b (a,explain) p.color ; members = M.add a c (M.remove b p.members) ; } else { color = M.add a (b,explain) p.color ; members = M.add b c (M.remove a p.members) ; } let iter f p = M.iter f p.members let map f p = M.fold (fun a (b,explain) p -> join ~explain (f a) (f b) p) p.color empty end module Make(A : Map.OrderedType) = MakeExplain(A)(Unit) frama-c-Fluorine-20130601/src/wp/qed/src/kind.mli0000644000175000017500000000610612155630203020202 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Sort and Types Tools --- *) (* -------------------------------------------------------------------------- *) (** Logic Types Utilities *) open Logic val of_tau : ('f,'a) datatype -> sort val of_poly : (int -> sort) -> ('f,'a) datatype -> sort val image : sort -> sort val degree_of_tau : ('f,'a) datatype -> int val degree_of_list : ('f,'a) datatype list -> int val degree_of_sig : ('f,'a) funtype -> int val type_params : int -> ('f,'a) datatype list val merge : sort -> sort -> sort val merge_list : ('a -> sort) -> sort -> 'a list -> sort val tmap : ('a,'f) datatype array -> ('a,'f) datatype -> ('a,'f) datatype val basename : sort -> string val pretty : Format.formatter -> sort -> unit val pp_tau : (Format.formatter -> int -> unit) -> (Format.formatter -> 'f -> unit) -> (Format.formatter -> 'a -> unit) -> Format.formatter -> ('f,'a) datatype -> unit val pp_data : (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> Format.formatter -> 'a -> 'b list -> unit val pp_record: (Format.formatter -> 'f -> unit) -> (Format.formatter -> 'b -> unit) -> Format.formatter -> ?opened:bool -> ('f * 'b) list -> unit val eq_tau : ('f -> 'f -> bool) -> ('a -> 'a -> bool) -> ('f,'a) datatype -> ('f,'a) datatype -> bool val compare_tau: ('f -> 'f -> int) -> ('a -> 'a -> int) -> ('f,'a) datatype -> ('f,'a) datatype -> int frama-c-Fluorine-20130601/src/wp/qed/src/export_whycore.mli0000644000175000017500000001375612155630203022347 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Common Exportation Engine for Alt-Ergo and Why3 --- *) (* -------------------------------------------------------------------------- *) open Logic open Format open Plib open Engine (** Common Exportation Engine for Why-3 and Alt-Ergo *) module Make(T : Term) : sig open T type trigger = (T.var,Fun.t) ftrigger type typedef = (tau,Field.t,Fun.t) ftypedef class virtual engine : object method virtual datatype : ADT.t -> string method virtual field : Field.t -> string method basename : string -> string method virtual link : cmode -> Fun.t -> link method link_name : cmode -> Fun.t -> string method declare : string -> unit method declare_all : string list -> unit method local : (unit -> unit) -> unit method global : (unit -> unit) -> unit method t_int : string method t_real : string method t_bool : string method t_prop : string method virtual t_atomic : tau -> bool method pp_tvar : int printer method virtual pp_array : tau printer method virtual pp_farray : tau printer2 method virtual pp_datatype : ADT.t -> tau list printer method pp_subtau : tau printer method mode : mode method with_mode : mode -> (mode -> unit) -> unit method virtual e_true : cmode -> string method virtual e_false : cmode -> string method virtual pp_int : amode -> Z.t printer method virtual pp_cst : Numbers.cst printer method pp_real : R.t printer method virtual is_atomic : term -> bool method virtual op_spaced : string -> bool method virtual callstyle : callstyle method pp_apply : cmode -> term -> term list printer method pp_fun : cmode -> Fun.t -> term list printer method op_scope : amode -> string option method virtual op_real_of_int : op method virtual op_add : amode -> op method virtual op_sub : amode -> op method virtual op_mul : amode -> op method virtual op_div : amode -> op method virtual op_mod : amode -> op method virtual op_minus : amode -> op method pp_times : formatter -> Z.t -> term -> unit method virtual op_equal : cmode -> op method virtual op_noteq : cmode -> op method virtual op_eq : cmode -> amode -> op method virtual op_neq : cmode -> amode -> op method virtual op_lt : cmode -> amode -> op method virtual op_leq : cmode -> amode -> op method pp_array_get : formatter -> term -> term -> unit method pp_array_set : formatter -> term -> term -> term -> unit method virtual op_record : string * string method pp_get_field : formatter -> term -> Field.t -> unit method pp_def_fields : record printer method virtual op_not : cmode -> op method virtual op_and : cmode -> op method virtual op_or : cmode -> op method virtual op_imply : cmode -> op method virtual op_equiv : cmode -> op method pp_not : term printer method pp_imply : formatter -> term list -> term -> unit method pp_equal : term printer2 method pp_noteq : term printer2 method virtual pp_conditional : formatter -> term -> term -> term -> unit method virtual pp_forall : tau -> var list printer method virtual pp_intros : tau -> var list printer method virtual pp_exists : tau -> var list printer method pp_lambda : var list printer method bind : var -> unit method virtual pp_let : formatter -> string -> term -> unit method is_shareable : term -> bool method pp_atom : term printer method pp_flow : term printer method pp_tau : tau printer method pp_var : var printer method pp_term : term printer method pp_prop : term printer method pp_expr : tau -> term printer method pp_param : var printer method virtual pp_trigger : trigger printer method virtual pp_declare_adt : formatter -> ADT.t -> int -> unit method virtual pp_declare_def : formatter -> ADT.t -> int -> tau -> unit method virtual pp_declare_sum : formatter -> ADT.t -> int -> (Fun.t * tau list) list -> unit method pp_declare_symbol : cmode -> formatter -> Fun.t -> unit method declare_type : formatter -> ADT.t -> int -> typedef -> unit method declare_axiom : formatter -> string -> T.var list -> trigger list list -> term -> unit method declare_prop : kind:string -> formatter -> string -> T.var list -> trigger list list -> term -> unit end end frama-c-Fluorine-20130601/src/wp/qed/src/ocamldoc.css0000644000175000017500000001043612155630203021046 0ustar mehdimehdi/**************************************************************************/ /* */ /* This file is part of WP plug-in of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* CEA (Commissariat a l'energie atomique et aux energies */ /* 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). */ /* */ /**************************************************************************/ * { margin: 0; padding: 0 } body { color: #222; font-family: "Verdana", sans-serif; font-size: 11px; width: 18cm; margin-left: 2.5cm; margin-top: 0.5cm; margin-bottom: 1cm; padding: 4mm 18mm 4mm 28mm; border: thin dotted gray; background: #EEEEEE } h1 { width: 18cm; padding: 2mm 10mm 2mm 10mm; position: relative; left: -1cm; margin-top: 3mm; margin-bottom: 3mm; border: thin solid black; background: lightgray; font-size: 20px; font-family: "Times", serif; font-weight: bold; text-align: left; color: black } h2 { width: 18cm; margin-top: 2mm; margin-bottom: 2mm; border-bottom: thin solid gray; color: darkgreen } h3 { width: 15cm; margin-left: 4mm; margin-top: 4mm; margin-bottom: 2mm; border-bottom: thin solid gray; color: darkgreen } h4,h5,h6, div.h7, div.h8, div.h9 { margin-left: 4mm; margin-top: 4mm; margin-bottom: 1mm; font-size: 10px; font-style: italic; font-weight: bold; color: darkgreen } hr { border: 1pt solid darkgreen; margin-top: 4mm; margin-bottom: 4mm } a:visited { color: maroon; text-decoration: none } a:link { color: maroon; text-decoration: none } a:hover { background-color: lightgray; color: darkgreen } a:active { background-color: lightgray; color: firebrick } .navbar { margin-bottom: 4mm ; font-size: 10px } .keyword { font-weight : bold; color: darkgoldenrod } .keywordsign { color : #C04600 } .superscript { font-size: 7px } .subscript { font-size: 7px } .warning { color: firebrick ; font-style: italic; margin-right:1ex } .info { padding: 1mm 1mm 1mm 1em; margin-left: 1em; margin-right: 3em; border-left: darkgreen 1px solid; } td .info { border-left: none } .param_info { margin-top: 4px; margin-left : 3em; margin-right : 3em } .typetable { border-style : hidden } .indextable { margin-top: 2mm ; padding: 2mm 6mm 2mm 4mm ; border-style : hidden ; border-top: darkgreen thin solid ; border-bottom: darkgreen thin solid } .paramstable { border-style : hidden ; padding: 5pt 5pt } /* body { background-color : White } */ tr { font-size: 11px } td.typefieldcomment { font-family: serif; color: darkgreen } pre { color : #263F71 ; font-size: 11px; font-family: "Everson Mono", monospace; margin-top: 1mm } .code { color : #465F91 ; font-size: 11px; font-family: "Everson Mono", monospace } .comment { color : darkgreen; font-family: serif } .constructor { color : darkblue } .type { color: #5C6585 } .string { color: maroon } div.sig_block {margin-left: 2em} li { margin-left: 2em } p { margin-top: 2mm ; margin-bottom: 2mm } ul { margin-top: 2mm ; margin-bottom: 2mm }frama-c-Fluorine-20130601/src/wp/qed/src/idxmap.ml0000644000175000017500000000733412155630203020372 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 type S = sig type key type 'a t val is_empty : 'a t -> bool val empty : 'a t val add : key -> 'a -> 'a t -> 'a t val mem : key -> 'a t -> bool val find : key -> 'a t -> 'a val remove : key -> 'a t -> 'a t val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : (key -> 'a -> 'b) -> 'a t -> 'b t val mapf : (key -> 'a -> 'b option) -> 'a t -> 'b t val filter : (key -> 'a -> bool) -> 'a t -> 'a t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val union : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val inter : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t end module type IndexedKey = sig type t val id : t -> int (** unique per t *) end module Make( K : IndexedKey ) = struct type key = K.t type 'a t = (key * 'a) Intmap.t let is_empty = Intmap.is_empty let empty = Intmap.empty let add k x m = Intmap.add (K.id k) (k,x) m let mem k m = Intmap.mem (K.id k) m let find k m = snd (Intmap.find (K.id k) m) let remove k m = Intmap.remove (K.id k) m let compare f m1 m2 = Intmap.compare (fun (_,a) (_,b) -> f a b) m1 m2 let equal f m1 m2 = Intmap.equal (fun (_,a) (_,b) -> f a b) m1 m2 let iter f m = Intmap.iter (fun (k,v) -> f k v) m let map f m = Intmap.map (fun (k,v) -> k,f k v) m let pack k = function None -> None | Some v -> Some (k,v) let mapf f m = Intmap.mapf (fun _ (k,v) -> pack k (f k v)) m let filter f m = Intmap.filter (fun _ (k,v) -> f k v) m let fold f m w = Intmap.fold (fun (k,v) w -> f k v w) m w let union f a b = Intmap.union (fun _ (k,v) (_,v') -> k,f k v v') a b let inter f a b = Intmap.inter (fun _ (k,v) (_,v') -> k,f k v v') a b let pack k = function None -> None | Some v -> Some (k,v) let merge f a b = Intmap.merge (fun _ u v -> match u , v with | None , None -> None | Some(k,v) , None -> pack k (f k (Some v) None) | None , Some(k,v) -> pack k (f k None (Some v)) | Some(k,v) , Some(_,v') -> pack k (f k (Some v) (Some v')) ) a b end frama-c-Fluorine-20130601/src/wp/qed/src/typechecker.mli0000644000175000017500000000515212155630203021563 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Qed Syntax Typechecker *) (* -------------------------------------------------------------------------- *) open Logic module Make(ADT:Data)(Field:Field) : sig type t (* Not yet generalized type *) type env (* Typing environment *) type tau = (Field.t,ADT.t) datatype type signature = (Field.t,ADT.t) funtype type lookup = { make_field : Syntax.id -> sort -> Field.t ; lookup_field : Syntax.id -> Field.t -> bool ; lookup_typedef : Syntax.id -> tau ; lookup_datatype : ADT.t -> tau option ; lookup_signature : Syntax.id -> signature ; } val signature : lookup -> Syntax.t list -> Syntax.t -> signature val create : lookup -> Syntax.arg list -> env val typecheck : env -> Syntax.e -> Syntax.t option -> tau val final_degree : env -> int val final_type : env -> t -> tau val final_node : env -> int -> tau val final_fields : env -> int -> Field.t list end frama-c-Fluorine-20130601/src/wp/qed/src/topology.mli0000644000175000017500000000421512155630203021130 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** Topological sort in graphs *) module type Element = sig type t val hash : t -> int val equal : t -> t -> bool end module Make(E : Element) : sig type succ = (E.t -> unit) -> E.t -> unit (** Iterator on the successors of an element *) type root = (E.t -> unit) -> unit (** Iterator on the required roots *) val components : succ:succ -> root:root -> ?size:int -> unit -> E.t list array (** The array of components. For two elements [a in Ci] and [b in Cj] with [i<=j], then [a->*b] by transitive closure of [succ] relation. *) end frama-c-Fluorine-20130601/src/wp/qed/src/numbers.mll0000644000175000017500000001311312155630203020727 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Parsing for Constants --- *) (* -------------------------------------------------------------------------- *) { type base = Dec | Hex type sign = Pos | Neg type cst = { base : base ; sign : sign ; man : string ; com : string ; exp : int ; } let error m s = raise (Invalid_argument (Printf.sprintf "%s %S" m s)) let sign = function | "-" -> Neg | "+" -> Pos | "" -> Pos | s -> error "Unexpected sign" s let exp e = (* first char: exponent, second char: optional sign *) let n = String.length e in if n > 1 then let k = if e.[1] = '+' then 2 else 1 in int_of_string (String.sub e k (String.length e - k)) else 0 let rec trail s k = if k >= 0 && s.[k] = '0' then trail s (pred k) else k let rec head s k = if k < String.length s && s.[k] = '0' then head s (succ k) else k let compile sign base man com exp = let man = let k = head man 0 in let n = String.length man in if k < n then String.sub man k (n-k) else "" in let com = let n = String.length com in let k = trail com (n-1) in if k > 0 then String.sub com 1 k else "" in { base ; sign ; man ; com ; exp } } let zero = '0'* let sign = ['-' '+'] let digit = ['0'-'9'] let exp = sign? digit+ let hex = ['a'-'f' 'A'-'F' '0'-'9'] rule token = parse (sign? as s) "0d"? (digit* as m) (("." digit*)? as c) ((['e' 'E'] exp)? as e) eof { compile (sign s) Dec m c (exp e) } | (sign? as s) "0x"? (hex* as m) (("." hex*)? as c) ((['p' 'P'] exp)? as e) eof { compile (sign s) Hex m c (exp e) } | _ { raise Not_found } and token_dec = parse (sign? as s) "0d"? (digit* as m) (("." digit*)? as c) ((['e' 'E'] exp)? as e) eof { compile (sign s) Dec m c (exp e) } | _ { raise Not_found } and token_hex = parse (sign? as s) "0x"? (hex* as m) (("." hex*)? as c) ((['p' 'P'] exp)? as e) eof { compile (sign s) Hex m c (exp e) } | _ { raise Not_found } { let parse ?base s = try let lexbuf = Lexing.from_string s in match base with | None -> token lexbuf | Some Dec -> token_dec lexbuf | Some Hex -> token_hex lexbuf with Not_found -> error "Unrecognized constant" s let pretty fmt cst = begin if cst.sign = Neg then Format.pp_print_char fmt '-' ; Format.pp_print_char fmt '.' ; Format.pp_print_string fmt cst.man ; Format.pp_print_string fmt cst.com ; Format.pp_print_char fmt (match cst.base with Dec -> 'e' | Hex -> 'p') ; Format.pp_print_int fmt cst.exp ; end let is_zero cst = cst.man = "" && cst.com = "" let hex c = let d = match c with | '0' .. '9' -> int_of_char '0' | 'a' .. 'f' -> int_of_char 'a' - 10 | 'A' .. 'F' -> int_of_char 'A' - 10 | _ -> let e = "?" in e.[0] <- c ; error "Incorrect hex-digit" e in int_of_char c - d open Big_int let rec add_hex s a i = if i < String.length s then let d = hex s.[i] in let a = shift_left_big_int a 4 in let a = add_int_big_int d a in add_hex s a (succ i) else a let of_hex s (* non empty *) = let u = hex s.[0] in let a = big_int_of_int u in add_hex s a 1 let big_int_of_hex s = if String.length s > 0 then of_hex s else zero_big_int let dec_of_hex s = if String.length s > 0 then string_of_big_int (of_hex s) else "" let power_of_two e = if e < 0 then raise (Invalid_argument "negative power") ; let a = shift_left_big_int unit_big_int e in string_of_big_int a let power_of_ten e = if e < 0 then raise (Invalid_argument "negative power") ; let s = String.make (succ e) '0' in s.[0] <- '1' ; s let significant cst = let digits = cst.man ^ cst.com in let coma = String.length cst.com in let exp = match cst.base with | Dec -> cst.exp - coma | Hex -> cst.exp - 4 * coma in digits , exp } frama-c-Fluorine-20130601/src/wp/qed/src/linker.ml0000644000175000017500000001315712155630203020374 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 open Logic open Plib module B = Map.Make(String) module S = Set.Make(String) (* -------------------------------------------------------------------------- *) (* --- Identifiers --- *) (* -------------------------------------------------------------------------- *) let is_letter c = c = '_' || ('a' <= c && c <= 'z') || ('a' <= c && c <= 'z') || ('0' <= c && c <= '9') let is_ident op = is_letter op.[String.length op - 1] let ident base = let p = Buffer.create 32 in for i=0 to String.length base - 1 do let c = base.[i] in if is_letter c then Buffer.add_char p c done ; Buffer.contents p (* -------------------------------------------------------------------------- *) (* --- Allocation --- *) (* -------------------------------------------------------------------------- *) type allocator = { mutable base : int B.t ; mutable domain : S.t ; } let rec lookup d a k = let s = Printf.sprintf "%s_%d" a k in if S.mem s d then lookup d a (succ k) else s,k let fresh m a = let k0 = try B.find a m.base with Not_found -> 0 in let s,k = lookup m.domain a k0 in m.base <- B.add a (succ k) m.base ; m.domain <- S.add s m.domain ; s let declare m x = m.domain <- S.add x m.domain let allocator () = { domain = S.empty ; base = B.empty } let copy m = { domain = m.domain ; base = m.base } (* -------------------------------------------------------------------------- *) (* --- Linker --- *) (* -------------------------------------------------------------------------- *) class type ['a,'idx] linker = object method lock : unit method clear : unit method push : 'idx method pop : 'idx -> unit method mem : 'a -> bool method find : 'a -> string method link : 'a -> string -> unit method print : 'a printer method alloc : basename:string -> 'a -> string method alloc_with : allocator -> unit method reserve : basename:string -> string method bind_reserved : 'a -> string -> unit end module Link(A : Symbol) = struct module I = Map.Make(A) type index = string I.t class alinker = object(self) val mutable alloc : allocator option = None val mutable index : index = I.empty method push = index method pop idx = index <- idx method lock = alloc <- None method alloc_with allocator = alloc <- Some allocator method clear = index <- I.empty method find a = I.find a index method mem a = I.mem a index method print fmt a = try pp_print_string fmt (I.find a index) with Not_found -> fprintf fmt "<%a>" A.pretty a method link a f = match alloc with | None -> failwith "Qed.Linker.Locked" | Some allocator -> declare allocator f ; index <- I.add a f index method alloc ~basename a = let s = self#reserve ~basename in index <- I.add a s index ; s method reserve ~basename = match alloc with | None -> failwith "Qed.Linker.Locked" | Some allocator -> fresh allocator basename method bind_reserved a s = index <- I.add a s index end let linker () = (new alinker :> (A.t,index) linker) end (* -------------------------------------------------------------------------- *) (* --- Records --- *) (* -------------------------------------------------------------------------- *) module Record(T : Logic.Term) = struct module Smap = Map.Make (struct type t = T.Field.t list let compare = Hcons.compare_list T.Field.compare end) module Amap = Map.Make(T.ADT) type t = { mutable fields : T.Field.t list Amap.t ; mutable record : T.ADT.t Smap.t ; } let create () = { fields = Amap.empty ; record = Smap.empty } let register m adt fs = begin m.fields <- Amap.add adt fs m.fields ; m.record <- Smap.add fs adt m.record ; end let get_fields m a = Amap.find a m.fields let get_record m s = Smap.find s m.record end frama-c-Fluorine-20130601/src/wp/qed/src/idxmap.mli0000644000175000017500000000504512155630203020540 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** Map with indexed keys *) module type S = sig type key type 'a t val is_empty : 'a t -> bool val empty : 'a t val add : key -> 'a -> 'a t -> 'a t val mem : key -> 'a t -> bool val find : key -> 'a t -> 'a val remove : key -> 'a t -> 'a t val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : (key -> 'a -> 'b) -> 'a t -> 'b t val mapf : (key -> 'a -> 'b option) -> 'a t -> 'b t val filter : (key -> 'a -> bool) -> 'a t -> 'a t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val union : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val inter : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t end module type IndexedKey = sig type t val id : t -> int (** unique per t *) end module Make( K : IndexedKey ) : S with type key = K.t frama-c-Fluorine-20130601/src/wp/qed/src/lexer.mli0000644000175000017500000000501312155630203020370 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Terms *) (* -------------------------------------------------------------------------- *) open Syntax type lexeme = | INT of string | REAL of string | STRING of string | IDENT of string | QUOTED of string | KEYWORD of string | END | EOF type keymap val keymap : string list -> keymap val extend : keymap -> string list -> keymap include Input.S with type token = lexeme and type langage = keymap val skip_pos : input -> position val skip_key : input -> string -> unit val skip_ident : input -> id val pp_lexeme : Format.formatter -> lexeme -> unit val is_key : input -> string -> bool val parse_list : left:string -> sep:string -> right:string -> (input -> 'a) -> input -> 'a list option val parse_option : key:string -> (input -> 'a) -> input -> 'a option frama-c-Fluorine-20130601/src/wp/qed/src/intset.mli0000644000175000017500000000417512155630203020567 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** Set of integers using Patricia Trees. From the paper of Chris Okasaki and Andrew Gill: 'Fast Mergeable Integer Maps'. *) type t val compare : t -> t -> int val equal : t -> t -> bool val empty : t val singleton : int -> t val is_empty : t -> bool val cardinal : t -> int val elements : t -> int list val mem : int -> t -> bool val add : int -> t -> t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val subset : t -> t -> bool val iter : (int -> unit) -> t -> unit val fold : (int -> 'a -> 'a) -> t -> 'a -> 'a frama-c-Fluorine-20130601/src/wp/qed/src/kind.ml0000644000175000017500000001470212155630203020032 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Tau & Sort Manipulations --- *) (* -------------------------------------------------------------------------- *) open Logic let rec of_poly alpha = function | Prop -> Sprop | Bool -> Sbool | Int -> Sint | Real -> Sreal | Tvar x -> alpha x | Data _ -> Sdata | Array(_,d) -> Sarray (of_poly alpha d) | Record _ -> Sdata let of_tau t = of_poly (fun _ -> Sdata) t let rec merge a b = match a,b with | Sdata , _ | _ , Sdata -> Sdata | Sprop , _ | _ , Sprop -> Sprop | Sbool , _ | _ , Sbool -> Sbool | Sarray x , Sarray y -> Sarray (merge x y) | Sarray _ , _ | _ , Sarray _ -> Sdata | Sint , Sreal | Sreal , Sint -> Sreal | Sint , Sint -> Sint | Sreal , Sreal -> Sreal let image = function Sarray s -> s | _ -> Sdata let rec merge_list f s = function | [] -> s | x::xs -> if s = Sprop then Sprop else merge_list f (merge s (f x)) xs let pretty fmt = function | Sprop -> Format.pp_print_string fmt "Prop" | Sbool -> Format.pp_print_string fmt "Bool" | Sdata -> Format.pp_print_string fmt "Term" | Sint -> Format.pp_print_string fmt "Int" | Sreal -> Format.pp_print_string fmt "Real" | Sarray _ -> Format.pp_print_string fmt "Array" let basename = function | Sprop | Sbool -> "P" | Sdata -> "a" | Sint -> "x" | Sreal -> "r" | Sarray _ -> "m" let rec degree_of_tau = function | Tvar n -> n | Int | Real | Bool | Prop -> 0 | Data(_,ts) -> degree_of_list ts | Array(a,b) -> max (degree_of_tau a) (degree_of_tau b) | Record fts -> List.fold_left (fun r (_,t) -> max r (degree_of_tau t)) 0 fts and degree_of_list = function | [] -> 0 | t::ts -> max (degree_of_tau t) (degree_of_list ts) and degree_of_sig f = max (degree_of_tau f.result) (degree_of_list f.params) let rec tmap xs = function | Int -> Int | Real -> Real | Bool -> Bool | Prop -> Prop | Tvar k -> xs.(k-1) | Array(a,b) -> Array(tmap xs a,tmap xs b) | Data(a,ts) -> Data(a,List.map (tmap xs) ts) | Record fts -> Record(List.map (fun (f,t) -> f,tmap xs t) fts) let type_params n = let rec vars k n = if k <= n then Tvar k :: vars (succ k) n else [] in vars 1 n let pp_data pdata ptau fmt a = function | [] -> pdata fmt a | [t] -> Format.fprintf fmt "%a %a" ptau t pdata a | t::ts -> Format.fprintf fmt "@[(@[%a" ptau t ; List.iter (fun t -> Format.fprintf fmt ",@,%a" ptau t) ts ; Format.fprintf fmt ")@]@ %a@]" pdata a let pp_record pfield ptau fmt ?(opened=false) fts = Format.fprintf fmt "@[{@[" ; List.iter (fun (f,t) -> Format.fprintf fmt "@ @[%a : %a ;@]" pfield f ptau t) fts ; if opened then Format.fprintf fmt "@ ..." ; Format.fprintf fmt "@]@ }@]" let rec pp_tau pvar pfield pdata fmt = function | Int -> Format.pp_print_string fmt "int" | Real -> Format.pp_print_string fmt "real" | Bool -> Format.pp_print_string fmt "bool" | Prop -> Format.pp_print_string fmt "prop" | Tvar x -> pvar fmt x | Array(Int,te) -> Format.fprintf fmt "%a[]" (pp_tau pvar pfield pdata) te | Array(tk,te) -> Format.fprintf fmt "%a[%a]" (pp_tau pvar pfield pdata) te (pp_tau pvar pfield pdata) tk | Data(a,ts) -> pp_data pdata (pp_tau pvar pfield pdata) fmt a ts | Record fts -> pp_record pfield (pp_tau pvar pfield pdata) fmt fts let rec eq_tau cfield cadt t1 t2 = match t1 , t2 with | (Bool|Int|Real|Prop|Tvar _) , (Bool|Int|Real|Prop|Tvar _) -> t1 = t2 | Array(ta,tb) , Array(ta',tb') -> eq_tau cfield cadt ta ta' && eq_tau cfield cadt tb tb' | Array _ , _ | _ , Array _ -> false | Data(a,ts) , Data(b,ts') -> cadt a b && Hcons.equal_list (eq_tau cfield cadt) ts ts' | Data _ , _ | _ , Data _ -> false | Record fts , Record gts -> Hcons.equal_list (fun (f,t) (g,t') -> cfield f g && eq_tau cfield cadt t t') fts gts | Record _ , _ | _ , Record _ -> false let rec compare_tau cfield cadt t1 t2 = match t1 , t2 with | Bool , Bool -> 0 | Bool , _ -> (-1) | _ , Bool -> 1 | Int , Int -> 0 | Int , _ -> (-1) | _ , Int -> 1 | Real , Real -> 0 | Real , _ -> (-1) | _ , Real -> 1 | Prop , Prop -> 0 | Prop , _ -> (-1) | _ , Prop -> 1 | Tvar k , Tvar k' -> Pervasives.compare k k' | Tvar _ , _ -> (-1) | _ , Tvar _ -> 1 | Array(ta,tb) , Array(ta',tb') -> let c = compare_tau cfield cadt ta ta' in if c = 0 then compare_tau cfield cadt tb tb' else c | Array _ , _ -> (-1) | _ , Array _ -> 1 | Data(a,ts) , Data(b,ts') -> let c = cadt a b in if c = 0 then Hcons.compare_list (compare_tau cfield cadt) ts ts' else c | Data _ , _ -> (-1) | _ , Data _ -> 1 | Record fts , Record gts -> Hcons.compare_list (fun (f,t) (g,t') -> let c = cfield f g in if c = 0 then compare_tau cfield cadt t t' else c ) fts gts frama-c-Fluorine-20130601/src/wp/qed/src/collection.ml0000644000175000017500000001115012155630203021232 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Aggregation of MergeMap and MergeSet --- *) (* -------------------------------------------------------------------------- *) module type T = sig type t val hash : t -> int val equal : t -> t -> bool val compare : t -> t -> int end module type Map = sig type key type 'a t val empty : 'a t val add : key -> 'a -> 'a t -> 'a t val mem : key -> 'a t -> bool val find : key -> 'a t -> 'a val findk : key -> 'a t -> key * 'a val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val mapf : (key -> 'a -> 'b option) -> 'a t -> 'b t val filter : (key -> 'a -> bool) -> 'a t -> 'a t val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val iter_sorted : (key -> 'a -> unit) -> 'a t -> unit val fold_sorted : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val union : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val inter : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val subset : (key -> 'a -> 'b -> bool) -> 'a t -> 'b t -> bool val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iterk : (key -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit val iter2 : (key -> 'a option -> 'b option -> unit) -> 'a t -> 'b t -> unit val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t type domain val domain : 'a t -> domain end module type Set = sig type elt type t val empty : t val add : elt -> t -> t val singleton : elt -> t val elements : t -> elt list val mem : elt -> t -> bool val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val filter : (elt -> bool) -> t -> t val partition : (elt -> bool) -> t -> t * t val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val iter_sorted : (elt -> unit) -> t -> unit val fold_sorted : (elt -> 'a -> 'a) -> t -> 'a -> 'a val union : t -> t -> t val inter : t -> t -> t val subset : t -> t -> bool val intersect : t -> t -> bool type 'a mapping val mapping : (elt -> 'a) -> t -> 'a mapping end module type S = sig type t type set type 'a map val hash : t -> int val equal : t -> t -> bool val compare : t -> t -> int module Map : Map with type 'a t = 'a map and type key = t and type domain = set module Set : Set with type t = set and type elt = t and type 'a mapping = 'a map end module Make(A : T) = struct type t = A.t type set = A.t list Intmap.t type 'a map = (A.t * 'a) list Intmap.t let hash = A.hash let equal = A.equal let compare = A.compare module Map_i = Mergemap.Make(A) module Set_i = Mergeset.Make(A) module Map = struct include Map_i type domain = set let domain m = Intmap.map (List.map fst) m end module Set = struct include Set_i type 'a mapping = 'a map let mapping f m = Intmap.map (List.map (fun k -> k,f k)) m end end frama-c-Fluorine-20130601/src/wp/qed/src/pool.ml0000644000175000017500000000723212155630203020056 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- First Order Logic --- *) (* -------------------------------------------------------------------------- *) open Hcons open Logic module type Type = sig type t val dummy : t val equal : t -> t -> bool end module Make(T : Type) = struct type var = { vid : int ; vbase : string ; vrank : int ; vtau : T.t ; } let hash_var x = Hcons.hash_pair x.vrank (Hashtbl.hash x.vbase) let pretty fmt x = Format.fprintf fmt "%s_%d" x.vbase x.vrank (* HASHCONSING *) module W = Weak.Make (struct type t = var let hash = hash_var let equal x y = x.vbase = y.vbase && x.vrank = y.vrank && T.equal x.vtau y.vtau end) let kid = ref 0 let hmap = W.create 32993 (* 3-th Leyland Prime number *) let insert base rank tau = let x0 = { vid = 0 ; vbase = base ; vrank = rank ; vtau = tau ; } in try W.find hmap x0 with Not_found -> let k = let i = !kid in (assert (i <> -1) ; incr kid ; i) in let x = { x0 with vid = k } in W.add hmap x ; x let dummy = insert "" 0 T.dummy let hash x = x.vid let equal = (==) let compare x y = let cmp = String.compare x.vbase y.vbase in if cmp <> 0 then cmp else let cmp = Pervasives.compare x.vrank y.vrank in if cmp <> 0 then cmp else Pervasives.compare x.vid y.vid (* POOL *) type pool = (string,int ref) Hashtbl.t let create ?copy () = match copy with | None -> Hashtbl.create 131 | Some pool -> Hashtbl.copy pool let counter pool base = try Hashtbl.find pool base with Not_found -> let c = ref 0 in Hashtbl.add pool base c ; c let add pool x = let c = counter pool x.vbase in if !c <= x.vrank then c := succ x.vrank let next pool base = let c = counter pool base in let k = !c in incr c ; k let fresh pool base tau = let rank = next pool base in insert base rank tau let alpha pool x = fresh pool x.vbase x.vtau end frama-c-Fluorine-20130601/src/wp/qed/src/ast.ml0000644000175000017500000000742412155630203017677 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Utilities over Syntax --- *) (* -------------------------------------------------------------------------- *) open Syntax let rec range = function | E_ANY p | E_TRUE p | E_FALSE p -> p | E_INT x | E_REAL x | E_PVAR x -> fst x | E_BIN(a,_,_,b) | E_IF(a,_,_,b) | A_SET(a,_,b) | A_GET(a,b) -> Input.merge (left a) (left b) | E_UNA(p,_,a) -> Input.merge p (right a) | E_FUN(x,_,es) -> range_list (fst x) es | E_LET(x,_,_,_,b) | E_FORALL(x,_,_,_,b) | E_EXISTS(x,_,_,_,b) -> Input.merge (fst x) (right b) | E_RECORD(pos,fs) -> range_fields pos fs | E_SETFIELD(e,_,fs) -> range_fields (left e) fs | E_GETFIELD(e,f,_) -> Input.merge (left e) (fst f) and range_list p = function | [] -> p | [e] -> Input.merge p (right e) | _::es -> range_list p es and range_fields p = function | [] -> p | [_,_,e] -> Input.merge p (right e) | _::fes -> range_fields p fes and left = function | E_TRUE p | E_FALSE p | E_ANY p -> p | E_INT x | E_REAL x | E_PVAR x | E_FUN(x,_,_) | E_LET(x,_,_,_,_) | E_FORALL(x,_,_,_,_) | E_EXISTS(x,_,_,_,_) -> fst x | E_BIN(a,_,_,_) | E_IF(a,_,_,_) | A_GET(a,_) | A_SET(a,_,_) -> left a | E_UNA(p,_,_) | E_RECORD(p,_) -> p | E_SETFIELD(e,_,_) | E_GETFIELD(e,_,_) -> left e and right = function | E_TRUE p | E_FALSE p | E_ANY p -> p | E_INT x | E_REAL x | E_PVAR x | E_FUN(x,_,[]) -> fst x | E_BIN(_,_,_,b) | E_LET(_,_,_,_,b) | E_IF(_,_,_,b) | E_FORALL(_,_,_,_,b) | E_EXISTS(_,_,_,_,b) | A_GET(_,b) | A_SET(_,_,b) -> right b | E_UNA(p,_,_) -> p | E_FUN(_,_,e::es) -> right_list e es | E_RECORD(p,fes) -> right_fields p fes | E_SETFIELD(e,_,fes) -> right_fields (right e) fes | E_GETFIELD(_,f,_) -> fst f and right_list e = function | [] -> right e | e::es -> right_list e es and right_fields p = function | [] -> p | (_,_,e)::fes -> right_fields (right e) fes let raise_at e = function | Input.SyntaxError _ as err -> raise err | err -> raise (Input.locate (range e) err) let error_at e msg = Input.error_at (range e) msg let kloc = ref 0 let reset () = kloc := 0 let fresh () = incr kloc ; !kloc frama-c-Fluorine-20130601/src/wp/qed/src/topology.ml0000644000175000017500000000634412155630203020764 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Topological Sort --- *) (* -------------------------------------------------------------------------- *) module type Element = sig type t val hash : t -> int val equal : t -> t -> bool end module Make(E : Element) = struct module H = Hashtbl.Make(E) type succ = (E.t -> unit) -> E.t -> unit type root = (E.t -> unit) -> unit type t = { root : int H.t ; comp : int H.t ; succ : (E.t -> unit) -> E.t -> unit ; mutable stack : (int * E.t) list ; mutable ndfs : int ; mutable ncomp : int ; } let create f n = { root = H.create n ; comp = H.create n ; succ = f ; stack = [] ; ndfs = 0 ; ncomp = 0 ; } let rec pop g n = function | (k, w) :: l when k > n -> H.add g.comp w g.ncomp ; pop g n l | l -> l let push g v n = g.stack <- (n,v) :: g.stack let rec visit g v = if not (H.mem g.root v) then begin let n = g.ndfs in g.ndfs <- succ n ; H.add g.root v n ; g.succ (fun w -> visit g w ; if not (H.mem g.comp w) then let r_v = H.find g.root v in let r_w = H.find g.root w in H.replace g.root v (min r_v r_w) ) v ; if H.find g.root v = n then begin H.add g.comp v g.ncomp ; g.stack <- pop g n g.stack ; g.ncomp <- succ g.ncomp ; end else push g v n end let components ~succ ~root ?(size=997) () = let g = create succ size in root (visit g) ; let t = Array.make g.ncomp [] in H.iter (fun v i -> t.(i) <- v::t.(i)) g.comp ; t end frama-c-Fluorine-20130601/src/wp/qed/src/unify.mli0000644000175000017500000000522512155630203020410 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Datatypes Unifier *) (* -------------------------------------------------------------------------- *) open Logic module Make(ADT:Data)(Field:Field) : sig type mgu type t type tau = (Field.t,ADT.t) datatype type signature = (Field.t,ADT.t) funtype val create : (ADT.t -> tau option) -> mgu val fresh : mgu -> t val int : t val real : t val bool : t val prop : t val quoted : mgu -> string -> t val array : t -> t -> t val record : (Field.t * t) list -> t val data : ADT.t -> t list -> t val typedef : t array -> tau -> t val of_tau : mgu -> tau -> t val of_sig : mgu -> signature -> t * t list val unify : mgu -> t -> t -> unit val sort : mgu -> t -> sort val fields : mgu -> t -> (Field.t * t) list val generalize : mgu -> t -> tau val final_degree : mgu -> int (** Number of polymorphic variables yet computed by [generalize] *) val pretty : mgu -> Format.formatter -> t -> unit end frama-c-Fluorine-20130601/src/wp/qed/src/intmap.ml0000644000175000017500000004715112155630203020401 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Patricia Trees By L. Correnson --- *) (* -------------------------------------------------------------------------- *) type 'a t = | Empty | Lf of int * 'a | Br of int * int * 'a t * 'a t (* prefix , mask , sub-tree with prefix & mask = 0 , sub-tree with prefix & mask = 1 *) (* -------------------------------------------------------------------------- *) (* --- Debug --- *) (* -------------------------------------------------------------------------- *) let pp_mask m fmt p = begin let bits = Array.create 63 false in let last = ref 0 in for i = 0 to 62 do let u = 1 lsl i in if u land p <> 0 then bits.(i) <- true ; if u == m then last := i ; done ; Format.pp_print_char fmt '*' ; for i = !last - 1 downto 0 do Format.pp_print_char fmt (if bits.(i) then '1' else '0') ; done ; end let pp_bits fmt k = begin let bits = Array.create 63 false in let last = ref 0 in for i = 0 to 62 do if (1 lsl i) land k <> 0 then ( bits.(i) <- true ; if i > !last then last := i ) ; done ; for i = !last downto 0 do Format.pp_print_char fmt (if bits.(i) then '1' else '0') ; done ; end let rec pp_tree tab fmt = function | Empty -> () | Lf(k,_) -> Format.fprintf fmt "%sL%a@\n" tab pp_bits k | Br(p,m,l,r) -> let next = tab ^ " " in pp_tree next fmt l ; Format.fprintf fmt "%s@@%a@\n" tab (pp_mask m) p ; pp_tree next fmt r (* -------------------------------------------------------------------------- *) (* --- Bit utilities --- *) (* -------------------------------------------------------------------------- *) let zero_bit k m = (k land m) == 0 let mask p m = p land (m-1) let match_prefix k p m = (mask k m) == p let lowest_bit x = x land (-x) let branching_bit p0 p1 = lowest_bit (p0 lxor p1) let included_mask m n = (* m mask is strictly included into n *) (* can not use (m < n) when n is (1 lsl 62) = min_int < 0 *) (* must use (0 < (n-m) instead *) 0 < ( n - m ) let included_prefix p m q n = (* prefix p1 with mask m1 in included into prefix p2 with mask m2 *) included_mask m n && match_prefix q p m (* -------------------------------------------------------------------------- *) (* --- Smart Constructors --- *) (* -------------------------------------------------------------------------- *) let empty = Empty let lf k = function None -> Empty | Some x -> Lf(k,x) let br p m t0 t1 = match t0 , t1 with | Empty,t | t,Empty -> t | _ -> Br(p,m,t0,t1) let join p t0 q t1 = let m = branching_bit p q in let r = mask p m in if zero_bit p m then Br(r,m,t0,t1) else Br(r,m,t1,t0) (* t0 and t1 has different prefix, but best common prefix is unknown *) let glue t0 t1 = match t0 , t1 with | Empty,t | t,Empty -> t | (Lf(p,_) | Br(p,_,_,_)) , (Lf(q,_) | Br(q,_,_,_)) -> join p t0 q t1 (* -------------------------------------------------------------------------- *) (* --- Access API --- *) (* -------------------------------------------------------------------------- *) let is_empty = function | Empty -> true | Lf _ | Br _ -> false let size t = let rec walk n = function | Empty -> n | Lf _ -> succ n | Br(_,_,a,b) -> walk (walk n a) b in walk 0 t let rec mem k = function | Empty -> false | Lf(i,_) -> i=k | Br(p,m,t0,t1) -> match_prefix k p m && mem k (if zero_bit k m then t0 else t1) let rec find k = function | Empty -> raise Not_found | Lf(i,x) -> if k = i then x else raise Not_found | Br(p,m,t0,t1) -> if match_prefix k p m then find k (if zero_bit k m then t0 else t1) else raise Not_found (* -------------------------------------------------------------------------- *) (* --- Comparison --- *) (* -------------------------------------------------------------------------- *) let rec compare cmp s t = if s == t then 0 else match s , t with | Empty , Empty -> 0 | Empty , _ -> (-1) | _ , Empty -> 1 | Lf(i,x) , Lf(j,y) -> let ck = Pervasives.compare i j in if ck = 0 then cmp x y else ck | Lf _ , _ -> (-1) | _ , Lf _ -> 1 | Br(p,m,s0,s1) , Br(q,n,t0,t1) -> let cm = Pervasives.compare m n in if cm <> 0 then cm else let cp = Pervasives.compare p q in if cp <> 0 then cp else let c0 = compare cmp s0 t0 in if c0 <> 0 then c0 else compare cmp s1 t1 let rec equal eq s t = if s == t then true else match s , t with | Empty , Empty -> true | Empty , _ -> false | _ , Empty -> false | Lf(i,x) , Lf(j,y) -> i == j && eq x y | Lf _ , _ -> false | _ , Lf _ -> false | Br(p,m,s0,s1) , Br(q,n,t0,t1) -> p==q && m==n && equal eq s0 t0 && equal eq s1 t1 (* -------------------------------------------------------------------------- *) (* --- Addition --- *) (* -------------------------------------------------------------------------- *) let rec add k x = function | Empty -> Lf(k,x) | Lf(i,_) as t -> let s = Lf(k,x) in if k = i then s else join k s i t | Br(p,m,t0,t1) as t -> if match_prefix k p m then (* k belongs to tree *) if zero_bit k m then Br(p,m,add k x t0,t1) (* k is in t0 *) else Br(p,m,t0,add k x t1) (* k is in t1 *) else (* k is disjoint from tree *) join k (Lf(k,x)) p t (* -------------------------------------------------------------------------- *) (* --- Remove --- *) (* -------------------------------------------------------------------------- *) let rec remove k = function | Empty -> Empty | Lf(i,_) as t -> if i = k then Empty else t | Br(p,m,t0,t1) as t -> if match_prefix k p m then (* k belongs to tree *) if zero_bit k m then br p m (remove k t0) t1 (* k is in t0 *) else br p m t0 (remove k t1) (* k is in t1 *) else t (* k disjoint from the tree *) (* -------------------------------------------------------------------------- *) (* --- Insert --- *) (* -------------------------------------------------------------------------- *) let rec insert phi k x = function | Empty -> Lf(k,x) | Lf(i,y) as t -> if i = k then Lf(i,phi i x y) else let s = Lf(k,x) in join k s i t | Br(p,m,t0,t1) as t -> if match_prefix k p m then (* k belongs to tree *) if zero_bit k m then br p m (insert phi k x t0) t1 (* k is in t0 *) else br p m t0 (insert phi k x t1) (* k is in t1 *) else (* k is disjoint from tree *) let s = Lf(k,x) in join k s p t (* -------------------------------------------------------------------------- *) (* --- Map --- *) (* -------------------------------------------------------------------------- *) let rec map phi = function | Empty -> Empty | Lf(k,x) -> Lf(k,phi x) | Br(p,m,t0,t1) -> Br(p,m,map phi t0,map phi t1) let rec mapi phi = function | Empty -> Empty | Lf(k,x) -> Lf(k,phi k x) | Br(p,m,t0,t1) -> Br(p,m,mapi phi t0,mapi phi t1) let rec mapf phi = function | Empty -> Empty | Lf(k,x) -> lf k (phi k x) | Br(_,_,t0,t1) -> glue (mapf phi t0) (mapf phi t1) let rec filter phi = function | Empty -> Empty | Lf(i,x) as t -> if phi i x then t else Empty | Br(_,_,t0,t1) -> glue (filter phi t0) (filter phi t1) (* -------------------------------------------------------------------------- *) (* --- Iter --- *) (* -------------------------------------------------------------------------- *) let rec iter phi = function | Empty -> () | Lf(_,x) -> phi x | Br(_,_,t0,t1) -> iter phi t0 ; iter phi t1 let rec iteri phi = function | Empty -> () | Lf(k,x) -> phi k x | Br(_,_,t0,t1) -> iteri phi t0 ; iteri phi t1 let rec fold phi t e = match t with | Empty -> e | Lf(_,x) -> phi x e | Br(_,_,t0,t1) -> fold phi t1 (fold phi t0 e) let rec foldi phi t e = match t with | Empty -> e | Lf(i,x) -> phi i x e | Br(_,_,t0,t1) -> foldi phi t1 (foldi phi t0 e) (* -------------------------------------------------------------------------- *) (* --- Intersects --- *) (* -------------------------------------------------------------------------- *) let rec intersect s t = match s , t with | Empty , _ -> false | _ , Empty -> false | Lf(i,_) , Lf(j,_) -> i=j | Lf(i,_) , Br _ -> mem i t | Br _ , Lf(j,_) -> mem j s | Br(p,m,s0,s1) , Br(q,n,t0,t1) -> if p == q && m == n then (* prefixes agree *) (intersect s0 t0) || (intersect s1 t1) else if included_prefix p m q n then (* q contains p. Intersect t with a subtree of s *) if zero_bit q m then intersect s0 t (* t has bit m = 0 => t is inside s0 *) else intersect s1 t (* t has bit m = 1 => t is inside s1 *) else if included_prefix q n p m then (* p contains q. Intersect s with a subtree of t *) if zero_bit p n then intersect s t0 (* s has bit n = 0 => s is inside t0 *) else intersect s t1 (* t has bit n = 1 => s is inside t1 *) else (* prefix disagree *) false (* -------------------------------------------------------------------------- *) (* --- Inter --- *) (* -------------------------------------------------------------------------- *) let occur i t = try Some (find i t) with Not_found -> None let rec inter phi s t = match s , t with | Empty , _ -> Empty | _ , Empty -> Empty | Lf(i,x) , Lf(j,y) -> if i = j then Lf(i,phi i x y) else Empty | Lf(i,x) , Br _ -> (match occur i t with None -> Empty | Some y -> Lf(i,phi i x y)) | Br _ , Lf(j,y) -> (match occur j s with None -> Empty | Some x -> Lf(j,phi j x y)) | Br(p,m,s0,s1) , Br(q,n,t0,t1) -> if p == q && m == n then (* prefixes agree *) glue (inter phi s0 t0) (inter phi s1 t1) else if included_prefix p m q n then (* q contains p. Intersect t with a subtree of s *) if zero_bit q m then inter phi s0 t (* t has bit m = 0 => t is inside s0 *) else inter phi s1 t (* t has bit m = 1 => t is inside s1 *) else if included_prefix q n p m then (* p contains q. Intersect s with a subtree of t *) if zero_bit p n then inter phi s t0 (* s has bit n = 0 => s is inside t0 *) else inter phi s t1 (* t has bit n = 1 => s is inside t1 *) else (* prefix disagree *) Empty (* -------------------------------------------------------------------------- *) (* --- Union --- *) (* -------------------------------------------------------------------------- *) let rec union phi s t = match s , t with | Empty , _ -> t | _ , Empty -> s | Lf(i,x) , Lf(j,y) -> if i = j then Lf(i,phi i x y) else join i s j t | Lf(i,x) , Br _ -> insert phi i x t | Br _ , Lf(j,y) -> insert (fun j y x -> phi j x y) j y s | Br(p,m,s0,s1) , Br(q,n,t0,t1) -> if p == q && m == n then (* prefixes agree *) Br(p,m, union phi s0 t0 , union phi s1 t1 ) else if included_prefix p m q n then (* q contains p. Merge t with a subtree of s *) if zero_bit q m then Br(p,m,union phi s0 t,s1) (* t has bit m = 0 => t is inside s0 *) else Br(p,m,s0,union phi s1 t) (* t has bit m = 1 => t is inside s1 *) else if included_prefix q n p m then (* p contains q. Merge s with a subtree of t *) if zero_bit p n then Br(q,n,union phi s t0,t1) (* s has bit n = 0 => s is inside t0 *) else Br(q,n,t0,union phi s t1) (* t has bit n = 1 => s is inside t1 *) else (* prefix disagree *) join p s q t (* -------------------------------------------------------------------------- *) (* --- Merge --- *) (* -------------------------------------------------------------------------- *) let map1 phi s = mapf (fun i x -> phi i (Some x) None) s let map2 phi t = mapf (fun j y -> phi j None (Some y)) t let rec merge phi s t = match s , t with | Empty , _ -> map2 phi t | _ , Empty -> map1 phi s | Lf(i,x) , Lf(j,y) -> if i = j then lf i (phi i (Some x) (Some y)) else let a = lf i (phi i (Some x) None) in let b = lf j (phi j None (Some y)) in glue a b | Lf(i,x) , Br(q,n,t0,t1) -> if match_prefix i q n then (* leaf i is in tree t *) if zero_bit i n then glue (merge phi s t0) (map2 phi t1) (* s=i is in t0 *) else glue (map2 phi t0) (merge phi s t1) (* s=i is in t1 *) else (* leaf i does not appear in t *) glue (lf i (phi i (Some x) None)) (map2 phi t) | Br(p,m,s0,s1) , Lf(j,y) -> if match_prefix j p m then (* leaf j is in tree s *) if zero_bit j m then glue (merge phi s0 t) (map1 phi s1) (* t=j is in s0 *) else glue (map1 phi s0) (merge phi s1 t) (* t=j is in s1 *) else (* leaf j does not appear in s *) glue (map1 phi s) (lf j (phi j None (Some y))) | Br(p,m,s0,s1) , Br(q,n,t0,t1) -> if p == q && m == n then (* prefixes agree *) glue (merge phi s0 t0) (merge phi s1 t1) else if included_prefix p m q n then (* q contains p. Merge t with a subtree of s *) if zero_bit q m then (* t has bit m = 0 => t is inside s0 *) glue (merge phi s0 t) (map1 phi s1) else (* t has bit m = 1 => t is inside s1 *) glue (map1 phi s0) (merge phi s1 t) else if included_prefix q n p m then (* p contains q. Merge s with a subtree of t *) if zero_bit p n then (* s has bit n = 0 => s is inside t0 *) glue (merge phi s t0) (map2 phi t1) else (* s has bit n = 1 => s is inside t1 *) glue (map2 phi t0) (merge phi s t1) else glue (map1 phi s) (map2 phi t) (* -------------------------------------------------------------------------- *) (* --- Iter Kernel --- *) (* -------------------------------------------------------------------------- *) let rec iterk phi s t = match s , t with | Empty , _ | _ , Empty -> () | Lf(i,x) , Lf(j,y) -> if i = j then phi i x y | Lf(i,x) , Br _ -> (match occur i t with None -> () | Some y -> phi i x y) | Br _ , Lf(j,y) -> (match occur j s with None -> () | Some x -> phi j x y) | Br(p,m,s0,s1) , Br(q,n,t0,t1) -> if p == q && m == n then (* prefixes agree *) (iterk phi s0 t0 ; iterk phi s1 t1) else if included_prefix p m q n then (* q contains p. Intersect t with a subtree of s *) if zero_bit q m then iterk phi s0 t (* t has bit m = 0 => t is inside s0 *) else iterk phi s1 t (* t has bit m = 1 => t is inside s1 *) else if included_prefix q n p m then (* p contains q. Intersect s with a subtree of t *) if zero_bit p n then iterk phi s t0 (* s has bit n = 0 => s is inside t0 *) else iterk phi s t1 (* t has bit n = 1 => s is inside t1 *) else (* prefix disagree *) () (* -------------------------------------------------------------------------- *) (* --- Iter2 --- *) (* -------------------------------------------------------------------------- *) let iter21 phi s = iteri (fun i x -> phi i (Some x) None) s let iter22 phi t = iteri (fun j y -> phi j None (Some y)) t let rec iter2 phi s t = match s , t with | Empty , _ -> iter22 phi t | _ , Empty -> iter21 phi s | Lf(i,x) , Lf(j,y) -> if i = j then phi i (Some x) (Some y) else ( phi i (Some x) None ; phi j None (Some y) ) | Lf(i,x) , Br(q,n,t0,t1) -> if match_prefix i q n then (* leaf i is in tree t *) if zero_bit i n then (iter2 phi s t0 ; iter22 phi t1) (* s=i is in t0 *) else (iter22 phi t0 ; iter2 phi s t1) (* s=i is in t1 *) else (* leaf i does not appear in t *) (phi i (Some x) None ; iter22 phi t) | Br(p,m,s0,s1) , Lf(j,y) -> if match_prefix j p m then (* leaf j is in tree s *) if zero_bit j m then (iter2 phi s0 t ; iter21 phi s1) (* t=j is in s0 *) else (iter21 phi s0 ; iter2 phi s1 t) (* t=j is in s1 *) else (* leaf j does not appear in s *) (iter21 phi s ; phi j None (Some y)) | Br(p,m,s0,s1) , Br(q,n,t0,t1) -> if p == q && m == n then (* prefixes agree *) (iter2 phi s0 t0 ; iter2 phi s1 t1) else if included_prefix p m q n then (* q contains p. Merge t with a subtree of s *) if zero_bit q m then (* t has bit m = 0 => t is inside s0 *) (iter2 phi s0 t ; iter21 phi s1) else (* t has bit m = 1 => t is inside s1 *) (iter21 phi s0 ; iter2 phi s1 t) else if included_prefix q n p m then (* p contains q. Merge s with a subtree of t *) if zero_bit p n then (* s has bit n = 0 => s is inside t0 *) (iter2 phi s t0 ; iter22 phi t1) else (* s has bit n = 1 => s is inside t1 *) (iter22 phi t0 ; iter2 phi s t1) else (iter21 phi s ; iter22 phi t) (* -------------------------------------------------------------------------- *) (* --- Subset --- *) (* -------------------------------------------------------------------------- *) let rec subset phi s t = match s , t with | Empty , _ -> true | _ , Empty -> false | Lf(i,x) , Lf(j,y) -> if i = j then phi i x y else false | Lf(i,x) , Br _ -> (match occur i t with None -> false | Some y -> phi i x y) | Br _ , Lf _ -> false | Br(p,m,s0,s1) , Br(q,n,t0,t1) -> if p == q && m == n then (* prefixes agree *) (subset phi s0 t0 && subset phi s1 t1) else if included_prefix p m q n then (* q contains p: t is included in a (strict) subtree of s *) false else if included_prefix q n p m then (* p contains q: s is included in a subtree of t *) if zero_bit p n then subset phi s t0 (* s has bit n = 0 => s is inside t0 *) else subset phi s t1 (* t has bit n = 1 => s is inside t1 *) else (* prefix disagree *) false (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/qed/src/intset.ml0000644000175000017500000000473112155630203020414 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Patricia Sets By L. Correnson --- *) (* -------------------------------------------------------------------------- *) type t = unit Intmap.t let empty = Intmap.empty let singleton x = Intmap.add x () Intmap.empty let add x s = Intmap.add x () s let is_empty = Intmap.is_empty let mem = Intmap.mem let cardinal = Intmap.size let compare = Intmap.compare (fun () () -> 0) let equal = Intmap.equal (fun () () -> true) let _keep _ _ _ = () let _same _ () () = true let union = Intmap.union _keep let inter = Intmap.inter _keep let subset = Intmap.subset _same let diff = Intmap.merge (fun _i x y -> if y = None then x else None) let iter f = Intmap.iteri (fun i () -> f i) let fold f s e = Intmap.foldi (fun i () e -> f i e) s e let elements s = fold (fun x s -> x::s) s [] frama-c-Fluorine-20130601/src/wp/qed/src/idxset.ml0000644000175000017500000004412012155630203020402 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 type S = sig include Set.S val map : (elt -> elt) -> t -> t val mapf : (elt -> elt option) -> t -> t val intersect : t -> t -> bool end module type IndexedElements = sig type t val id : t -> int (* unique per t *) end module Make(E : IndexedElements) = struct type t = | Empty | Leaf of int * E.t | Branch of int * int * t * t type elt = E.t let empty = Empty let is_empty = function Empty -> true | _ -> false let singleton e = Leaf( E.id e , e ) let zero_bit k m = (k land m) == 0 let rec mem_k k = function | Empty -> false | Leaf(j,_) -> k == j | Branch (_, m, l, r) -> mem_k k (if zero_bit k m then l else r) let mem e s = mem_k (E.id e) s let lowest_bit x = x land (-x) let branching_bit p0 p1 = lowest_bit (p0 lxor p1) let mask p m = p land (m-1) let join p0 t0 p1 t1 = let m = branching_bit p0 p1 in if zero_bit p0 m then Branch (mask p0 m, m, t0, t1) else Branch (mask p0 m, m, t1, t0) let match_prefix k p m = (mask k m) == p let rec insert k e = function | Empty -> Leaf(k,e) | Leaf(j,_) as t -> if j == k then t else join k (Leaf(k,e)) j t | Branch (p,m,t0,t1) as t -> if match_prefix k p m then if zero_bit k m then Branch (p, m, insert k e t0, t1) else Branch (p, m, t0, insert k e t1) else join k (Leaf(k,e)) p t let add e t = insert (E.id e) e t let branch p m t0 t1 = match t0,t1 with | Empty,t | t,Empty -> t | _ -> Branch (p,m,t0,t1) let rec remove_k k = function | Empty -> Empty | Leaf(j,_) as t -> if k == j then Empty else t | Branch (p,m,t0,t1) as t -> if match_prefix k p m then if zero_bit k m then branch p m (remove_k k t0) t1 else branch p m t0 (remove_k k t1) else t let remove e t = remove_k (E.id e) t let rec union a b = match a,b with | Empty, t -> t | t, Empty -> t | Leaf(k,e), t -> insert k e t | t, Leaf(k,e) -> insert k e t | (Branch (p,m,s0,s1) as s), (Branch (q,n,t0,t1) as t) -> if m == n && match_prefix q p m then (* The trees have the same prefix. Merge the subtrees. *) Branch (p, m, union s0 t0, union s1 t1) else if m < n && match_prefix q p m then (* [q] contains [p]. Merge [t] with a subtree of [s]. *) if zero_bit q m then Branch (p, m, union s0 t, s1) else Branch (p, m, s0, union s1 t) else if m > n && match_prefix p q n then (* [p] contains [q]. Merge [s] with a subtree of [t]. *) if zero_bit p n then Branch (q, n, union s t0, t1) else Branch (q, n, t0, union s t1) else (* The prefixes disagree. *) join p s q t let rec subset s1 s2 = match (s1,s2) with | Empty, _ -> true | _, Empty -> false | Leaf(k1,_), _ -> mem_k k1 s2 | Branch _, Leaf _ -> false | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> if m1 == m2 && p1 == p2 then subset l1 l2 && subset r1 r2 else if m1 > m2 && match_prefix p1 p2 m2 then if zero_bit p1 m2 then subset l1 l2 && subset r1 l2 else subset l1 r2 && subset r1 r2 else false let rec inter s1 s2 = match (s1,s2) with | Empty, _ -> Empty | _, Empty -> Empty | Leaf(k1,_), _ -> if mem_k k1 s2 then s1 else Empty | _, Leaf(k2,_) -> if mem_k k2 s1 then s2 else Empty | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> if m1 == m2 && p1 == p2 then union (inter l1 l2) (inter r1 r2) else if m1 < m2 && match_prefix p2 p1 m1 then inter (if zero_bit p2 m1 then l1 else r1) s2 else if m1 > m2 && match_prefix p1 p2 m2 then inter s1 (if zero_bit p1 m2 then l2 else r2) else Empty let rec diff s1 s2 = match (s1,s2) with | Empty, _ -> Empty | _, Empty -> s1 | Leaf(k1,_), _ -> if mem_k k1 s2 then Empty else s1 | _, Leaf(k2,_) -> remove_k k2 s1 | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> if m1 == m2 && p1 == p2 then union (diff l1 l2) (diff r1 r2) else if m1 < m2 && match_prefix p2 p1 m1 then if zero_bit p2 m1 then union (diff l1 s2) r1 else union l1 (diff r1 s2) else if m1 > m2 && match_prefix p1 p2 m2 then if zero_bit p1 m2 then diff s1 l2 else diff s1 r2 else s1 let rec cardinal = function | Empty -> 0 | Leaf _ -> 1 | Branch (_,_,t0,t1) -> cardinal t0 + cardinal t1 let rec iter f = function | Empty -> () | Leaf(_,e) -> f e | Branch (_,_,t0,t1) -> iter f t0; iter f t1 let rec iteri f = function | Empty -> () | Leaf(k,e) -> f k e | Branch (_,_,t0,t1) -> iteri f t0; iteri f t1 let rec fold f s accu = match s with | Empty -> accu | Leaf(_,e) -> f e accu | Branch (_,_,t0,t1) -> fold f t0 (fold f t1 accu) let map f s = fold (fun e s -> add (f e) s) s Empty let mapf f s = fold (fun e s -> match f e with None -> s | Some e -> add e s) s Empty let rec for_all p = function | Empty -> true | Leaf(_,e) -> p e | Branch (_,_,t0,t1) -> for_all p t0 && for_all p t1 let rec exists p = function | Empty -> false | Leaf(_,e) -> p e | Branch (_,_,t0,t1) -> exists p t0 || exists p t1 let rec filter pr = function | Empty -> Empty | Leaf(_,e) as t -> if pr e then t else Empty | Branch (p,m,t0,t1) -> branch p m (filter pr t0) (filter pr t1) let partition p s = let t = ref Empty in let f = ref Empty in iteri (fun k e -> let r = if p e then t else f in r := insert k e !r) s ; !t , !f let rec choose = function | Empty -> raise Not_found | Leaf(_,e) -> e | Branch (_, _,t0,_) -> choose t0 (* we know that [t0] is non-empty *) let e_compare a b = Pervasives.compare (E.id a) (E.id b) let e_min a b = if e_compare a b <=0 then a else b let e_max a b = if e_compare a b <=0 then b else a let elements s = let rec elements_aux acc = function | Empty -> acc | Leaf(_,e) -> e :: acc | Branch (_,_,l,r) -> elements_aux (elements_aux acc l) r in (* unfortunately there is no easy way to get the elements in ascending order with little-endian Patricia trees *) List.sort e_compare (elements_aux [] s) let split x s = let coll k (l, b, r) = if k < x then add k l, b, r else if k > x then l, b, add k r else l, true, r in fold coll s (Empty, false, Empty) (*s There is no way to give an efficient implementation of [min_elt] and [max_elt], as with binary search trees. The following implementation is a traversal of all elements, barely more efficient than [fold min t (choose t)] (resp. [fold max t (choose t)]). Note that we use the fact that there is no constructor [Empty] under [Branch] and therefore always a minimal (resp. maximal) element there. *) let rec min_elt = function | Empty -> raise Not_found | Leaf(_,e) -> e | Branch (_,_,s,t) -> e_min (min_elt s) (min_elt t) let rec max_elt = function | Empty -> raise Not_found | Leaf(_,e) -> e | Branch (_,_,s,t) -> e_max (max_elt s) (max_elt t) let rec equal a b = match a,b with | Empty , Empty -> true | Empty , _ | _ , Empty -> false | Leaf(i,_) , Leaf(j,_) -> i=j | Leaf _ , _ | _ , Leaf _ -> false | Branch(p1,m1,l1,r1) , Branch(p2,m2,l2,r2) -> p1 = p2 && m1 = m2 && equal l1 l2 && equal r1 r2 let rec compare a b = match a,b with | Empty , Empty -> 0 | Empty , _ -> (-1) | _ , Empty -> 1 | Leaf(i,_) , Leaf(j,_) -> Pervasives.compare i j | Leaf _ , _ -> (-1) | _ , Leaf _ -> 1 | Branch(p1,m1,l1,r1) , Branch(p2,m2,l2,r2) -> let c = Pervasives.compare p1 p2 in if c<>0 then c else let c = Pervasives.compare m1 m2 in if c<>0 then c else let c = compare l1 l2 in if c<>0 then c else compare r1 r2 let rec intersect s1 s2 = match (s1,s2) with | Empty, _ -> false | _, Empty -> false | Leaf(k1,_), _ -> mem_k k1 s2 | _, Leaf(k2,_) -> mem_k k2 s1 | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> if m1 == m2 && p1 == p2 then intersect l1 l2 || intersect r1 r2 else if m1 < m2 && match_prefix p2 p1 m1 then intersect (if zero_bit p2 m1 then l1 else r1) s2 else if m1 > m2 && match_prefix p1 p2 m2 then intersect s1 (if zero_bit p1 m2 then l2 else r2) else false end module Positive(E : IndexedElements) = struct type t = | Empty | Leaf of int * E.t | Branch of int * int * t * t type elt = E.t let empty = Empty let is_empty = function Empty -> true | _ -> false let singleton e = Leaf( E.id e , e ) let index e = let k = E.id e in assert (k >= 0) ; k let singleton e = Leaf( index e , e ) let zero_bit k m = (k land m) == 0 let rec mem_k k = function | Empty -> false | Leaf(j,_) -> k == j | Branch (p, _, l, r) -> if k <= p then mem_k k l else mem_k k r let rec min_elt = function | Empty -> raise Not_found | Leaf(_,e) -> e | Branch (_,_,s,_) -> min_elt s let rec max_elt = function | Empty -> raise Not_found | Leaf(_,e) -> e | Branch (_,_,_,t) -> max_elt t let mem e s = mem_k (index e) s let mask k m = (k lor (m-1)) land (lnot m) (* we first write a naive implementation of [highest_bit] only has to work for bytes *) let naive_highest_bit x = assert (x < 256); let rec loop i = if i = 0 then 1 else if x lsr i = 1 then 1 lsl i else loop (i-1) in loop 7 (* then we build a table giving the highest bit for bytes *) let hbit = Array.init 256 naive_highest_bit (* to determine the highest bit of [x] we split it into bytes *) let highest_bit_32 x = let n = x lsr 24 in if n != 0 then hbit.(n) lsl 24 else let n = x lsr 16 in if n != 0 then hbit.(n) lsl 16 else let n = x lsr 8 in if n != 0 then hbit.(n) lsl 8 else hbit.(x) let highest_bit_64 x = let n = x lsr 32 in if n != 0 then (highest_bit_32 n) lsl 32 else highest_bit_32 x let highest_bit = match Sys.word_size with | 32 -> highest_bit_32 | 64 -> highest_bit_64 | _ -> assert false let branching_bit p0 p1 = highest_bit (p0 lxor p1) let join p0 t0 p1 t1 = let m = branching_bit p0 p1 in if zero_bit p0 m then Branch (mask p0 m, m, t0, t1) else Branch (mask p0 m, m, t1, t0) let match_prefix k p m = (mask k m) == p let rec insert k e = function | Empty -> Leaf(k,e) | Leaf(j,_) as t -> if j == k then t else join k (Leaf(k,e)) j t | Branch (p,m,t0,t1) as t -> if match_prefix k p m then if zero_bit k m then Branch (p, m, insert k e t0, t1) else Branch (p, m, t0, insert k e t1) else join k (Leaf(k,e)) p t let add e t = insert (index e) e t let branch p m t0 t1 = match t0,t1 with | Empty,t | t,Empty -> t | _ -> Branch (p,m,t0,t1) let rec remove_k k = function | Empty -> Empty | Leaf(j,_) as t -> if k == j then Empty else t | Branch (p,m,t0,t1) as t -> if match_prefix k p m then if zero_bit k m then branch p m (remove_k k t0) t1 else branch p m t0 (remove_k k t1) else t let remove e t = remove_k (index e) t let rec union a b = match a,b with | Empty, t -> t | t, Empty -> t | Leaf(k,e), t -> insert k e t | t, Leaf(k,e) -> insert k e t | (Branch (p,m,s0,s1) as s), (Branch (q,n,t0,t1) as t) -> if m == n && match_prefix q p m then (* The trees have the same prefix. Merge the subtrees. *) Branch (p, m, union s0 t0, union s1 t1) else if m > n && match_prefix q p m then (* [q] contains [p]. Merge [t] with a subtree of [s]. *) if zero_bit q m then Branch (p, m, union s0 t, s1) else Branch (p, m, s0, union s1 t) else if m < n && match_prefix p q n then (* [p] contains [q]. Merge [s] with a subtree of [t]. *) if zero_bit p n then Branch (q, n, union s t0, t1) else Branch (q, n, t0, union s t1) else (* The prefixes disagree. *) join p s q t let rec subset s1 s2 = match (s1,s2) with | Empty, _ -> true | _, Empty -> false | Leaf(k1,_), _ -> mem_k k1 s2 | Branch _, Leaf _ -> false | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> if m1 == m2 && p1 == p2 then subset l1 l2 && subset r1 r2 else if m1 < m2 && match_prefix p1 p2 m2 then if zero_bit p1 m2 then subset l1 l2 && subset r1 l2 else subset l1 r2 && subset r1 r2 else false let rec inter s1 s2 = match (s1,s2) with | Empty, _ -> Empty | _, Empty -> Empty | Leaf(k1,_), _ -> if mem_k k1 s2 then s1 else Empty | _, Leaf(k2,_) -> if mem_k k2 s1 then s2 else Empty | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> if m1 == m2 && p1 == p2 then union (inter l1 l2) (inter r1 r2) else if m1 > m2 && match_prefix p2 p1 m1 then inter (if zero_bit p2 m1 then l1 else r1) s2 else if m1 < m2 && match_prefix p1 p2 m2 then inter s1 (if zero_bit p1 m2 then l2 else r2) else Empty let rec diff s1 s2 = match (s1,s2) with | Empty, _ -> Empty | _, Empty -> s1 | Leaf(k1,_), _ -> if mem_k k1 s2 then Empty else s1 | _, Leaf(k2,_) -> remove_k k2 s1 | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> if m1 == m2 && p1 == p2 then union (diff l1 l2) (diff r1 r2) else if m1 > m2 && match_prefix p2 p1 m1 then if zero_bit p2 m1 then union (diff l1 s2) r1 else union l1 (diff r1 s2) else if m1 < m2 && match_prefix p1 p2 m2 then if zero_bit p1 m2 then diff s1 l2 else diff s1 r2 else s1 let rec cardinal = function | Empty -> 0 | Leaf _ -> 1 | Branch (_,_,t0,t1) -> cardinal t0 + cardinal t1 let rec equal a b = match a,b with | Empty , Empty -> true | Empty , _ | _ , Empty -> false | Leaf(i,_) , Leaf(j,_) -> i=j | Leaf _ , _ | _ , Leaf _ -> false | Branch(p1,m1,l1,r1) , Branch(p2,m2,l2,r2) -> p1 = p2 && m1 = m2 && equal l1 l2 && equal r1 r2 let rec compare a b = match a,b with | Empty , Empty -> 0 | Empty , _ -> (-1) | _ , Empty -> 1 | Leaf(i,_) , Leaf(j,_) -> Pervasives.compare i j | Leaf _ , _ -> (-1) | _ , Leaf _ -> 1 | Branch(p1,m1,l1,r1) , Branch(p2,m2,l2,r2) -> let c = Pervasives.compare p1 p2 in if c<>0 then c else let c = Pervasives.compare m1 m2 in if c<>0 then c else let c = compare l1 l2 in if c<>0 then c else compare r1 r2 let rec iter f = function | Empty -> () | Leaf(_,e) -> f e | Branch (_,_,t0,t1) -> iter f t0; iter f t1 let rec iteri f = function | Empty -> () | Leaf(k,e) -> f k e | Branch (_,_,t0,t1) -> iteri f t0; iteri f t1 let rec fold f s accu = match s with | Empty -> accu | Leaf(_,e) -> f e accu | Branch (_,_,t0,t1) -> fold f t0 (fold f t1 accu) let map f s = fold (fun e s -> add (f e) s) s Empty let mapf f s = fold (fun e s -> match f e with None -> s | Some e -> add e s) s Empty let rec for_all p = function | Empty -> true | Leaf(_,e) -> p e | Branch (_,_,t0,t1) -> for_all p t0 && for_all p t1 let rec exists p = function | Empty -> false | Leaf(_,e) -> p e | Branch (_,_,t0,t1) -> exists p t0 || exists p t1 let rec filter pr = function | Empty -> Empty | Leaf(_,e) as t -> if pr e then t else Empty | Branch (p,m,t0,t1) -> branch p m (filter pr t0) (filter pr t1) let partition p s = let t = ref Empty in let f = ref Empty in iteri (fun k e -> let r = if p e then t else f in r := insert k e !r) s ; !t , !f let rec choose = function | Empty -> raise Not_found | Leaf(_,e) -> e | Branch (_, _,t0,_) -> choose t0 (* we know that [t0] is non-empty *) let elements s = let rec elements_aux acc = function | Empty -> acc | Leaf(_,e) -> e :: acc | Branch (_,_,l,r) -> elements_aux (elements_aux acc r) l in elements_aux [] s let split x s = let coll k (l, b, r) = if k < x then add k l, b, r else if k > x then l, b, add k r else l, true, r in fold coll s (Empty, false, Empty) let rec intersect s1 s2 = match (s1,s2) with | Empty, _ -> false | _, Empty -> false | Leaf(k1,_) , _ -> mem_k k1 s2 | _ , Leaf(k2,_) -> mem_k k2 s1 | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> if m1 == m2 && p1 == p2 then intersect l1 l2 || intersect r1 r2 else if m1 > m2 && match_prefix p2 p1 m1 then intersect (if zero_bit p2 m1 then l1 else r1) s2 else if m1 < m2 && match_prefix p1 p2 m2 then intersect s1 (if zero_bit p1 m2 then l2 else r2) else false end frama-c-Fluorine-20130601/src/wp/qed/src/compiler.ml0000644000175000017500000002107712155630203020722 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Compiler for Qed Syntax --- *) (* -------------------------------------------------------------------------- *) open Logic open Syntax module Make(T:Term) = struct module Tc = Typechecker.Make(T.ADT)(T.Field) type symbol = | Fun of T.signature * T.Fun.t | Val of T.tau * T.term type lookup = { make_field : Syntax.id -> sort -> T.Field.t ; lookup_field : Syntax.id -> T.Field.t -> bool ; lookup_typedef : Syntax.id -> T.tau ; lookup_datatype : T.ADT.t -> T.tau option ; lookup_symbol : Syntax.id -> symbol ; } let rec cc_type env alpha = function | T_INT -> Int | T_REAL -> Real | T_BOOL -> Bool | T_PROP -> Prop | T_ARRAY(k,e) -> Array(cc_type env alpha k,cc_type env alpha e) | T_ALPHA x -> begin try List.assoc (snd x) alpha with Not_found -> Input.error_at (fst x) "unknown type variable %s" (snd x) end | T_RECORD fts -> Record (List.map (fun (f,t) -> let t = cc_type env alpha t in let a = env.make_field f (Kind.of_tau t) in a , t) fts) | T_SORT(ts,x) -> begin try let t = env.lookup_typedef x in let d = Kind.degree_of_tau t in if d<>List.length ts then Input.error_at (fst x) "type '%s' has arity %d" (snd x) d ; let ts = List.map (cc_type env alpha) ts in Kind.tmap (Array.of_list ts) t with Not_found -> Input.error_at (fst x) "unknown type '%s'" (snd x) end let cc_tau env xs t = (* environment for alpha-variables *) let rec quoted k = function | [] -> [] | x::xs -> (snd x,Tvar k)::quoted (succ k) xs in cc_type env (quoted 1 xs) t (* -------------------------------------------------------------------------- *) (* --- Compilation of typed terms --- *) (* -------------------------------------------------------------------------- *) let binop = function | ADD -> T.e_add | SUB -> T.e_sub | MUL -> T.e_mul | DIV -> T.e_div | MOD -> T.e_mod | AND -> (fun x y -> T.e_and [x;y]) | OR -> (fun x y -> T.e_or [x;y]) | IMPLY -> (fun h p -> T.e_imply [h] p) | EQUIV -> T.e_equiv | LT -> T.e_lt | LEQ -> T.e_leq | GT -> (fun x y -> T.e_lt y x) | GEQ -> (fun x y -> T.e_leq y x) | EQ -> T.e_eq | NEQ -> T.e_neq type env = { symbol : Syntax.id -> symbol ; field : Syntax.id -> sort -> T.Field.t ; typing : Tc.env ; pool : T.pool ; mutable locals : (string * T.term) list ; } type value = Efun of T.Fun.t | Eval of T.term let push (env:env) x k = let tau = Tc.final_node env.typing k in let var = T.fresh env.pool ~basename:(snd x) tau in let term = T.e_var var in env.locals <- (snd x,term) :: env.locals ; var let pop env x = assert (fst (List.hd env.locals) = snd x) ; env.locals <- List.tl env.locals let lookup env x = try Eval(List.assoc (snd x) env.locals) with Not_found -> try match env.symbol x with | Fun(_,f) -> Efun f | Val(_,e) -> Eval e with Not_found -> Input.error_at (fst x) "unknown symbol '%s'" (snd x) let make_field env f k = let tf = Tc.final_node env.typing k in let sf = Kind.of_tau tf in env.field f sf let rec cc env e = try match e with | E_ANY pos -> Input.error_at pos "unexpected pattern" | E_PVAR x -> Input.error_at (fst x) "unexpected pattern" | E_INT(_,z) -> T.e_zint (Z.of_string z) | E_REAL(_,r) -> T.e_real (R.of_string r) | E_TRUE _ -> T.e_true | E_FALSE _ -> T.e_false | E_BIN(x,_,op,y) -> (binop op) (cc env x) (cc env y) | E_UNA(_,NOT,x) -> T.e_not (cc env x) | E_UNA(_,OPP,x) -> T.e_opp (cc env x) | E_FUN(x,_,es) -> begin match lookup env x with | Eval value -> if es <> [] then Input.error_at (fst x) "local variable %s can not be applied" (snd x) ; value | Efun f -> T.e_fun f (List.map (cc env) es) end | E_IF(e,_,a,b) -> T.e_if (cc env e) (cc env a) (cc env b) | A_GET(m,k) -> T.e_get (cc env m) (cc env k) | A_SET(m,k,v) -> T.e_set (cc env m) (cc env k) (cc env v) | E_GETFIELD(r,f,k) -> T.e_getfield (cc env r) (make_field env f k) | E_SETFIELD(r,k,fvs) -> let base = cc env r in let fbase = List.map (fun fd -> fd , T.e_getfield base fd) (Tc.final_fields env.typing k) in let fvalues = List.map (fun (f,k,v) -> make_field env f k,cc env v) fvs in let rec merge fbase fvalues = match fbase , fvalues with | [] , _ -> fvalues | _ , [] -> fbase | fb::fb_others , gv::gv_others -> let cmp = T.Field.compare (fst fb) (fst gv) in if cmp < 0 then fb :: (merge fb_others fvalues) else if cmp > 0 then gv :: (merge fbase gv_others) else gv :: (merge fb_others gv_others) in T.e_record (merge fbase fvalues) | E_RECORD(_,fvs) -> T.e_record (List.map (fun (f,k,v) -> make_field env f k , cc env v) fvs) | E_LET(x,_,_,a,b) -> let va = cc env a in env.locals <- (snd x,va)::env.locals ; let vb = cc env b in env.locals <- List.tl env.locals ; vb | E_FORALL(x,k,_,_,p) -> let var = push env x k in let prop = T.e_forall [var] (cc env p) in pop env x ; prop | E_EXISTS(x,k,_,_,p) -> let var = push env x k in let prop = T.e_exists [var] (cc env p) in pop env x ; prop with err -> Ast.raise_at e err (* -------------------------------------------------------------------------- *) (* --- Signature & Expression entry points --- *) (* -------------------------------------------------------------------------- *) let tc_lookup global = { Tc.make_field = global.make_field ; Tc.lookup_field = global.lookup_field ; Tc.lookup_typedef = global.lookup_typedef ; Tc.lookup_datatype = global.lookup_datatype ; Tc.lookup_signature = (fun x -> match global.lookup_symbol x with | Fun(s,_) -> s | Val(t,_) -> { result=t ; params=[] }) ; } let cc_sig global params result = Tc.signature (tc_lookup global) params result let cc_def global params result expr = let sigma = Tc.create (tc_lookup global) params in let tr = Tc.typecheck sigma expr result in let env = { symbol=global.lookup_symbol ; field =global.make_field ; typing=sigma ; locals=[] ; pool=T.pool () ; } in let xs = List.map (fun (x,k,_) -> push env x k) params in let value = cc env expr in let txs = List.map (fun (_,k,_) -> Tc.final_node sigma k) params in { Logic.result=tr ; Logic.params=txs } , T.e_lambda xs value let cc_exp global expr = let sigma = Tc.create (tc_lookup global) [] in let tr = Tc.typecheck sigma expr None in let env = { symbol=global.lookup_symbol ; field=global.make_field ; typing=sigma ; locals=[] ; pool=T.pool() ; } in let value = cc env expr in tr , value end frama-c-Fluorine-20130601/src/wp/qed/src/linker.mli0000644000175000017500000000572712155630203020551 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Identifiers Management --- *) (* -------------------------------------------------------------------------- *) open Format open Logic open Plib (** {2 Identifiers} *) val is_ident : string -> bool (** Operators is an identifier *) val ident : string -> string (** Filter out non-letter characters *) (** {2 Allocators} *) type allocator val allocator : unit -> allocator val declare : allocator -> string -> unit val fresh : allocator -> string -> string val copy : allocator -> allocator (** {2 Linkers} *) class type ['a,'idx] linker = object method lock : unit method clear : unit method push : 'idx method pop : 'idx -> unit method mem : 'a -> bool method find : 'a -> string method link : 'a -> string -> unit method print : 'a printer method alloc : basename:string -> 'a -> string method reserve : basename:string -> string method bind_reserved : 'a -> string -> unit method alloc_with : allocator -> unit end module Link(A : Symbol) : sig type index val linker : unit -> (A.t,index) linker end module Record(T : Logic.Term) : sig type t val create : unit -> t val register : t -> T.ADT.t -> T.Field.t list -> unit val get_fields : t -> T.ADT.t -> T.Field.t list val get_record : t -> T.Field.t list -> T.ADT.t end frama-c-Fluorine-20130601/src/wp/qed/src/r.mli0000644000175000017500000000402012155630203017507 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** Real number arithmetics. *) type t val to_string : t -> string val of_string : string -> t type maybe = | Sure_true | Sure_false | Unknown val eq : t -> t -> maybe val lt : t -> t -> maybe val leq : t -> t -> maybe val opp : t -> t val positive : t -> bool val negative : t -> bool val hash : t -> int val equal : t -> t -> bool (* representation equality *) val compare : t -> t -> int val pretty : Format.formatter -> t -> unit frama-c-Fluorine-20130601/src/wp/qed/src/export_why3.ml0000644000175000017500000002737512155630203021412 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Exportation Engine for Why-3 --- *) (* -------------------------------------------------------------------------- *) open Logic open Format open Plib open Export open Engine module Make(T : Term) = struct module T = T module E = Export_whycore.Make(T) open T type tau = (Field.t,ADT.t) datatype type record = (Field.t * term) list type trigger = (var,Fun.t) ftrigger type typedef = (tau,Field.t,Fun.t) ftypedef let libraries = [ "bool.Bool" ; "int.Int" ; "int.ComputerDivision" ; "real.RealInfix" ; "real.FromInt" ; "map.Map" ; "qed.Arith" ; ] class virtual engine = object(self) inherit E.engine as super initializer begin self#declare_all [ "theory" ; "use" ; "import" ; "clone" ; "namespace" ; "end" ; "as" ; "type" ; "function" ; "predicate" ; "inductive" ; "axiom" ; "lemma" ; "goal" ; "map" ; "get" ; "set" ; "true" ; "false" ; "True" ; "False" ; "from_int" ; ] ; end method basename s = (** TODO: better uncapitalization of the first letter? utf8? *) let lower0 = Char.lowercase s.[0] in if String.length s > 0 && lower0 <> s.[0] then let s = String.copy s in s.[0] <- lower0; s else s (* -------------------------------------------------------------------------- *) (* --- Types --- *) (* -------------------------------------------------------------------------- *) method pp_tau fmt = function | Prop -> assert false (* prop should never be printed *) | x -> super#pp_tau fmt x method t_atomic = function | Int | Real | Bool | Prop | Tvar _ -> true | Array _ -> false | Data(_,[]) -> true | Data _ -> false | Record _ -> true method pp_farray fmt a b = fprintf fmt "map %a %a" self#pp_subtau a self#pp_subtau b method pp_array fmt b = fprintf fmt "map int %a" self#pp_subtau b method pp_datatype adt fmt = function | [] -> pp_print_string fmt (self#datatype adt) | ts -> Plib.pp_call_apply (self#datatype adt) self#pp_subtau fmt ts (* -------------------------------------------------------------------------- *) (* --- Primitives --- *) (* -------------------------------------------------------------------------- *) method callstyle = CallApply method op_spaced (_:string) = true (* -------------------------------------------------------------------------- *) (* --- Arithmetics --- *) (* -------------------------------------------------------------------------- *) method pp_int amode fmt k = match amode with | Aint -> Z.pretty fmt k | Areal -> fprintf fmt "%a.0" Z.pretty k method pp_cst fmt cst = let open Numbers in let man = if cst.man = "" then "0" else cst.man in let com = if cst.com = "" then "0" else cst.com in match cst.sign , cst.base with | Pos,Dec -> fprintf fmt "%s.%se%d" man com cst.exp | Neg,Dec -> fprintf fmt "(-.%s.%se%d)" man com cst.exp | Pos,Hex -> fprintf fmt "0x%s.%sp%d" man com cst.exp | Neg,Hex -> fprintf fmt "(-.0x%s.%sp%d)" man com cst.exp method op_real_of_int = Call "real_of_int" method op_add = function Aint -> Assoc "+" | Areal -> Assoc "+." method op_sub = function Aint -> Assoc "-" | Areal -> Assoc "-." method op_mul = function Aint -> Assoc "*" | Areal -> Assoc "*." method op_div = function Aint -> Call "div" | Areal -> Op "/." method op_mod = function Aint -> Call "mod" | Areal -> Call "rmod" method op_minus = function Aint -> Op "-" | Areal -> Op "-." method op_eq cmode (_:amode) = match cmode with | Cprop -> Op "=" | Cterm -> Call "eqb" method op_neq cmode (_:amode) = match cmode with | Cprop -> Op "<>" | Cterm -> Call "neqb" method op_lt cmode amode = match cmode , amode with | Cprop , Aint -> Op "<" | Cprop , Areal -> Op "<." | Cterm , Aint -> Call "zlt" | Cterm , Areal -> Call "rlt" method op_leq cmode amode = match cmode , amode with | Cprop , Aint -> Op "<=" | Cprop , Areal -> Op "<=." | Cterm , Aint -> Call "zleq" | Cterm , Areal -> Call "rleq" (* -------------------------------------------------------------------------- *) (* --- Logical Connectives --- *) (* -------------------------------------------------------------------------- *) method e_true = function Cterm -> "True" | Cprop -> "true" method e_false = function Cterm -> "False" | Cprop -> "false" method op_equal = function Cterm -> Call "eqb" | Cprop -> Op "=" method op_noteq = function Cterm -> Call "neqb" | Cprop -> Op "<>" method op_not = function Cprop -> Op "not" | Cterm -> Call "notb" method op_and = function Cprop -> Assoc "/\\" | Cterm -> Call "andb" method op_or = function Cprop -> Assoc "\\/" | Cterm -> Call "orb" method op_imply = function Cprop -> Assoc "->" | Cterm -> Call "implb" method op_equiv = function Cprop -> Op "<->" | Cterm -> Op "=" (* -------------------------------------------------------------------------- *) (* --- Conditional --- *) (* -------------------------------------------------------------------------- *) method pp_conditional fmt a b c = begin fprintf fmt "@[if " ; self#with_mode Mpositive (fun _ -> self#pp_atom fmt a) ; fprintf fmt "@ then %a" self#pp_atom b ; fprintf fmt "@ else %a" self#pp_atom c ; fprintf fmt "@]" ; end (* -------------------------------------------------------------------------- *) (* --- Atomicity --- *) (* -------------------------------------------------------------------------- *) method is_atomic e = match T.repr e with | Kint z -> Z.positive z | Apply(_,[]) -> false | Apply _ -> true | Aset _ | Aget _ -> true | _ -> T.is_simple e (* -------------------------------------------------------------------------- *) (* --- Records --- *) (* -------------------------------------------------------------------------- *) method op_record = "{" , "}" (* -------------------------------------------------------------------------- *) (* --- Binders --- *) (* -------------------------------------------------------------------------- *) method pp_let fmt x e = fprintf fmt "@[let %s = %a in@]@ " x self#pp_flow e method pp_forall tau fmt = function | [] -> () | x::xs -> fprintf fmt "@[forall %a" self#pp_var x ; List.iter (fun x -> fprintf fmt "@ %a" self#pp_var x) xs ; fprintf fmt "@ : %a.@]" self#pp_tau tau ; method pp_intros tau fmt = function | [] -> () | x::xs -> fprintf fmt "@[forall %a" self#pp_var x ; List.iter (fun x -> fprintf fmt "@ %a" self#pp_var x) xs ; fprintf fmt "@ : %a@]" self#pp_tau tau ; method pp_exists tau fmt = function | [] -> () | x::xs -> fprintf fmt "@[exists %a" self#pp_var x ; List.iter (fun x -> fprintf fmt "@ %a" self#pp_var x) xs ; fprintf fmt "@ : %a.@]" self#pp_tau tau ; method pp_trigger fmt t = let rec pretty fmt = function | TgAny -> assert false | TgVar x -> self#pp_var fmt x | TgGet(t,k) -> fprintf fmt "@[%a[%a]@]" pretty t pretty k | TgSet(t,k,v) -> fprintf fmt "@[%a[%a@ <- %a]@]" pretty t pretty k pretty v | TgFun(f,ts) -> call Cterm f fmt ts | TgProp(f,ts) -> call Cprop f fmt ts and call mode f fmt ts = match self#link mode f with | F_call f -> Plib.pp_call_apply ~f pretty fmt ts | F_left(e,f) -> Plib.pp_fold_apply ~e ~f pretty fmt ts | F_right(e,f) -> Plib.pp_fold_apply_rev ~e ~f pretty fmt (List.rev ts) | F_assoc op -> Plib.pp_assoc ~e:"?" ~op pretty fmt ts in fprintf fmt "@[%a@]" pretty t (* -------------------------------------------------------------------------- *) (* --- Declarations --- *) (* -------------------------------------------------------------------------- *) method pp_declare_adt fmt adt n = begin fprintf fmt "type %s" (self#datatype adt) ; for i=1 to n do self#pp_tvar fmt i done ; end method pp_declare_def fmt adt n def = begin fprintf fmt "@[" ; self#pp_declare_adt fmt adt n ; fprintf fmt "@ = %a@]" self#pp_tau def ; end method pp_declare_sum fmt adt n cases = begin fprintf fmt "@[" ; self#pp_declare_adt fmt adt n ; List.iter (fun (c,ts) -> fprintf fmt "@ @[| %s@]" (self#link_name Cterm c) ; List.iter (fun t -> fprintf fmt "@ %a" self#pp_tau t) ts ; ) cases ; fprintf fmt "@]" end method declare_signature fmt f ts t = begin let cmode = Export.ctau t in fprintf fmt "@[%a" (self#pp_declare_symbol cmode) f ; List.iter (fun t -> fprintf fmt "@ %a" self#pp_subtau t) ts ; match t with | Prop -> () | _ -> fprintf fmt "@ : %a@]@\n" self#pp_tau t ; end method declare_definition fmt f xs t e = self#global begin fun () -> let cmode = Export.ctau t in fprintf fmt "@[%a" (self#pp_declare_symbol cmode) f ; List.iter (fun x -> self#bind x ; let t = T.tau_of_var x in fprintf fmt "@ (%a : %a)" self#pp_var x self#pp_tau t ) xs ; match cmode with | Cprop -> fprintf fmt " =@ @[%a@]@]@\n" self#pp_prop e | Cterm -> fprintf fmt " : %a =@ @[%a@]@]@\n" self#pp_tau t (self#pp_expr t) e end method declare_fixpoint ~prefix fmt f xs t e = begin self#declare_signature fmt f (List.map tau_of_var xs) t ; let fix = prefix ^ self#link_name (ctau t) f in self#declare_axiom fmt fix xs [] (e_eq (e_fun f (List.map e_var xs)) e) ; end end end frama-c-Fluorine-20130601/src/wp/qed/src/z.mli0000644000175000017500000000616112155630203017527 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** Natural arithmetics *) type t val zero : t val one : t val minus_one : t (** {2 Operations} *) val succ : t -> t val pred : t -> t val int : int -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val opp : t -> t val div : t -> t -> t (** Defined to be [q] such that: - [abs(q)] is the enclidian quotient of [abs(a)] and [abs(b)], - [q] has the sign of [a.b] *) val remainder : t -> t -> t (** Defined to be [a - q.b] where [q = a div b] *) val euclidian : t -> t -> t * t (** returns div and mod *) val equal : t -> t -> bool val not_equal : t -> t -> bool val leq : t -> t -> bool val lt : t -> t -> bool val positive : t -> bool val negative : t -> bool val null : t -> bool val lt_zero : t -> bool val gt_zero : t -> bool val min : t -> t -> t val max : t -> t -> t type sign = Null | Positive | Negative val sign : t -> sign val two_power : t -> t val cast_size: size:t -> signed:bool -> value:t -> t val cast_max: max:t -> signed:bool -> value:t -> t (** {2 Bitwise operations } *) val bitwise_shift_left : t -> t -> t val bitwise_shift_right : t -> t -> t val bitwise_and : t -> t -> t val bitwise_or : t -> t -> t val bitwise_xor : t -> t -> t val bitwise_not : t -> t (** {2 Conversions} *) val of_int : int -> t val to_int : t -> int option val to_big_int : t -> Big_int.big_int val of_big_int : Big_int.big_int -> t val to_string : t -> string val of_string : string -> t val pretty : Format.formatter -> t -> unit (** {2 Algebraic Data Type} *) val hash : t -> int val compare : t -> t -> int frama-c-Fluorine-20130601/src/wp/qed/src/mergeset.mli0000644000175000017500000000511712155630203021071 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Merging Set Functor *) (* -------------------------------------------------------------------------- *) module type Elt = sig type t val hash : t -> int val equal : t -> t -> bool val compare : t -> t -> int end module Make(E : Elt) : sig type elt = E.t type t = elt list Intmap.t val is_empty : t -> bool val empty : t val add : elt -> t -> t val singleton : elt -> t val elements : t -> elt list val mem : elt -> t -> bool val iter : (elt -> unit) -> t -> unit val iter_sorted : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val fold_sorted: (elt -> 'a -> 'a) -> t -> 'a -> 'a val filter : (elt -> bool) -> t -> t val partition : (elt -> bool) -> t -> t * t val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val union : t -> t -> t val inter : t -> t -> t val subset : t -> t -> bool val intersect : t -> t -> bool end frama-c-Fluorine-20130601/src/wp/qed/src/hcons.mli0000644000175000017500000000527212155630203020372 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Hash-Consing Utilities *) (* -------------------------------------------------------------------------- *) val primes : int array val hash_int : int -> int val hash_tag : 'a -> int val hash_pair : int -> int -> int val hash_triple : int -> int -> int -> int val hash_list : ('a -> int) -> int -> 'a list -> int val hash_array : ('a -> int) -> int -> 'a array -> int val hash_opt : ('a -> int) -> int -> 'a option -> int val eq_list : 'a list -> 'a list -> bool (** Uses [==]. *) val eq_array : 'a array -> 'a array -> bool (** Uses [==]. *) val equal_list : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool val equal_array : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool val compare_list : ('a -> 'a -> int) -> 'a list -> 'a list -> int val exists_array : ('a -> bool) -> 'a array -> bool val forall_array : ('a -> bool) -> 'a array -> bool val fold_list : ('a -> 'a -> 'a) -> ('b -> 'a) -> 'a -> 'b list -> 'a val fold_array : ('a -> 'a -> 'a) -> ('b -> 'a) -> 'a -> 'b array -> 'a frama-c-Fluorine-20130601/src/wp/qed/src/export.mli0000644000175000017500000001322612155630203020577 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Exportation to Foreign Languages --- *) (* -------------------------------------------------------------------------- *) (** Export Engine Factory *) open Format open Logic open Plib open Linker open Engine val cmode : mode -> cmode val amode : mode -> amode val pmode : mode -> pmode val tmode : ('a,'f) Logic.datatype -> mode val ctau : ('a,'f) Logic.datatype -> cmode val link_name : link -> string module Make(T : Term) : sig open T type tau = (Field.t,ADT.t) datatype type record = (Field.t * term) list type trigger = (var,Fun.t) ftrigger type typedef = (tau,Field.t,Fun.t) ftypedef class virtual engine : object method virtual datatype : ADT.t -> string method virtual field : Field.t -> string method basename : string -> string (** Allows to sanitize the basename used for every name except function. *) method virtual link : cmode -> Fun.t -> link method link_name : cmode -> Fun.t -> string method declare : string -> unit method declare_all : string list -> unit method local : (unit -> unit) -> unit method global : (unit -> unit) -> unit method virtual t_int : string method virtual t_real : string method virtual t_bool : string method virtual t_prop : string method virtual t_atomic : tau -> bool method virtual pp_tvar : int printer method virtual pp_array : tau printer method virtual pp_farray : tau printer2 method virtual pp_datatype : ADT.t -> tau list printer method pp_subtau : tau printer method mode : mode method with_mode : mode -> (mode -> unit) -> unit method virtual e_true : cmode -> string method virtual e_false : cmode -> string method virtual pp_int : amode -> Z.t printer method virtual pp_cst : Numbers.cst printer method pp_real : R.t printer method virtual is_atomic : term -> bool method virtual op_spaced : string -> bool method virtual callstyle : callstyle method virtual pp_apply : cmode -> term -> term list printer method pp_fun : cmode -> Fun.t -> term list printer method virtual op_scope : amode -> string option method virtual op_real_of_int : op method virtual op_add : amode -> op method virtual op_sub : amode -> op method virtual op_mul : amode -> op method virtual op_div : amode -> op method virtual op_mod : amode -> op method virtual op_minus : amode -> op method pp_times : formatter -> Z.t -> term -> unit method virtual op_equal : cmode -> op method virtual op_noteq : cmode -> op method virtual op_eq : cmode -> amode -> op method virtual op_neq : cmode -> amode -> op method virtual op_lt : cmode -> amode -> op method virtual op_leq : cmode -> amode -> op method virtual pp_array_get : formatter -> term -> term -> unit method virtual pp_array_set : formatter -> term -> term -> term -> unit method virtual pp_get_field : formatter -> term -> Field.t -> unit method virtual pp_def_fields : record printer method virtual op_not : cmode -> op method virtual op_and : cmode -> op method virtual op_or : cmode -> op method virtual op_imply : cmode -> op method virtual op_equiv : cmode -> op method pp_not : term printer method pp_imply : formatter -> term list -> term -> unit method pp_equal : term printer2 method pp_noteq : term printer2 method virtual pp_conditional : formatter -> term -> term -> term -> unit method virtual pp_forall : tau -> var list printer method virtual pp_exists : tau -> var list printer method virtual pp_lambda : var list printer method bind : var -> unit method virtual is_shareable : term -> bool method virtual pp_let : formatter -> string -> term -> unit method pp_atom : term printer method pp_flow : term printer method pp_tau : tau printer method pp_var : var printer method pp_term : term printer method pp_prop : term printer method pp_expr : tau -> term printer end end frama-c-Fluorine-20130601/src/wp/qed/src/listset.ml0000644000175000017500000001051312155630203020570 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Merging List-Set Functor --- *) (* -------------------------------------------------------------------------- *) module type Elt = sig type t val equal : t -> t -> bool val compare : t -> t -> int end module Make(E : Elt) = struct type elt = E.t type t = E.t list let compare = Hcons.compare_list E.compare let equal = Hcons.equal_list E.equal let empty = [] let rec add x = function | [] -> [x] | (e::es) as m -> let c = E.compare x e in if c < 0 then x :: m else if c > 0 then e :: add x es else m let rec mem x = function | [] -> false | e::es -> let c = E.compare x e in if c < 0 then false else if c > 0 then mem x es else true let iter = List.iter let fold = List.fold_right let filter = List.filter let partition = List.partition let rec union xs ys = match xs , ys with | [] , zs | zs , [] -> zs | (x::xtail) , (y::ytail) -> let c = E.compare x y in if c < 0 then x :: union xtail ys else if c > 0 then y :: union xs ytail else x :: union xtail ytail let rec inter xs ys = match xs , ys with | [] , _ | _ , [] -> [] | (x::xtail) , (y::ytail) -> let c = E.compare x y in if c < 0 then inter xtail ys else if c > 0 then inter xs ytail else x :: inter xtail ytail let rec subset xs ys = match xs , ys with | [] , _ -> true | _::_ , [] -> false | (x::xtail) , (y::ytail) -> let c = E.compare x y in if c < 0 then false else if c > 0 then subset xs ytail else subset xtail ytail let rec diff xs ys = match xs , ys with | [] , _ -> [] | _ , [] -> xs | (x::xtail) , (y::ytail) -> let c = E.compare x y in if c < 0 then x :: diff xtail ys else if c > 0 then diff xs ytail else diff xtail ytail let rec intersect xs ys = match xs , ys with | [] , _ | _ , [] -> false | (x::xtail) , (y::ytail) -> let c = E.compare x y in if c < 0 then intersect xtail ys else if c > 0 then intersect xs ytail else true let rec fact rxs cxs rys xs ys = match xs , ys with | [] , _ | _ , [] -> List.rev_append rxs xs , List.rev cxs , List.rev_append rys ys | x::xtail , y::ytail -> let c = E.compare x y in if c < 0 then fact (x::rxs) cxs rys xtail ys else if c > 0 then fact rxs cxs (y::rys) xs ytail else fact rxs (x::cxs) rys xtail ytail let factorize xs ys = fact [] [] [] xs ys let rec big_union = function | [] -> [] | e::es -> union e (big_union es) let rec big_inter = function | [] -> [] | [e] -> e | e::es -> inter e (big_inter es) end frama-c-Fluorine-20130601/src/wp/qed/src/parser.mli0000644000175000017500000000453112155630203020551 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Parser for Terms *) (* -------------------------------------------------------------------------- *) open Logic open Syntax open Lexer val keymap : Lexer.keymap val extend : string list -> Lexer.keymap (** Parses ['a1 ... 'an t] *) val parse_typedef : input -> id list * id (** Parses [t1 -> ... tn -> tr] *) val parse_signature : input -> ( t list * t ) (** Parses [arg ... arg] *) val parse_args : input -> arg list (** Parses [constructor] and [injective] *) val parse_category : input -> 'a category (** Parses a type *) val parse_type : input -> t (** Parses an expression (or a pattern) *) val parse_expr : input -> e frama-c-Fluorine-20130601/src/wp/qed/src/depends.mli0000644000175000017500000000521612155630203020700 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Logic (** Dependencies *) module Make(T : Term) : sig open T (** {3 Set} *) type depends val depends : unit -> depends val union : depends -> depends -> depends val subset : depends -> depends -> bool (** {3 Iterators} *) val iter_types : (ADT.t -> unit) -> depends -> unit val iter_fields : (Field.t -> unit) -> depends -> unit val iter_functions : (Fun.t -> unit) -> depends -> unit val iter_predicates : (Fun.t -> unit) -> depends -> unit val mem_type : depends -> ADT.t -> bool val mem_field : depends -> Field.t -> bool val mem_function : depends -> Fun.t -> bool val mem_predicate : depends -> Fun.t -> bool (** {3 Accumulators} *) val add_type : depends -> ADT.t -> unit val add_field : depends -> Field.t -> unit val add_function : depends -> Fun.t -> unit val add_predicate : depends -> Fun.t -> unit val add_depend : target:depends -> source:depends -> unit val add_tau : depends -> tau -> unit val add_term : depends -> term -> unit val add_prop : depends -> term -> unit (** {3 Topological Sort} *) end frama-c-Fluorine-20130601/src/wp/qed/src/plib.ml0000644000175000017500000001152712155630203020035 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 --- *) (* -------------------------------------------------------------------------- *) open Format let kprintf f text = let buffer = Buffer.create 80 in kfprintf (fun fmt -> pp_print_flush fmt () ; f (Buffer.contents buffer) ) (formatter_of_buffer buffer) text let sprintf text = kprintf (fun s -> s) text let failure text = kprintf (fun s -> failwith s) text let to_string pp x = let buffer = Buffer.create 80 in let fmt = formatter_of_buffer buffer in pp fmt x ; pp_print_flush fmt () ; Buffer.contents buffer type 'a printer = formatter -> 'a -> unit type 'a printer2 = formatter -> 'a -> 'a -> unit let pp_call_var ~f pp fmt = function | [] -> pp_print_string fmt f | x::xs -> fprintf fmt "@[%s(%a" f pp x ; List.iter (fun y -> fprintf fmt ",@ %a" pp y) xs ; fprintf fmt ")@]" let pp_call_void ~f pp fmt = function | [] -> fprintf fmt "%s()" f | x::xs -> fprintf fmt "@[%s(%a" f pp x ; List.iter (fun y -> fprintf fmt ",@ %a" pp y) xs ; fprintf fmt ")@]" let pp_call_apply ~f pp fmt = function | [] -> pp_print_string fmt f | xs -> fprintf fmt "@[(%s" f ; List.iter (fun y -> fprintf fmt "@ %a" pp y) xs ; fprintf fmt ")@]" let pp_binop ~op pp fmt a b = fprintf fmt "%a@ %s %a" pp a op pp b let pp_assoc ~e ~op pp fmt = function | [] -> pp_print_string fmt e | x::xs -> pp fmt x ; List.iter (fun y -> fprintf fmt " %s@ %a" op pp y) xs let rec pp_fold_binop ~e ~op pp fmt = function | [] -> pp_print_string fmt e | [x] -> pp fmt x | x::xs -> fprintf fmt "(%a %s@ %a)" pp x op (pp_fold_binop ~e ~op pp) xs let rec pp_fold_call ~e ~f pp fmt = function | [] -> pp_print_string fmt e | [x] -> pp fmt x | x::xs -> fprintf fmt "%s(%a,@ %a)" f pp x (pp_fold_call ~e ~f pp) xs let rec pp_fold_apply ~e ~f pp fmt = function | [] -> pp_print_string fmt e | [x] -> pp fmt x | x::xs -> fprintf fmt "(%s@ %a@ %a)" f pp x (pp_fold_apply ~e ~f pp) xs let rec pp_fold_call_rev ~e ~f pp fmt = function | [] -> pp_print_string fmt e | [x] -> pp fmt x | x::xs -> fprintf fmt "%s(%a,@ %a)" f (pp_fold_call_rev ~e ~f pp) xs pp x let rec pp_fold_apply_rev ~e ~f pp fmt = function | [] -> pp_print_string fmt e | [x] -> pp fmt x | x::xs -> fprintf fmt "(%s@ %a@ %a)" f pp x (pp_fold_apply_rev ~e ~f pp) xs let pp_listcompact ~sep pp fmt = function | [] -> () | x::xs -> pp fmt x ; List.iter (fun x -> fprintf fmt "%s@,%a" sep pp x) xs let pp_listsep ~sep pp fmt = function | [] -> () | x::xs -> pp fmt x ; List.iter (fun x -> fprintf fmt "%s@ %a" sep pp x) xs type index = Isingle | Ifirst | Ilast | Imiddle let iteri f = function | [] -> () | [x] -> f Isingle x | x::xs -> let rec iterk f = function | [] -> () | [x] -> f Ilast x | x::xs -> f Imiddle x ; iterk f xs in f Ifirst x ; iterk f xs let iterk f xs = let rec step f k = function | [] -> () | x::xs -> f k x ; step f (succ k) xs in step f 0 xs let mapk f xs = let rec step f k = function | [] -> [] | x::xs -> let y = f k x in y :: step f (succ k) xs in step f 0 xs frama-c-Fluorine-20130601/src/wp/qed/src/input.mli0000644000175000017500000000550412155630203020415 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Utilities *) (* -------------------------------------------------------------------------- *) open Syntax type 'a lexer = Lexing.lexbuf -> 'a exception SyntaxError of position * string val merge : position -> position -> position val merge_list : ('a -> position) -> position -> 'a list -> position val error_at : position -> ('a,Format.formatter,unit,'b) format4 -> 'a val pp_position : Format.formatter -> position -> unit val locate : position -> exn -> exn val nowhere : position val string_of_exn : exn -> string module type Lexer = sig type token type langage val eof : token val create : langage -> token lexer end module type S = sig type input type token type langage val open_file : langage -> string -> input val open_shell : langage -> string -> input val close : input -> unit val token : input -> token val skip : input -> unit val context : input -> string -> unit val position : input -> position val error : input -> ('a,Format.formatter,unit,'b) format4 -> 'a end module Make(L : Lexer) : S with type token = L.token and type langage = L.langage frama-c-Fluorine-20130601/src/wp/qed/src/Makefile.src0000644000175000017500000000402412155630203020775 0ustar mehdimehdi########################################################################## # # # This file is part of WP plug-in of Frama-C. # # # # Copyright (C) 2007-2013 # # CEA (Commissariat a l'energie atomique et aux energies # # 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). # # # ########################################################################## # Shared with WP's Makefile in order to facilitate recompilation of Qed # from Frama-C QED_LIB_ML = z r numbers hcons intmap intset idxset idxmap \ listset listmap mergeset mergemap collection \ partition relation sigma \ plib topology QED_SRC_ML = kind pool term pretty depends \ linker export export_coq export_whycore export_why3 export_altergo \ input ast lexer parser \ unify typechecker compiler \ pattern \ QED_SRC_MLI = logic engine syntax QED_GENERATED=lexerframa-c-Fluorine-20130601/src/wp/qed/src/mergemap.ml0000644000175000017500000000776712155630203020717 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Merging Map Functor --- *) (* -------------------------------------------------------------------------- *) module type Key = sig type t val hash : t -> int val equal : t -> t -> bool val compare : t -> t -> int end module Make(K : Key) = struct module Lmap = Listmap.Make(K) type key = K.t type 'a t = 'a Lmap.t Intmap.t (* sorted collisions *) let is_empty m = try Intmap.iteri (fun _ m -> if m<>[] then raise Exit) m ; true with Exit -> false let empty = Intmap.empty let add k v m = let h = K.hash k in let w = try Lmap.add k v (Intmap.find h m) with Not_found -> [k,v] in Intmap.add h w m let find k m = Lmap.find k (Intmap.find (K.hash k) m) let findk k m = Lmap.findk k (Intmap.find (K.hash k) m) let mem k m = try ignore (find k m) ; true with Not_found -> false let map f m = Intmap.map (Lmap.map f) m let mapi f m = Intmap.map (Lmap.mapi f) m let select phi m = Intmap.mapf (fun _h w -> match phi w with [] -> None | w -> Some w) m let mapf f = select (Lmap.mapf f) let filter f = select (Lmap.filter f) let remove k = select (Lmap.remove k) let iter f m = Intmap.iter (Lmap.iter f) m let iter_sorted f m = let xs = ref [] in Intmap.iter (fun w -> xs := List.merge (fun a b -> K.compare (fst a) (fst b)) w !xs ) m ; List.iter (fun (k,v) -> f k v) !xs let fold f m a = Intmap.fold (Lmap.fold f) m a let fold_sorted f m a = let xs = Intmap.fold (List.merge (fun a b -> K.compare (fst a) (fst b))) m [] in List.fold_left (fun acc (k,v) -> f k v acc) a xs let union f = Intmap.union (fun _h -> Lmap.union f) let inter f = Intmap.inter (fun _h -> Lmap.inter f) let subset f = Intmap.subset (fun _h -> Lmap.subset f) let equal eq m1 m2 = Intmap.equal (Lmap.equal eq) m1 m2 let iterk f = Intmap.iterk (fun _h -> Lmap.iterk f) let iter2 f m1 m2 = Intmap.iter2 (fun _h u1 u2 -> let w1 = match u1 with None -> [] | Some w -> w in let w2 = match u2 with None -> [] | Some w -> w in Lmap.iter2 f w1 w2) m1 m2 let merge f m1 m2 = Intmap.merge (fun _h u1 u2 -> let w1 = match u1 with None -> [] | Some w -> w in let w2 = match u2 with None -> [] | Some w -> w in match Lmap.merge f w1 w2 with | [] -> None | w -> Some w) m1 m2 end frama-c-Fluorine-20130601/src/wp/qed/src/mergemap.mli0000644000175000017500000000607212155630203021054 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Merging Map Functor *) (* -------------------------------------------------------------------------- *) module type Key = sig type t val hash : t -> int val equal : t -> t -> bool val compare : t -> t -> int end module Make(K : Key) : sig type key = K.t type 'a t = (key * 'a) list Intmap.t val is_empty : 'a t -> bool val empty : 'a t val add : key -> 'a -> 'a t -> 'a t val mem : key -> 'a t -> bool val find : key -> 'a t -> 'a val findk : key -> 'a t -> key * 'a val remove : key -> 'a t -> 'a t val filter : (key -> 'a -> bool) -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val mapf : (key -> 'a -> 'b option) -> 'a t -> 'b t val iter : (key -> 'a -> unit) -> 'a t -> unit val iter_sorted : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val fold_sorted: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val union : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val inter : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val subset : (key -> 'a -> 'b -> bool) -> 'a t -> 'b t -> bool val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iterk : (key -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit val iter2 : (key -> 'a option -> 'b option -> unit) -> 'a t -> 'b t -> unit val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t end frama-c-Fluorine-20130601/src/wp/qed/src/sigma.ml0000644000175000017500000001072212155630203020203 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Logic module type S = sig type t type term type explain exception Contradiction of explain val empty : t val assume : ?explain:explain -> term -> t -> t val rewrite : ?explain:explain -> term -> term -> t -> t val reduce : t -> term -> term * explain val is_true : t -> term -> explain option val is_false : t -> term -> explain option val iter : (term -> term -> explain -> unit) -> t -> unit end module type Explain = sig type t val bot : t val cup : t -> t -> t end module Make(T : Logic.Term)(E : Explain) = struct type term = T.term type explain = E.t exception Contradiction of explain open T type t = { domain : Vars.t ; def : (term * explain) Tmap.t ; (* core facts *) mutable mem : (term * explain) Tmap.t ; (* memoization *) } let empty = { domain = Vars.empty ; def = Tmap.empty ; mem = Tmap.empty ; } let iter f s = Tmap.iter (fun a (b,e) -> f a b e) s.def let rec apply s xs a = let ys = T.vars a in if Vars.intersect xs ys then (* Filter out bound variables *) apply_sub s xs a else if not (Vars.intersect s.domain ys) then (* Filter out-of-scope *) a , E.bot else (* Memoization *) try Tmap.find a s.mem with Not_found -> let w = apply_sub s xs a in s.mem <- Tmap.add a w s.mem ; w and apply_sub s xs a = let w = ref E.bot in let b = T.f_map (fun xs a -> let (a,e) = apply s xs a in w := E.cup !w e ; a) xs a in b , !w let reduce s a = apply s Vars.empty a let is_true s a = let r,e = reduce s a in if r == e_true then Some e else None let is_false s a = let r,e = reduce s a in if r == e_false then Some e else None let add_def e a b s = try let b0,e0 = Tmap.find a s.mem in match T.are_equal b b0 with | No -> raise (Contradiction(E.cup e0 e)) | Yes -> s (* nothing to do *) | Maybe -> raise Not_found with Not_found -> let def = Tmap.add a (b,e) s.def in { domain = Vars.union (T.vars a) s.domain ; mem = def ; def } let add_lit e a s = add_def e a e_true (add_def e (e_not a) e_false s) let rec add_pred e p s = match T.repr p with | True -> s | False -> raise (Contradiction e) | And ps -> add_all e ps s | Fun _ | Not _ | Neq _ -> add_lit e p s | Lt(x,y) -> add_lit e p (add_lit e (e_leq x y) (add_lit e (e_neq x y) s)) | Leq(x,y) -> begin match is_true s (e_leq y x) with | Some e0 -> add_pred (E.cup e e0) (e_eq x y) s | None -> add_lit e p s end | Eq(x,y) -> begin match T.is_closed x , T.is_closed y with | true , false -> add_def e y x s | false , true -> add_def e x y s | _ -> add_lit e p s end | _ -> s and add_all e ps s = match ps with | [] -> s | p::ps -> add_all e ps (add_pred e p s) let assume ?(explain=E.bot) p s = add_pred explain p s let rewrite ?(explain=E.bot) a b s = add_def explain a b s end frama-c-Fluorine-20130601/src/wp/qed/src/pattern.mli0000644000175000017500000000507512155630203020736 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Logic (* -------------------------------------------------------------------------- *) (* --- Pattern Matching --- *) (* -------------------------------------------------------------------------- *) type 'f fpattern = | Pvar of int | Pint of Z.t | Pfun of 'f * 'f fpattern list val size : 'a fpattern -> int (** Number of pattern variables. *) val size_all : 'a fpattern list -> int (** Number of all patterns variables. *) module Make(T : Term) : sig open T type pattern = Fun.t fpattern val pmatch : pattern -> term -> term array (** Raise [Not_found] or returns the substitution as an array indexed by pattern variable number. *) val pmatch_all : pattern list -> term list -> term array (** Raise [Not_found] or returns the substitution as an array indexed by pattern variable number. *) val instance : term array -> pattern -> term (** Compute the term matched by the pattern and the substitution. *) end frama-c-Fluorine-20130601/src/wp/qed/src/term.ml0000644000175000017500000016336012155630203020061 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- First Order Logic --- *) (* -------------------------------------------------------------------------- *) open Hcons open Logic module Make(ADT : Logic.Data)(Field : Logic.Field)(Fun : Logic.Function) = struct (* -------------------------------------------------------------------------- *) type tau = (Field.t,ADT.t) Logic.datatype type signature = (Field.t,ADT.t) Logic.funtype type path = int list module POOL = Pool.Make (struct type t = tau let dummy = Prop let equal = Kind.eq_tau Field.equal ADT.equal end) open POOL type var = POOL.var module VID = struct type t = var let id x = x.vid end module Vars = Idxset.Positive(VID) module Vmap = Idxmap.Make(VID) module Builtins = Map.Make(Fun) type 'a symbol = (Field.t,Fun.t,var,'a) term_repr type term = { id : int ; hash : int ; size : int ; vars : Vars.t ; sort : sort ; repr : repr ; } and repr = term symbol module ADT = ADT module Field = Field module Fun = Fun module Var : Variable with type t = var = struct type t = var let hash x = x.vid let equal = (==) let compare = POOL.compare let pretty = POOL.pretty let id x = Printf.sprintf "%s_%d" x.vbase x.vid let basename x = x.vbase let sort x = Kind.of_tau x.vtau let dummy = POOL.dummy end let tau_of_var x = x.vtau let base_of_var x = x.vbase let base_of_tau = function | Int -> "i" | Real -> "r" | Prop -> "p" | Bool -> "p" | Data(a,_) -> ADT.basename a | Array _ -> "t" | Tvar 1 -> "a" | Tvar 2 -> "b" | Tvar 3 -> "c" | Tvar 4 -> "d" | Tvar 5 -> "e" | Tvar _ -> "f" | Record _ -> "r" (* -------------------------------------------------------------------------- *) (* --- Variables --- *) (* -------------------------------------------------------------------------- *) type pool = POOL.pool let pool = POOL.create let add_var pool x = POOL.add pool x let add_vars pool xs = Vars.iter (POOL.add pool) xs let add_term pool t = Vars.iter (POOL.add pool) t.vars let fresh pool ?basename tau = let base = match basename with Some base -> base | None -> base_of_tau tau in POOL.fresh pool base tau let alpha pool x = POOL.alpha pool x let rec basename t = match t.repr with | Kint _ -> "x" | Kreal _ -> "r" | Aset(a,_,_) -> basename a | _ -> Kind.basename t.sort (* -------------------------------------------------------------------------- *) (* --- Representation --- *) (* -------------------------------------------------------------------------- *) let repr e = e.repr let hash e = e.hash let id e = e.id let vars e = e.vars let hash_subterms = function | False -> 0 | True -> 0 | Kint n -> Z.hash n | Kreal x -> R.hash x | Times(n,t) -> Z.hash n * t.hash | Add xs | Mul xs | And xs | Or xs -> hash_list hash 0 xs | Div(x,y) | Mod(x,y) | Eq(x,y) | Neq(x,y) | Leq(x,y) | Lt(x,y) | Aget(x,y) -> hash_pair x.hash y.hash | Not e -> succ e.hash | Imply(hs,p) -> hash_list hash p.hash hs | If(e,a,b) | Aset(e,a,b) -> hash_triple e.hash a.hash b.hash | Fun(f,xs) -> hash_list hash (Fun.hash f) xs | Rdef fxs -> hash_list (fun (f,x) -> hash_pair (Field.hash f) x.hash) 0 fxs | Rget(e,f) -> hash_pair e.hash (Field.hash f) | Var x -> Var.hash x | Bind(Forall,x,e) -> 1 + 7 * Var.hash x + 31 * e.hash | Bind(Exists,x,e) -> 2 + 7 * Var.hash x + 31 * e.hash | Bind(Lambda,x,e) -> 3 + 7 * Var.hash x + 31 * e.hash | Apply(a,xs) -> hash_list hash a.hash xs let hash_head = function | False -> 0 | True -> 1 | Kint _ -> 2 | Kreal _ -> 3 | Times _ -> 4 | Add _ -> 5 | Mul _ -> 6 | And _ -> 7 | Or _ -> 8 | Div _ -> 9 | Mod _ -> 10 | Eq _ -> 11 | Neq _ -> 12 | Leq _ -> 13 | Lt _ -> 14 | Not _ -> 15 | Imply _ -> 16 | If _ -> 17 | Fun _ -> 18 | Var _ -> 19 | Bind _ -> 20 | Apply _ -> 21 | Aset _ -> 22 | Aget _ -> 23 | Rdef _ -> 24 | Rget _ -> 25 let hash_repr t = hash_head t + 31 * hash_subterms t let equal_repr a b = match a,b with | True , True -> true | False , False -> true | Kint n , Kint m -> Z.equal n m | Kreal x , Kreal y -> R.equal x y | Times(n,x) , Times(m,y) -> x==y && Z.equal n m | Add xs , Add ys | Mul xs , Mul ys | And xs , And ys | Or xs , Or ys -> eq_list xs ys | Div(x,y) , Div(x',y') | Mod(x,y) , Mod(x',y') | Eq(x,y) , Eq(x',y') | Neq(x,y) , Neq(x',y') | Leq(x,y) , Leq(x',y') | Lt(x,y) , Lt(x',y') | Aget(x,y) , Aget(x',y') -> x==x' && y==y' | Not a , Not b -> a==b | Imply(hs,p) , Imply(hs',q) -> p==q && eq_list hs hs' | If(e,a,b) , If(e',a',b') | Aset(e,a,b) , Aset(e',a',b') -> e==e' && a==a' && b==b' | Fun(f,xs) , Fun(g,ys) -> Fun.equal f g && eq_list xs ys | Var x , Var y -> Var.equal x y | Bind(q,x,e) , Bind(q',x',e') -> q=q' && Var.equal x x' && e==e' | Apply(x,ys) , Apply(x',ys') -> x==x' && eq_list ys ys' | Rget(x,f) , Rget(x',g) -> x==x' && Field.equal f g | Rdef fxs , Rdef gys -> equal_list (fun (f,x) (g,y) -> x==y && Field.equal f g) fxs gys | _ -> assert (hash_head a <> hash_head b) ; false let sort x = x.sort let vars x = x.vars let vars_repr = function | True | False | Kint _ | Kreal _ -> Vars.empty | Times(_,x) | Not x | Rget(x,_) -> x.vars | Add xs | Mul xs | And xs | Or xs | Fun(_,xs) -> Hcons.fold_list Vars.union (fun x -> x.vars) Vars.empty xs | Div(x,y) | Mod(x,y) | Eq(x,y) | Neq(x,y) | Leq(x,y) | Lt(x,y) | Aget(x,y) -> Vars.union x.vars y.vars | Imply(xs,a) | Apply(a,xs) -> Hcons.fold_list Vars.union vars a.vars xs | If(e,a,b) | Aset(e,a,b) -> Vars.union e.vars (Vars.union a.vars b.vars) | Var x -> Vars.singleton x | Bind(_,x,e) -> Vars.remove x e.vars | Rdef fxs -> List.fold_left (fun s (_,x) -> Vars.union s x.vars) Vars.empty fxs let sort_repr = function | True | False -> Sbool | Kint _ -> Sint | Kreal _ -> Sreal | Times(_,x) -> Kind.merge Sint x.sort | Add xs | Mul xs -> Kind.merge_list sort Sint xs | And xs | Or xs -> Kind.merge_list sort Sbool xs | Imply(hs,p) -> Kind.merge_list sort p.sort hs | Not x -> x.sort | Fun(f,_) -> Fun.sort f | Aget(m,_) -> Kind.image m.sort | Aset(m,_,_) -> m.sort | Rget(_,f) -> Field.sort f | Rdef _ -> Sdata | Div(x,y) | Mod(x,y) -> Kind.merge x.sort y.sort | Eq _ | Neq _ | Leq _ | Lt _ -> Sbool | Apply(x,_) -> x.sort | If(_,a,b) -> Kind.merge a.sort b.sort | Var x -> Kind.of_tau x.vtau | Bind((Forall|Exists),_,_) -> Sprop | Bind(Lambda,_,e) -> e.sort let rec size_list n w = function | [] -> n+w | x::xs -> size_list (succ n) (max w x.size) xs let rec size_rdef n w = function | [] -> n+w | (_,x)::fxs -> size_rdef (succ n) (max w x.size) fxs let size_repr = function | True | False | Kint _ -> 0 | Var _ | Kreal _ -> 1 | Times(_,x) -> succ x.size | Add xs | Mul xs | And xs | Or xs -> size_list 1 0 xs | Imply(hs,p) -> size_list 1 p.size hs | Not x -> succ x.size | Fun(_,xs) -> size_list 1 0 xs | Aget(a,b) -> 1 + max a.size b.size | Aset(a,b,c) -> 1 + max a.size (max b.size c.size) | Rget(a,_) -> 1 + a.size | Rdef fxs -> 1 + size_rdef 0 0 fxs | Div(x,y) | Mod(x,y) -> 2 + max x.size y.size | Eq(x,y) | Neq(x,y) | Lt(x,y) | Leq(x,y) -> 1 + max x.size y.size | Apply(x,xs) -> size_list 1 x.size xs | If(a,b,c) -> 2 + max a.size (max b.size c.size) | Bind(_,_,p) -> 3 + p.size (* -------------------------------------------------------------------------- *) (* --- Hconsed --- *) (* -------------------------------------------------------------------------- *) module W = Weak.Make (struct type t = term let hash t = t.hash let equal t1 t2 = equal_repr t1.repr t2.repr end) let kid = ref 0 let fid = ref 0 let hmap = W.create 32993 (* 3-th Leyland Prime number *) let insert r = let h = hash_repr r in (* Only [hash] and [repr] are significant for lookup in weak hmap *) let e0 = { id=0 ; hash=h ; repr=r ; size=0; vars=Vars.empty ; sort=Sdata ; } in try W.find hmap e0 with Not_found -> let k = let i = !kid in (assert (i <> -1) ; incr kid ; i) in let e = { id = k ; hash = h ; repr = r ; vars = vars_repr r ; sort = sort_repr r ; size = size_repr r ; } in W.add hmap e ; e (* -------------------------------------------------------------------------- *) (* --- Comparison --- *) (* -------------------------------------------------------------------------- *) module COMPARE = struct let cmp_size a b = Pervasives.compare a.size b.size let rank_bind = function Forall -> 0 | Exists -> 1 | Lambda -> 2 let cmp_bind p q = rank_bind p - rank_bind q let cmp_field phi (f,x) (g,y) = let cmp = Field.compare f g in if cmp <> 0 then cmp else phi x y let cmp_struct phi a b = match a.repr , b.repr with | True , True -> 0 | True , _ -> (-1) | _ , True -> 1 | False , False -> 0 | False , _ -> (-1) | _ , False -> 1 | Kint a , Kint b -> Z.compare a b | Kint _ , _ -> (-1) | _ , Kint _ -> 1 | Kreal a , Kreal b -> R.compare a b | Kreal _ , _ -> (-1) | _ , Kreal _ -> 1 | Var x , Var y -> Var.compare x y | Var _ , _ -> (-1) | _ , Var _ -> 1 | Eq(a1,b1) , Eq(a2,b2) | Neq(a1,b1) , Neq(a2,b2) | Lt(a1,b1) , Lt(a2,b2) | Leq(a1,b1) , Leq(a2,b2) | Div(a1,b1) , Div(a2,b2) | Mod(a1,b1) , Mod(a2,b2) -> let cmp = phi a1 a2 in if cmp <> 0 then cmp else phi b1 b2 | Eq _ , _ -> (-1) | _ , Eq _ -> 1 | Neq _ , _ -> (-1) | _ , Neq _ -> 1 | Lt _ , _ -> (-1) | _ , Lt _ -> 1 | Leq _ , _ -> (-1) | _ , Leq _ -> 1 | Fun(f,xs) , Fun(g,ys) -> let cmp = Fun.compare f g in if cmp <> 0 then cmp else Hcons.compare_list phi xs ys | Fun _ , _ -> (-1) | _ , Fun _ -> 1 | Times(a,x) , Times(b,y) -> let cmp = Z.compare a b in if cmp <> 0 then cmp else phi x y | Times _ , _ -> (-1) | _ , Times _ -> 1 | Not x , Not y -> phi x y | Not _ , _ -> (-1) | _ , Not _ -> 1 | Imply(h1,p1) , Imply(h2,p2) -> Hcons.compare_list phi (p1::h1) (p2::h2) | Imply _ , _ -> (-1) | _ , Imply _ -> 1 | Add xs , Add ys | Mul xs , Mul ys | And xs , And ys | Or xs , Or ys -> Hcons.compare_list phi xs ys | Add _ , _ -> (-1) | _ , Add _ -> 1 | Mul _ , _ -> (-1) | _ , Mul _ -> 1 | And _ , _ -> (-1) | _ , And _ -> 1 | Or _ , _ -> (-1) | _ , Or _ -> 1 | Div _ , _ -> (-1) | _ , Div _ -> 1 | Mod _ , _ -> (-1) | _ , Mod _ -> 1 | If(a1,b1,c1) , If(a2,b2,c2) -> let cmp = phi a1 a2 in if cmp <> 0 then cmp else let cmp = phi b1 b2 in if cmp <> 0 then cmp else phi c1 c2 | If _ , _ -> (-1) | _ , If _ -> 1 | Aget(a1,b1) , Aget(a2,b2) -> let cmp = phi a1 a2 in if cmp <> 0 then cmp else phi b1 b2 | Aget _ , _ -> (-1) | _ , Aget _ -> 1 | Aset(a1,k1,v1) , Aset(a2,k2,v2) -> let cmp = phi a1 a2 in if cmp <> 0 then cmp else let cmp = phi k1 k2 in if cmp <> 0 then cmp else phi v1 v2 | Aset _ , _ -> (-1) | _ , Aset _ -> 1 | Rget(r1,f1) , Rget(r2,f2) -> let cmp = phi r1 r2 in if cmp <> 0 then cmp else Field.compare f1 f2 | Rget _ , _ -> (-1) | _ , Rget _ -> 1 | Rdef fxs , Rdef gys -> Hcons.compare_list (cmp_field phi) fxs gys | Rdef _ , _ -> (-1) | _ , Rdef _ -> 1 | Apply(a,xs) , Apply(b,ys) -> Hcons.compare_list phi (a::xs) (b::ys) | Apply _ , _ -> (-1) | _ , Apply _ -> 1 | Bind(q1,x1,p1) , Bind(q2,x2,p2) -> let cmp = cmp_bind q1 q2 in if cmp <> 0 then cmp else let cmp = phi p1 p2 in if cmp <> 0 then cmp else Var.compare x1 x2 let rec compare a b = if a == b then 0 else let cmp = cmp_size a b in if cmp <> 0 then cmp else cmp_struct compare a b end let weigth e = e.size let compare = COMPARE.compare (* -------------------------------------------------------------------------- *) (* --- Constructors for normalized terms --- *) (* -------------------------------------------------------------------------- *) let e_zero = insert (Kint Z.zero) let e_one = insert (Kint Z.one) let e_true = insert True let e_false = insert False let e_int n = insert (Kint (Z.int n)) let e_zint z = insert (Kint z) let e_real x = insert (Kreal x) let e_var x = insert(Var x) let c_div x y = insert (Div(x,y)) let c_mod x y = insert (Mod(x,y)) let c_leq x y = insert (Leq(x,y)) let c_lt x y = insert (Lt (x,y)) let insert_eq x y = insert (Eq (x,y)) let insert_neq x y = insert (Neq(x,y)) let sym c x y = if compare x y > 0 then c y x else c x y let compare_field (f,x) (g,y) = let cmp = Field.compare f g in if cmp = 0 then compare x y else cmp let c_eq = sym insert_eq let c_neq = sym insert_neq let c_fun f xs = insert(Fun(f,xs)) let c_add = function | [] -> e_zero | [x] -> x | xs -> insert(Add(List.sort compare xs)) let c_mul = function | [] -> e_one | [x] -> x | xs -> insert(Mul(List.sort compare xs)) let c_times z t = insert(Times(z,t)) let c_and = function | [] -> e_true | [x] -> x | xs -> insert(And(List.sort compare xs)) let c_or = function | [] -> e_false | [x] -> x | xs -> insert(Or(List.sort compare xs)) let c_imply hs p = insert(Imply(List.sort compare hs,p)) let c_not x = insert(Not x) let c_if e a b = insert(If(e,a,b)) let c_apply a es = if es=[] then a else insert(Apply(a,es)) let c_bind q x e = insert(Bind(q,x,e)) let c_get m k = insert(Aget(m,k)) let c_set m k v = insert(Aset(m,k,v)) let c_getfield m f = insert(Rget(m,f)) let c_record fxs = match fxs with | [] | [_] -> insert(Rdef fxs) | fx::gys -> try let base (f,v) = match v.repr with | Rget(r,g) when Field.equal f g -> r | _ -> raise Exit in let r = base fx in List.iter (fun gy -> if base gy != r then raise Exit) gys ; r with Exit -> insert(Rdef (List.sort compare_field fxs)) let insert _ = assert false (* [insert] should not be used afterwards *) let rec subterm e = function [] -> e | n :: l -> let children = match e.repr with | True | False | Kint _ | Kreal _ | Var _ -> [] | Times (n,e) -> [ e_zint n; e] | Add l | Mul l | And l | Or l | Fun (_,l) -> l | Div (e1,e2) | Mod (e1,e2) | Eq(e1,e2) | Neq(e1,e2) | Leq (e1,e2) | Lt(e1,e2) | Aget(e1,e2) -> [e1;e2] | Not e | Bind(_,_,e) -> [e] | Imply(l,e) -> l @ [e] | If(e1,e2,e3) | Aset(e1,e2,e3) -> [e1;e2;e3] | Rget(e,_) -> [e] | Rdef fxs -> List.map snd fxs | Apply(e,es) -> e::es in subterm (List.nth children n) l (* -------------------------------------------------------------------------- *) (* --- Builtin Computation Support --- *) (* -------------------------------------------------------------------------- *) let builtins = ref Builtins.empty let add_builtin (f:Fun.t) (compute:term list -> term) = let cs = try Builtins.find f !builtins with Not_found -> [] in builtins := Builtins.add f (cs @ [compute]) !builtins let rec eval_builtins xs = function | [] -> raise Not_found | c::cs -> try c xs with Not_found -> eval_builtins xs cs let c_builtin f xs = try eval_builtins xs (Builtins.find f !builtins) with Not_found -> c_fun f xs (* -------------------------------------------------------------------------- *) (* --- User Operators --- *) (* -------------------------------------------------------------------------- *) let rec op_revassoc phi xs = function | [] -> xs | e::es -> match e.repr with | Fun(f,ts) when Fun.equal f phi -> op_revassoc phi (op_revassoc f xs ts) es | _ -> op_revassoc phi (e::xs) es let rec op_idempotent = function | [] -> [] | [_] as l -> l | x::( (y::_) as w ) -> if x==y then op_idempotent w else x :: op_idempotent w let op_inversible xs ys = let rec simpl modified turn xs ys = match xs , ys with | x::xs , y::ys when x==y -> simpl true turn xs ys | _ -> let xs = List.rev xs in let ys = List.rev ys in if turn then simpl modified false xs ys else modified,xs,ys in simpl false true xs ys let element = function | E_none -> assert false | E_int k -> e_int k | E_true -> e_true | E_false -> e_false | E_const f -> c_fun f [] let is_element e x = match e , x.repr with | E_int k , Kint z -> Z.equal (Z.int k) z | E_true , True -> true | E_false , False -> false | E_const f , Fun(g,[]) -> Fun.equal f g | _ -> false let isnot_element e x = not (is_element e x) let is_neutral f e = match Fun.category f with | Operator op -> is_element op.neutral e | _ -> false let is_absorbant f e = match Fun.category f with | Operator op -> is_element op.absorbant e | _ -> false let op_fun builtin f op xs = let xs = if op.associative then let xs = op_revassoc f [] xs in if op.commutative then List.sort compare xs else List.rev xs else if op.commutative then List.sort compare xs else xs in if op.absorbant <> E_none && List.exists (is_element op.absorbant) xs then element op.absorbant else let xs = if op.neutral <> E_none then List.filter (isnot_element op.neutral) xs else xs in let xs = if op.idempotent then op_idempotent xs else xs in match xs with | [] when op.neutral <> E_none -> element op.neutral | [x] when op.associative -> x | _ -> if builtin then c_builtin f xs else c_fun f xs let e_fungen builtin f xs = match Fun.category f with | Logic.Operator op -> op_fun builtin f op xs | _ -> if builtin then c_builtin f xs else c_fun f xs let e_fun = e_fungen true let e_funop = e_fungen false let e_funraw = c_fun (* -------------------------------------------------------------------------- *) (* --- Symbols --- *) (* -------------------------------------------------------------------------- *) type t = term let equal = (==) let is_primitive e = match e.repr with | True | False | Kint _ | Kreal _ -> true | _ -> false let is_atomic e = match e.repr with | True | False | Kint _ | Kreal _ | Var _ -> true | _ -> false let is_simple e = match e.repr with | True | False | Kint _ | Kreal _ | Var _ | Fun(_,[]) -> true | _ -> false let is_closed e = Vars.is_empty e.vars let is_prop e = match e.sort with | Sprop | Sbool -> true | _ -> false let is_int e = match e.sort with | Sint -> true | _ -> false let is_real e = match e.sort with | Sreal -> true | _ -> false let is_arith e = match e.sort with | Sreal | Sint -> true | _ -> false (* -------------------------------------------------------------------------- *) (* --- Ground & Arithmetics --- *) (* -------------------------------------------------------------------------- *) let z_op c f x y = match x.repr , y.repr with | Kint z , Kint z' -> e_zint (f z z') | _ -> c x y let z_rel fc fe c xs ys = match xs , ys with | [] , [] -> if fc c Z.zero then e_true else e_false | [] , _ -> fe (e_zint c) (c_add ys) (* c+0 R ys <-> c R ys *) | _ , [] -> fe (c_add xs) (e_zint (Z.opp c)) (* c+xs R 0 <-> xs R -c *) | _ -> match Z.sign c with | Z.Null -> fe (c_add xs) (c_add ys) (* 0+xs R ys <-> xs R ys *) | Z.Negative -> fe (c_add xs) (c_add (e_zint (Z.opp c) :: ys)) (* c+xs R ys <-> xs R (-c+ys) *) | Z.Positive -> fe (c_add (e_zint c :: xs)) (c_add ys) (* c+xs R ys <-> (c+xs) R ys *) let z_eq = z_rel Z.equal c_eq let z_neq = z_rel Z.not_equal c_neq let z_leq c xs ys = if Z.equal c Z.one && List.for_all is_int xs && List.for_all is_int ys then c_lt (c_add xs) (c_add ys) else z_rel Z.leq c_leq c xs ys let z_lt c xs ys = if not (Z.null c) && List.for_all is_int xs && List.for_all is_int ys then z_leq (Z.succ c) xs ys else z_rel Z.lt c_lt c xs ys let rec ground f c xs = function | {repr=Kint n}::ts -> ground f (f c n) xs ts | x::ts -> ground f c (x::xs) ts | [] -> c , xs (* --- Times --- *) let rec times z e = if Z.equal z Z.one then e else if Z.equal z Z.zero then e_zint Z.zero else match e.repr with | Kint z' -> e_zint (Z.mul z z') | Kreal r when Z.equal z Z.minus_one -> e_real (R.opp r) | Times(z',t) -> times (Z.mul z z') t | _ -> c_times z e (* --- Additions --- *) let rec unfold_affine acc k = function | [] -> acc | t::others -> unfold_affine (unfold_affine1 acc k t) k others and unfold_affine1 acc k t = match t.repr with | Times(n,t) -> unfold_affine1 acc (Z.mul k n) t | Kint z -> (Z.mul k z , e_one) :: acc | Add ts -> unfold_affine acc k ts | _ -> (k,t) :: acc (* sorts monoms by terms *) let compare_monoms (_,t1) (_,t2) = Pervasives.compare t1.id t2.id (* factorized monoms *) let rec fold_monom ts k t = if Z.equal Z.zero k then ts else if Z.equal Z.one k then t::ts else times k t :: ts (* monoms sorted by terms *) let rec fold_affine f a = function | (n1,t1)::(n2,t2)::kts when t1 == t2 -> fold_affine f a ((Z.add n1 n2,t1)::kts) | (k,t)::kts -> fold_affine f (f a k t) kts | [] -> a let affine a = let kts = unfold_affine1 [] Z.one a in let fact,const = List.partition (fun (_,base) -> base.id = e_one.id) kts in let base = List.fold_left (fun z (k,_) -> Z.add z k) Z.zero const in { constant = base ; factors = fact } (* ts normalized *) let addition ts = let kts = unfold_affine [] Z.one ts in let kts = List.sort compare_monoms kts in c_add (fold_affine fold_monom [] kts) (* --- Relations --- *) let is_affine e = match e.repr with | Kint _ | Times _ | Add _ -> true | _ -> false let rec partition_monoms phi c xs ys = function | [] -> phi c xs ys | (k,t) :: kts -> if t == e_one then partition_monoms phi (Z.add k c) xs ys kts else if Z.positive k then partition_monoms phi c (fold_monom xs k t) ys kts else partition_monoms phi c xs (fold_monom ys (Z.opp k) t) kts let relation cmp zcmp x y = if is_affine x || is_affine y then let kts = unfold_affine1 (unfold_affine1 [] Z.one x) Z.minus_one y in let kts = List.sort compare_monoms kts in let kts = fold_affine (fun ts k t -> (k,t)::ts) [] kts in partition_monoms zcmp Z.zero [] [] kts else cmp x y (* --- Multiplications --- *) let rec mul_unfold acc = function | [] -> acc | t::others -> match t.repr with | Times(z,t) -> mul_unfold (e_zint z :: acc) (t::others) | Mul ts -> mul_unfold (mul_unfold acc ts) others | _ -> mul_unfold (t::acc) others let multiplication ts = (* ts normalized *) let ts = mul_unfold [] ts in let s,ts = ground Z.mul Z.one [] ts in if Z.equal Z.zero s then e_zint Z.zero else if ts=[] then e_zint s else let t = c_mul ts in if Z.equal s Z.one then t else c_times s t (* --- Divisions --- *) let e_div a b = match b.repr with | Kint z when Z.equal z Z.one -> a | _ -> c_div a b let e_mod a b = match b.repr with | Kint z when Z.equal z Z.one -> a | _ -> c_mod a b (* --- Comparisons --- *) let e_lt x y = if x==y then e_false else relation c_lt z_lt x y let e_leq x y = if x==y then e_true else relation c_leq z_leq x y (* -------------------------------------------------------------------------- *) (* --- Logical --- *) (* -------------------------------------------------------------------------- *) let is_true e = match e.repr with | True -> Logic.Yes | False -> Logic.No | _ -> Logic.Maybe let is_false e = match e.repr with | True -> Logic.No | False -> Logic.Yes | _ -> Logic.Maybe exception Absorbant let rec fold_and p_not acc xs = match xs with | [] -> acc | x::others -> match x.repr with | False -> raise Absorbant | True -> fold_and p_not acc others | And xs -> fold_and p_not (fold_and p_not acc xs) others | _ -> fold_and p_not ((x,p_not x)::acc) others let rec fold_or p_not acc xs = match xs with | [] -> acc | x::others -> match x.repr with | True -> raise Absorbant | False -> fold_or p_not acc others | Or xs -> fold_or p_not (fold_or p_not acc xs) others | _ -> fold_or p_not ((x,p_not x)::acc) others (* an atom is (t,not t) *) let atom_eq a b = fst a == fst b let atom_opp a b = fst a == snd b || snd a == fst a let compare_atom (x1,nx1) (x2,nx2) = Pervasives.compare (min x1.id nx1.id) (min x2.id nx2.id) let rec fact_atom acc ms = match acc , ms with | a::_ , b::qs when atom_eq a b -> fact_atom acc qs | a::_ , b::_ when atom_opp a b -> raise Absorbant | _ , b::qs -> fact_atom (b::acc) qs | _ , [] -> acc let conjunction p_not ts = try let ms = fold_and p_not [] ts in let ms = fact_atom [] (List.sort compare_atom ms) in c_and (List.map fst ms) with Absorbant -> e_false let disjunction p_not ts = try let ms = fold_or p_not [] ts in let ms = fact_atom [] (List.sort compare_atom ms) in c_or (List.map fst ms) with Absorbant -> e_true let rec implication p_not a b = match a.repr , b.repr with | True , _ -> b | False , _ -> e_true | _ , True -> e_true | _ , False -> p_not a | Not p , Not q -> implication p_not q p | And ts , _ -> if List.memq b ts then e_true else if List.memq (p_not b) ts then e_false else c_imply ts b | _ -> if a == b then e_true else if p_not b == a then e_false else c_imply [a] b type structural = | S_equal (* equal constants or constructors *) | S_disequal (* different constants or constructors *) | S_injection (* same function, injective or constructor *) | S_inversible (* same function, inversible on both side *) | S_disjunction (* both constructors, but different ones *) | S_functions (* general functions *) let structural f g = if Fun.equal f g then match Fun.category f with | Logic.Injection -> S_injection | Logic.Operator { inversible=true } -> S_inversible | Logic.Constructor | Logic.Constant _ -> S_equal | Logic.Function | Logic.Operator _ -> S_functions else match Fun.category f , Fun.category g with | Logic.Constructor , Logic.Constructor -> S_disequal | Logic.Constant a , Logic.Constant b -> if Z.equal a b then S_equal else S_disequal | _ -> S_functions let rec eq_all phi p_not xs ys = match xs , ys with | [] , [] -> Yes | [] , _ | _ , [] -> No | x::xs , y::ys -> match (phi p_not x y).repr with | False -> No | True -> eq_all phi p_not xs ys | _ -> match eq_all phi p_not xs ys with | No -> No | Yes | Maybe -> Maybe let rec neq_any phi p_not xs ys = match xs , ys with | [] , [] -> No | [] , _ | _ , [] -> Yes | x::xs , y :: ys -> match (phi p_not x y).repr with | True -> Yes | False -> neq_any phi p_not xs ys | _ -> match neq_any phi p_not xs ys with | Yes -> Yes | No | Maybe -> Maybe let eqbuiltins = ref Builtins.empty let add_builtin_eq f r = eqbuiltins := Builtins.add f r !eqbuiltins let get_builtin_eq x y = let fetch x = match x.repr with | Fun(f,_) -> Builtins.find f !eqbuiltins | _ -> raise Not_found in try fetch x x y with Not_found -> fetch y x y let rec equality p_not x y = if x == y then e_true else relation (eq_builtin p_not) z_eq x y and eq_builtin p_not x y = try get_builtin_eq x y with Not_found -> eq_symb p_not x y and eq_symb p_not x y = match x.repr , y.repr with | Kint z , Kint z' -> if Z.equal z z' then e_true else e_false | Kreal z , Kreal z' -> if R.eq z z' = R.Sure_true then e_true else c_eq x y | True , _ -> y | _ , True -> x | False , _ -> p_not y | _ , False -> p_not x | Fun(f,xs) , Fun(g,ys) -> begin match structural f g with | S_equal -> e_true | S_disequal -> e_false | S_injection -> eq_maybe x y (eq_all equality p_not xs ys) | S_disjunction -> e_false | S_functions -> c_eq x y | S_inversible -> let m,xs,ys = op_inversible xs ys in if m then c_eq (e_fun f xs) (e_fun g ys) else c_eq x y end | Fun(f,[]) , Kint z | Kint z , Fun(f,[]) -> begin match Fun.category f with | Logic.Constant k -> if Z.equal k z then e_true else e_false | _ -> c_eq x y end | Rdef fxs , Rdef gys -> begin try eq_maybe x y (eq_all eq_field p_not fxs gys) with Exit -> e_false end | _ -> c_eq x y and eq_maybe x y = function Yes -> e_true | No -> e_false | Maybe -> c_eq x y and eq_field p_not (f,x) (g,y) = if Field.equal f g then equality p_not x y else raise Exit let rec disequality p_not x y = if x == y then e_false else relation (neq_builtin p_not) z_neq x y and neq_builtin p_not x y = try p_not (get_builtin_eq x y) with Not_found -> neq_symb p_not x y and neq_symb p_not x y = match x.repr , y.repr with | Kint z , Kint z' -> if Z.equal z z' then e_false else e_true | Kreal z , Kreal z' -> if R.eq z z' = R.Sure_false then e_true else c_neq x y | True , _ -> p_not y | _ , True -> p_not x | False , _ -> y | _ , False -> x | Fun(f,xs) , Fun(g,ys) -> begin match structural f g with | S_equal -> e_false | S_disequal -> e_true | S_injection -> neq_maybe x y (neq_any disequality p_not xs ys) | S_disjunction -> e_true | S_functions -> c_neq x y | S_inversible -> let m,xs,ys = op_inversible xs ys in if m then c_neq (e_fun f xs) (e_fun g ys) else c_neq x y end | Fun(f,[]) , Kint z | Kint z , Fun(f,[]) -> begin match Fun.category f with | Logic.Constant k -> if Z.equal k z then e_false else e_true | _ -> c_neq x y end | Rdef fxs , Rdef gys -> begin try neq_maybe x y (neq_any neq_field p_not fxs gys) with Exit -> e_true end | _ -> c_neq x y and neq_maybe x y = function Yes -> e_true | No -> e_false | Maybe -> c_neq x y and neq_field p_not (f,x) (g,y) = if Field.equal f g then disequality p_not x y else raise Exit (* -------------------------------------------------------------------------- *) (* --- Boolean Simplifications --- *) (* -------------------------------------------------------------------------- *) let cache = Array.create 0x800 (e_true,e_false) let cacheid p = p.id land 0x7FF let getcache p = cache.(cacheid p) let setcache p q = cache.(cacheid p) <- (p,q) let rec e_not x = match x.repr with | True -> e_false | False -> e_true | Lt(x,y) -> c_leq y x | Leq(x,y) -> c_lt y x | Eq(x,y) -> c_neq x y | Neq(x,y) -> c_eq x y | Not x -> x | (And _ | Or _ | Imply _) -> e_cachednot x | _ -> c_not x and e_cachednot x = let (p,q) = getcache x in if p == x then q else let q = match x.repr with | And xs -> e_or (List.map e_not xs) | Or xs -> e_and (List.map e_not xs) | Imply(hs,p) -> e_and (e_not p :: hs) | _ -> assert false in setcache x q ; q and e_imply hs p = match p.repr with | Imply(hs',p') -> implication e_not (e_and (hs @ hs')) p' | _ -> implication e_not (e_and hs) p and e_and = function | [] -> e_true | [t] -> t | ts -> conjunction e_not ts and e_or = function | [] -> e_false | [t] -> t | ts -> disjunction e_not ts and e_eq x y = equality e_not x y and e_neq x y = disequality e_not x y let e_if e a b = match e.repr with | True -> a | False -> b | _ -> if a == b then a else match a.repr , b.repr with | True , _ -> disjunction e_not [e;b] | _ , False -> conjunction e_not [e;a] | False , _ -> conjunction e_not [e_not e;b] | _ , True -> disjunction e_not [e_not e;a] | _ -> match e.repr with | Not e0 -> c_if e0 b a | Neq(u,v) -> c_if (e_eq u v) b a | _ -> c_if e a b let e_bool = function true -> e_true | false -> e_false let e_literal v p = if v then p else e_not p let literal p = match p.repr with | Neq(a,b) -> false , c_eq a b | Lt(x,y) -> false , c_leq y x | Not q -> false , q | _ -> true , p let are_equal a b = is_true (e_eq a b) (* -------------------------------------------------------------------------- *) (* --- Arrays --- *) (* -------------------------------------------------------------------------- *) let rec e_get m k = match m.repr with | Aset(m0,k0,v0) -> begin match are_equal k k0 with | Yes -> v0 | No -> e_get m0 k | Maybe -> c_get m k end | _ -> c_get m k let rec e_set m k v = match m.repr with | Aset(m0,k0,_) -> begin match are_equal k k0 with | Yes -> e_set m0 k0 v | No | Maybe -> c_set m k v end | _ -> c_set m k v (* -------------------------------------------------------------------------- *) (* --- Records --- *) (* -------------------------------------------------------------------------- *) let rec get_field m0 f = function | [] -> c_getfield m0 f | (g,y)::gys -> if Field.equal f g then y else get_field m0 f gys let e_getfield m f = match m.repr with | Rdef gys -> get_field m f gys | _ -> c_getfield m f let e_record fxs = c_record fxs type record = (Field.t * term) list (* -------------------------------------------------------------------------- *) (* --- Non-Binding Morphism --- *) (* -------------------------------------------------------------------------- *) let r_map f e = match e.repr with | Kint _ | Kreal _ | True | False -> e | Not e -> e_not (f e) | Add xs -> addition (List.map f xs) | Mul xs -> multiplication (List.map f xs) | And xs -> e_and (List.map f xs) | Or xs -> e_or (List.map f xs) | Mod(x,y) -> e_mod (f x) (f y) | Div(x,y) -> e_div (f x) (f y) | Eq(x,y) -> e_eq (f x) (f y) | Neq(x,y) -> e_neq (f x) (f y) | Lt(x,y) -> e_lt (f x) (f y) | Leq(x,y) -> e_leq (f x) (f y) | Times(z,t) -> times z (f t) | If(e,a,b) -> e_if (f e) (f a) (f b) | Imply(hs,p) -> e_imply (List.map f hs) (f p) | Fun(g,xs) -> e_fun g (List.map f xs) | Aget(x,y) -> e_get (f x) (f y) | Aset(x,y,z) -> e_set (f x) (f y) (f z) | Rget(x,g) -> e_getfield (f x) g | Rdef gxs -> e_record (List.map (fun (g,x) -> g, f x) gxs) | Var _ | Bind _ | Apply _ -> assert false (* -------------------------------------------------------------------------- *) (* --- Binders --- *) (* -------------------------------------------------------------------------- *) exception Applies let e_bind q x a = match q with | (Forall | Exists) -> if not (Vars.mem x a.vars) then a else c_bind q x a | Lambda -> c_bind q x a let rec e_forall xs a = match xs with | [] -> a | x::xs -> let a = e_forall xs a in if Vars.mem x a.vars then c_bind Forall x a else a let rec e_exists xs a = match xs with | [] -> a | x::xs -> let a = e_exists xs a in if Vars.mem x a.vars then c_bind Exists x a else a let rec e_lambda xs a = match xs with | [] -> a | x::xs -> e_bind Lambda x (e_lambda xs a) (* -------------------------------------------------------------------------- *) (* --- Substitutions --- *) (* -------------------------------------------------------------------------- *) (* substitution environment *) type senv = { pool : POOL.pool ; mutable hmem : term Intmap.t ; (* memoization table *) sigma : term Intmap.t ; (* substitution : var.id -> term *) domain : Vars.t ; (* Domain(sigma) *) codomain : Vars.t ; (* Codomain (sigma) *) } let senv pool = { pool = pool ; hmem = Intmap.empty ; sigma = Intmap.empty ; domain = Vars.empty ; codomain = Vars.empty ; } let rec e_apply ?pool (a:term) (xs:term list) : term = if xs=[] then a else let pool = match pool with Some p -> p | None -> let p = POOL.create () in add_term p a ; List.iter (add_term p) xs ; p in reduction (senv pool) a xs and reduction senv (a:term) (args:term list) : term = match a.repr , args with | Bind(_,x,core) , arg::args -> let senv = { senv with sigma = Intmap.add x.vid arg senv.sigma ; domain = Vars.add x senv.domain ; codomain = Vars.union arg.vars senv.codomain ; } in reduction senv core args | _ -> (* sigma is now as much as possible *) if Vars.is_empty senv.domain then c_apply a args else c_apply (apply_subst senv a) args and apply_subst senv (a:term) : term = if not (Vars.intersect a.vars senv.domain) then a else try Intmap.find a.id senv.hmem (* memoized *) with Not_found -> let result = match a.repr with | Var x -> (try Intmap.find x.vid senv.sigma with Not_found -> a) | Bind(q,x,b) -> if Vars.mem x senv.codomain then let y = POOL.alpha senv.pool x in let senv0 = { pool = senv.pool ; hmem = Intmap.empty ; domain = Vars.add x senv.domain ; codomain = Vars.add y senv.codomain ; sigma = Intmap.add x.vid (e_var y) senv.sigma } in e_bind q y (apply_subst senv0 b) else e_bind q x (apply_subst senv b) | Apply(phi,vs) -> let vs' = List.map (apply_subst senv) vs in let phi' = apply_subst senv phi in e_apply phi' vs' | _ -> r_map (apply_subst senv) a in (* memoization *) senv.hmem <- Intmap.add a.id result senv.hmem ; result let e_subst ?pool x a b = let pool = match pool with Some p -> p | None -> let p = POOL.create () in add_var p x ; add_term p a ; add_term p b ; p in let senv = { pool = pool ; hmem = Intmap.empty ; domain = Vars.singleton x ; codomain = a.vars ; sigma = Intmap.add x.vid a Intmap.empty ; } in apply_subst senv b (* -------------------------------------------------------------------------- *) (* --- Smart Constructors --- *) (* -------------------------------------------------------------------------- *) let e_equiv = e_eq let e_sum = addition let e_prod = multiplication let e_opp x = times Z.minus_one x let e_add x y = addition [x;y] let e_sub x y = addition [x;e_opp y] let e_mul x y = multiplication [x;y] let e_times k x = if Z.equal k Z.zero then e_zero else if Z.equal k Z.one then x else times k x (* -------------------------------------------------------------------------- *) (* --- Congruence --- *) (* -------------------------------------------------------------------------- *) exception NO_CONGRUENCE exception FIELD_NEQ let rec concat2 f xs ys = match xs,ys with | [],[] -> [] | x::xs , y::ys -> f x y @ (concat2 f xs ys) | _ -> raise NO_CONGRUENCE let rec congr_eq a b = match a.repr , b.repr with | Fun(f,xs) , Fun(g,ys) -> begin match structural f g with | S_equal | S_disequal | S_disjunction | S_inversible -> [] | S_injection -> concat2 congr_argeq xs ys | S_functions -> raise NO_CONGRUENCE end | Rdef fxs , Rdef gys -> concat2 congr_fieldeq fxs gys | _ -> raise NO_CONGRUENCE and congr_argeq a b = try congr_eq a b with NO_CONGRUENCE -> [a,b] and congr_fieldeq (f,a) (g,b) = if Field.equal f g then congr_argeq a b else raise NO_CONGRUENCE let congruence_eq a b = try Some (congr_eq a b) with NO_CONGRUENCE -> None let rec congr_neq a b = match a.repr , b.repr with | Fun(f,xs) , Fun(g,ys) -> begin match structural f g with | S_equal | S_disequal | S_disjunction | S_inversible -> [] | S_injection -> concat2 congr_argneq xs ys | S_functions -> raise NO_CONGRUENCE end | Rdef fxs , Rdef gys -> begin try concat2 congr_fieldneq fxs gys with FIELD_NEQ -> [] end | _ -> raise NO_CONGRUENCE and congr_argneq a b = try congr_neq a b with NO_CONGRUENCE -> [a,b] and congr_fieldneq (f,a) (g,b) = if Field.equal f g then congr_argneq a b else raise FIELD_NEQ let congruence_neq a b = try Some(congr_neq a b) with NO_CONGRUENCE -> None (* -------------------------------------------------------------------------- *) (* --- List All2/Any2 --- *) (* -------------------------------------------------------------------------- *) let e_all2 phi xs ys = let n = List.length xs in let m = List.length ys in if n <> m then e_false else conjunction e_not (List.map2 phi xs ys) let e_any2 phi xs ys = let n = List.length xs in let m = List.length ys in if n <> m then e_true else disjunction e_not (List.map2 phi xs ys) (* -------------------------------------------------------------------------- *) (* --- Flat Reasoning --- *) (* -------------------------------------------------------------------------- *) let rec flat_eq a b = match a.repr , b.repr with | Fun(f,xs) , Fun(g,ys) -> begin match structural f g with | S_equal -> e_true | S_disequal -> e_false | S_injection -> e_all2 flat_eq xs ys | S_disjunction -> e_false | S_functions | S_inversible -> e_eq a b end | Rdef fxs , Rdef gys -> begin try e_all2 (fun (f,x) (g,y) -> if Field.equal f g then flat_eq x y else raise Exit ) fxs gys with Exit -> e_false end | _ -> e_eq a b let rec flat_neq a b = match a.repr , b.repr with | Fun(f,xs) , Fun(g,ys) -> begin match structural f g with | S_equal -> e_false | S_disequal -> e_true | S_injection -> e_any2 flat_neq xs ys | S_disjunction -> e_true | S_functions | S_inversible -> e_neq a b end | Rdef fxs , Rdef gys -> begin try e_any2 (fun (f,x) (g,y) -> if Field.equal f g then flat_neq x y else raise Exit ) fxs gys with Exit -> e_true end | _ -> e_neq a b let flattens a b = match a.repr , b.repr with | (Rdef _ | Fun _) , (Rdef _ | Fun _) -> true | _ -> false let rec flat qs e = match e.repr with | Eq(a,b) when flattens a b -> (flat_eq a b)::qs | Neq(a,b) when flattens a b -> (flat_neq a b)::qs | And ps -> List.fold_left flat qs ps | _ -> e::qs let flatten p = List.rev (flat [] p) let flattenable e = match e.repr with | Eq(a,b) | Neq(a,b) -> flattens a b | And _ -> true | _ -> false (* -------------------------------------------------------------------------- *) (* --- Iterators --- *) (* -------------------------------------------------------------------------- *) let e_repr = function | True -> e_true | False -> e_false | Kint z -> e_zint z | Kreal r -> e_real r | Var x -> e_var x | Bind(q,x,e) -> e_bind q x e | Apply(a,xs) -> e_apply a xs | Times(k,e) -> e_times k e | Not e -> e_not e | Add xs -> addition xs | Mul xs -> multiplication xs | And xs -> e_and xs | Or xs -> e_or xs | Mod(x,y) -> e_mod x y | Div(x,y) -> e_div x y | Eq(x,y) -> e_eq x y | Neq(x,y) -> e_neq x y | Lt(x,y) -> e_lt x y | Leq(x,y) -> e_leq x y | If(e,a,b) -> e_if e a b | Imply(hs,p) -> e_imply hs p | Fun(g,xs) -> e_fun g xs | Aget(m,k) -> e_get m k | Aset(m,k,v) -> e_set m k v | Rget(r,f) -> e_getfield r f | Rdef fvs -> e_record fvs let e_map f e = match e.repr with | Var _ -> e | Apply(a,xs) -> e_apply (f a) (List.map f xs) | Bind _ -> raise (Invalid_argument "Qed.Term.e_map") | _ -> r_map f e let f_map f xs e = match e.repr with | Var _ -> e | Apply(a,ps) -> e_apply (f xs a) (List.map (f xs) ps) | Bind(q,x,p) -> e_bind q x (f (Vars.add x xs) p) | _ -> r_map (f xs) e let e_iter f e = match e.repr with | True | False | Kint _ | Kreal _ | Var _ -> () | Times(_,e) | Not e | Bind(_,_,e) | Rget(e,_) -> f e | Add xs | Mul xs | And xs | Or xs -> List.iter f xs | Mod(x,y) | Div(x,y) | Eq(x,y) | Neq(x,y) | Leq(x,y) | Lt(x,y) | Aget(x,y) -> f x ; f y | Rdef fvs -> List.iter (fun (_,v) -> f v) fvs | If(e,a,b) | Aset(e,a,b) -> f e ; f a ; f b | Imply(xs,x) -> List.iter f xs ; f x | Apply(x,xs) -> f x ; List.iter f xs | Fun(_,xs) -> List.iter f xs let f_iter f xs e = match e.repr with | Bind(_,x,e) -> f (Vars.add x xs) e | _ -> e_iter (f xs) e (* -------------------------------------------------------------------------- *) (* --- Sub-terms --- *) (* -------------------------------------------------------------------------- *) let change_subterm e pos child = let bad_position () = failwith "cannot replace subterm at given position" in let rec change_in_list children cur_pos rest = match children, cur_pos with | [], _ -> bad_position () | e::l, 0 -> (aux e rest) :: l | e::l, n -> e :: (change_in_list l (n-1) rest) (* since all repr might be shared, better work on an immutable copy than on the original array. *) and aux e pos = match pos with [] -> child | i::l -> begin match e.repr with | True | False | Kint _ | Kreal _ | Var _ -> bad_position () | Times (_,e) when i = 0 && l = [] -> begin match child.repr with Kint n -> times n e | _ -> e_mul child e end | Times(n,e) when i = 1 -> times n (aux e l) | Times _ -> bad_position () | Add ops -> e_sum (change_in_list ops i l) | Mul ops -> e_prod (change_in_list ops i l) | Div (e1,e2) when i = 0 -> e_div (aux e1 l) e2 | Div (e1,e2) when i = 1 -> e_div e1 (aux e2 l) | Div _ -> bad_position () | Mod (e1,e2) when i = 0 -> e_mod (aux e1 l) e2 | Mod (e1,e2) when i = 1 -> e_mod e1 (aux e2 l) | Mod _ -> bad_position () | Eq (e1,e2) when i = 0 -> e_eq (aux e1 l) e2 | Eq (e1,e2) when i = 1 -> e_eq e1 (aux e2 l) | Eq _ -> bad_position () | Neq (e1,e2) when i = 0 -> e_neq (aux e1 l) e2 | Neq (e1,e2) when i = 1 -> e_neq e1 (aux e2 l) | Neq _ -> bad_position () | Leq (e1,e2) when i = 0 -> e_leq (aux e1 l) e2 | Leq (e1,e2) when i = 1 -> e_leq e1 (aux e2 l) | Leq _ -> bad_position () | Lt (e1,e2) when i = 0 -> e_lt (aux e1 l) e2 | Lt (e1,e2) when i = 1 -> e_lt e1 (aux e2 l) | Lt _ -> bad_position () | Aget (e1,e2) when i = 0 -> e_get (aux e1 l) e2 | Aget (e1,e2) when i = 1 -> e_get e1 (aux e2 l) | Aget _ -> bad_position () | And ops -> e_and (change_in_list ops i l) | Or ops -> e_or (change_in_list ops i l) | Not e when i = 0 -> e_not (aux e l) | Not _ -> bad_position () | Imply(ops,e) -> let nb = List.length ops in if i < nb then e_imply (change_in_list ops i l) e else if i = nb then e_imply ops (aux e l) else bad_position () | If(e1,e2,e3) when i = 0 -> e_if (aux e1 l) e2 e3 | If(e1,e2,e3) when i = 1 -> e_if e1 (aux e2 l) e3 | If(e1,e2,e3) when i = 2 -> e_if e1 e2 (aux e3 l) | If _ -> bad_position () | Aset(e1,e2,e3) when i = 0 -> e_set (aux e1 l) e2 e3 | Aset(e1,e2,e3) when i = 1 -> e_set e1 (aux e2 l) e3 | Aset(e1,e2,e3) when i = 2 -> e_set e1 e2 (aux e3 l) | Aset _ -> bad_position () | Rdef _ | Rget _ -> failwith "change in place for records not yet implemented" | Fun (f,ops) -> e_fun f (change_in_list ops i l) | Bind(q,x,t) when i = 0 -> e_bind q x (aux t l) | Bind _ -> bad_position () | Apply(f,args) when i = 0 -> e_apply (aux f l) args | Apply (f,args) -> e_apply f (change_in_list args i l) end in aux e pos (* -------------------------------------------------------------------------- *) (* --- DEBUG --- *) (* -------------------------------------------------------------------------- *) let pp_bind fmt = function | Forall -> Format.pp_print_string fmt "Forall" | Exists -> Format.pp_print_string fmt "Exists" | Lambda -> Format.pp_print_string fmt "Lambda" let pp_var fmt x = Format.fprintf fmt "X%03d(%s:%d)" x.vid x.vbase x.vrank let pp_id fmt x = Format.fprintf fmt " #%03d" x.id let pp_ids fmt xs = List.iter (pp_id fmt) xs let pp_field fmt (f,x) = Format.fprintf fmt "@ %a:%a;" Field.pretty f pp_id x let pp_record fmt fxs = List.iter (pp_field fmt) fxs let pp_repr fmt = function | Kint z -> Format.fprintf fmt "constant %s" (Z.to_string z) | Kreal z -> Format.fprintf fmt "real constant %s" (R.to_string z) | True -> Format.pp_print_string fmt "true" | False -> Format.pp_print_string fmt "false" | Times(z,x) -> Format.fprintf fmt "times %s%a" (Z.to_string z) pp_id x | Add xs -> Format.fprintf fmt "add%a" pp_ids xs | Mul xs -> Format.fprintf fmt "mul%a" pp_ids xs | And xs -> Format.fprintf fmt "and%a" pp_ids xs | Div(a,b) -> Format.fprintf fmt "div%a%a" pp_id a pp_id b | Mod(a,b) -> Format.fprintf fmt "mod%a%a" pp_id a pp_id b | Or xs -> Format.fprintf fmt "or%a" pp_ids xs | If(e,a,b) -> Format.fprintf fmt "if%a%a%a" pp_id e pp_id a pp_id b | Imply(hs,p) -> Format.fprintf fmt "imply%a =>%a" pp_ids hs pp_id p | Neq(a,b) -> Format.fprintf fmt "neq%a%a" pp_id a pp_id b | Eq(a,b) -> Format.fprintf fmt "eq%a%a" pp_id a pp_id b | Leq(a,b) -> Format.fprintf fmt "leq%a%a" pp_id a pp_id b | Lt(a,b) -> Format.fprintf fmt "lt%a%a" pp_id a pp_id b | Not e -> Format.fprintf fmt "not%a" pp_id e | Fun(f,es) -> Format.fprintf fmt "fun %a%a" Fun.pretty f pp_ids es | Apply(phi,es) -> Format.fprintf fmt "apply%a%a" pp_id phi pp_ids es | Var x -> Format.fprintf fmt "var %a" pp_var x | Bind(q,x,e) -> Format.fprintf fmt "bind %a %a. %a" pp_bind q pp_var x pp_id e | Rdef fxs -> Format.fprintf fmt "@[record {%a }@]" pp_record fxs | Rget(e,f) -> Format.fprintf fmt "field %a.%a" pp_id e Field.pretty f | Aset(m,k,v) -> Format.fprintf fmt "array%a[%a :=%a ]" pp_id m pp_id k pp_id v | Aget(m,k) -> Format.fprintf fmt "array%a[%a ]" pp_id m pp_id k let pp_rid fmt e = pp_repr fmt e.repr let rec pp_debug disp fmt e = if not (Intset.mem e.id !disp) then begin Format.fprintf fmt "%a = %a@." pp_id e pp_repr e.repr ; disp := Intset.add e.id !disp ; pp_children disp fmt e ; end and pp_children disp fmt e = e_iter (pp_debug disp fmt) e let debug fmt e = Format.fprintf fmt "%a with:@." pp_id e ; pp_debug (ref Intset.empty) fmt e let pretty = debug (* ------------------------------------------------------------------------ *) (* --- Term Set,Map and Vars --- *) (* ------------------------------------------------------------------------ *) module E = struct type t = term let id t = t.id end module Tset = Idxset.Make(E) module Tmap = Idxmap.Make(E) (* ------------------------------------------------------------------------ *) (* --- Record Decomposition --- *) (* ------------------------------------------------------------------------ *) let record_with fvs = let bases = ref Tmap.empty in let best = ref None in List.iter (fun (f,v) -> match v.repr with | Rget(base,g) when Field.equal f g -> let count = try succ (Tmap.find base !bases) with Not_found -> 1 in bases := Tmap.add base count !bases ; ( match !best with | Some(_,c) when c < count -> () | _ -> best := Some(base,count) ) | _ -> () ) fvs ; match !best with | None -> None | Some(base,_) -> let fothers = List.filter (fun (f,v) -> match v.repr with | Rget( other , g ) -> other != base || not (Field.equal f g) | _ -> true) fvs in Some ( base , fothers ) (* ------------------------------------------------------------------------ *) (* --- Sizing Terms --- *) (* ------------------------------------------------------------------------ *) let rec count k m e = if not (Tset.mem e !m) then begin incr k ; m := Tset.add e !m ; e_iter (count k m) e ; end let size e = let k = ref 0 in count k (ref Tset.empty) e ; !k (* ------------------------------------------------------------------------ *) (* --- Shared Sub-Terms --- *) (* ------------------------------------------------------------------------ *) type mark = | Unmarked (* first traversal *) | FirstMark (* second traversal *) | Marked (* finished *) type marks = { closed : Vars.t ; (* context-declared variables *) marked : (term -> bool) ; (* context-letified terms *) shareable : (term -> bool) ; (* terms that can be shared *) mutable mark : mark Tmap.t ; (* current marks during traversal *) mutable shared : Tset.t ; (* marked several times *) mutable roots : term list ; (* added as marked roots *) } let get_mark m e = try Tmap.find e m.mark with Not_found -> Unmarked let set_mark m e t = m.mark <- Tmap.add e t m.mark let rec walk m xs e = if not (is_simple e) then begin match get_mark m e with | Unmarked -> if m.marked e then set_mark m e Marked else begin set_mark m e FirstMark ; f_iter (walk m) xs e ; end | FirstMark -> if m.shareable e && Vars.subset e.vars m.closed && not (Vars.intersect e.vars xs) then m.shared <- Tset.add e m.shared else f_iter (walk m) xs e ; set_mark m e Marked | Marked -> () end let mark m e = m.roots <- e :: m.roots ; walk m Vars.empty e type defs = { mutable stack : term list ; mutable defined : Tset.t ; } let rec collect shared defs e = if not (Tset.mem e defs.defined) then begin e_iter (collect shared defs) e ; if Tset.mem e shared then defs.stack <- e :: defs.stack ; defs.defined <- Tset.add e defs.defined ; end let marks ?(shared=fun _ -> false) ?(shareable=fun _ -> true) ?(closed=Vars.empty) () = { closed = closed ; marked = shared ; shareable = shareable ; shared = Tset.empty ; mark = Tmap.empty ; roots = [] ; } let defs m = let defines = { stack=[] ; defined=Tset.empty } in List.iter (collect m.shared defines) m.roots ; List.rev defines.stack let shared ?shared ?shareable ?closed es = let m = marks ?shared ?shareable ?closed () in List.iter (mark m) es ; defs m end frama-c-Fluorine-20130601/src/wp/qed/src/pretty.mli0000644000175000017500000000427512155630203020611 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Printer for Qed Output. *) (* -------------------------------------------------------------------------- *) open Logic open Format module Make(T : Term) : sig open T type env val empty : env val closed : Vars.t -> env val marks : env -> marks val bind : string -> term -> env -> env val fresh : env -> term -> string * env val pp_tau : formatter -> tau -> unit val pp_term : env -> formatter -> term -> unit val pp_def : env -> formatter -> term -> unit end frama-c-Fluorine-20130601/src/wp/qed/src/partition.mli0000644000175000017500000000564612155630203021276 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** Union-find based partitions *) module type S = sig type t (** Partitions *) type elt (** Elements *) type explain (** Explanations *) val empty : t val join : ?explain:explain -> elt -> elt -> t -> t (** Immediate. *) val class_of : t -> elt -> elt (** Amortized. *) val is_equal : t -> elt -> elt -> bool (** Returns [true] is the two elements are in the same class. *) val members : t -> elt -> elt list (** All members, including self. Explanations can be recover from [explain]. *) val repr : t -> elt -> elt * explain (** Returns [class_of] with explaination *) val equal : t -> elt -> elt -> explain option (** Returns [Some e] if equal with explanation [e]. Amortized. *) val explain : t -> elt -> elt -> explain (** Returns [e] is [equal] returns [Some e], and [bot] otherwise. *) val iter : (elt -> elt list -> unit) -> t -> unit (** Including selves. *) val map : (elt -> elt) -> t -> t (** Rebuild all the classes. *) end (** Type of Explanations *) module type Explain = sig type t val bot : t val cup : t -> t -> t end (** Partitions without Explanations *) module Make(A : Map.OrderedType) : S with type elt = A.t and type explain = unit (** Partitions with Explanations *) module MakeExplain(A : Map.OrderedType)(E : Explain) : S with type elt = A.t and type explain = E.t frama-c-Fluorine-20130601/src/wp/qed/src/export.ml0000644000175000017500000006513412155630203020433 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Exportation to Foreign Languages --- *) (* -------------------------------------------------------------------------- *) open Format open Logic open Plib open Linker open Engine let cmode = function | Mpositive | Mnegative -> Cprop | Mterm | Mterm_int | Mterm_real | Mint | Mreal -> Cterm let pmode = function | Mpositive -> Positive | Mnegative -> Negative | Mterm | Mterm_int | Mterm_real | Mint | Mreal -> Boolean let amode = function | Mpositive | Mnegative | Mterm | Mterm_int | Mint -> Aint | Mterm_real | Mreal -> Areal let smode = function | Sprop -> Mpositive | Sint -> Mterm_int | Sreal -> Mterm_real | Sbool | Sarray _ | Sdata -> Mterm let tmode = function | Prop -> Mpositive | Bool -> Mterm | Int -> Mterm_int | Real -> Mterm_real | Tvar _ | Array _ | Record _ | Data _ -> Mterm let ctau = function | Prop -> Cprop | _ -> Cterm let link_name = function F_call f | F_left(_,f) | F_right(_,f) | F_assoc f -> f module Make(T : Term) = struct open T (* -------------------------------------------------------------------------- *) (* --- Linkers --- *) (* -------------------------------------------------------------------------- *) module ADT = T.ADT module Field = T.Field module Fun = T.Fun type tau = (Field.t,ADT.t) datatype type var = Var.t type term = T.term type record = (Field.t * term) list type trigger = (var,Fun.t) ftrigger type typedef = (tau,Field.t,Fun.t) ftypedef module Mvar = Map.Make(Var) module Ladt = Link(ADT) module Lfield = Link(Field) module Lfun = Link(Fun) module Lvar = Link(Var) module STerm = Link (struct type t = term let hash = T.hash let equal = T.equal let compare = T.compare let pretty = T.pretty let id t = Printf.sprintf "E%03d" (T.id t) end) (* -------------------------------------------------------------------------- *) (* --- Pretty Printing Engine --- *) (* -------------------------------------------------------------------------- *) module TauMap = Map.Make (struct type t = T.tau let compare = Kind.compare_tau Field.compare ADT.compare end) let add_var x vars = let tx = T.tau_of_var x in let xs = try TauMap.find tx vars with Not_found -> [] in TauMap.add tx (x::xs) vars let rec binders q xs p = match T.repr p with | Bind(q',y,p') when q'=q -> binders q (add_var y xs) p' | _ -> xs,p let rec lambda xs p = match T.repr p with | Bind(Lambda,y,p') -> lambda (y::xs) p' | _ -> List.rev xs , p class virtual engine = object(self) method virtual datatype : ADT.t -> string method virtual field : Field.t -> string method basename : string -> string = fun x -> x val mutable global = allocator () val mutable vars = Vars.empty method declare = Linker.declare global method declare_all = List.iter (Linker.declare global) val linker_variable = Lvar.linker () val linker_shared = STerm.linker () method private push = let gstack = global in begin global <- copy global ; linker_variable#alloc_with global ; linker_shared#alloc_with global ; gstack , linker_variable#push , linker_shared#push end method private pop (gstack,idx_var,idx_shared) = begin global <- gstack ; linker_variable#alloc_with gstack ; linker_variable#pop idx_var ; linker_shared#alloc_with gstack ; linker_shared#pop idx_shared ; end method local (job : unit -> unit) = let gstack = self#push in try job () ; self#pop gstack with err -> self#pop gstack ; raise err method global (job : unit -> unit) = let gstack = self#push in try linker_variable#clear ; linker_shared#clear ; vars <- Vars.empty ; job () ; self#pop gstack with err -> self#pop gstack ; raise err (* -------------------------------------------------------------------------- *) (* --- Types --- *) (* -------------------------------------------------------------------------- *) method virtual t_int : string method virtual t_real : string method virtual t_bool : string method virtual t_prop : string method virtual t_atomic : tau -> bool method virtual pp_tvar : int printer method virtual pp_array : tau printer method virtual pp_farray : tau printer2 method virtual pp_datatype : ADT.t -> tau list printer method pp_subtau fmt t = if self#t_atomic t then self#pp_tau fmt t else fprintf fmt "@[(%a)@]" self#pp_tau t method pp_tau fmt = function | Int -> pp_print_string fmt self#t_int | Real -> pp_print_string fmt self#t_real | Bool -> pp_print_string fmt self#t_bool | Prop -> pp_print_string fmt self#t_prop | Array(Int,d) -> self#pp_array fmt d | Array(k,d) -> self#pp_farray fmt k d | Record _fts -> failwith "Qed.Export.record" | Tvar x -> self#pp_tvar fmt x | Data(adt,ts) -> self#pp_datatype adt fmt ts (* -------------------------------------------------------------------------- *) (* --- Mode --- *) (* -------------------------------------------------------------------------- *) val mutable mode = Mpositive method mode = mode method with_mode m f = let m0 = mode in if m = m0 then f m else try mode <- m ; f m0 ; mode <- m0 with err -> mode <- m0 ; raise err (* -------------------------------------------------------------------------- *) (* --- Variables --- *) (* -------------------------------------------------------------------------- *) method pp_var = linker_variable#print (* -------------------------------------------------------------------------- *) (* --- Atoms --- *) (* -------------------------------------------------------------------------- *) method virtual e_true : cmode -> string method virtual e_false : cmode -> string method virtual pp_int : amode -> Z.t printer method virtual pp_cst : Numbers.cst printer method virtual is_atomic : term -> bool method pp_real fmt x = let cst = Numbers.parse (R.to_string x) in if Numbers.is_zero cst then self#pp_int Areal fmt Z.zero else self#pp_cst fmt cst (* -------------------------------------------------------------------------- *) (* --- Calls --- *) (* -------------------------------------------------------------------------- *) method virtual op_spaced : string -> bool method virtual callstyle : callstyle method virtual link : cmode -> Fun.t -> link method link_name m f = link_name (self#link m f) method private pp_call ~f fmt xs = match self#callstyle with | CallVar -> Plib.pp_call_var ~f self#pp_flow fmt xs | CallVoid -> Plib.pp_call_void ~f self#pp_flow fmt xs | CallApply -> Plib.pp_call_apply ~f self#pp_atom fmt xs method private pp_callsorts ~f fmt sorts xs = let pp_mode pp fmt (m,x) = self#with_mode m (fun _ -> pp fmt x) in let rec wrap sorts xs = match sorts , xs with | [] , _ -> List.map (fun x -> Mterm,x) xs | _ , [] -> [] | m::ms , x::xs -> (smode m,x)::(wrap ms xs) in let mxs = wrap sorts xs in match self#callstyle with | CallVar -> Plib.pp_call_var ~f (pp_mode self#pp_flow) fmt mxs | CallVoid -> Plib.pp_call_void ~f (pp_mode self#pp_flow) fmt mxs | CallApply -> Plib.pp_call_apply ~f (pp_mode self#pp_atom) fmt mxs method private pp_unop ~op fmt x = match op with | Assoc op | Op op -> if self#op_spaced op && self#is_atomic x then fprintf fmt "%s %a" op self#pp_flow x else fprintf fmt "%s%a" op self#pp_atom x | Call f -> self#pp_call f fmt [x] method private pp_binop ~op fmt x y = match op with | Assoc op | Op op -> fprintf fmt "%a %s@ %a" self#pp_atom x op self#pp_atom y | Call f -> self#pp_call f fmt [x;y] method private pp_binop_term ~op fmt x y = self#with_mode Mterm (fun _old -> self#pp_binop ~op fmt x y) method private pp_nary ~op fmt xs = match op with | Assoc op -> Plib.pp_assoc ~e:"?" ~op self#pp_atom fmt xs | Op op -> Plib.pp_fold_binop ~e:"?" ~op self#pp_atom fmt xs | Call f -> match self#callstyle with | CallVar | CallVoid -> Plib.pp_fold_call ~e:"?" ~f self#pp_flow fmt xs | CallApply -> Plib.pp_fold_apply ~e:"?" ~f self#pp_atom fmt xs method pp_fun cmode fct fmt xs = match self#link cmode fct with | F_call f -> self#pp_callsorts ~f fmt (Fun.params fct) xs | F_assoc op -> Plib.pp_assoc ~e:"?" ~op self#pp_atom fmt xs | F_left(e,f) -> begin match self#callstyle with | CallVar | CallVoid -> Plib.pp_fold_call ~e ~f self#pp_flow fmt xs | CallApply -> Plib.pp_fold_apply ~e ~f self#pp_atom fmt xs end | F_right(e,f) -> begin let xs = List.rev xs in match self#callstyle with | CallVar | CallVoid -> Plib.pp_fold_call_rev ~e ~f self#pp_flow fmt xs | CallApply -> Plib.pp_fold_apply_rev ~e ~f self#pp_atom fmt xs end method virtual pp_apply : cmode -> term -> term list printer (* -------------------------------------------------------------------------- *) (* --- Arithmetics Operators --- *) (* -------------------------------------------------------------------------- *) method virtual op_scope : amode -> string option method virtual op_real_of_int : op method virtual op_add : amode -> op method virtual op_sub : amode -> op method virtual op_mul : amode -> op method virtual op_div : amode -> op method virtual op_mod : amode -> op method virtual op_minus : amode -> op (* -------------------------------------------------------------------------- *) (* --- Comparisons --- *) (* -------------------------------------------------------------------------- *) method virtual op_equal : cmode -> op method virtual op_noteq : cmode -> op method virtual op_eq : cmode -> amode -> op method virtual op_neq : cmode -> amode -> op method virtual op_lt : cmode -> amode -> op method virtual op_leq : cmode -> amode -> op (* -------------------------------------------------------------------------- *) (* --- Arithmetics Printers --- *) (* -------------------------------------------------------------------------- *) method private pp_arith_arg flow fmt e = match T.repr e with | Kint _ | Kreal _ -> self#pp_atom fmt e | _ -> self#pp_arith_atom flow fmt e method private pp_arith_atom flow fmt e = if mode = Mreal && T.is_int e then self#with_mode Mint (fun _ -> match self#op_real_of_int with | Op op | Assoc op -> begin match flow with | Atom -> fprintf fmt "(%s %a)" op self#pp_atom e | Flow -> fprintf fmt "%s %a" op self#pp_atom e end | Call f -> begin match self#callstyle with | CallVar | CallVoid -> fprintf fmt "%s(%a)" f self#pp_flow e | CallApply -> match flow with | Atom -> fprintf fmt "(%s %a)" f self#pp_atom e | Flow -> fprintf fmt "%s %a" f self#pp_atom e end) else match flow with | Flow -> self#pp_flow fmt e | Atom -> self#pp_atom fmt e method private pp_arith_call ~f fmt xs = match self#callstyle with | CallVar -> Plib.pp_call_var ~f (self#pp_arith_arg Flow) fmt xs | CallVoid -> Plib.pp_call_void ~f (self#pp_arith_arg Flow) fmt xs | CallApply -> Plib.pp_call_apply ~f (self#pp_arith_arg Atom) fmt xs method private pp_arith_unop ~phi fmt a = self#with_mode (if T.is_real a then Mreal else Mint) begin fun _ -> match phi (amode mode) with | Assoc op | Op op -> if self#op_spaced op && self#is_atomic a then fprintf fmt "%s %a" op (self#pp_arith_arg Atom) a else fprintf fmt "%s%a" op (self#pp_arith_arg Atom) a | Call f -> self#pp_arith_call ~f fmt [a] end method private pp_arith_binop ~phi fmt a b = self#with_mode (if T.is_real a || T.is_real b then Mreal else Mint) begin fun _ -> match phi (amode mode) with | Assoc op | Op op -> Plib.pp_binop op (self#pp_arith_arg Atom) fmt a b | Call f -> self#pp_arith_call ~f fmt [a;b] end method private pp_arith_nary ~phi fmt xs = self#with_mode (if List.exists T.is_real xs then Mreal else Mint) begin fun _ -> match phi (amode mode) with | Assoc op -> Plib.pp_assoc ~e:"?" ~op (self#pp_arith_arg Atom) fmt xs | Op op -> Plib.pp_fold_binop ~e:"?" ~op (self#pp_arith_arg Atom) fmt xs | Call f -> match self#callstyle with | CallVar | CallVoid -> Plib.pp_fold_call ~e:"?" ~f (self#pp_arith_arg Flow) fmt xs | CallApply -> Plib.pp_fold_apply ~e:"?" ~f (self#pp_arith_arg Atom) fmt xs end method private pp_arith_cmp ~phi fmt a b = let is_real = T.is_real a || T.is_real b in let amode = if is_real then Areal else Aint in let gmode = if is_real then Mreal else Mint in match phi (cmode mode) amode with | Assoc op | Op op -> self#with_mode gmode (fun emode -> let scope = match emode with | Mpositive | Mnegative | Mterm | Mterm_int | Mterm_real -> self#op_scope amode | Mint | Mreal -> None in match scope with | None -> begin fprintf fmt "@[" ; Plib.pp_binop op (self#pp_arith_arg Atom) fmt a b ; fprintf fmt "@]" ; end | Some s -> begin fprintf fmt "@[(" ; Plib.pp_binop op (self#pp_arith_arg Atom) fmt a b ; fprintf fmt ")%s@]" s ; end) | Call f -> begin fprintf fmt "@[" ; self#with_mode gmode (fun _ -> self#pp_arith_call ~f fmt [a;b]) ; fprintf fmt "@]" ; end method pp_times fmt k e = if Z.equal k Z.minus_one then self#pp_arith_unop ~phi:(self#op_minus) fmt e else self#pp_arith_binop ~phi:(self#op_mul) fmt (T.e_zint k) e (* -------------------------------------------------------------------------- *) (* --- Arrays --- *) (* -------------------------------------------------------------------------- *) method virtual pp_array_get : formatter -> term -> term -> unit method virtual pp_array_set : formatter -> term -> term -> term -> unit (* -------------------------------------------------------------------------- *) (* --- Records --- *) (* -------------------------------------------------------------------------- *) method virtual pp_get_field : formatter -> term -> Field.t -> unit method virtual pp_def_fields : record printer (* -------------------------------------------------------------------------- *) (* --- Logical Connectives --- *) (* -------------------------------------------------------------------------- *) method virtual op_not : cmode -> op method virtual op_and : cmode -> op method virtual op_or : cmode -> op method virtual op_imply : cmode -> op method virtual op_equiv : cmode -> op (* -------------------------------------------------------------------------- *) (* --- Polarity --- *) (* -------------------------------------------------------------------------- *) method pp_not fmt p = let pp = self#pp_unop ~op:(self#op_not (cmode mode)) in match mode with | Mpositive -> mode <- Mnegative ; pp fmt p ; mode <- Mpositive | Mnegative -> mode <- Mpositive ; pp fmt p ; mode <- Mnegative | _ -> pp fmt p method private pp_polarity pp fmt (inv,x) = match mode with | Mpositive when inv -> mode <- Mnegative ; pp fmt x ; mode <- Mpositive | Mnegative when inv -> mode <- Mpositive ; pp fmt x ; mode <- Mnegative | _ -> pp fmt x method pp_imply fmt hs p = let op = self#op_imply (cmode mode) in let pp_atom = self#pp_polarity self#pp_atom in let pp_flow = self#pp_polarity self#pp_flow in let xs = List.map (fun h -> true,h) hs @ [false,p] in match op with | Assoc op -> Plib.pp_assoc ~e:"?" ~op pp_atom fmt xs | Op op -> Plib.pp_fold_binop ~e:"?" ~op pp_atom fmt xs | Call f -> match self#callstyle with | CallVar | CallVoid -> Plib.pp_fold_call ~e:"?" ~f pp_flow fmt xs | CallApply -> Plib.pp_fold_apply ~e:"?" ~f pp_atom fmt xs (* -------------------------------------------------------------------------- *) (* --- Equality --- *) (* -------------------------------------------------------------------------- *) method pp_equal fmt a b = let cm = cmode mode in match Kind.merge (T.sort a) (T.sort b) with | Sprop | Sbool -> self#pp_binop ~op:(self#op_equiv cm) fmt a b | Sdata | Sarray _ -> self#pp_binop_term ~op:(self#op_equal cm) fmt a b | Sint | Sreal -> self#pp_arith_cmp ~phi:(self#op_eq) fmt a b method pp_noteq fmt a b = let cm = cmode mode in match Kind.merge (T.sort a) (T.sort b) with | Sprop | Sbool -> self#pp_unop ~op:(self#op_not cm) fmt (T.e_equiv a b) | Sdata | Sarray _ -> self#pp_binop_term ~op:(self#op_noteq cm) fmt a b | Sint | Sreal -> self#pp_arith_cmp ~phi:(self#op_neq) fmt a b (* -------------------------------------------------------------------------- *) (* --- Conditional --- *) (* -------------------------------------------------------------------------- *) method virtual pp_conditional : formatter -> term -> term -> term -> unit (* -------------------------------------------------------------------------- *) (* --- Quantifiers --- *) (* -------------------------------------------------------------------------- *) method virtual pp_forall : tau -> var list printer method virtual pp_exists : tau -> var list printer method virtual pp_lambda : var list printer method private pp_binders fmt p = match T.repr p with | Bind(Lambda,x,p) -> let xs,p = lambda [x] p in List.iter self#bind xs ; self#pp_lambda fmt xs ; self#pp_binders fmt p | Bind((Forall|Exists) as q,x,p) -> let vars,p = binders q (add_var x TauMap.empty) p in TauMap.iter (fun t xs -> List.iter self#bind xs ; let xs = List.sort Var.compare xs in match q with | Forall -> fprintf fmt "%a@ " (self#pp_forall t) xs | Exists -> fprintf fmt "%a@ " (self#pp_exists t) xs | Lambda -> assert false ) vars ; self#pp_binders fmt p | _ -> self#pp_shared fmt p (* -------------------------------------------------------------------------- *) (* --- Sharing --- *) (* -------------------------------------------------------------------------- *) method bind x = let basename = self#basename (T.base_of_var x) in ignore (linker_variable#alloc ~basename x) ; vars <- Vars.add x vars method virtual is_shareable : term -> bool method virtual pp_let : Format.formatter -> string -> term -> unit method private pp_lets fmt xes e = begin let m0 = mode in List.iter (fun (x,e) -> mode <- Mterm ; self#pp_let fmt x e ; linker_shared#bind_reserved e x ; ) xes ; mode <- m0 ; self#pp_flow fmt e ; end method private pp_shared fmt e = let shared e = linker_shared#mem e in let shareable e = self#is_shareable e in let es = T.shared ~shareable ~shared ~closed:vars [e] in if es <> [] then self#local (fun () -> let xes = List.map (fun e -> let basename = self#basename (T.basename e) in let var = linker_shared#reserve ~basename in var , e ) es in self#pp_lets fmt xes e) else self#pp_flow fmt e (* -------------------------------------------------------------------------- *) (* --- Expressions --- *) (* -------------------------------------------------------------------------- *) method private op_scope_for e = match mode with | (Mpositive | Mnegative | Mterm) when T.is_int e -> self#op_scope Aint | (Mpositive | Mnegative | Mterm) when T.is_real e -> self#op_scope Areal | Mterm_int -> self#op_scope Aint | Mterm_real -> self#op_scope Areal | _ -> None method pp_atom fmt e = try pp_print_string fmt (linker_shared#find e) with Not_found -> if self#is_atomic e then self#pp_repr fmt e else fprintf fmt "@[(%a)@]" self#pp_repr e ; match self#op_scope_for e with | None -> () | Some s -> pp_print_string fmt s method pp_flow fmt e = try pp_print_string fmt (linker_shared#find e) with Not_found -> match self#op_scope_for e with | None -> self#pp_repr fmt e | Some s -> fprintf fmt "@[(%a)%s@]" self#pp_repr e s method private pp_addition fmt xs = let amode = if List.exists T.is_real xs then Areal else Aint in match self#op_add amode , self#op_sub amode , self#op_minus amode with | Assoc add , Assoc sub , Op minus -> let factor x = match T.repr x with | Kint z when Z.negative z -> (false,T.e_zint (Z.opp z)) | Kreal r when R.negative r -> (false,T.e_real (R.opp r)) | Times(k,y) when Z.negative k -> (false,T.e_times (Z.opp k) y) | _ -> (true,x) in let sxs = List.map factor xs in let sxs = List.stable_sort (fun (s1,e1) (s2,e2) -> match s1,s2 with | true,true | false,false -> Pervasives.compare (T.weigth e1) (T.weigth e2) | true,false -> (-1) | false,true -> 1 ) sxs in Plib.iteri (fun i (s,x) -> begin match i , s with | (Ifirst | Isingle) , false -> if self#op_spaced minus && self#is_atomic x then fprintf fmt "%s " minus else pp_print_string fmt minus | (Ifirst | Isingle) , true -> () | (Imiddle | Ilast) , true -> fprintf fmt "@ %s " add | (Imiddle | Ilast) , false -> fprintf fmt "@ %s " sub end ; self#pp_arith_arg Atom fmt x ) sxs | _ -> self#pp_arith_nary ~phi:(self#op_add) fmt xs method private pp_repr fmt e = match T.repr e with | True -> pp_print_string fmt (self#e_true (cmode mode)) | False -> pp_print_string fmt (self#e_false (cmode mode)) | Var x -> begin match cmode mode with | Cterm -> self#pp_var fmt x | Cprop -> fprintf fmt "(%a = %s)" self#pp_var x (self#e_true Cterm) end | Not p -> begin match T.repr p with | Var x -> begin match cmode mode with | Cterm -> self#pp_not fmt p | Cprop -> fprintf fmt "(%a = %s)" self#pp_var x (self#e_false Cterm) end | _ -> self#pp_not fmt p end | Kint x -> self#pp_int (amode mode) fmt x | Kreal x -> self#pp_real fmt x | Add xs -> self#pp_addition fmt xs | Mul xs -> self#pp_arith_nary ~phi:(self#op_mul) fmt xs | Div(a,b) -> self#pp_arith_binop ~phi:(self#op_div) fmt a b | Mod(a,b) -> self#pp_arith_binop ~phi:(self#op_mod) fmt a b | Times(k,a) -> self#pp_times fmt k a | Eq(a,b) -> self#pp_equal fmt a b | Neq(a,b) -> self#pp_noteq fmt a b | Lt(a,b) -> self#pp_arith_cmp ~phi:(self#op_lt) fmt a b | Leq(a,b) -> self#pp_arith_cmp ~phi:(self#op_leq) fmt a b | Aget(a,k) -> self#with_mode Mterm (fun _ -> self#pp_array_get fmt a k) | Aset(a,k,v) -> self#with_mode Mterm (fun _ -> self#pp_array_set fmt a k v) | Rget(r,f) -> self#with_mode Mterm (fun _ -> self#pp_get_field fmt r f) | Rdef fts -> self#with_mode Mterm (fun _ -> self#pp_def_fields fmt fts) | If(a,b,c) -> self#pp_conditional fmt a b c | And ts -> self#pp_nary ~op:(self#op_and (cmode mode)) fmt ts | Or ts -> self#pp_nary ~op:(self#op_or (cmode mode)) fmt ts | Imply(hs,p) -> self#pp_imply fmt hs p | Apply(e,es) -> self#with_mode Mterm (fun em -> self#pp_apply (cmode em) e fmt es) | Fun(f,ts) -> self#with_mode Mterm (fun em -> self#pp_fun (cmode em) f fmt ts) | Bind _ -> self#local (fun () -> self#pp_binders fmt e) (* -------------------------------------------------------------------------- *) (* --- Formulae --- *) (* -------------------------------------------------------------------------- *) method private pp_expr_mode m fmt e = mode <- m ; self#pp_shared fmt e method pp_term = self#pp_expr_mode Mterm method pp_prop = self#pp_expr_mode Mpositive method pp_expr (tau:tau) = self#pp_expr_mode (tmode tau) end end frama-c-Fluorine-20130601/src/wp/qed/src/engine.mli0000644000175000017500000002237412155630203020527 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Engine Signature --- *) (* -------------------------------------------------------------------------- *) (** Generic Engine Signature *) open Format open Logic open Plib open Linker type op = | Op of string (** Infix or prefix operator *) | Assoc of string (** Left-associative binary operator (like + and -) *) | Call of string (** Logic function or predicate *) type link = | F_call of string (** n-ary function *) | F_left of string * string (** 2-ary function left-to-right (0,+) *) | F_right of string * string (** 2-ary function right-to-left (0,+) *) | F_assoc of string (** associative infix operator *) type callstyle = | CallVar (** Call is [f(x,...)] ; [f()] can be written [f] *) | CallVoid (** Call is [f(x,...)] ; in [f()], [()] is mandatory *) | CallApply (** Call is [f x ...] *) type mode = | Mpositive (** Current scope is [Prop] in positive position. *) | Mnegative (** Current scope is [Prop] in negative position. *) | Mterm (** Current scope is [Term]. *) | Mterm_int (** [Int] is required but actual scope is [Term]. *) | Mterm_real (** [Real] is required but actual scope is [Term]. *) | Mint (** Current scope is [Int]. *) | Mreal (** Current scope is [Real]. *) type flow = Flow | Atom type cmode = Cprop | Cterm type amode = Aint | Areal type pmode = Positive | Negative | Boolean type ('x,'f) ftrigger = | TgAny | TgVar of 'x | TgGet of ('x,'f) ftrigger * ('x,'f) ftrigger | TgSet of ('x,'f) ftrigger * ('x,'f) ftrigger * ('x,'f) ftrigger | TgFun of 'f * ('x,'f) ftrigger list | TgProp of 'f * ('x,'f) ftrigger list type ('t,'f,'c) ftypedef = | Tabs | Tdef of 't | Trec of ('f * 't) list | Tsum of ('c * 't list) list (** Generic Engine Signature *) class type virtual ['adt,'field,'logic,'tau,'var,'term] engine = object (** {3 Linking} *) method virtual datatype : 'adt -> string method virtual field : 'field -> string method basename : string -> string (** Allows to sanitize the basename used for every name except function. *) method virtual link : cmode -> 'logic -> link method link_name : cmode -> 'logic -> string (** {3 Global and Local Environment} *) method declare : string -> unit method declare_all : string list -> unit method local : (unit -> unit) -> unit (** Calls the continuation in a local copy of the environment. Previous environment is restored after return, but allocators are left unchanged to enforce on-the-fly alpha-conversion. *) method global : (unit -> unit) -> unit (** Calls the continuation in a fresh local environment. Previous environment is restored after return. *) (** {3 Types} *) method t_int : string method t_real : string method t_bool : string method t_prop : string method t_atomic : 'tau -> bool method pp_array : 'tau printer (** For [Z->a] arrays *) method pp_farray : 'tau printer2 (** For [k->a] arrays *) method pp_tvar : int printer (** Type variables. *) method pp_datatype : 'adt -> 'tau list printer method pp_tau : 'tau printer (** Without parentheses. *) method pp_subtau : 'tau printer (** With parentheses if non-atomic. *) (** {3 Current Mode} The mode represents the expected type for a term to printed. A requirement for all term printers in the engine is that current mode must be correctly set before call. Each term printer is then responsible for setting appropriate modes for its sub-terms. *) method mode : mode method with_mode : mode -> (mode -> unit) -> unit (** Calls the continuation with given mode for sub-terms. The englobing mode is passed to continuation and then restored. *) method op_scope : amode -> string option (** Optional scoping post-fix operator when entering arithmetic mode. *) (** {3 Primitives} *) method e_true : cmode -> string (** ["true"] *) method e_false : cmode -> string (** ["false"] *) method pp_int : amode -> Z.t printer method pp_real : R.t printer method pp_cst : Numbers.cst printer (** Non-zero reals *) (** {3 Variables} *) method pp_var : 'var printer (** Default to local env *) (** {3 Calls} These printers only applies to connective, operators and functions that are morphisms {i w.r.t} current mode. *) method callstyle : callstyle method pp_fun : cmode -> 'logic -> 'term list printer method pp_apply : cmode -> 'term -> 'term list printer (** {3 Arithmetics Operators} *) method op_real_of_int : op method op_add : amode -> op method op_sub : amode -> op method op_mul : amode -> op method op_div : amode -> op method op_mod : amode -> op method op_minus : amode -> op method pp_times : formatter -> Z.t -> 'term -> unit (** Defaults to [self#op_minus] or [self#op_mul] *) (** {3 Comparison Operators} *) method op_equal : cmode -> op method op_noteq : cmode -> op method op_eq : cmode -> amode -> op method op_neq : cmode -> amode -> op method op_lt : cmode -> amode -> op method op_leq : cmode -> amode -> op method pp_equal : 'term printer2 method pp_noteq : 'term printer2 (** {3 Arrays} *) method pp_array_get : formatter -> 'term -> 'term -> unit (** Access ["a[k]"]. *) method pp_array_set : formatter -> 'term -> 'term -> 'term -> unit (** Update ["a[k <- v]"]. *) (** {3 Records} *) method pp_get_field : formatter -> 'term -> 'field -> unit (** Field access. *) method pp_def_fields : ('field * 'term) list printer (** Record construction. *) (** {3 Logical Connectives} *) method op_not : cmode -> op method op_and : cmode -> op method op_or : cmode -> op method op_imply : cmode -> op method op_equiv : cmode -> op (** {3 Conditionals} *) method pp_not : 'term printer method pp_imply : formatter -> 'term list -> 'term -> unit method pp_conditional : formatter -> 'term -> 'term -> 'term -> unit (** {3 Binders} *) method pp_forall : 'tau -> 'var list printer (** with separator *) method pp_exists : 'tau -> 'var list printer (** with separator *) method pp_lambda : 'var list printer (** {3 Bindings} *) method is_shareable : 'term -> bool method bind : 'var -> unit method pp_let : formatter -> string -> 'term -> unit (** {3 Terms} *) method is_atomic : 'term -> bool (** Sub-terms that require parentheses. Shared sub-terms are detected on behalf of this method. *) method pp_flow : 'term printer (** Printer with shared sub-terms and without parentheses. *) method pp_atom : 'term printer (** Printer with shared sun-terms and parentheses for non-atomic expressions. *) (** {3 Top Level} *) method pp_term : 'term printer (** Prints in {i term} mode. Default uses [self#pp_shared] with mode [Mterm] inside an [] box. *) method pp_prop : 'term printer (** Prints in {i prop} mode. Default uses [self#pp_shared] with mode [Mprop] inside an [] box. *) method pp_expr : 'tau -> 'term printer (** Prints in {i term}, {i arithemtic} or {i prop} mode with respect to provided type. *) method declare_type : formatter -> 'adt -> int -> ('tau,'field,'logic) ftypedef -> unit method declare_axiom : formatter -> string -> 'var list -> ('var,'logic) ftrigger list list -> 'term -> unit method declare_signature : formatter -> 'logic -> 'tau list -> 'tau -> unit method declare_definition : formatter -> 'logic -> 'var list -> 'tau -> 'term -> unit end frama-c-Fluorine-20130601/src/wp/qed/src/depends.ml0000644000175000017500000001141112155630203020521 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Logic module Make(T : Term) = struct open T (* -------------------------------------------------------------------------- *) (* --- Dependencies --- *) (* -------------------------------------------------------------------------- *) module Types = Set.Make(ADT) module Fields = Set.Make(Field) module Funs = Set.Make(Fun) type depends = { mutable d_types : Types.t ; mutable d_fields : Fields.t ; mutable d_funs : Funs.t ; mutable d_preds : Funs.t ; } let depends () = { d_types = Types.empty ; d_fields = Fields.empty ; d_funs = Funs.empty ; d_preds = Funs.empty ; } let subset d1 d2 = Types.subset d1.d_types d2.d_types && Fields.subset d1.d_fields d2.d_fields && Funs.subset d1.d_funs d2.d_funs && Funs.subset d1.d_preds d2.d_preds let union d1 d2 = { d_types = Types.union d1.d_types d2.d_types ; d_fields = Fields.union d1.d_fields d2.d_fields ; d_funs = Funs.union d1.d_funs d2.d_funs ; d_preds = Funs.union d1.d_preds d2.d_preds ; } let iter_types f d = Types.iter f d.d_types let iter_fields f d = Fields.iter f d.d_fields let iter_functions f d = Funs.iter f d.d_funs let iter_predicates f d = Funs.iter f d.d_preds let mem_type d a = Types.mem a d.d_types let mem_field d f = Fields.mem f d.d_fields let mem_function d f = Funs.mem f d.d_funs let mem_predicate d p = Funs.mem p d.d_preds let add_type d a = d.d_types <- Types.add a d.d_types let add_field d f = d.d_fields <- Fields.add f d.d_fields let add_function d f = d.d_funs <- Funs.add f d.d_funs let add_predicate d p = d.d_preds <- Funs.add p d.d_preds let add_depend ~target:d ~source:d0 = begin d.d_types <- Types.union d.d_types d0.d_types ; d.d_fields <- Fields.union d.d_fields d0.d_fields ; d.d_funs <- Funs.union d.d_funs d0.d_funs ; d.d_preds <- Funs.union d.d_preds d0.d_preds ; end let rec add_tau d = function | Prop | Bool | Int | Real | Tvar _ -> () | Array(a,b) -> add_tau d a ; add_tau d b | Record fts -> List.iter (fun (f,t) -> add_field d f ; add_tau d t) fts | Data(a,ts) -> add_type d a ; List.iter (add_tau d) ts type mode = Sterm | Sprop let rec add_expr d m e = match T.repr e with (* term sub-terms *) | True | False | Kint _ | Kreal _ | Times _ | Add _ | Mul _ | Div _ | Mod _ | Eq _ | Neq _ | Leq _ | Lt _ | Aget _ | Aset _ -> T.e_iter (add_expr d Sterm) e (* prop/term level *) | And _ | Or _ | Not _ | Imply _ | If _ -> T.e_iter (add_expr d m) e (* special *) | Fun(f,es) -> begin List.iter (add_expr d Sterm) es ; match m with | Sterm -> add_function d f | Sprop -> add_predicate d f end | Rdef fts -> List.iter (fun (f,e) -> add_field d f ; add_expr d Sterm e) fts | Rget(e,f) -> add_field d f ; add_expr d Sterm e | Apply(e,es) -> add_expr d m e ; List.iter (add_expr d Sterm) es | Var x -> add_tau d (tau_of_var x) | Bind(_,x,p) -> add_tau d (tau_of_var x) ; add_expr d Sprop p let add_term d e = add_expr d Sterm e let add_prop d p = add_expr d Sprop p end frama-c-Fluorine-20130601/src/wp/qed/src/pattern.ml0000644000175000017500000000615512155630203020565 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Logic (* -------------------------------------------------------------------------- *) (* --- Pattern Matching --- *) (* -------------------------------------------------------------------------- *) type 'f fpattern = | Pvar of int | Pint of Z.t | Pfun of 'f * 'f fpattern list let rec alloc n = function | Pvar x -> max n (succ x) | Pint _ -> n | Pfun(_,ps) -> alloc_all n ps and alloc_all n ps = List.fold_left alloc n ps let size p = alloc 0 p let size_all ps = alloc_all 0 ps module Make(T : Term) = struct type pattern = T.Fun.t fpattern let assign s i e = match s.(i) with | None -> s.(i) <- Some e | Some e0 -> if e!=e0 then raise Not_found let rec unify_all s ps es = match ps , es with | [] , [] -> () | [] , _ | _ , [] -> raise Not_found | p::ps , e::es -> unify s p e ; unify_all s ps es and unify s p e = match p , T.repr e with | Pvar k , _ -> assign s k e | Pint z , Kint c when Z.equal z c -> () | Pfun(f,ps) , Fun(g,es) when T.Fun.equal f g -> unify_all s ps es | _ -> raise Not_found let extract = function Some e -> e | None -> raise Not_found let pmatch p e = let s = Array.create (size p) None in unify s p e ; Array.map extract s let pmatch_all ps es = let s = Array.create (size_all ps) None in unify_all s ps es ; Array.map extract s let rec instance s = function | Pvar x -> s.(x) | Pint n -> T.e_zint n | Pfun(f,ps) -> T.e_funraw f (List.map (instance s) ps) end frama-c-Fluorine-20130601/src/wp/qed/src/lexer.mll0000644000175000017500000001230212155630203020372 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Lexing type lexeme = | INT of string | REAL of string | STRING of string | IDENT of string | QUOTED of string | KEYWORD of string | END | EOF type keymap = (string,lexeme) Hashtbl.t let operators = [ "(" ; ")" ; "[" ; "]" ; "{" ; "}" ; "+" ; "-" ; "*" ; "/" ; "%" ; "." ; "," ; ":" ; ";" ; "?" ; "!" ; "=>" ; "<=>" ; "->" ; "<-"; "<->" ; "<=" ; ">=" ; ">" ; "<" ; "=" ; "!=" ; "<>" ; ";;" ] let keymap keywords = let kmap = Hashtbl.create 31 in let add_key k = Hashtbl.add kmap k (KEYWORD k) in List.iter add_key operators ; List.iter add_key keywords ; kmap let extend kmap keywords = let kmap = Hashtbl.copy kmap in let add_key k = Hashtbl.add kmap k (KEYWORD k) in List.iter add_key keywords ; kmap let word keymap m = try Hashtbl.find keymap m with Not_found -> IDENT m } let digit = ['0'-'9'] let letter = ['a'-'z' 'A'-'Z' '_'] rule token keymap = parse '\n' { new_line lexbuf ; token keymap lexbuf } | '.' [' ' '\t' '\r']* '\n' { Lexing.new_line lexbuf ; END } | ['\t' '\r' ' '] { token keymap lexbuf } | "(*" { comment 0 lexbuf ; token keymap lexbuf } | '"' (([^ '"' '\n']*) as s)'"' { STRING s } | "0x"? digit+ { INT (Lexing.lexeme lexbuf) } | digit+ ('.' digit+)? (['e' 'E'] ['+' '-']? digit+)? { REAL(Lexing.lexeme lexbuf) } | letter (letter | digit)* '\''* { word keymap (Lexing.lexeme lexbuf) } | ['\'' '#'] letter (letter|digit)* { QUOTED(Lexing.lexeme lexbuf) } | [ '(' ')' '[' ']' '+' '-' '*' '/' '.' ',' ':' ';' '?' '!' '%' '{' '}' ] | "=>" | "<=>" | "->" | "<->" | "<=" | ">=" | ">" | "<" | "=" | "!=" | "<>" | ";;" { Hashtbl.find keymap (Lexing.lexeme lexbuf) } | eof { EOF } | _ { failwith (Printf.sprintf "Unexpected token %S" (Lexing.lexeme lexbuf)) } and comment n = parse | "*)" { if n > 0 then comment (n-1) lexbuf } | "(*" { comment (n+1) lexbuf } | '\n' { Lexing.new_line lexbuf ; comment n lexbuf } | eof { failwith "unexpected end-of-line inside comments" } | _ { comment n lexbuf } { include Input.Make (struct type token = lexeme type langage = keymap let eof = EOF let create = token end) let pp_lexeme fmt = function | KEYWORD k -> Format.fprintf fmt "keyword %S" k | IDENT a -> Format.fprintf fmt "ident %S" a | INT a -> Format.fprintf fmt "int %S" a | REAL a -> Format.fprintf fmt "real %S" a | QUOTED a -> Format.fprintf fmt "quoted %S" a | STRING a -> Format.fprintf fmt "string %S" a | END -> Format.fprintf fmt "end of sentence" | EOF -> Format.fprintf fmt "eof" let skip_pos input = let p = position input in skip input ; p let skip_ident input = match token input with | IDENT x -> skip input ; position input , x | a -> error input "Missing identifier (%a)" pp_lexeme a let skip_key input k = match token input with | KEYWORD k0 when k0 = k -> skip input | a -> error input "Missing '%s' (%a)" k pp_lexeme a let is_key input k = match token input with | KEYWORD k0 when k0 = k -> skip input ; true | _ -> false let parse_list ~left ~sep ~right pp input = let rec collect xs = let x = pp input in if is_key input sep then collect (x::xs) else if is_key input right then List.rev (x::xs) else error input "Missing ',' or ')'" in if is_key input left then if is_key input right then Some [] else Some(collect []) else None let parse_option ~key pp input = if is_key input key then Some (pp input) else None } frama-c-Fluorine-20130601/src/wp/qed/src/Makefile0000644000175000017500000000654312155630203020217 0ustar mehdimehdi########################################################################## # # # This file is part of WP plug-in of Frama-C. # # # # Copyright (C) 2007-2013 # # CEA (Commissariat a l'energie atomique et aux energies # # 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). # # # ########################################################################## # -------------------------------------------------------------------------- # --- QED : a prover / simplifier in classical logic modulo --- # -------------------------------------------------------------------------- PACK?=no include Makefile.src LIB_ML:=$(QED_LIB_ML) SRC_ML:=$(QED_SRC_ML) SRC_MLI:=$(QED_SRC_MLI) LBO= $(addsuffix .cmo,$(LIB_ML)) LBX= $(addsuffix .cmx,$(LIB_ML)) CML= $(addsuffix .cmi,$(SRC_MLI)) CMI= $(CML) $(addsuffix .cmi,$(SRC_ML)) CMO= $(addsuffix .cmo,$(SRC_ML)) CMX= $(addsuffix .cmx,$(SRC_ML)) DOC= $(addsuffix .mli,$(LIB_ML) $(SRC_MLI) $(SRC_ML)) .PHONY: all byte opt doc all: byte opt byte: ../bin/Qed.cmo Makefile Makefile.src opt: ../bin/Qed.cmx Makefile Makefile.src doc: ../html/index.html Qed.cmo: $(LBO) $(CMO) $(CML) $(OCAMLC) -pack -o $@ $(LBO) $(CML) $(CMO) ifeq ($(PACK),no) Qed.cmx: $(LBX) $(CMX) $(CML) $(OCAMLOPT) -pack -o $@ $(LBX) $(CML) $(CMX) else Qed.cmx: $(LBX) $(CMX) $(CML) $(OCAMLOPT) -pack -for-pack $(PACK) -o $@ $(LBX) $(CML) $(CMX) endif ../bin/Qed.cmo: Qed.cmo @mkdir -p ../bin cp Qed.cmo Qed.cmi ../bin/ ../bin/Qed.cmx: Qed.cmx @mkdir -p ../bin cp Qed.cmx Qed.cmi Qed.o ../bin/ ../html/index.html: $(DOC) Makefile @rm -fr ../html @mkdir -p ../html $(OCAMLDOC) -html -d ../html -t "Qed Library" -stars $(DOC) @cp -f ocamldoc.css ../html/style.css depend: lexer.ml numbers.ml depend.pdf: depend.dot dot -T pdf -Grotate=180 -o $@ $< depend.dot: .depend $(OCAMLDOC) -dot-reduce -o $@ -dot $(addsuffix .mli,$(SRC_MLI)) $(addsuffix .ml,$(LIB_ML) $(SRC_ML)) clean:: rm -fr ../html rm -f lexer.ml depend.dot depend.pdf distclean:: rm -f ../bin/Qed.* INCLUDES= OPTCMI= OPTCMO= -w PSUZ -warn-error PSUZ ifeq ($(PACK),no) OPTCMX= -w PSUZ -warn-error PSUZ -for-pack Qed else OPTCMX= -w PSUZ -warn-error PSUZ -for-pack $(PACK).Qed endif include MakeOcaml frama-c-Fluorine-20130601/src/wp/qed/src/hcons.ml0000644000175000017500000001033612155630203020216 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Hash Consing Utilities --- *) (* -------------------------------------------------------------------------- *) let primes = [| 2 ; 3 ; 5 ; 7 ; 11 ; 13 ; 17 ; 19 ; 23 ; 29 ; 31 ; 37 ; 41 ; 43 ; 47 ; 53 ; 59 ; 61 ; 67 ; 71 ; 73 ; 79 ; 83 ; 89 ; 97 ; 101 ; 103 ; 107 ; 109 ; 113 ; 127 ; 131 ; 137 ; 139 ; 149 ; 151 ; 157 ; 163 ; 167 ; 173 ; 179 ; 181 ; 191 ; 193 ; 197 ; 199 ; 211 ; 223 ; 227 ; 229 ; 233 ; 239 ; 241 ; 251 ; 257 ; 263 ; 269 ; 271 ; 277 ; 281 |] let n_primes = Array.length primes let hash_int t = if t < n_primes then primes.(t) else 1 let hash_tag x = hash_int (Obj.tag (Obj.repr x)) let hash_pair x y = x * 599 + y * 799 let hash_triple x y z = x * 281 + y * 599 + z * 799 let rec hash_list f h = function | [] -> h | x::xs -> hash_list f (h * 599 + f x) xs let hash_opt f h = function | None -> h | Some x -> h * 281 + f x let hash_array f h xs = let rec collect h xs i = if i < Array.length xs then collect (h * 599 + f xs.(i)) xs (succ i) else h in collect h xs 0 let rec compare_list cmp xs ys = match xs , ys with | [] , [] -> 0 | [] , _ :: _ -> -1 | _ :: _ , [] -> 1 | x::xs , y::ys -> let c = cmp x y in if c = 0 then compare_list cmp xs ys else c let rec equal_list eq xs ys = match xs , ys with | [] , [] -> true | [] , _ :: _ | _ :: _ , [] -> false | x::xs , y::ys -> eq x y && equal_list eq xs ys let equal_array eq xs ys = let n = Array.length xs in let m = Array.length ys in n = m && begin try for i=0 to n-1 do if not (eq xs.(i) ys.(i)) then raise Exit done ; true with Exit -> false end let exists_array f xs = try for i=0 to Array.length xs - 1 do if f xs.(i) then raise Exit done ; false with Exit -> true let forall_array f xs = try for i=0 to Array.length xs - 1 do if not (f xs.(i)) then raise Exit done ; true with Exit -> false let rec eq_list xs ys = match xs, ys with | [] , [] -> true | [] , _::_ | _::_ , [] -> false | x::xs , y::ys -> x==y && eq_list xs ys let eq_array xs ys = let n = Array.length xs in let m = Array.length ys in n = m && begin try for i=0 to n-1 do if not (xs.(i) == ys.(i)) then raise Exit done ; true with Exit -> false end let rec fold_list op f a = function | [] -> a | x::xs -> fold_list op f (op a (f x)) xs let fold_array op f a xs = let rec collect op f a xs i = if i < Array.length xs then collect op f (op a (f xs.(i))) xs (succ i) else a in collect op f a xs 0 frama-c-Fluorine-20130601/src/wp/qed/src/idxset.mli0000644000175000017500000000403412155630203020553 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** Set of indexed elements implemented as Patricia sets. *) module type S = sig include Set.S val map : (elt -> elt) -> t -> t val mapf : (elt -> elt option) -> t -> t val intersect : t -> t -> bool end module type IndexedElements = sig type t val id : t -> int (** unique per t *) end module Make( E : IndexedElements ) : S with type elt = E.t module Positive( E : IndexedElements ) : S with type elt = E.t (** With only positive index *) frama-c-Fluorine-20130601/src/wp/qed/src/export_altergo.ml0000644000175000017500000003605712155630203022152 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Exportation Engine for Alt-Ergo --- *) (* -------------------------------------------------------------------------- *) open Logic open Format open Plib open Linker open Engine open Export let rec cartesian f = function | [] | [_] -> () | x::xs -> List.iter (fun y -> f x y) xs ; cartesian f xs let tau_of_sort = function | Sint -> Int | Sreal -> Real | Sbool -> Bool | Sprop | Sdata | Sarray _ -> raise Not_found let tau_of_arraysort = function | Sarray s -> tau_of_sort s | _ -> raise Not_found module Make(T : Term) = struct open T module E = Export_whycore.Make(T) module ADT = T.ADT module Field = T.Field module Fun = T.Fun type tau = (Field.t,ADT.t) datatype type var = Var.t type term = T.term type record = (Field.t * term) list type trigger = (T.var,Fun.t) ftrigger class virtual engine = object(self) inherit E.engine as super initializer begin self#declare_all [ "type" ; "logic" ; "predicate" ; "function" ; "axiom" ; "goal" ; "farray" ; "true" ; "false" ; ] ; end (* -------------------------------------------------------------------------- *) (* --- Types --- *) (* -------------------------------------------------------------------------- *) method t_atomic (_:tau) = true method pp_array fmt data = fprintf fmt "%a farray" self#pp_tau data method pp_farray fmt key data = fprintf fmt "(%a,%a) farray" self#pp_tau key self#pp_tau data method virtual get_typedef : ADT.t -> tau option method virtual set_typedef : ADT.t -> tau -> unit method pp_datatype adt fmt ts = match self#get_typedef adt with | Some def -> let t = Kind.tmap (Array.of_list ts) def in self#pp_tau fmt t | None -> match ts with | [] -> pp_print_string fmt (self#datatype adt) | [t] -> fprintf fmt "%a@ %s" self#pp_tau t (self#datatype adt) | t::ts -> fprintf fmt "@[(%a" self#pp_tau t ; List.iter (fun t -> fprintf fmt ",@,%a" self#pp_tau t) ts ; fprintf fmt ")@ %s@]" (self#datatype adt) (* -------------------------------------------------------------------------- *) (* --- Primitives --- *) (* -------------------------------------------------------------------------- *) method callstyle = CallVar (* -------------------------------------------------------------------------- *) (* --- Arithmetics --- *) (* -------------------------------------------------------------------------- *) method pp_int amode fmt z = match amode with | Aint -> Z.pretty fmt z | Areal -> fprintf fmt "%a.0" Z.pretty z method pp_cst fmt cst = let open Numbers in match cst.sign , cst.base with | Pos,Dec -> let man = if cst.man = "" then "0" else cst.man in let com = if cst.com = "" then "0" else cst.com in fprintf fmt "%s.%se%d" man com cst.exp | Neg,Dec -> let man = if cst.man = "" then "0" else cst.man in let com = if cst.com = "" then "0" else cst.com in fprintf fmt "(-%s.%se%d)" man com cst.exp | _,Hex -> let hex,exp = Numbers.significant cst in let base = Numbers.dec_of_hex hex in if exp > 0 then let sign = match cst.sign with Pos -> "" | Neg -> "-" in fprintf fmt "(%s%s.0*%s.0)" sign base (Numbers.power_of_two exp) else if exp < 0 then let sign = match cst.sign with Pos -> "" | Neg -> "-" in fprintf fmt "(%s%s.0/%s.0)" sign base (Numbers.power_of_two (-exp)) else match cst.sign with | Pos -> fprintf fmt "%s.0" base | Neg -> fprintf fmt "(-%s.0)" base method op_real_of_int = Call "real_of_int" method op_minus (_:amode) = Op "-" method op_add (_:amode) = Assoc "+" method op_sub (_:amode) = Assoc "-" method op_mul (_:amode) = Assoc "*" method op_div = function Aint -> Call "cdiv" | Areal -> Op "/" method op_mod = function Aint -> Call "cmod" | Areal -> Call "rmod" method op_eq cmode _amode = match cmode with | Cprop -> Op "=" | Cterm -> Call "eqb" method op_neq cmode _amode = match cmode with | Cprop -> Op "<>" | Cterm -> Call "neqb" method op_lt cmode amode = match cmode , amode with | Cprop , _ -> Op "<" | Cterm , Aint -> Call "zlt" | Cterm , Areal -> Call "rlt" method op_leq cmode amode = match cmode , amode with | Cprop , _ -> Op "<=" | Cterm , Aint -> Call "zleq" | Cterm , Areal -> Call "rleq" (* -------------------------------------------------------------------------- *) (* --- Logical Connectives --- *) (* -------------------------------------------------------------------------- *) method e_true _ = "true" method e_false _ = "false" method op_not = function Cprop -> Op "not" | Cterm -> Call "notb" method op_and = function Cprop -> Assoc "and" | Cterm -> Call "andb" method op_or = function Cprop -> Assoc "or" | Cterm -> Call "orb" method op_imply = function Cprop -> Assoc "->" | Cterm -> Call "implb" method op_equiv = function Cprop -> Op "<->" | Cterm -> Call "eqb" method op_equal = function Cprop -> Op "=" | Cterm -> Call "eqb" method op_noteq = function Cprop -> Op "<>" | Cterm -> Call "neqb" (* -------------------------------------------------------------------------- *) (* --- Conditional --- *) (* -------------------------------------------------------------------------- *) method pp_conditional fmt a b c = match Export.pmode self#mode with | Negative -> let cond = T.e_and [T.e_imply [a] b ; T.e_imply [T.e_not a] c] in self#pp_flow fmt cond | Positive -> let cond = T.e_or [T.e_and [a;b] ; T.e_and [T.e_not a;c]] in self#pp_flow fmt cond | Boolean -> begin fprintf fmt "@[ite(" ; self#with_mode Mterm (fun _ -> self#pp_atom fmt a) ; fprintf fmt ",@ %a" self#pp_atom b ; fprintf fmt ",@ %a" self#pp_atom c ; fprintf fmt ")@]" ; end (* -------------------------------------------------------------------------- *) (* --- Records --- *) (* -------------------------------------------------------------------------- *) method op_record = "{" , "}" (* -------------------------------------------------------------------------- *) (* --- Atomicity --- *) (* -------------------------------------------------------------------------- *) method op_spaced op = is_ident op method is_atomic e = match T.repr e with | Kint z -> Z.positive z | Kreal _ -> true | Apply _ -> true | Aset _ | Aget _ | Fun _ -> true | _ -> T.is_simple e (* -------------------------------------------------------------------------- *) (* --- Type Checking --- *) (* -------------------------------------------------------------------------- *) method typeof_getfield _ = raise Not_found method typeof_setfield _ = raise Not_found method typeof_call _ = raise Not_found method typecheck e = match T.sort e with | Sint -> Int | Sreal -> Real | Sbool -> Bool | Sprop -> raise Not_found | Sdata | Sarray _ -> match T.repr e with | Var x -> tau_of_var x | Aset(m,k,v) -> (try self#typecheck m with Not_found -> Array(self#typecheck k,self#typecheck v)) | Fun(f,_) -> (try tau_of_sort (Fun.sort f) with Not_found -> self#typeof_call f) | Aget(m,_) -> (try tau_of_arraysort (T.sort m) with Not_found -> match self#typecheck m with | Array(_,v) -> v | _ -> raise Not_found) | Rdef ((f,_)::_) -> self#typeof_setfield f | Rget (_,f) -> self#typeof_getfield f | _ -> raise Not_found (* -------------------------------------------------------------------------- *) (* --- Lets --- *) (* -------------------------------------------------------------------------- *) method pp_let fmt x e = try let tau = self#typecheck e in fprintf fmt "@[let %s = %a : %a in@]@ " x self#pp_flow e self#pp_tau tau with Not_found -> fprintf fmt "@[let %s = %a in@]@ " x self#pp_flow e (* -------------------------------------------------------------------------- *) (* --- Binders --- *) (* -------------------------------------------------------------------------- *) method pp_forall tau fmt = function | [] -> () | x::xs -> fprintf fmt "@[forall %a" self#pp_var x ; List.iter (fun x -> fprintf fmt ",@,%a" self#pp_var x) xs ; fprintf fmt "@ : %a.@]" self#pp_tau tau ; method pp_intros tau fmt = function | [] -> () | x::xs -> fprintf fmt "@[forall %a" self#pp_var x ; List.iter (fun x -> fprintf fmt ",@,%a" self#pp_var x) xs ; fprintf fmt "@ : %a@]" self#pp_tau tau ; method pp_exists tau fmt = function | [] -> () | x::xs -> fprintf fmt "@[exists %a" self#pp_var x ; List.iter (fun x -> fprintf fmt ",@,%a" self#pp_var x) xs ; fprintf fmt "@ : %a.@]" self#pp_tau tau ; method pp_trigger fmt t = let rec pretty fmt = function | TgAny -> assert false | TgVar x -> self#pp_var fmt x | TgGet(t,k) -> fprintf fmt "@[%a[%a]@]" pretty t pretty k | TgSet(t,k,v) -> fprintf fmt "@[%a[%a@ <- %a]@]" pretty t pretty k pretty v | TgFun(f,ts) -> call Cterm f fmt ts | TgProp(f,ts) -> call Cprop f fmt ts and call mode f fmt ts = match self#link mode f with | F_call f -> Plib.pp_call_var ~f pretty fmt ts | F_left(e,f) -> Plib.pp_fold_call ~e ~f pretty fmt ts | F_right(e,f) -> Plib.pp_fold_call_rev ~e ~f pretty fmt (List.rev ts) | F_assoc op -> Plib.pp_assoc ~e:"?" ~op pretty fmt ts in fprintf fmt "@[%a@]" pretty t method pp_goal ~model fmt p = if model <= 0 then self#pp_prop fmt p else begin let rec intros xs p = match T.repr p with | Bind(Forall,x,p) -> intros (x::xs) p | _ -> xs , p in let xs,p = intros [] p in List.iter (fun x -> self#bind x ; fprintf fmt "@[forall %a \"model:%d\" : %a.@]@ " self#pp_var x model self#pp_tau (tau_of_var x)) (List.rev xs) ; self#pp_prop fmt p ; end (* -------------------------------------------------------------------------- *) (* --- Declarations --- *) (* -------------------------------------------------------------------------- *) method pp_declare_adt fmt adt = function | 0 -> fprintf fmt "type %s" (self#datatype adt) | 1 -> fprintf fmt "type %a %s" self#pp_tvar 1 (self#datatype adt) | n -> begin fprintf fmt "type (%a" self#pp_tvar 1 ; for i=2 to n do fprintf fmt ",%a" self#pp_tvar i done ; fprintf fmt ") %s" (self#datatype adt) ; end method pp_declare_def fmt adt n def = begin fprintf fmt "(* @[inlined type " ; self#pp_declare_adt fmt adt n ; fprintf fmt "@ = %a@] *)" self#pp_tau def ; self#set_typedef adt def ; end method pp_declare_sum fmt adt n cases = let is_enum = function (_,[]) -> true | _ -> false in if List.for_all is_enum cases then begin fprintf fmt "@[" ; self#pp_declare_adt fmt adt n ; Plib.iteri (fun index (c,_) -> match index with | Ifirst | Isingle -> fprintf fmt " = %s" (self#link_name Cterm c) | Imiddle | Ilast -> fprintf fmt "@ | %s" (self#link_name Cterm c) ) cases ; fprintf fmt "@]" end else begin self#pp_declare_adt fmt adt n ; pp_print_newline fmt () ; let result = Data(adt,Kind.type_params n) in List.iter (fun (c,ts) -> self#declare_signature fmt c ts result ) cases ; let rank = "rank_" ^ self#datatype adt in fprintf fmt "logic %s : %a -> int@\n" rank self#pp_tau result ; Plib.iterk (fun k (c,ts) -> fprintf fmt "@[axiom %s_%d:@ " rank k ; let xs = Plib.mapk (fun k t -> fprintf fmt "forall x%d:%a.@ " k self#pp_tau t ; Printf.sprintf "x%d" k) ts in fprintf fmt "%s(%a)=%d@]@\n" rank (Plib.pp_call_var ~f:(self#link_name Cterm c) pp_print_string) xs k ) cases ; end method declare_signature fmt f ts t = begin let cmode = Export.ctau t in fprintf fmt "@[logic %s :@ " (self#link_name cmode f) ; if ts <> [] then begin Plib.pp_listcompact ~sep:"," self#pp_tau fmt ts ; fprintf fmt "@ -> " ; end ; fprintf fmt "%a@]@\n" self#pp_tau t end method declare_definition fmt f xs t e = self#global begin fun () -> let cmode = Export.ctau t in fprintf fmt "@[%a@,(" (self#pp_declare_symbol cmode) f ; Plib.pp_listsep ~sep:"," (fun fmt x -> self#bind x ; let t = T.tau_of_var x in fprintf fmt "%a:%a" self#pp_var x self#pp_tau t ) fmt xs ; match cmode with | Cprop -> fprintf fmt ") =@ @[%a@]@]@\n" self#pp_prop e | Cterm -> fprintf fmt ") :@ %a =@ @[%a@]@]@\n" self#pp_tau t (self#pp_expr t) e end end end frama-c-Fluorine-20130601/src/wp/qed/src/z.ml0000644000175000017500000001546612155630203017366 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Big_int (* Nb of significant digits in a "word" of Big_int. *) let nb_digits_of_big_int = let r = let rec nb_digits y = if 1 = num_digits_big_int (power_int_positive_int 2 y) then nb_digits (y + 1) else y in nb_digits 1 in r let base = power_int_positive_int 2 nb_digits_of_big_int let base16bits = power_int_positive_int 2 16 (* If X is such that x = let f a x =(a * base) + x in List.fold_left f 0 X, and Y such that y = let f a y =(a * base) + y in List.fold_left f 0 Y, we have map2_base base op x y = let f a x y =(a * base) + (op x y) in List.fold_left f 0 X Y *) let map2_base b op x y = let rec map2_base_rec a x y = let (qx, mx) = quomod_big_int x b and (qy, my) = quomod_big_int y b in let res_m = op mx my and res_q = if (eq_big_int zero_big_int qx) && (eq_big_int zero_big_int qy) then a else map2_base_rec a qx qy in add_big_int (mult_big_int res_q b) res_m in map2_base_rec zero_big_int x y let bitwise_op_positive_big_int op x y = assert (ge_big_int x zero_big_int); assert (ge_big_int y zero_big_int); let g = let f u v = assert(is_int_big_int u) ; assert(is_int_big_int v) ; let r = op (int_of_big_int u) (int_of_big_int v) in big_int_of_int (r) in map2_base base16bits f in let r = map2_base base g x y in assert (ge_big_int r zero_big_int); r let lnot_big_int w = minus_big_int (succ_big_int w) let shift_left_big_int x y = (* idem multiplication *) mult_big_int x (power_int_positive_big_int 2 y) let shift_right_big_int x y = (* idem division rounding to -oo *) div_big_int x (power_int_positive_big_int 2 y) let power_two = let h = Hashtbl.create 7 in fun k -> try Hashtbl.find h k with Not_found -> let p = power_int_positive_int 2 k in Hashtbl.add h k p; p let two_power y = try let k = int_of_big_int y in power_two k with Failure _ -> assert false let bitwise_op_big_int op x y = let (positive_x, op_sx) = if gt_big_int zero_big_int x then (lnot_big_int x, (fun u v -> op (lnot u) v)) else (x, op) in let (positive_y, op_sx_sy) = if gt_big_int zero_big_int y then (lnot_big_int y, (fun u v -> op_sx u (lnot v))) else (y, op_sx) in let (positive_op_map, op_map) = if 0 = (op_sx_sy 0 0) then (op_sx_sy, (fun w -> w)) else ((fun u v -> lnot (op_sx_sy u v)), lnot_big_int) in op_map (bitwise_op_positive_big_int positive_op_map positive_x positive_y) let bitwise_not w = minus_big_int (succ_big_int w) let bitwise_and = bitwise_op_big_int (land) let bitwise_or = bitwise_op_big_int (lor) let bitwise_xor = bitwise_op_big_int (lxor) let bitwise_shift_right = shift_right_big_int let bitwise_shift_left = shift_left_big_int let cast_max ~max ~signed ~value = if (not signed) then mod_big_int value max else if eq_big_int (bitwise_and max value) zero_big_int then bitwise_and value (pred_big_int max) else bitwise_or (bitwise_not (pred_big_int max)) value let cast_size ~size ~signed ~value = let max = if (not signed) then two_power size else two_power (pred_big_int size) in cast_max ~max ~signed ~value (* end of bitwise operations *) type t = big_int let zero = zero_big_int let one = unit_big_int let minus_one = minus_big_int one let int = big_int_of_int let succ = succ_big_int let pred = pred_big_int let add = add_big_int let sub = sub_big_int let mul = mult_big_int let opp = minus_big_int let div a b = let sb = sign_big_int b in if sb = 0 then failwith "Division by zero" ; let sa = sign_big_int a in if sa = 0 then zero else let a = abs_big_int a in let b = abs_big_int b in let q = div_big_int a b in if sa * sb > 0 then q else minus_big_int q let remainder a b = let sb = sign_big_int b in if sb = 0 then failwith "Division by zero" ; let sa = sign_big_int a in if sa = 0 then zero else let a = abs_big_int a in let b = abs_big_int b in let r = mod_big_int a b in if sa > 0 then r else minus_big_int r let euclidian a b = let sb = sign_big_int b in if sb = 0 then failwith "Division by zero" ; let sa = sign_big_int a in if sa = 0 then zero , zero else let a = abs_big_int a in let b = abs_big_int b in let q,r = quomod_big_int a b in ( (if sa * sb > 0 then q else minus_big_int q) , (if sa > 0 then r else minus_big_int r) ) let to_string = string_of_big_int let of_string = big_int_of_string let pretty fmt x = Format.pp_print_string fmt (string_of_big_int x) let of_int = big_int_of_int let to_int x = try Some(int_of_big_int x) with _ -> None let to_big_int x = x let of_big_int x = x let hash x = Hashtbl.hash (to_string x) let compare = compare_big_int let equal = eq_big_int let not_equal x y = compare x y <> 0 let leq = le_big_int let lt = lt_big_int let max x y = if leq x y then y else x let min x y = if leq x y then x else y let positive x = sign_big_int x >= 0 let negative x = sign_big_int x <= 0 let null x = sign_big_int x = 0 let lt_zero x = sign_big_int x < 0 let gt_zero x = sign_big_int x > 0 type sign = Null | Positive | Negative let sign x = let s = sign_big_int x in if s < 0 then Negative else if s > 0 then Positive else Null frama-c-Fluorine-20130601/src/wp/qed/src/input.ml0000644000175000017500000001275112155630203020246 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Utilities --- *) (* -------------------------------------------------------------------------- *) open Syntax type 'a lexer = Lexing.lexbuf -> 'a exception SyntaxError of position * string let merge p q = let r = if p.p_line <= q.p_line then p else q in { r with p_start = min p.p_start q.p_start ; p_stop = max p.p_stop q.p_stop ; } let rec merge_list f p = function | [] -> p | x::xs -> merge_list f (merge p (f x)) xs let pp_position fmt p = Format.fprintf fmt "File \"%s\", line %d, characters %d-%d" p.p_file p.p_line (p.p_start - p.p_bol+1) (p.p_stop - p.p_bol) let error_at position message = let buffer = Buffer.create 80 in Format.kfprintf (fun fmt -> Format.pp_print_flush fmt () ; raise (SyntaxError(position,Buffer.contents buffer))) (Format.formatter_of_buffer buffer) message let string_of_exn = function | Failure msg -> msg | e -> Printexc.to_string e let locate position = function | SyntaxError _ as e -> e | e -> SyntaxError(position,string_of_exn e) let nowhere = { p_file = "qed-prelude" ; p_line = 0 ; p_bol = 0 ; p_start = 0 ; p_stop = 0 ; } module type Lexer = sig type token type langage val eof : token val create : langage -> token lexer end module type S = sig type input type token type langage val open_file : langage -> string -> input val open_shell : langage -> string -> input val close : input -> unit val token : input -> token val skip : input -> unit val context : input -> string -> unit val position : input -> position val error : input -> ('a,Format.formatter,unit,'b) format4 -> 'a end module Make(L : Lexer) = struct open Lexing type id = position * string type token = L.token type langage = L.langage type input = { lexing : token lexer ; lexbuf : Lexing.lexbuf ; inc : in_channel option ; mutable token : token ; mutable lock : int ; mutable context : string ; } let init_pos lex f = let pos = { pos_fname = f ; pos_lnum = 1 ; pos_bol = 0 ; pos_cnum = 0 ; } in ( lex.lex_start_p <- pos ; lex.lex_curr_p <- pos ) let first_token lexing lexbuf = try lexing lexbuf with End_of_file -> L.eof let open_file lang f = let inc = open_in f in let lexbuf = from_channel inc in let lexing = L.create lang in init_pos lexbuf f ; { inc = Some inc ; lexbuf = lexbuf ; lexing = lexing ; token = first_token lexing lexbuf ; context = "file "^f ; lock = 256 ; } let open_shell lang buffer = let lexbuf = Lexing.from_string buffer in let lexing = L.create lang in init_pos lexbuf "toplevel" ; { inc = None ; lexbuf = lexbuf ; lexing = lexing ; token = first_token lexing lexbuf ; context = "toplevel" ; lock = 256 ; } let context input s = input.context <- s let close input = input.token <- L.eof ; match input.inc with Some inc -> close_in inc | None -> () let position input = let start = input.lexbuf.lex_start_p in let stop = input.lexbuf.lex_curr_p in { p_file = start.pos_fname ; p_line = start.pos_lnum ; p_bol = start.pos_bol ; p_start = start.pos_cnum ; p_stop = stop.pos_cnum ; } let error input message = error_at (position input) message let skip input = if input.token <> L.eof then try input.token <- input.lexing input.lexbuf ; input.lock <- 256 with | End_of_file -> input.token <- L.eof | e -> let msg = Printf.sprintf "Lexical failure (%s)" (string_of_exn e) in raise (locate (position input) (Failure msg)) let token input = if input.lock < 0 then failwith input.context ; input.lock <- pred input.lock ; input.token end frama-c-Fluorine-20130601/src/wp/qed/src/compiler.mli0000644000175000017500000000473012155630203021070 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (** Qed Compiler to Ground *) (* -------------------------------------------------------------------------- *) open Logic module Make(T:Term) : sig type symbol = | Fun of T.signature * T.Fun.t | Val of T.tau * T.term type lookup = { make_field : Syntax.id -> sort -> T.Field.t ; lookup_field : Syntax.id -> T.Field.t -> bool ; lookup_typedef : Syntax.id -> T.tau ; lookup_datatype : T.ADT.t -> T.tau option ; lookup_symbol : Syntax.id -> symbol ; } val cc_tau : lookup -> Syntax.id list -> Syntax.t -> T.tau val cc_sig : lookup -> Syntax.t list -> Syntax.t -> T.signature val cc_def : lookup -> Syntax.arg list -> Syntax.t option -> Syntax.e -> T.signature * T.term val cc_exp : lookup -> Syntax.e -> T.tau * T.term end frama-c-Fluorine-20130601/src/wp/qed/src/export_altergo.mli0000644000175000017500000000607512155630203022320 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Logic open Format open Plib open Linker open Engine (** Exportation Engine for Alt-Ergo. Provides a full {{:Export.S.engine-c.html}engine} from a {{:Export.S.linker-c.html}linker}. *) module Make(T : Term) : sig open T type trigger = (T.var,Fun.t) ftrigger class virtual engine : object method typecheck : term -> tau (** or raise Not_found *) method typeof_call : Fun.t -> tau (** or raise Not_found *) method typeof_setfield : Field.t -> tau (** or raise Not_found *) method typeof_getfield : Field.t -> tau (** or raise Not_found *) method virtual get_typedef : ADT.t -> tau option method virtual set_typedef : ADT.t -> tau -> unit inherit [ADT.t,Field.t,Fun.t,tau,var,term] Engine.engine method op_spaced : string -> bool method op_record : string * string method pp_forall : tau -> var list printer method pp_intros : tau -> var list printer method pp_exists : tau -> var list printer method pp_param : var printer method pp_trigger : (var,Fun.t) ftrigger printer method pp_declare_symbol : cmode -> Fun.t printer method pp_declare_adt : formatter -> ADT.t -> int -> unit method pp_declare_def : formatter -> ADT.t -> int -> tau -> unit method pp_declare_sum : formatter -> ADT.t -> int -> (Fun.t * tau list) list -> unit method pp_goal : model:int -> formatter -> term -> unit method declare_prop : kind:string -> formatter -> string -> T.var list -> trigger list list -> term -> unit end end frama-c-Fluorine-20130601/src/wp/qed/src/parser.ml0000644000175000017500000003727712155630203020415 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- PARSER --- *) (* -------------------------------------------------------------------------- *) open Syntax open Lexer let keymap = Lexer.keymap [ "and" ; "bool" ; "constructor" ; "div" ; "else" ; "exists" ; "false" ; "forall" ; "if" ; "iff"; "in" ; "include"; "injective" ; "int" ; "let" ; "mod" ; "not" ; "or" ; "prop" ; "real" ; "then" ; "true" ; "with" ; ] let extend = Lexer.extend keymap let parse_recursion = ref (fun _ -> assert false) let parse_radditive = ref (fun _ -> assert false) (* -------------------------------------------------------------------------- *) (* --- Types --- *) (* -------------------------------------------------------------------------- *) let rec parse_type input = context input "type" ; match parse_typelist input with | Some [t] -> parse_polymorphic t input | Some ts -> let id = skip_ident input in parse_polymorphic (T_SORT(ts,id)) input | None -> let t = parse_simpletype input in parse_polymorphic t input and parse_simpletype input = match token input with | KEYWORD "bool" -> skip input ; T_BOOL | KEYWORD "prop" -> skip input ; T_PROP | KEYWORD "real" -> skip input ; T_REAL | KEYWORD "int" -> skip input ; T_INT | QUOTED x -> let p = skip_pos input in T_ALPHA (p,x) | IDENT x -> let p = skip_pos input in T_SORT([],(p,x)) | KEYWORD "{" -> skip input ; T_RECORD (parse_record_type input) | _ -> error input "missing type" and parse_record_type input = context input "record" ; match token input with | KEYWORD "}" -> skip input ; [] | IDENT a -> let p = skip_pos input in let f = (p,a) in skip_key input ":" ; let t = parse_type input in begin match token input with | KEYWORD "}" -> skip input ; [f,t] | KEYWORD ";" -> skip input ; (f,t)::parse_record_type input | _ -> error input "missing record field" end | _ -> error input "missing record field" and parse_typelist input = parse_list ~left:"(" ~sep:"," ~right:")" parse_type input and parse_polymorphic t input = match token input with | IDENT x -> let id = skip_pos input,x in parse_polymorphic (T_SORT([t],id)) input | KEYWORD "[" -> let ta = skip input ; if is_key input "]" then T_ARRAY(T_INT,t) else let k = parse_type input in skip_key input "]" ; T_ARRAY(k,t) in parse_polymorphic ta input | _ -> t (* -------------------------------------------------------------------------- *) (* --- Access --- *) (* -------------------------------------------------------------------------- *) let rec parse_access atom input = match token input with | KEYWORD "[" -> skip input ; let key = !parse_radditive input in let arr = if is_key input "->" then let value = !parse_radditive input in A_SET( atom , key , value ) else A_GET( atom , key ) in skip_key input "]" ; parse_access arr input | KEYWORD "." -> skip input ; let field = skip_ident input in let acc = E_GETFIELD(atom,field,Ast.fresh()) in parse_access acc input | _ -> atom (* -------------------------------------------------------------------------- *) (* --- Records --- *) (* -------------------------------------------------------------------------- *) let rec parse_fields input = let f = skip_ident input in skip_key input "=" ; let v = !parse_recursion input in parse_morefields f v input and parse_morefields f v input = let k = Ast.fresh () in if is_key input ";" then (f,k,v)::parse_fields input else [f,k,v] let parse_record parse_arguments input = match token input with | IDENT x -> let id = skip_pos input,x in let xs = parse_arguments input in if xs <> [] || token input = KEYWORD "with" then begin let r = E_FUN(id,Ast.fresh(),xs) in skip_key input "with" ; let fs = parse_fields input in E_SETFIELD(r,Ast.fresh(),fs) end else begin skip_key input "=" ; let v = !parse_recursion input in E_RECORD (fst id,parse_morefields id v input) end | KEYWORD "}" -> (* not skip! *) let pos = position input in E_RECORD(pos,[]) | _ -> let r = !parse_recursion input in skip_key input "with" ; let fs = parse_fields input in E_SETFIELD(r,Ast.fresh(),fs) (* -------------------------------------------------------------------------- *) (* --- Atoms --- *) (* -------------------------------------------------------------------------- *) let rec parse_leaf input = match token input with | INT x -> let p = skip_pos input in Some(E_INT(p,x)) | REAL x -> let p = skip_pos input in Some(E_REAL(p,x)) | IDENT "_" -> let p = skip_pos input in Some(E_ANY p) | IDENT x -> let p = skip_pos input in Some(E_FUN((p,x),Ast.fresh(),[])) | QUOTED x -> let p = skip_pos input in Some(E_PVAR(p,x)) | KEYWORD "true" -> let p = skip_pos input in Some(E_TRUE p) | KEYWORD "false" -> let p = skip_pos input in Some(E_FALSE p) | KEYWORD "(" -> skip input ; let e = !parse_recursion input in skip_key input ")" ; Some e | KEYWORD "{" -> skip input ; let e = parse_record parse_arguments input in skip_key input "}" ; Some e | _ -> None and parse_arg input = match parse_leaf input with | Some e -> Some (parse_access e input) | None -> None and parse_arguments input = context input "arguments" ; match parse_arg input with | None -> [] | Some x -> x :: parse_arguments input and parse_value input = match parse_arg input with | Some e -> e | None -> error input "Missing expression" (* -------------------------------------------------------------------------- *) (* --- Factors --- *) (* -------------------------------------------------------------------------- *) let parse_factor input = context input "factor" ; match token input with | IDENT x -> let id = skip_pos input,x in let xs = parse_arguments input in let value = E_FUN(id,Ast.fresh(),xs) in if xs<>[] then value else parse_access value input | KEYWORD "-" -> let p = skip_pos input in let a = parse_value input in E_UNA(p,OPP,a) | KEYWORD "not" -> let p = skip_pos input in let a = parse_value input in E_UNA(p,NOT,a) | _ -> parse_value input (* -------------------------------------------------------------------------- *) (* --- Divisions --- *) (* -------------------------------------------------------------------------- *) let parse_division input = let a = parse_factor input in match token input with | KEYWORD "mod" -> let p = skip_pos input in let b = parse_factor input in E_BIN(a,p,MOD,b) | KEYWORD "div" -> let p = skip_pos input in let b = parse_factor input in E_BIN(a,p,DIV,b) | _ -> a (* -------------------------------------------------------------------------- *) (* --- Multiplications --- *) (* -------------------------------------------------------------------------- *) let parse_multiplicative input = let rec pp_mult x input = match token input with | KEYWORD "*" -> let p = skip_pos input in let y = parse_division input in let z = E_BIN(x,p,MUL,y) in pp_mult z input | _ -> x in context input "multiplicative" ; pp_mult (parse_division input) input (* -------------------------------------------------------------------------- *) (* --- Additions --- *) (* -------------------------------------------------------------------------- *) let parse_additive input = let rec pp_add x input = match token input with | KEYWORD "+" -> let p = skip_pos input in let y = parse_multiplicative input in let z = E_BIN(x,p,ADD,y) in pp_add z input | KEYWORD "-" -> let p = skip_pos input in let y = parse_multiplicative input in let z = E_BIN(x,p,SUB,y) in pp_add z input | _ -> x in context input "additive" ; pp_add (parse_multiplicative input) input (* -------------------------------------------------------------------------- *) (* --- Relations --- *) (* -------------------------------------------------------------------------- *) let rec parse_ascending x input = match token input with | KEYWORD "<" -> let p = skip_pos input in let y = parse_additive input in let t = E_BIN(x,p,LT,y) in let w = parse_ascending y input in if w == y then t else E_BIN(t,p,AND,w) | KEYWORD "<=" -> let p = skip_pos input in let y = parse_additive input in let t = E_BIN(x,p,LEQ,y) in let w = parse_ascending y input in if w == y then t else E_BIN(t,p,AND,w) | _ -> x let rec parse_descending x input = match token input with | KEYWORD ">" -> let p = skip_pos input in let y = parse_additive input in let t = E_BIN(x,p,GT,y) in let w = parse_ascending y input in if w == y then t else E_BIN(t,p,ADD,w) | KEYWORD ">=" -> let p = skip_pos input in let y = parse_additive input in let t = E_BIN(x,p,GEQ,y) in let w = parse_ascending y input in if w == y then t else E_BIN(t,p,AND,w) | _ -> x let parse_relation input = context input "relation" ; let x = parse_additive input in match token input with | KEYWORD ("<" | "<=") -> (* no skip *) parse_ascending x input | KEYWORD (">" | ">=") -> (* no skip *) parse_descending x input | KEYWORD "=" -> let p = skip_pos input in let y = parse_additive input in E_BIN(x,p,EQ,y) | KEYWORD "!=" -> let p = skip_pos input in let y = parse_additive input in E_BIN(x,p,NEQ,y) | _ -> x (* -------------------------------------------------------------------------- *) (* --- Logical --- *) (* -------------------------------------------------------------------------- *) let parse_logical input = let rec pp_log x input = match token input with | KEYWORD "and" -> let p = skip_pos input in let y = parse_relation input in let z = E_BIN(x,p,AND,y) in pp_log z input | KEYWORD "or" -> let p = skip_pos input in let y = parse_relation input in let z = E_BIN(x,p,OR,y) in pp_log z input | _ -> x in context input "logical" ; let x = parse_relation input in pp_log x input let rec parse_idents input = let x = skip_ident input in if is_key input "," then x :: parse_idents input else [x] let rec parse_bindings binder input = context input "bindings" ; let xs = parse_idents input in let t = if is_key input ":" then Some(parse_type input) else None in let p = match token input with | KEYWORD "." -> skip input ; !parse_recursion input | KEYWORD "," -> skip input ; parse_bindings binder input | _ -> error input "expected '.' or ','" in List.fold_right (fun x p -> binder x t p) xs p (* -------------------------------------------------------------------------- *) (* --- Left-to-right (deductive and bindings) --- *) (* -------------------------------------------------------------------------- *) let rec parse_deductive input = context input "deductive" ; match token input with | KEYWORD "let" -> skip input ; let id = skip_ident input in let t = if is_key input ":" then Some(parse_type input) else None in skip_key input "=" ; let a = parse_deductive input in skip_key input "in" ; let b = parse_deductive input in E_LET(id,Ast.fresh(),t,a,b) | KEYWORD "if" -> skip input ; let e = parse_deductive input in skip_key input "then" ; let a = parse_deductive input in skip_key input "else" ; let b = parse_deductive input in E_IF(e,Ast.fresh(),a,b) | KEYWORD "forall" -> skip input ; parse_bindings (fun x t p -> E_FORALL(x,Ast.fresh(),t,[],p)) input | KEYWORD "exists" -> skip input ; parse_bindings (fun x t p -> E_EXISTS(x,Ast.fresh(),t,[],p)) input | _ -> let x = parse_logical input in match token input with | KEYWORD ("=>"|"->") -> let p = skip_pos input in let y = parse_deductive input in E_BIN(x,p,IMPLY,y) | KEYWORD ("<=>"|"<->") -> let p = skip_pos input in let y = parse_logical input in E_BIN(x,p,EQUIV,y) | _ -> x (* -------------------------------------------------------------------------- *) (* --- Root Expressions --- *) (* -------------------------------------------------------------------------- *) let parse_expr = parse_deductive let () = begin parse_recursion := parse_deductive ; parse_radditive := parse_additive ; end (* -------------------------------------------------------------------------- *) (* --- Declarations --- *) (* -------------------------------------------------------------------------- *) let rec parse_quoted xs input = match token input with | QUOTED a -> let p = skip_pos input in parse_quoted ((p,a)::xs) input | IDENT a -> let p = skip_pos input in List.rev xs , (p,a) | _ -> error input "expected type name or polymorphic type variable" let parse_typedef input = parse_quoted [] input let rec parse_fsig ts input = let tr = parse_type input in if is_key input "->" then parse_fsig (tr::ts) input else List.rev ts , tr let parse_signature input = parse_fsig [] input let rec parse_args input = match token input with | IDENT _ -> let x = skip_ident input in ( x , Ast.fresh () , None ) :: parse_args input | KEYWORD "(" -> skip input ; let x = skip_ident input in skip_key input ":" ; let t = parse_type input in skip_key input ")" ; ( x , Ast.fresh () , Some t ) :: parse_args input | _ -> [] let parse_category input = match token input with | KEYWORD "constructor" -> skip input ; Logic.Constructor | KEYWORD "injective" -> skip input ; Logic.Injection | _ -> Logic.Function (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/qed/src/intmap.mli0000644000175000017500000000607612155630203020553 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** Maps with integers keys using Patricia Trees. From the paper of Chris Okasaki and Andrew Gill: 'Fast Mergeable Integer Maps'. *) type 'a t val empty : 'a t val lf : int -> 'a option -> 'a t val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val is_empty : 'a t -> bool val size : 'a t -> int val mem : int -> 'a t -> bool val find : int -> 'a t -> 'a (** or raise Not_found *) val add : int -> 'a -> 'a t -> 'a t val remove : int -> 'a t -> 'a t val insert : (int -> 'a -> 'a -> 'a) -> int -> 'a -> 'a t -> 'a t val iter : ('a -> unit) -> 'a t -> unit val iteri : (int -> 'a -> unit) -> 'a t -> unit val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b val foldi : (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t val mapf : (int -> 'a -> 'b option) -> 'a t -> 'b t val filter : (int -> 'a -> bool) -> 'a t -> 'a t val intersect : 'a t -> 'b t -> bool val inter : (int -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val union : (int -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val subset : (int -> 'a -> 'b -> bool) -> 'a t -> 'b t -> bool val merge : (int -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val iter2 : (int -> 'a option -> 'b option -> unit) -> 'a t -> 'b t -> unit val iterk : (int -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit val pp_bits : Format.formatter -> int -> unit val pp_tree : string -> Format.formatter -> 'a t -> unit frama-c-Fluorine-20130601/src/wp/qed/src/listmap.ml0000644000175000017500000001273312155630203020560 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Merging List-map Functor --- *) (* -------------------------------------------------------------------------- *) module type Key = sig type t val equal : t -> t -> bool val compare : t -> t -> int end module Make(K : Key) = struct type key = K.t type 'a t = (key * 'a) list let empty = [] let rec add k v = function | [] -> [k,v] | (a::next) as w -> let c = K.compare k (fst a) in if c < 0 then (k,v) :: w else if c = 0 then (k,v) :: next else (* c > 0 *) a :: add k v next let rec findk k = function | [] -> raise Not_found | ((k0,_) as e) :: next -> let c = K.compare k k0 in if c < 0 then raise Not_found else if c > 0 then findk k next else e let find k m = snd (findk k m) let mem k m = try ignore (find k m) ; true with Not_found -> false let map f m = List.map (fun (k,v) -> k,f v) m let mapi f m = List.map (fun (k,v) -> k,f k v) m let iter f m = List.iter (fun (k,v) -> f k v) m let remove k m = List.filter (fun (k0,_) -> K.compare k k0 <> 0) m let filter f m = List.filter (fun (k,x) -> f k x) m let rec mapf f = function | [] -> [] | (k,x)::m -> match f k x with | Some y -> (k,y)::mapf f m | None -> mapf f m let rec fold f m a = match m with | (k,v)::w -> f k v (fold f w a) | [] -> a let rec union f w1 w2 = match w1 , w2 with | [] , w | w , [] -> w | ((k1,v1) as a1)::r1 , ((k2,v2) as a2)::r2 -> let c = K.compare k1 k2 in if c < 0 then a1 :: union f r1 w2 else if c > 0 then a2 :: union f w1 r2 else (k1,f k1 v1 v2) :: union f r1 r2 let rec inter f w1 w2 = match w1 , w2 with | [] , _ | _ , [] -> [] | (k1,v1)::r1 , (k2,v2)::r2 -> let c = K.compare k1 k2 in if c < 0 then inter f r1 w2 else if c > 0 then inter f w1 r2 else (k1,f k1 v1 v2) :: inter f r1 r2 let rec subset f w1 w2 = match w1 , w2 with | [] , _ -> true | _::_ , [] -> false | (k1,v1)::r1 , (k2,v2)::r2 -> let c = K.compare k1 k2 in if c < 0 then false else if c > 0 then subset f w1 r2 else (f k1 v1 v2 && subset f r1 r2) let rec equal eq w1 w2 = match w1 , w2 with | [] , [] -> true | [] , _::_ | _::_ , [] -> false | (k1,v1)::r1 , (k2,v2)::r2 -> K.equal k1 k2 && eq v1 v2 && equal eq r1 r2 let rec iterk (f : K.t -> 'a -> 'b -> unit) (w1 : (K.t * 'a) list) (w2 : (K.t * 'b) list) = match w1 , w2 with | [] , _ | _ , [] -> () | (k1,v1)::r1 , (k2,v2)::r2 -> let c = K.compare k1 k2 in if c < 0 then iterk f r1 w2 else if c > 0 then iterk f w1 r2 else (f k1 v1 v2 ; iterk f r1 r2) let rec iter2 (f : K.t -> 'a option -> 'b option -> unit) (w1 : (K.t * 'a) list) (w2 : (K.t * 'b) list) = match w1 , w2 with | [] , [] -> () | _ , [] -> List.iter (fun (k1,v1) -> f k1 (Some v1) None) w1 | [] , _ -> List.iter (fun (k2,v2) -> f k2 None (Some v2)) w2 | (k1,v1)::r1 , (k2,v2)::r2 -> let c = K.compare k1 k2 in if c < 0 then (f k1 (Some v1) None ; iter2 f r1 w2) else if c > 0 then (f k2 None (Some v2) ; iter2 f w1 r2) else (f k1 (Some v1) (Some v2) ; iter2 f r1 r2) let cons k v w = match v with | None -> w | Some x -> (k,x) :: w let rec merge (f : K.t -> 'a option -> 'b option -> 'c option) w1 w2 = match w1 , w2 with | [] , [] -> [] | _ , [] -> mapf (fun k1 v1 -> f k1 (Some v1) None) w1 | [] , _ -> mapf (fun k2 v2 -> f k2 None (Some v2)) w2 | (k1,v1)::r1 , (k2,v2)::r2 -> let c = K.compare k1 k2 in if c < 0 then cons k1 (f k1 (Some v1) None) (merge f r1 w2) else if c > 0 then cons k2 (f k2 None (Some v2)) (merge f w1 r2) else cons k1 (f k1 (Some v1) (Some v2)) (merge f r1 r2) end frama-c-Fluorine-20130601/src/wp/qed/src/export_coq.mli0000644000175000017500000000405612155630203021442 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Logic open Format open Plib open Linker (** Exportation Engine for Coq. Provides a full {{:Export.S.engine-c.html}engine} from a {{:Export.S.linker-c.html}linker}. *) module Make(T : Term) : sig open T class virtual engine : object inherit [ADT.t,Field.t,Fun.t,tau,var,term] Engine.engine method op_spaced : string -> bool method declare_fixpoint : prefix:string -> formatter -> Fun.t -> var list -> tau -> term -> unit end end frama-c-Fluorine-20130601/src/wp/LogicSemantics.ml0000644000175000017500000007254612155630215020466 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- ACSL Translation --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Cil_datatype open LogicBuiltins open Clabels open Ctypes open Lang open Lang.F open Definitions open Memory module Make(M : Memory.Model) = struct open M type loc = M.loc type value = loc Memory.value type logic = loc Memory.logic type region = loc sloc list type sigma = Sigma.t module L = Cvalues.Logic(M) module C = LogicCompiler.Make(M) (* -------------------------------------------------------------------------- *) (* --- Frames --- *) (* -------------------------------------------------------------------------- *) type frame = C.frame let pp_frame = C.pp_frame let get_frame = C.get_frame let in_frame = C.in_frame let mem_frame = C.mem_frame let mem_at_frame = C.mem_at_frame let mem_at = C.mem_at let frame = C.frame let frame_copy = C.frame_copy let call_pre = C.call_pre let call_post = C.call_post let return = C.return let result = C.result let status = C.status let guards = C.guards (* -------------------------------------------------------------------------- *) (* --- Debugging --- *) (* -------------------------------------------------------------------------- *) let pp_logic fmt = function | Vexp e -> F.pp_term fmt e | Vloc l -> M.pretty fmt l | Lset _ | Vset _ -> Format.pp_print_string fmt "" let pp_bound fmt = function None -> () | Some p -> F.pp_term fmt p let pp_sloc fmt = function | Sloc l -> M.pretty fmt l | Sarray(l,_,s) -> Format.fprintf fmt "@[%a@,+[%s]@]" M.pretty l (Int64.to_string s) | Srange(l,_,a,b) -> Format.fprintf fmt "@[%a@,+(%a@,..%a)@]" M.pretty l pp_bound a pp_bound b | Sdescr _ -> Format.fprintf fmt "" let pp_region fmt sloc = List.iter (fun s -> Format.fprintf fmt "@ %a" pp_sloc s) sloc (* -------------------------------------------------------------------------- *) (* --- Translation Environment & Recursion --- *) (* -------------------------------------------------------------------------- *) type env = C.env let new_env = C.new_env let move = C.move let sigma = C.sigma let call s = C.move (C.new_env []) s let logic_of_value = function | Val e -> Vexp e | Loc l -> Vloc l let loc_of_term env t = match C.logic env t with | Vexp e -> M.pointer_loc e | Vloc l -> l | _ -> Wp_parameters.abort ~current:true "Unexpected set (%a)" Printer.pp_term t let val_of_term env t = match C.logic env t with | Vexp e -> e | Vloc l -> M.pointer_val l | _ -> Wp_parameters.abort ~current:true "Unexpected set (%a)" Printer.pp_term t let set_of_term env t = let v = C.logic env t in match v with | Vexp s when Logic_typing.is_set_type t.term_type -> let te = Logic_typing.type_of_set_elem t.term_type in [Vset.Set(tau_of_ltype te,s)] | _ -> L.vset v let collection_of_term env t = let v = C.logic env t in match v with | Vexp s when Logic_typing.is_set_type t.term_type -> let te = Logic_typing.type_of_set_elem t.term_type in Vset [Vset.Set(tau_of_ltype te,s)] | w -> w let term env t = match C.logic env t with | Vexp e -> e | Vloc l -> M.pointer_val l | s -> Vset.concretize (L.vset s) (* -------------------------------------------------------------------------- *) (* --- Accessing an Offset (sub field-index in a compound) --- *) (* -------------------------------------------------------------------------- *) let rec access_offset env (v:logic) = function | TNoOffset -> v | TModel _ -> Wp_parameters.not_yet_implemented "Model field" | TField(f,offset) -> let v_f = L.map (fun r -> e_getfield r (Cfield f)) v in access_offset env v_f offset | TIndex(k,offset) -> let rk = C.logic env k in let v_k = L.apply e_get v rk in access_offset env v_k offset (* -------------------------------------------------------------------------- *) (* --- Updating an Offset (sub field-index in a compound) --- *) (* -------------------------------------------------------------------------- *) let rec update_offset env (r:term) offset (v:term) = match offset with | TNoOffset -> v | TModel _ -> Wp_parameters.not_yet_implemented "Model field" | TField(f,offset) -> let r_f = e_getfield r (Cfield f) in let r_fv = update_offset env r_f offset v in e_setfield r (Cfield f) r_fv | TIndex(k,offset) -> let k = val_of_term env k in let r_kv = update_offset env (e_get r k) offset v in e_set r k r_kv (* -------------------------------------------------------------------------- *) (* --- Shifting Location of an Offset (pointer shift) --- *) (* -------------------------------------------------------------------------- *) (* typ is logic-type of (load v) *) let rec shift_offset env typ (v:logic) = function | TNoOffset -> typ , v | TModel _ -> Wp_parameters.not_yet_implemented "Model field" | TField(f,offset) -> shift_offset env f.ftype (L.field v f) offset | TIndex(k,offset) -> let te = Cil.typeOf_array_elem typ in let size = Ctypes.array_size typ in let obj = Ctypes.object_of te in let vloc = L.shift v obj ?size (C.logic env k) in shift_offset env te vloc offset (* -------------------------------------------------------------------------- *) (* --- --- *) (* -------------------------------------------------------------------------- *) type lv_value = | VAL of logic | VAR of varinfo let logic_var env lv = match lv.lv_origin with | None -> VAL (C.logic_var env lv) | Some x -> if x.vformal then match C.formal x with | Some v -> VAL (logic_of_value v) | None -> VAR x else VAR x (* -------------------------------------------------------------------------- *) (* --- Term L-Values (this means 'loading' the l-value) --- *) (* -------------------------------------------------------------------------- *) let load_loc env typ loc loffset = let te,lp = shift_offset env typ (Vloc loc) loffset in L.load (C.sigma env) (Ctypes.object_of te) lp let term_lval env (lhost,loffset) = match lhost with | TResult _ -> let r = C.result () in access_offset env (Vexp (e_var r)) loffset | TMem e -> let te = Logic_typing.ctype_of_pointed e.term_type in let te , lp = shift_offset env te (C.logic env e) loffset in L.load (C.sigma env) (Ctypes.object_of te) lp | TVar{lv_name="\\exit_status"} -> assert (loffset = TNoOffset) ; (* int ! *) Vexp (e_var (C.status ())) | TVar lv -> begin match logic_var env lv with | VAL v -> access_offset env v loffset | VAR x -> load_loc env x.vtype (M.cvar x) loffset end (* -------------------------------------------------------------------------- *) (* --- Address of L-Values --- *) (* -------------------------------------------------------------------------- *) let addr_lval env (lhost,loffset) = match lhost with | TResult _ -> Wp_parameters.fatal "Address of \\result" | TMem e -> let te = Logic_typing.ctype_of_pointed e.term_type in snd (shift_offset env te (C.logic env e) loffset) | TVar lv -> begin match logic_var env lv with | VAL v -> Wp_parameters.fatal "Address of logic value (%a)@." pp_logic v | VAR x -> snd (shift_offset env x.vtype (Vloc (M.cvar x)) loffset) end (* -------------------------------------------------------------------------- *) (* --- Unary Operators --- *) (* -------------------------------------------------------------------------- *) (* Only integral *) let term_unop = function | Neg -> L.map_opp | BNot -> L.map Cint.l_not | LNot -> L.map e_not (* -------------------------------------------------------------------------- *) (* --- Equality --- *) (* -------------------------------------------------------------------------- *) type eqsort = | EQ_set | EQ_loc | EQ_plain | EQ_array of Matrix.matrix | EQ_comp of compinfo | EQ_incomparable let eqsort_of_type t = match Logic_utils.unroll_type t with | Ltype({lt_name="set"},[_]) -> EQ_set | Linteger | Lreal | Lvar _ | Larrow _ | Ltype _ -> EQ_plain | Ctype t -> match Ctypes.object_of t with | C_pointer _ -> EQ_loc | C_int _ | C_float _ -> EQ_plain | C_comp c -> EQ_comp c | C_array a -> EQ_array (Matrix.of_array a) let eqsort_of_comparison a b = match eqsort_of_type a.term_type , eqsort_of_type b.term_type with | EQ_set , _ | _ , EQ_set -> EQ_set | EQ_loc , EQ_loc -> EQ_loc | EQ_comp c1 , EQ_comp c2 -> if Compinfo.equal c1 c2 then EQ_comp c1 else EQ_incomparable | EQ_array (t1,d1) , EQ_array (t2,d2) -> if Ctypes.equal t1 t2 then match Matrix.merge d1 d2 with | Some d -> EQ_array(t1,d) | None -> EQ_incomparable else EQ_incomparable | EQ_plain , EQ_plain -> EQ_plain | _ -> EQ_incomparable let use_equal positive = not positive && Wp_parameters.ExtEqual.get () let term_equal positive env a b = match eqsort_of_comparison a b with | EQ_set -> let sa = set_of_term env a in let sb = set_of_term env b in (* TODO: should be parametric in the equality of elements *) Vset.equal sa sb | EQ_loc -> let la = loc_of_term env a in let lb = loc_of_term env b in M.loc_eq la lb | EQ_comp c -> let va = val_of_term env a in let vb = val_of_term env b in if use_equal positive then p_equal va vb else Cvalues.equal_comp c va vb | EQ_array m -> let va = val_of_term env a in let vb = val_of_term env b in if use_equal positive then p_equal va vb else Cvalues.equal_array m va vb | EQ_plain -> p_equal (val_of_term env a) (val_of_term env b) | EQ_incomparable -> (* incomparrable terms *) Wp_parameters.warning ~current:true "@[Incomparable terms (comparison is False):@ type %a with@ type %a@]" Printer.pp_logic_type a.term_type Printer.pp_logic_type b.term_type ; p_false let term_diff positive env a b = p_not (term_equal (not positive) env a b) let compare_term env vrel lrel a b = if Logic_typing.is_pointer_type a.term_type then lrel (loc_of_term env a) (loc_of_term env b) else vrel (val_of_term env a) (val_of_term env b) (* -------------------------------------------------------------------------- *) (* --- Term Comparison --- *) (* -------------------------------------------------------------------------- *) let exp_equal env a b = Vexp(e_prop (term_equal true env a b)) let exp_diff env a b = Vexp(e_prop (term_diff true env a b)) let exp_compare env vrel lrel a b = Vexp(e_prop (compare_term env vrel lrel a b)) (* -------------------------------------------------------------------------- *) (* --- Binary Operators --- *) (* -------------------------------------------------------------------------- *) let toreal t v = if t then L.map Cfloat.real_of_int v else v let arith env fint freal a b = let va = C.logic env a in let vb = C.logic env b in let ta = Logic_typing.is_integral_type a.term_type in let tb = Logic_typing.is_integral_type b.term_type in if ta && tb then fint va vb else freal (toreal ta va) (toreal tb vb) let term_binop env binop a b = match binop with | PlusA -> arith env L.apply_add (L.apply Cfloat.radd) a b | MinusA -> arith env L.apply_sub (L.apply Cfloat.rsub) a b | Mult -> arith env (L.apply e_mul) (L.apply Cfloat.rmul) a b | Div -> arith env (L.apply e_div) (L.apply Cfloat.rdiv) a b | Mod -> L.apply e_mod (C.logic env a) (C.logic env b) | PlusPI | IndexPI -> let va = C.logic env a in let vb = C.logic env b in let te = Logic_typing.ctype_of_pointed a.term_type in L.shift va (Ctypes.object_of te) vb | MinusPI -> let va = C.logic env a in let vb = C.logic env b in let te = Logic_typing.ctype_of_pointed a.term_type in L.shift va (Ctypes.object_of te) (L.map_opp vb) | MinusPP -> let te = Logic_typing.ctype_of_pointed a.term_type in let la = loc_of_term env a in let lb = loc_of_term env b in Vexp(M.loc_diff (Ctypes.object_of te) la lb) | Shiftlt -> L.apply Cint.l_lsl (C.logic env a) (C.logic env b) | Shiftrt -> L.apply Cint.l_lsr (C.logic env a) (C.logic env b) | BAnd -> L.apply Cint.l_and (C.logic env a) (C.logic env b) | BXor -> L.apply Cint.l_xor (C.logic env a) (C.logic env b) | BOr -> L.apply Cint.l_or (C.logic env a) (C.logic env b) | LAnd -> Vexp(e_and [val_of_term env a;val_of_term env b]) | LOr -> Vexp(e_or [val_of_term env a;val_of_term env b]) | Lt -> exp_compare env p_lt M.loc_lt a b | Gt -> exp_compare env p_lt M.loc_lt b a | Le -> exp_compare env p_leq M.loc_leq a b | Ge -> exp_compare env p_leq M.loc_leq b a | Eq -> exp_equal env a b | Ne -> exp_diff env a b (* -------------------------------------------------------------------------- *) (* --- Term Cast --- *) (* -------------------------------------------------------------------------- *) type cvsort = | L_real | L_integer | L_cint of c_int | L_cfloat of c_float | L_pointer of typ let rec cvsort_of_type t = match Logic_utils.unroll_type t with | Ltype({lt_name="set"},[t]) -> cvsort_of_type t | Linteger -> L_integer | Lreal -> L_real | Ctype c -> begin match Ctypes.object_of c with | C_int i -> L_cint i | C_float f -> L_cfloat f | C_pointer te -> L_pointer te | C_array a -> L_pointer a.arr_element | obj -> Warning.error "cast from (%a) not yet implemented" Ctypes.pretty obj end | _ -> Warning.error "cast from (%a) not yet implemented" Printer.pp_logic_type t let term_cast env typ t = match Ctypes.object_of typ , cvsort_of_type t.term_type with | C_int i , L_cint i0 -> let v = C.logic env t in if (Ctypes.sub_c_int i0 i) then v else L.map (Cint.iconvert i) v | C_int i , L_integer -> L.map (Cint.iconvert i) (C.logic env t) | C_int i , L_pointer _ -> L.map_l2t (M.int_of_loc i) (C.logic env t) | C_int i , (L_cfloat _ | L_real) -> L.map (Cint.of_real i) (C.logic env t) | C_float f , (L_cfloat _ | L_real) -> L.map (Cfloat.fconvert f) (C.logic env t) | C_float f , (L_cint _ | L_integer) -> L.map (Cfloat.float_of_int f) (C.logic env t) | C_pointer ty , L_pointer t0 -> let value = C.logic env t in let o_src = Ctypes.object_of t0 in let o_dst = Ctypes.object_of ty in if Ctypes.compare o_src o_dst = 0 then value else L.map_loc (M.cast { pre=o_src ; post=o_dst }) value | C_pointer ty , (L_integer | L_cint _) -> let obj = Ctypes.object_of ty in L.map_t2l (M.loc_of_int obj) (C.logic env t) | _ -> Warning.error "Cast from (%a) to (%a) not yet implemented" Printer.pp_typ typ Printer.pp_logic_type t.term_type (* -------------------------------------------------------------------------- *) (* --- Environment Binding --- *) (* -------------------------------------------------------------------------- *) let bind_quantifiers (env:env) qs = let rec acc xs env hs = function | [] -> List.rev xs , env , hs | v::vs -> let t = Lang.tau_of_ltype v.lv_type in let x = Lang.freshvar ~basename:v.lv_name t in let h = Cvalues.has_ltype v.lv_type (e_var x) in let e = C.env_let env v (Vexp (e_var x)) in acc (x::xs) e (h::hs) vs in acc [] env [] qs (* -------------------------------------------------------------------------- *) (* --- Term Nodes --- *) (* -------------------------------------------------------------------------- *) let rec term_node (env:env) t = match t.term_node with | TConst c -> Vexp (Cvalues.logic_constant c) | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ -> Vexp (Cvalues.constant_term t) | TLval lval -> term_lval env lval | TAddrOf lval | TStartOf lval -> addr_lval env lval | TUnOp(Neg,t) when not (Logic_typing.is_integral_type t.term_type) -> L.map Cfloat.ropp (C.logic env t) | TUnOp(unop,t) -> term_unop unop (C.logic env t) | TBinOp(binop,a,b) -> term_binop env binop a b | TCastE(ty,t) -> term_cast env ty t | Tapp(f,ls,ts) -> begin match LogicBuiltins.logic f with | ACSLDEF -> let es = List.map (val_of_term env) ts in Vexp( C.call_fun env f ls es ) | CONST e -> Vexp e | LFUN phi -> let vs = List.map (val_of_term env) ts in Vexp( e_fun phi vs ) end | Tlambda _ -> Warning.error "Lambda-functions not yet implemented" | TDataCons(c,ts) -> let es = List.map (val_of_term env) ts in begin match LogicBuiltins.ctor c with | ACSLDEF -> Vexp( e_fun (CTOR c) es ) | CONST e -> Vexp e | LFUN phi -> Vexp( e_fun phi es ) end | Tif( cond , a , b ) -> let c = val_of_term env cond in let a = val_of_term env a in let b = val_of_term env b in Vexp (e_if c a b) | Tat( t , label ) -> let clabel = Clabels.c_label label in C.logic (C.env_at env clabel) t | Tbase_addr (label,t) -> ignore label ; L.map_loc M.base_addr (C.logic env t) | Toffset (label, _t) -> ignore label ; Warning.error "Offset construct not implemented yet" | Tblock_length (label,t) -> let obj = object_of (Logic_typing.ctype_of_pointed t.term_type) in let sigma = C.mem_at env (c_label label) in L.map_l2t (M.block_length sigma obj) (C.logic env t) | Tnull -> Vloc M.null | TCoerce (_,_) | TCoerceE (_,_) -> Wp_parameters.fatal "Jessie constructs" | TUpdate(a,offset,b) -> Vexp (update_offset env (val_of_term env a) offset (val_of_term env b)) | Tempty_set -> Vset [] | Tunion ts -> L.union t.term_type (List.map (collection_of_term env) ts) | Tinter ts -> L.inter t.term_type (List.map (collection_of_term env) ts) | Tcomprehension(t,qs,cond) -> begin let xs,env,domain = bind_quantifiers env qs in let condition = match cond with | None -> p_conj domain | Some p -> let p = Lang.without_assume (C.pred true env) p in p_conj (p :: domain) in match C.logic env t with | Vexp e -> Vset[Vset.Descr(xs,e,condition)] | Vloc l -> Lset[Sdescr(xs,l,condition)] | _ -> Wp_parameters.fatal "comprehension set of sets" end | Tlet( { l_var_info=v ; l_body=LBterm a } , b ) -> let va = C.logic env a in C.logic (C.env_let env v va) b | Tlet _ -> Warning.error "Complex let-binding not implemented yet (%a)" Printer.pp_term t | Trange(a,b) -> let bound env = function | None -> None | Some x -> Some (val_of_term env x) in Vset(Vset.range (bound env a) (bound env b)) | Ttypeof _ | Ttype _ -> Warning.error "Type tag not implemented yet" | TLogic_coerce(_,t) -> term_node env t (* -------------------------------------------------------------------------- *) (* --- Separated --- *) (* -------------------------------------------------------------------------- *) let separated_terms env ts = L.separated begin List.map (fun t -> let te = Logic_typing.ctype_of_pointed t.term_type in let obj = Ctypes.object_of te in obj , L.sloc (C.logic env t) ) ts end (* -------------------------------------------------------------------------- *) (* --- Relations --- *) (* -------------------------------------------------------------------------- *) let relation positive env rel a b = match rel with | Rlt -> compare_term env p_lt M.loc_lt a b | Rgt -> compare_term env p_lt M.loc_lt b a | Rle -> compare_term env p_leq M.loc_leq a b | Rge -> compare_term env p_leq M.loc_leq b a | Req -> term_equal positive env a b | Rneq -> term_diff positive env a b (* -------------------------------------------------------------------------- *) (* --- Predicates --- *) (* -------------------------------------------------------------------------- *) let valid env acs label t = let te = Logic_typing.ctype_of_pointed t.term_type in let sigma = C.mem_at env (Clabels.c_label label) in let addrs = C.logic env t in L.valid sigma acs (Ctypes.object_of te) (L.sloc addrs) let predicate positive env p = match p.content with | Pfalse -> p_false | Ptrue -> p_true | Pseparated ts -> separated_terms env ts | Prel(rel,a,b) -> relation positive env rel a b | Pand(a,b) -> p_and (C.pred positive env a) (C.pred positive env b) | Por(a,b) -> p_or (C.pred positive env a) (C.pred positive env b) | Pxor(a,b) -> p_not (p_equiv (C.pred positive env a) (C.pred positive env b)) | Pimplies(a,b) -> p_imply (C.pred (not positive) env a) (C.pred positive env b) | Piff(a,b) -> p_equiv (C.pred positive env a) (C.pred positive env b) | Pnot a -> p_not (C.pred (not positive) env a) | Pif(t,a,b) -> p_if (p_bool (val_of_term env t)) (C.pred positive env a) (C.pred positive env b) | Papp(f,ls,ts) -> begin match LogicBuiltins.logic f with | ACSLDEF -> let es = List.map (val_of_term env) ts in C.call_pred env f ls es | CONST e -> p_bool e | LFUN phi -> let vs = List.map (val_of_term env) ts in p_call phi vs end | Plet( { l_var_info=v ; l_body=LBterm a } , p ) -> let va = C.logic env a in C.pred positive (C.env_let env v va) p | Plet _ -> Warning.error "Complex let-inding not implemented yet (%a)" Printer.pp_predicate_named p | Pforall(qs,p) -> let xs,env,hs = bind_quantifiers env qs in let p = Lang.without_assume (C.pred positive env) p in p_forall xs (p_hyps hs p) | Pexists(qs,p) -> let xs,env,hs = bind_quantifiers env qs in let p = Lang.without_assume (C.pred positive env) p in p_exists xs (p_conj (p :: hs)) | Pat(p,label) -> let clabel = Clabels.c_label label in C.pred positive (C.env_at env clabel) p | Pvalid(label,t) -> valid env RW label t | Pvalid_read(label,t) -> valid env RD label t | Pallocable _ | Pfreeable _ | Pfresh _ | Pinitialized _ -> Warning.error "Allocable, Freeable, Valid_read, Fresh and Initialized not yet implemented (%a)" Printer.pp_predicate_named p | Psubtype _ -> Warning.error "Type tags not implemented yet" (* -------------------------------------------------------------------------- *) (* --- Set of locations for a term representing a set of l-values --- *) (* -------------------------------------------------------------------------- *) let assignable_lval env lv = match fst lv with | TResult _ -> [] (* special case ! *) | _ -> L.sloc (addr_lval env lv) let assignable env t = match t.term_node with | Tempty_set -> [] | TLval lv | TStartOf lv -> assignable_lval env lv | Tunion ts -> List.concat (List.map (C.region env) ts) | Tinter _ -> Warning.error "Intersection in assigns not implemented yet" | Tcomprehension(t,qs,cond) -> begin let xs,env,domain = bind_quantifiers env qs in let conditions = match cond with | None -> domain | Some p -> C.pred true env p :: domain in List.map (function | Sloc l -> Sdescr(xs,l,p_conj conditions) | (Sarray _ | Srange _ | Sdescr _) as sloc -> let ys,l,extend = L.rdescr sloc in Sdescr(xs@ys,l,p_conj (extend :: conditions)) ) (C.region env t) end | Tat(t,label) -> C.region (C.env_at env (Clabels.c_label label)) t | Tlet( { l_var_info=v ; l_body=LBterm a } , b ) -> let va = C.logic env a in C.region (C.env_let env v va) b | Tlet _ -> Warning.error "Complex let-binding not implemented yet (%a)" Printer.pp_term t | TCastE(_,t) -> C.region env t | TLogic_coerce(_,t) -> C.region env t | TBinOp _ | TUnOp _ | Trange _ | TUpdate _ | Tapp _ | Tif _ | TConst _ | Tnull | TDataCons _ | Tlambda _ | Ttype _ | Ttypeof _ | TAlignOfE _ | TAlignOf _ | TSizeOfStr _ | TSizeOfE _ | TSizeOf _ | Tblock_length _ | Tbase_addr _ | Toffset _ | TAddrOf _ -> Wp_parameters.fatal "Non-assignable term (%a)" Printer.pp_term t | TCoerce (_,_) | TCoerceE (_,_) -> Wp_parameters.fatal "Jessie constructs" (* -------------------------------------------------------------------------- *) (* --- Boot Strapping --- *) (* -------------------------------------------------------------------------- *) let term_trigger env t = let v = term_node env t in if List.mem "TRIGGER" t.term_name then begin match v with | Vexp e -> C.trigger (Trigger.of_term e) | Vloc l -> C.trigger (Trigger.of_term (M.pointer_val l)) | _ -> Wp_parameters.warning ~current:true "Can not trigger on tset" end ; v let pred_trigger positive env np = let p = predicate positive env np in if List.mem "TRIGGER" np.Cil_types.name then C.trigger (Trigger.of_pred p) ; p let pred ~positive env p = Context.with_current_loc p.loc (pred_trigger positive env) p let logic env t = Context.with_current_loc t.term_loc (term_trigger env) t let region env t = Context.with_current_loc t.term_loc (assignable env) t let () = C.bootstrap_pred (fun positive env p -> pred ~positive env p) let () = C.bootstrap_term term let () = C.bootstrap_logic logic let () = C.bootstrap_region region let lemma = C.lemma (* -------------------------------------------------------------------------- *) (* --- Regions --- *) (* -------------------------------------------------------------------------- *) let assigns_from env froms = List.map (fun ({it_content=wr},_deps) -> object_of_logic_type wr.term_type , region env wr) froms let assigns env = function | WritesAny -> None | Writes froms -> Some (assigns_from env froms) let valid = L.valid let included = L.included let separated = L.separated let occurs_opt x = function None -> false | Some t -> F.occurs x t let occurs_sloc x = function | Sloc l -> M.occurs x l | Sarray(l,_,_) -> M.occurs x l | Srange(l,_,a,b) -> M.occurs x l || occurs_opt x a || occurs_opt x b | Sdescr(xs,l,p) -> if List.exists (Var.equal x) xs then false else (M.occurs x l || F.occursp x p) let occurs x = List.exists (occurs_sloc x) let vars_opt = function None -> Vars.empty | Some t -> F.vars t let vars_sloc = function | Sloc l | Sarray(l,_,_) -> M.vars l | Srange(l,_,a,b) -> Vars.union (M.vars l) (Vars.union (vars_opt a) (vars_opt b)) | Sdescr(xs,l,p) -> List.fold_left (fun xs x -> Vars.remove x xs) (Vars.union (M.vars l) (F.varsp p)) xs let vars sloc = List.fold_left (fun xs s -> Vars.union xs (vars_sloc s)) Vars.empty sloc end frama-c-Fluorine-20130601/src/wp/mcfg.mli0000644000175000017500000001277712155630215016647 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 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 : bool -> 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_env type t_prop val pretty : Format.formatter -> t_prop -> unit val merge : t_env -> t_prop -> t_prop -> t_prop val empty : t_prop (** 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 -> LogicUsage.logic_lemma -> 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 -> stmt option -> WpPropId.prop_id option -> WpPropId.assigns_desc -> t_prop -> t_prop val label : t_env -> Clabels.c_label -> t_prop -> t_prop val assign : t_env -> stmt -> lval -> exp -> t_prop -> t_prop val return : t_env -> stmt -> exp option -> t_prop -> t_prop val test : t_env -> stmt -> exp -> t_prop -> t_prop -> t_prop val switch : t_env -> stmt -> 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 < b *) val loop_entry : t_prop -> t_prop val loop_step : 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 val close : t_env -> t_prop -> t_prop (* -------------------------------------------------------------------------- *) (* --- FROM --- *) (* -------------------------------------------------------------------------- *) (** build [p => alpha(p)] for functional dependencies verification. *) val build_prop_of_from : t_env -> WpPropId.pred_info list -> t_prop -> t_prop end frama-c-Fluorine-20130601/src/wp/Cvalues.ml0000644000175000017500000005262112155630215017154 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Lifting Operations over Memory Values --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Ctypes open Qed open Lang open Lang.F open Memory open Definitions (* -------------------------------------------------------------------------- *) (* --- C Constants --- *) (* -------------------------------------------------------------------------- *) let rec constant = function | CInt64(z,_,_) -> e_bigint z | CChr c -> e_int64 (Ctypes.char c) | CReal(f,_,_) -> Cfloat.code_lit f | CEnum e -> constant_exp e.eival | CStr _ | CWStr _ -> Warning.error "String constants not yet implemented" and logic_constant = function | Integer(z,_) -> e_bigint z | LChr c -> e_int64 (Ctypes.char c) | LReal r -> Cfloat.acsl_lit r | LEnum e -> constant_exp e.eival | LStr _ | LWStr _ -> Warning.error "String constants not yet implemented" and constant_exp e = let e = Cil.constFold true e in match e.enode with | Const c -> constant c | _ -> Warning.error "constant(%a)" Printer.pp_exp e and constant_term t = let e = Cil.constFoldTerm true t in match e.term_node with | TConst c -> logic_constant c | _ -> Warning.error "constant(%a)" Printer.pp_term t (* -------------------------------------------------------------------------- *) (* The type contains C-integers *) let rec is_constrained ty = match Ctypes.object_of ty with | C_int _ -> true | C_float _ -> false | C_pointer _ -> false | C_array a -> is_constrained a.arr_element | C_comp c -> is_constrained_comp c and is_constrained_comp c = List.exists (fun f -> is_constrained f.ftype) c.cfields module type CASES = sig val prefix : string val model : Cint.model (* Natural : all types are constrained, but only with their natural values *) (* Machine : only atomic types are constrained *) val is_int : c_int -> term -> pred val is_float : c_float -> term -> pred val is_pointer : term -> pred end module STRUCTURAL(C : CASES) = struct let constrained_elt ty = match C.model with | Cint.Natural -> true | Cint.Machine -> is_constrained ty let constrained_comp c = match C.model with | Cint.Natural -> true | Cint.Machine -> is_constrained_comp c let model_int fmt i = match C.model with | Cint.Natural -> Format.pp_print_string fmt "int" | Cint.Machine -> Ctypes.pp_int fmt i let array_name te ds = let dim = List.length ds in match te with | C_int i -> Pretty_utils.sfprintf "%sArray%d_%a" C.prefix dim model_int i | C_float _ -> Pretty_utils.sfprintf "%sArray%d_float" C.prefix dim | C_pointer _ -> Pretty_utils.sfprintf "%sArray%d_pointer" C.prefix dim | C_comp c -> Pretty_utils.sfprintf "%sArray%d%s" C.prefix dim (Lang.comp_id c) | C_array _ -> Wp_parameters.fatal "Unflatten array (%s %a)" C.prefix Ctypes.pretty te let rec is_obj obj t = match obj with | C_int i -> C.is_int i t | C_float f -> C.is_float f t | C_pointer _ty -> C.is_pointer t | C_comp c -> if constrained_comp c then is_record c t else p_true | C_array a -> if constrained_elt a.arr_element then let te,ds = Ctypes.array_dimensions a in is_array te ds t else p_true and is_typ typ t = is_obj (Ctypes.object_of typ) t and is_record c s = Definitions.call_pred (Lang.generated_p (C.prefix ^ Lang.comp_id c)) (fun lfun -> let basename = if c.cstruct then "S" else "U" in let s = Lang.freshvar ~basename (Lang.tau_of_comp c) in let def = p_all (fun f -> is_typ f.ftype (e_getfield (e_var s) (Lang.Cfield f))) c.cfields in { d_lfun = lfun ; d_types = 0 ; d_params = [s] ; d_cluster = Definitions.compinfo c ; d_definition = Predicate(Def,def) ; }) [s] and is_array te ds t = Definitions.call_pred (Lang.generated_p (array_name te ds)) (fun lfun -> let x = Lang.freshvar ~basename:"T" (Matrix.tau te ds) in let ks = List.map (fun _d -> Lang.freshvar ~basename:"k" Logic.Int) ds in let e = List.fold_left (fun a k -> e_get a (e_var k)) (e_var x) ks in let def = p_forall ks (is_obj te e) in { d_lfun = lfun ; d_types = 0 ; d_params = [x] ; d_cluster = Definitions.matrix te ; d_definition = Predicate(Def,def) ; } ) [t] end (* -------------------------------------------------------------------------- *) (* --- Null-Values --- *) (* -------------------------------------------------------------------------- *) let null = Context.create "Lang.null" module NULL = STRUCTURAL (struct let prefix = "Null" let model = Cint.Natural let is_int _i = p_equal e_zero let is_float _f = p_equal e_zero_real let is_pointer p = Context.get null p end) let is_null = NULL.is_obj module TYPE = STRUCTURAL (struct let prefix = "Is" let model = Cint.Machine let is_int = Cint.irange let is_float = Cfloat.frange let is_pointer _ = p_true end) let has_ctype = TYPE.is_typ let has_ltype ltype e = match Logic_utils.unroll_type ltype with | Ctype typ -> has_ctype typ e | Ltype _ | Lvar _ | Linteger | Lreal | Larrow _ -> p_true let is_object obj = function | Loc _ -> p_true | Val e -> TYPE.is_obj obj e let cdomain typ = if is_constrained typ then Some(has_ctype typ) else None let ldomain ltype = match Logic_utils.unroll_type ltype with | Ctype typ -> cdomain typ | Ltype _ | Lvar _ | Linteger | Lreal | Larrow _ -> None (* -------------------------------------------------------------------------- *) (* --- ACSL Equality --- *) (* -------------------------------------------------------------------------- *) let s_eq = ref (fun _ _ _ -> assert false) (* recursion for equal_object *) module EQARRAY = Model.Generator(Matrix.NATURAL) (struct open Matrix type key = matrix type data = Lang.lfun let name = "Cvalues.EqArray" let compile (te,ds) = let lfun = Lang.generated_f "EqArray%s_%s" (Matrix.id ds) (Matrix.natural_id te) in let cluster = Definitions.matrix te in let denv = Matrix.denv ds in let tau = Matrix.tau te ds in let xa = Lang.freshvar ~basename:"T" tau in let xb = Lang.freshvar ~basename:"T" tau in let ta = e_var xa in let tb = e_var xb in let ta_xs = List.fold_left e_get ta denv.index_val in let tb_xs = List.fold_left e_get tb denv.index_val in let eq = p_call lfun (denv.size_val @ [ta ; tb]) in let property = p_hyps (denv.index_range) (!s_eq te ta_xs tb_xs) in let definition = p_forall denv.index_var property in (* Definition of the symbol *) Definitions.define_symbol { d_lfun = lfun ; d_types = 0 ; d_params = denv.size_var @ [xa ; xb ] ; d_definition = Predicate(Def,definition) ; d_cluster = cluster ; } ; (* Extensionnal Definition (with triggers) *) let name = Printf.sprintf "EqArrayExt%s_%s" (Matrix.id ds) (Matrix.natural_id te) in Definitions.define_lemma { l_name = name ; l_cluster = cluster ; l_types = 0 ; l_forall = denv.size_var @ [xa ; xb ] @ denv.index_var ; l_assumed = true ; l_triggers = [ [ Trigger.of_pred eq ; Trigger.of_term ta_xs ] ; [ Trigger.of_pred eq ; Trigger.of_term tb_xs ] ] ; l_lemma = property ; } ; (* Finally return symbol *) lfun end) let rec equal_object obj a b = match obj with | C_int _ | C_float _ | C_pointer _ -> p_equal a b | C_array t -> equal_array (Matrix.of_array t) a b | C_comp c -> equal_comp c a b and equal_typ typ a b = equal_object (Ctypes.object_of typ) a b and equal_comp c a b = Definitions.call_pred (Lang.generated_p ("Eq" ^ Lang.comp_id c)) (fun lfun -> let basename = if c.cstruct then "S" else "U" in let xa = Lang.freshvar ~basename (Lang.tau_of_comp c) in let xb = Lang.freshvar ~basename (Lang.tau_of_comp c) in let ra = e_var xa in let rb = e_var xb in let def = p_all (fun f -> let fd = Cfield f in equal_typ f.ftype (e_getfield ra fd) (e_getfield rb fd)) c.cfields in { d_lfun = lfun ; d_types = 0 ; d_params = [xa;xb] ; d_cluster = Definitions.compinfo c ; d_definition = Predicate(Def,def) ; } ) [a;b] and equal_array m a b = match m with | _obj , [None] -> p_equal a b | _ -> p_call (EQARRAY.get m) (Matrix.size m @ [a;b]) let () = s_eq := equal_object (* -------------------------------------------------------------------------- *) (* --- Lifting Values --- *) (* -------------------------------------------------------------------------- *) let map_value f = function | Val t -> Val t | Loc l -> Loc (f l) let map_sloc f = function | Sloc l -> Sloc (f l) | Sarray(l,obj,s) -> Sarray(f l,obj,s) | Srange(l,obj,a,b) -> Srange(f l,obj,a,b) | Sdescr(xs,l,p) -> Sdescr(xs,f l,p) let map_logic f = function | Vexp t -> Vexp t | Vloc l -> Vloc (f l) | Vset s -> Vset s | Lset ls -> Lset (List.map (map_sloc f) ls) (* -------------------------------------------------------------------------- *) (* --- Int-As-Boolans --- *) (* -------------------------------------------------------------------------- *) let bool_eq a b = e_if (e_eq a b) e_one e_zero let bool_lt a b = e_if (e_lt a b) e_one e_zero let bool_neq a b = e_if (e_eq a b) e_zero e_one let bool_leq a b = e_if (e_leq a b) e_one e_zero let bool_and a b = e_and [e_neq a e_zero ; e_neq b e_zero] let bool_or a b = e_or [e_neq a e_zero ; e_neq b e_zero] let is_true p = e_if (e_prop p) e_one e_zero let is_false p = e_if (e_prop p) e_zero e_one (* -------------------------------------------------------------------------- *) (* --- Lifting Memory Model to Values --- *) (* -------------------------------------------------------------------------- *) module Logic(M : Memory.Model) = struct type logic = M.loc Memory.logic type region = M.loc Memory.sloc list (* -------------------------------------------------------------------------- *) (* --- Projections --- *) (* -------------------------------------------------------------------------- *) let value = function | Vexp e -> e | Vloc l -> M.pointer_val l | Vset _ -> Warning.error "Set of values not yet implemented" | Lset _ -> Warning.error "T-Set of values not yet implemented" let loc = function | Vloc l -> l | Vexp e -> M.pointer_loc e | Vset _ -> Warning.error "Set of pointers not yet implemented" | Lset _ -> Warning.error "T-Set of regions not yet implemented" let rdescr = function | Sloc l -> [],l,p_true | Sdescr(xs,l,p) -> xs,l,p | Sarray(l,obj,s) -> let x = Lang.freshvar ~basename:"k" Logic.Int in let k = e_var x in [x],M.shift l obj k,Vset.in_size k s | Srange(l,obj,a,b) -> let x = Lang.freshvar ~basename:"k" Logic.Int in let k = e_var x in [x],M.shift l obj k,Vset.in_range k a b let vset_of_sloc sloc = List.map (function | Sloc p -> Vset.Singleton (M.pointer_val p) | u -> let xs,l,p = rdescr u in Vset.Descr( xs , M.pointer_val l , p ) ) sloc let sloc_of_vset vset = List.map (function | Vset.Singleton e -> Sloc (M.pointer_loc e) | w -> let xs,t,p = Vset.descr w in Sdescr(xs,M.pointer_loc t,p) ) vset let vset = function | Vexp v -> Vset.singleton v | Vloc l -> Vset.singleton (M.pointer_val l) | Vset s -> s | Lset sloc -> vset_of_sloc sloc let sloc = function | Vexp e -> [Sloc (M.pointer_loc e)] | Vloc l -> [Sloc l] | Lset ls -> ls | Vset vset -> sloc_of_vset vset (* -------------------------------------------------------------------------- *) (* --- Morphisms --- *) (* -------------------------------------------------------------------------- *) let is_single = function (Vexp _ | Vloc _) -> true | (Lset _ | Vset _) -> false let map_lift f1 f2 a = match a with | Vexp e -> Vexp (f1 e) | Vloc l -> Vexp (f1 (M.pointer_val l)) | _ -> Vset(f2 (vset a)) let apply_lift f1 f2 a b = if is_single a && is_single b then Vexp (f1 (value a) (value b)) else Vset (f2 (vset a) (vset b)) let map f = map_lift f (Vset.map f) let map_opp = map_lift e_opp Vset.map_opp let apply f = apply_lift f (Vset.lift f) let apply_add = apply_lift e_add Vset.lift_add let apply_sub = apply_lift e_sub Vset.lift_sub let map_loc f lv = if is_single lv then Vloc (f (loc lv)) else Lset (List.map (function | Sloc l -> Sloc (f l) | s -> let xs,l,p = rdescr s in Sdescr(xs,f l,p) ) (sloc lv)) let map_l2t f lv = if is_single lv then Vexp (f (loc lv)) else Vset (List.map (function | Sloc l -> Vset.Singleton (f l) | s -> let xs,l,p = rdescr s in Vset.Descr(xs,f l,p) ) (sloc lv)) let map_t2l f sv = if is_single sv then Vloc (f (value sv)) else Lset (List.map (function | Vset.Singleton e -> Sloc (f e) | s -> let xs,l,p = Vset.descr s in Sdescr(xs,f l,p) ) (vset sv)) (* -------------------------------------------------------------------------- *) (* --- Locations --- *) (* -------------------------------------------------------------------------- *) let field lv f = map_loc (fun l -> M.field l f) lv let restrict kset = function | None -> kset | Some s -> match kset with | Vset.Singleton _ | Vset.Set _ -> kset | Vset.Range(a,b) -> let cap l = function None -> Some l | u -> u in let s = Int64.pred s in Vset.Range(cap e_zero a,cap (e_int64 s) b) | Vset.Descr(xs,k,p) -> let a = e_zero in let b = e_int64 s in Vset.Descr(xs,k,p_conj [p_leq a k;p_lt k b;p]) let shift_set sloc obj size kset = match sloc , kset , size with | Sloc l , Vset.Range(None,None) , Some s -> Sarray(l,obj,s) | _ -> match sloc , restrict kset size with | Sloc l , Vset.Singleton k -> Sloc(M.shift l obj k) | Sloc l , Vset.Range(a,b) -> Srange(l,obj,a,b) | Srange(l,obj0,a0,b0) , Vset.Singleton k when Ctypes.equal obj0 obj -> Srange(l,obj0, Vset.bound_add a0 (Some k), Vset.bound_add b0 (Some k)) | Srange(l,obj0,a0,b0) , Vset.Range(a1,b1) when Ctypes.equal obj0 obj -> Srange(l,obj0, Vset.bound_add a0 a1, Vset.bound_add b0 b1) | _ -> let xs,l,p = rdescr sloc in let ys,k,q = Vset.descr kset in Sdescr( xs @ ys , M.shift l obj k , p_and p q ) let shift lv obj ?size kv = if is_single kv then let k = value kv in map_loc (fun l -> M.shift l obj k) lv else let ks = vset kv in Lset(List.fold_left (fun s sloc -> List.fold_left (fun s kset -> shift_set sloc obj size kset :: s ) s ks ) [] (sloc lv)) (* -------------------------------------------------------------------------- *) (* --- Load in Memory --- *) (* -------------------------------------------------------------------------- *) type loader = { mutable sloc : M.loc sloc list ; mutable vset : Vset.vset list ; } let flush prefer_loc a = match a with | { vset=[] } -> Lset (List.rev a.sloc) | { sloc=[] } -> Vset (List.rev a.vset) | _ -> if prefer_loc then Lset (a.sloc @ sloc_of_vset a.vset) else Vset (vset_of_sloc a.sloc @ a.vset) let loadsloc a sigma obj = function | Sloc l -> begin match M.load sigma obj l with | Val t -> a.vset <- Vset.Singleton t :: a.vset | Loc l -> a.sloc <- Sloc l :: a.sloc end | (Sarray _ | Srange _ | Sdescr _) as s -> let xs , l , p = rdescr s in begin match M.load sigma obj l with | Val t -> a.vset <- Vset.Descr(xs,t,p) :: a.vset | Loc l -> a.sloc <- Sdescr(xs,l,p) :: a.sloc end let load sigma obj lv = if is_single lv then let data = M.load sigma obj (loc lv) in Lang.assume (is_object obj data) ; match data with | Val t -> Vexp t | Loc l -> Vloc l else let a = { vset=[] ; sloc=[] } in List.iter (loadsloc a sigma obj) (sloc lv) ; flush (Ctypes.is_pointer obj) a let union t vs = let a = { vset=[] ; sloc=[] } in List.iter (function | Vexp e -> a.vset <- Vset.Singleton e::a.vset | Vloc l -> a.sloc <- Sloc l :: a.sloc | Vset s -> a.vset <- List.rev_append s a.vset | Lset s -> a.sloc <- List.rev_append s a.sloc ) vs ; flush (Logic_typing.is_pointer_type t) a let inter t vs = match List.map (fun v -> Vset.concretize (vset v)) vs with | [] -> if Logic_typing.is_pointer_type t then Lset [] else Vset [] | v::vs -> let s = List.fold_left Vset.inter v vs in let t = Lang.tau_of_ltype t in Vset [Vset.Set(t,s)] (* -------------------------------------------------------------------------- *) (* --- Sloc to Rloc --- *) (* -------------------------------------------------------------------------- *) let rloc obj = function | Sloc l -> Rloc(obj,l) | Sarray(l,t,s) -> Rarray(l,t,s) | Srange(l,t,a,b) -> Rrange(l,t,a,b) | Sdescr _ -> raise Exit (* -------------------------------------------------------------------------- *) (* --- Separated --- *) (* -------------------------------------------------------------------------- *) let separated_sloc w (obj1,sloc1) (obj2,sloc2) = List.fold_left (fun w s1 -> List.fold_left (fun w s2 -> let cond = try M.separated (rloc obj1 s1) (rloc obj2 s2) with Exit -> let xs,l1,p1 = rdescr s1 in let ys,l2,p2 = rdescr s2 in let se1 = Rloc(obj1,l1) in let se2 = Rloc(obj2,l2) in p_forall (xs@ys) (p_hyps [p1;p2] (M.separated se1 se2)) in cond::w ) w sloc2 ) w sloc1 let rec separated_from w r1 = function | r2::rs -> separated_from (separated_sloc w r1 r2) r1 rs | [] -> w let rec separated_regions w = function | r::rs -> separated_regions (separated_from w r rs) rs | [] -> w let separated regions = (* forall i let xs,l1,p1 = rdescr s1 in let ys,l2,p2 = rdescr s2 in let se1 = Rloc(obj1,l1) in let se2 = Rloc(obj2,l2) in p_forall xs (p_imply p1 (p_exists ys (p_and p2 (M.included se1 se2)))) let included obj1 r1 obj2 r2 = p_all (fun s1 -> p_any (fun s2 -> included_sloc obj1 s1 obj2 s2) r2) r1 (* -------------------------------------------------------------------------- *) (* --- Valid --- *) (* -------------------------------------------------------------------------- *) let valid_sloc sigma acs obj = function | Sloc l -> M.valid sigma acs (Rloc(obj,l)) | Sarray(l,t,s) -> M.valid sigma acs (Rarray(l,t,s)) | Srange(l,t,a,b) -> M.valid sigma acs (Rrange(l,t,a,b)) | Sdescr(xs,l,p) -> p_forall xs (p_imply p (M.valid sigma acs (Rloc(obj,l)))) let valid sigma acs obj = p_all (valid_sloc sigma acs obj) end frama-c-Fluorine-20130601/src/wp/why3_xml.mli0000644000175000017500000000563112155630215017474 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 file and the implementation have not been modified from the orignal why3 file (except removing the uses of the Debug module) *) (********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2013 -- INRIA - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) type element = { name : string; attributes : (string * string) list; elements : element list; } type t = { version : string; encoding : string; doctype : string; dtd : string; content : element; } exception Parse_error of string val from_file : string -> t (** returns the list of XML elements from the given file. raise [Sys_error] if the file cannot be opened. raise [Parse_error] if the file does not follow XML syntax *) frama-c-Fluorine-20130601/src/wp/Sigma.ml0000644000175000017500000001014212155630215016602 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Generic Sigma Factory --- *) (* -------------------------------------------------------------------------- *) open Lang.F module Make (C : Memory.Chunk) (H : Qed.Collection.S with type t = C.t) : Memory.Sigma with type chunk = C.t and type domain = H.set = struct type chunk = C.t type domain = H.set type t = { id : int ; mutable map : var H.map } let id = ref 0 (* for debugging purpose *) let build map = let k = !id in incr id ; { id = k ; map = map } let create () = build H.Map.empty let copy s = build s.map let newchunk c = Lang.freshvar ~basename:(C.basename_of_chunk c) (C.tau_of_chunk c) let merge a b = let pa = ref Passive.empty in let pb = ref Passive.empty in let merge_chunk c x y = if Var.equal x y then x else let z = newchunk c in pa := Passive.bind ~fresh:z ~bound:x !pa ; pb := Passive.bind ~fresh:z ~bound:y !pb ; z in let w = H.Map.union merge_chunk a.map b.map in build w , !pa , !pb let get w c = try H.Map.find c w.map with Not_found -> let x = newchunk c in w.map <- H.Map.add c x w.map ; x let mem w c = H.Map.mem c w.map let join a b = let p = ref Passive.empty in H.Map.iter2 (fun chunk x y -> match x,y with | Some x , Some y -> p := Passive.join x y !p | Some x , None -> b.map <- H.Map.add chunk x b.map | None , Some y -> a.map <- H.Map.add chunk y a.map | None , None -> ()) a.map b.map ; !p let assigned a b written = let p = ref Bag.empty in H.Map.iter2 (fun chunk x y -> if not (H.Set.mem chunk written) then match x,y with | Some x , Some y when x != y -> p := Bag.add (p_equal (e_var x) (e_var y)) !p | Some x , None -> b.map <- H.Map.add chunk x b.map | None , Some y -> a.map <- H.Map.add chunk y a.map | _ -> ()) a.map b.map ; !p let value w c = e_var (get w c) let iter f w = H.Map.iter f w.map let iter2 f w1 w2 = H.Map.iter2 f w1.map w2.map let havoc w xs = let ys = H.Set.mapping newchunk xs in build (H.Map.union (fun _c _old y -> y) w.map ys) let havoc_chunk w c = let x = newchunk c in build (H.Map.add c x w.map) let havoc_any _w = build H.Map.empty let domain w = H.Map.domain w.map let pretty fmt w = Format.fprintf fmt "@@%s%d" C.self w.id ; H.Map.iter (fun c x -> Format.fprintf fmt "@ %a:%a" C.pretty c Var.pretty x) w.map end frama-c-Fluorine-20130601/src/wp/ProverCoq.mli0000644000175000017500000000361712155630215017644 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Task open VCS (* -------------------------------------------------------------------------- *) (* --- Alt-Ergo Theorem Prover --- *) (* -------------------------------------------------------------------------- *) val prove : Wpo.t -> interactive:bool -> result task frama-c-Fluorine-20130601/src/wp/Context.ml0000644000175000017500000000671212155630215017176 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Location --- *) (* -------------------------------------------------------------------------- *) let with_current_loc loc phi x = let tmp = Cil_const.CurrentLoc.get () in try Cil_const.CurrentLoc.set loc ; let y = phi x in Cil_const.CurrentLoc.set tmp ; y with error -> Cil_const.CurrentLoc.set tmp ; raise error (* -------------------------------------------------------------------------- *) (* --- Local Context --- *) (* -------------------------------------------------------------------------- *) type 'a value = { name : string ; (* Descriptive *) mutable current : 'a option ; } let create ?default name = { name = name ; current = default } let name s = s.name let defined env = match env.current with None -> false | Some _ -> true let get env = match env.current with | Some e -> e | None -> Wp_parameters.fatal "Context '%s' non-initialized." env.name let set env s = env.current <- Some s let clear env = env.current <- None let update env f = match env.current with | Some e -> env.current <- Some (f e) | None -> Wp_parameters.fatal "Context '%s' non-initialized." env.name let bind_with env w f e = let tmp = env.current in env.current <- w ; try let e = f e in env.current <- tmp ; e with error -> env.current <- tmp ; raise error let bind env s f e = bind_with env (Some s) f e let free env f e = bind_with env None f e let push env x = let old = env.current in env.current <- Some x ; old let pop env old = env.current <- old let once f = let once = ref (Some f) in (fun () -> match !once with Some f -> once := None ; f () | None -> ()) (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/driver.mll0000644000175000017500000002235312155630215017220 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- External Driver --- *) (* -------------------------------------------------------------------------- *) { open Qed.Logic open Lexing open Cil_types open LogicBuiltins type token = | EOF | KEY of string | BOOLEAN | INTEGER | REAL | INT of ikind | FLT of fkind | ID of string | LINK of string let keywords = [ "library" , KEY "library" ; "type" , KEY "type" ; "ctor" , KEY "ctor" ; "logic" , KEY "logic" ; "predicate" , KEY "predicate" ; "boolean" , BOOLEAN ; "integer" , INTEGER ; "real" , REAL ; "char" , INT IChar ; "short" , INT IShort ; "int" , INT IInt ; "unsigned" , INT IUInt ; "float" , FLT FFloat ; "double" , FLT FDouble ; ] let ident x = try List.assoc x keywords with Not_found -> ID x let newline lexbuf = lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_lnum = succ lexbuf.lex_curr_p.pos_lnum } } let blank = [ ' ' '\t' ] let ident = [ 'a'-'z' 'A'-'Z' '_' '0'-'9' ]+ rule tok = parse eof { EOF } | '\n' { newline lexbuf ; tok lexbuf } | blank+ { tok lexbuf } | "//" [^ '\n']* '\n' { newline lexbuf ; tok lexbuf } | "/*" { comment lexbuf } | ident as a { ident a } | '"' (ident as a) '"' { LINK a } | _ { KEY (Lexing.lexeme lexbuf) } and comment = parse | eof { failwith "Unterminated comment" } | "*/" { tok lexbuf } | '\n' { newline lexbuf ; comment lexbuf } | _ { comment lexbuf } { let pretty fmt = function | EOF -> Format.pp_print_string fmt "" | KEY a | ID a -> Format.fprintf fmt "'%s'" a | LINK s -> Format.fprintf fmt "\"%s\"" s | BOOLEAN | INTEGER | REAL | INT _ | FLT _ -> Format.pp_print_string fmt "" type input = { lexbuf : Lexing.lexbuf ; mutable current : token ; } let skip input = if input.current <> EOF then input.current <- tok input.lexbuf let token input = input.current let key input a = match token input with | KEY b when a=b -> skip input ; true | _ -> false let skipkey input a = match token input with | KEY b when a=b -> skip input | _ -> failwith (Printf.sprintf "Missing '%s'" a) let ident input = match token input with | ID x -> skip input ; x | _ -> failwith "missing identifier" let kind input = let kd = match token input with | INTEGER -> Z | REAL -> R | BOOLEAN -> A | INT i -> I (Ctypes.c_int i) | FLT f -> F (Ctypes.c_float f) | ID _ -> A | _ -> failwith " expected" in skip input ; kd let parameter input = let k = kind input in match token input with | ID _ -> skip input ; k | _ -> k let rec parameters input = if key input ")" then [] else let p = parameter input in if key input "," then p :: parameters input else if key input ")" then [p] else failwith "Missing ',' or ')'" let signature input = if key input "(" then parameters input else [] let rec depend input = match token input with | ID a | LINK a -> skip input ; ignore (key input ",") ; a :: depend input | _ -> [] let link input = match token input with | LINK f | ID f -> skip input ; f | _ -> failwith "Missing link symbol" let op = { inversible = false ; associative = false ; commutative = false ; idempotent = false ; neutral = E_none ; absorbant = E_none ; } let op_elt input = ignore (key input ":") ; let op = link input in skipkey input ":" ; match op with | "0" -> E_int 0 | "1" -> E_int 1 | "-1" -> E_int (-1) | _ -> try E_const (LogicBuiltins.symbol op) with Not_found -> failwith (Printf.sprintf "Symbol '%s' undefined" op) let rec op_link bal op input = match token input with | LINK f -> skip input ; bal,Operator op,f | ID "left" -> skip input ; skipkey input ":" ; op_link Lang.Left op input | ID "right" -> skip input ; skipkey input ":" ; op_link Lang.Right op input | ID "associative" -> skip input ; skipkey input ":" ; op_link bal { op with associative = true } input | ID "commutative" -> skip input ; skipkey input ":" ; op_link bal { op with commutative = true } input | ID "ac" -> skip input ; skipkey input ":" ; op_link bal { op with commutative = true ; associative = true } input | ID "idempotent" -> skip input ; skipkey input ":" ; op_link bal { op with idempotent = true } input | ID "inversible" -> skip input ; skipkey input ":" ; op_link bal { op with inversible = true } input | ID "neutral" -> skip input ; let e = op_elt input in op_link bal { op with neutral = e } input | ID "absorbant" -> skip input ; let e = op_elt input in op_link bal { op with absorbant = e } input | ID t -> failwith (Printf.sprintf "Unknown tag '%s'" t) | _ -> failwith "Missing or " let logic_link input = match token input with | LINK f -> skip input ; Lang.Nary,Function,f | ID "constructor" -> skip input ; skipkey input ":" ; Lang.Nary,Function,link input | ID "injective" -> skip input ; skipkey input ":" ; Lang.Nary,Injection,link input | _ -> op_link Lang.Left op input let rec parse theory input = match token input with | EOF -> () | KEY "library" -> skip input ; let name = link input in ignore (key input ":") ; let depends = depend input in ignore (key input ";") ; add_library name depends ; parse name input | KEY "type" -> skip input ; let name = ident input in skipkey input "=" ; let link = link input in add_type name ~theory ~link () ; skipkey input ";" ; parse theory input | KEY "ctor" -> skip input ; let name = ident input in let args = signature input in skipkey input "=" ; let link = link input in add_ctor name args ~theory ~link () ; skipkey input ";" ; parse theory input | KEY "logic" -> skip input ; let result = kind input in let name = ident input in let args = signature input in skipkey input "=" ; let balance,category,link = logic_link input in add_logic result name args ~theory ~category ~balance ~link () ; skipkey input ";" ; parse theory input | KEY "predicate" -> skip input ; let name = ident input in let args = signature input in skipkey input "=" ; let link = link input in add_predicate name args ~theory ~link () ; skipkey input ";" ; parse theory input | _ -> failwith "Unexpected entry" let load file = try let inc = open_in file in let lex = Lexing.from_channel inc in lex.Lexing.lex_curr_p <- { lex.Lexing.lex_curr_p with Lexing.pos_fname = file } ; let input = { current = tok lex ; lexbuf = lex } in try parse "driver" input ; close_in inc with Failure msg -> close_in inc ; let source = lex.Lexing.lex_start_p in Wp_parameters.error ~source "(Driver Error) %s (at %a)" msg pretty (token input) with exn -> Wp_parameters.error "Error in driver '%s': %s" file (Printexc.to_string exn) (*TODO[LC] Think about projectification ... *) let loaded = ref false let load_drivers () = if not !loaded then begin List.iter (fun file -> let path = Wp_parameters.find_lib file in let echo = if Wp_parameters.has_dkey "driver" then path else file in Wp_parameters.feedback "Loading driver '%s'" echo ; load path) (Wp_parameters.Drivers.get ()) ; loaded := true ; if Wp_parameters.has_dkey "driver" then LogicBuiltins.dump () ; end } frama-c-Fluorine-20130601/src/wp/Definitions.ml0000644000175000017500000003557012155630215020031 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Definitions --- *) (* -------------------------------------------------------------------------- *) open LogicUsage open Cil_types open Cil_datatype open Ctypes open Qed.Logic open Lang open Lang.F type trigger = (var,lfun) Qed.Engine.ftrigger type typedef = (tau,field,lfun) Qed.Engine.ftypedef type cluster = { c_id : string ; c_title : string ; c_position : Lexing.position option ; mutable c_age : int ; mutable c_sorted : bool ; mutable c_records : compinfo list ; mutable c_types : logic_type_info list ; mutable c_symbols : dfun list ; mutable c_lemmas : dlemma list ; } and dlemma = { l_name : string ; l_cluster : cluster ; l_assumed : bool ; l_types : int ; l_forall : var list ; l_triggers : trigger list list (* OR of AND triggers *) ; l_lemma : pred ; } and dfun = { d_lfun : lfun ; d_cluster : cluster ; d_types : int ; d_params : var list ; d_definition : definition ; } and definition = | Logic of tau | Value of tau * recursion * term | Predicate of recursion * pred | Inductive of dlemma list and recursion = Def | Rec module Trigger = struct open Qed.Engine let rec of_exp mode t = match F.repr t with | Var x -> TgVar x | Aget(a,k) -> TgGet(of_exp Cterm a,of_exp Cterm k) | Aset(a,k,v) -> TgSet(of_exp Cterm a,of_exp Cterm k,of_exp Cterm v) | Fun(f,ts) -> let ts = List.map (of_exp Cterm) ts in begin match mode with | Cterm -> TgFun(f,ts) | Cprop -> TgProp(f,ts) end | _ -> TgAny let of_term t = of_exp Cterm t let of_pred p = of_exp Cprop (F.e_prop p) let rec collect xs = function | TgAny -> xs | TgVar x -> Vars.add x xs | TgGet(a,k) -> collect (collect xs a) k | TgSet(a,k,v) -> collect (collect (collect xs a) k) v | TgFun(_,ts) | TgProp(_,ts) -> List.fold_left collect xs ts let vars = collect Vars.empty let binders p = let rec collect xs p = match F.repr p with | Bind( Forall , x , p ) -> collect (x::xs) p | Imply( hs , p ) -> let xs , p = collect xs p in xs , F.e_imply hs p | _ -> List.rev xs , p in collect [] p let plug tgs p = let vars,lemma = binders (F.e_prop p) in let used = List.fold_left (List.fold_left collect) Vars.empty tgs in let xs , ys = List.partition (fun x -> Vars.mem x used) vars in xs , F.p_forall ys (F.p_bool lemma) end (* -------------------------------------------------------------------------- *) (* --- Registry --- *) (* -------------------------------------------------------------------------- *) module Cluster = Model.Index (struct type key = string type data = cluster let name = "Definitions.Cluster" let compare = String.compare let pretty = Format.pp_print_string end) module Symbol = Model.Index (struct type key = lfun type data = dfun let name = "Definitions.Symbol" let compare = Lang.Fun.compare let pretty = Lang.Fun.pretty end) module Lemma = Model.Index (struct type key = string type data = dlemma let name = "Definitions.Lemma" let compare = String.compare let pretty = Format.pp_print_string end) let touch c = c.c_age <- succ c.c_age ; c.c_sorted <- false let compare_symbol f g = Fun.compare f.d_lfun g.d_lfun let compare_lemma a b = String.compare a.l_name b.l_name let _sort c = if not c.c_sorted then begin c.c_records <- List.sort Compinfo.compare c.c_records ; c.c_types <- List.sort Logic_type_info.compare c.c_types ; c.c_symbols <- List.sort compare_symbol c.c_symbols ; c.c_lemmas <- List.sort compare_lemma c.c_lemmas ; c.c_sorted <- true ; end let () = begin Symbol.callback (fun _ f -> touch f.d_cluster ; f.d_cluster.c_symbols <- f :: f.d_cluster.c_symbols) ; Lemma.callback (fun _ a -> touch a.l_cluster ; a.l_cluster.c_lemmas <- a :: a.l_cluster.c_lemmas) ; end let define_symbol f = Symbol.define f.d_lfun f let update_symbol f = Symbol.update f.d_lfun f let find_lemma l = Lemma.find l.lem_name let compile_lemma cc l = Lemma.compile (fun _name -> cc l) l.lem_name let define_lemma l = Lemma.define l.l_name l let define_type c t = begin touch c ; c.c_types <- t :: c.c_types ; end (* -------------------------------------------------------------------------- *) (* --- Helpers --- *) (* -------------------------------------------------------------------------- *) let cluster_id c = c.c_id let cluster_title c = c.c_title let cluster_position c = c.c_position let cluster_age c = c.c_age let cluster_compare a b = String.compare a.c_id b.c_id let pp_cluster fmt c = Format.pp_print_string fmt c.c_id let newcluster ~id ?title ?position () = { c_id = id ; c_title = (match title with Some t -> t | None -> id) ; c_position = position ; c_age = 0 ; c_sorted = true ; c_types = [] ; c_records = [] ; c_symbols = [] ; c_lemmas = [] ; } let cluster ~id ?title ?position () = Cluster.memoize (fun id -> newcluster ~id ?title ?position ()) id let axiomatic ax = Cluster.memoize (fun id -> let title = Printf.sprintf "Axiomatic '%s'" ax.ax_name in let position = ax.ax_position in let cluster = newcluster ~id ~title ~position () in cluster) (Printf.sprintf "A_%s" ax.ax_name) let section = function | Toplevel 0 -> cluster ~id:"Axiomatic" ~title:"Global Definitions" () | Toplevel n -> let id = "Axiomatic" ^ string_of_int n in let title = Printf.sprintf "Global Definitions (continued #%d)" n in cluster ~id ~title () | Axiomatic ax -> axiomatic ax let compinfo c = Cluster.memoize (fun id -> let title = if c.cstruct then Printf.sprintf "Struct '%s'" c.cname else Printf.sprintf "Union '%s'" c.cname in let cluster = newcluster ~id ~title () in cluster.c_records <- [c] ; cluster) (Lang.comp_id c) let matrix = function | C_array _ -> assert false | C_comp c -> compinfo c | C_int _ | C_float _ | C_pointer _ -> Cluster.memoize (fun id -> newcluster ~id ~title:"Basic Arrays" ()) "Matrix" let call_fun lfun cc es = Symbol.compile (Lang.local cc) lfun ; e_fun lfun es let call_pred lfun cc es = Symbol.compile (Lang.local cc) lfun ; p_call lfun es (* -------------------------------------------------------------------------- *) (* --- Cluster Dependencies --- *) (* -------------------------------------------------------------------------- *) module DT = Logic_type_info.Set module DR = Compinfo.Set module DS = Datatype.String.Set module DF = Set.Make(Lang.Fun) module DC = Set.Make (struct type t = cluster let compare = cluster_compare end) (* -------------------------------------------------------------------------- *) (* --- Markers (test and set) --- *) (* -------------------------------------------------------------------------- *) type axioms = cluster * logic_lemma list class virtual visitor main = object(self) val mutable terms = Tset.empty val mutable types = DT.empty val mutable comps = DR.empty val mutable symbols = DF.empty val mutable dlemmas = DS.empty val mutable lemmas = DS.empty val mutable clusters = DC.empty val mutable theories = DS.empty val mutable locals = DC.add main DC.empty method set_local c = locals <- DC.add c locals method do_local c = if DC.mem c locals then true else (self#vcluster c ; false) method private vtypedef = function | None -> () | Some (LTsum cs) -> List.iter (fun c -> self#vadt (Lang.atype c.ctor_type)) cs | Some (LTsyn lt) -> self#vtau (Lang.tau_of_ltype lt) method vtype t = if not (DT.mem t types) then begin types <- DT.add t types ; let c = section (LogicUsage.section_of_type t) in if self#do_local c then begin self#vtypedef t.lt_def ; let def = match t.lt_def with | None -> Qed.Engine.Tabs | Some (LTsyn lt) -> Qed.Engine.Tdef (Lang.tau_of_ltype lt) | Some (LTsum cs) -> let cases = List.map (fun ct -> Lang.CTOR ct , List.map Lang.tau_of_ltype ct.ctor_params ) cs in Qed.Engine.Tsum cases in self#on_type t def ; end end method vcomp r = if not (DR.mem r comps) then begin comps <- DR.add r comps ; let c = compinfo r in if self#do_local c then begin let fts = List.map (fun f -> let t = Lang.tau_of_ctype f.ftype in self#vtau t ; Cfield f , t ) r.cfields in self#on_comp r fts ; end end method vfield = function | Mfield(a,_,_,_) -> self#vtheory a.mdt_theory | Cfield f -> self#vcomp f.fcomp method vadt = function | Mtype a | Mrecord(a,_) -> self#vtheory a.mdt_theory | Comp r -> self#vcomp r | Atype t -> self#vtype t method vtau = function | Prop | Bool | Int | Real | Tvar _ -> () | Array(a,b) -> self#vtau a ; self#vtau b | Record _ -> assert false | Data(a,ts) -> self#vadt a ; List.iter self#vtau ts method vparam x = self#vtau (tau_of_var x) method vterm t = if not (Tset.mem t terms) then begin terms <- Tset.add t terms ; F.e_iter self#vterm t ; match F.repr t with | Fun(f,_) -> self#vsymbol f | Rget(_,f) -> self#vfield f | Rdef fts -> List.iter (fun (f,_) -> self#vfield f) fts | Var x | Bind(_,x,_) -> self#vparam x | True | False | Kint _ | Kreal _ | Times _ | Add _ | Mul _ | Div _ | Mod _ | Eq _ | Neq _ | Leq _ | Lt _ | Aget _ | Aset _ | And _ | Or _ | Not _ | Imply _ | If _ | Apply _ -> () end method vpred p = self#vterm (F.e_prop p) method private vdefinition = function | Logic t -> self#vtau t | Value(t,_,e) -> self#vtau t ; self#vterm e | Predicate(_,p) -> self#vpred p | Inductive _ -> () method private vproperties = function | Logic _ | Value _ | Predicate _ -> () | Inductive cases -> List.iter self#vdlemma cases method private vdfun d = begin List.iter self#vparam d.d_params ; self#vdefinition d.d_definition ; self#on_dfun d ; self#vproperties d.d_definition ; end method private vlfun f = try let d = Symbol.find f in let c = d.d_cluster in if self#do_local c then self#vdfun d with Not_found -> Wp_parameters.fatal "Undefined symbol '%a'" Fun.pretty f method vsymbol f = if not (DF.mem f symbols) then begin symbols <- DF.add f symbols ; match f with | Lang.Function { f_scope = s } | Lang.Predicate { p_scope = s } -> begin match s with | External thy -> self#vtheory thy | Generated -> self#vlfun f end | ACSL _ -> self#vlfun f | CTOR c -> self#vadt (Lang.atype c.ctor_type) end method private vtrigger = function | Qed.Engine.TgAny -> () | Qed.Engine.TgVar x -> self#vparam x | Qed.Engine.TgGet(a,k) -> begin self#vtrigger a ; self#vtrigger k ; end | Qed.Engine.TgSet(a,k,v) -> begin self#vtrigger a ; self#vtrigger k ; self#vtrigger v ; end | Qed.Engine.TgFun(f,tgs) | Qed.Engine.TgProp(f,tgs) -> self#vsymbol f ; List.iter self#vtrigger tgs method private vdlemma a = if not (DS.mem a.l_name dlemmas) then begin dlemmas <- DS.add a.l_name dlemmas ; List.iter self#vparam a.l_forall ; List.iter (List.iter self#vtrigger) a.l_triggers ; self#vpred a.l_lemma ; self#on_dlemma a ; end method vlemma lem = let l = lem.lem_name in if not (DS.mem l lemmas) then begin lemmas <- DS.add l lemmas ; try let a = Lemma.find l in if self#do_local a.l_cluster then self#vdlemma a with Not_found -> Wp_parameters.fatal "Lemma '%s' undefined" l end method vcluster c = if not (DC.mem c clusters) then begin clusters <- DC.add c clusters ; self#on_cluster c ; end method vtheory thy = if not (DS.mem thy theories) then begin theories <- DS.add thy theories ; try let deps = LogicBuiltins.dependencies thy in List.iter self#vtheory deps ; self#on_library thy ; with Not_found -> self#on_theory thy end method vgoal (axioms : axioms option) prop = match axioms with | None -> begin let hs = LogicUsage.proof_context () in List.iter self#vlemma hs ; self#vpred prop ; end | Some(cluster,hs) -> begin self#section (cluster_title cluster) ; self#set_local cluster ; List.iter self#vlemma hs ; self#vpred prop ; end method vself = begin List.iter self#vcomp main.c_records ; List.iter self#vtype main.c_types ; List.iter (fun d -> self#vsymbol d.d_lfun) main.c_symbols ; List.iter (fun l -> self#vdlemma l) main.c_lemmas ; end method virtual section : string -> unit method virtual on_theory : string -> unit method virtual on_library : string -> unit method virtual on_cluster : cluster -> unit method virtual on_type : logic_type_info -> typedef -> unit method virtual on_comp : compinfo -> (field * tau) list -> unit method virtual on_dlemma : dlemma -> unit method virtual on_dfun : dfun -> unit end (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/CodeSemantics.mli0000644000175000017500000000501612155630215020440 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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-Code Translation --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Ctypes open Lang.F module Make(M : Memory.Model) : sig open M type loc = M.loc type value = loc Memory.value type sigma = Sigma.t val cval : value -> term val cloc : value -> loc val cast : typ -> typ -> value -> value val equal_typ : typ -> value -> value -> pred val equal_obj : c_object -> value -> value -> pred val exp : sigma -> exp -> value val cond : sigma -> exp -> pred val lval : sigma -> lval -> loc val loc_of_exp : sigma -> exp -> loc val val_of_exp : sigma -> exp -> term val return : sigma -> typ -> exp -> term val is_zero : sigma -> c_object -> loc -> pred val is_zero_range : sigma -> loc -> c_object -> term -> term -> pred end frama-c-Fluorine-20130601/src/wp/calculus.ml0000644000175000017500000007063112155630215017366 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 = Wp_parameters.register_category "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_goal wenv obj g = (*[LC] Adding scopes for loop invariant preservation *) let obj = match WpPropId.is_loop_preservation (fst g) with | None -> obj | Some stmt -> debug "add scope for loop preservation %a@." WpPropId.pp_pred_info g ; let blocks = Kernel_function.find_all_enclosing_blocks stmt in let kf = Kernel_function.find_englobing_kf stmt in let formals = Kernel_function.get_formals kf in List.fold_right (fun b obj -> W.scope wenv b.blocals Mcfg.SC_Block_out obj) blocks (W.scope wenv formals Mcfg.SC_Function_out obj) in 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 (@[%a@])@." WpPropId.pretty (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 a.WpPropId.a_stmt (Some h_id) a obj in Some (Clabels.c_label a.WpPropId.a_label), obj | WpPropId.AssignsAny a -> Wp_parameters.warning ~current:true ~once:true "Missing assigns clause (assigns 'everything' instead)" ; let obj = W.use_assigns wenv a.WpPropId.a_stmt 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 : 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 ; cfg: Cil2cfg.t; tbl : HE.t ; mutable memo : LabObligs.t; mutable obligs : LabObligs.t; } let empty cfg = debug "start computing (pass 1)@."; { mode = Pass1; 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 =@. @[ %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=@. @[ %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 (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 " = @[ %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.loop_entry 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)) res v stmt lval fct args p_post p_exit = debug "[wp_call] %a@." Printer.pp_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 Kernel_function.get_called fct with | None -> let obj = W.merge wenv 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 lval 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 if WpStrategy.is_default_behavior strategy && R.is_pass1 res then W.call_goal_precond wenv stmt kf args ~pre:(pre_goals) obj else obj let wp_stmt wenv s obj = match s.skind with | Return (r, _) -> W.return wenv s r obj | Instr i -> begin match i with | (Set (lv, e, _)) -> W.assign wenv s 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:", " Printer.pp_varinfo) 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.loop_step 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, lval, 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 res v stmt lval fct args objn obje | Cil2cfg.Vtest (true, s, 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 s c t_obj f_obj | Cil2cfg.Vtest (false, _, _) -> get_only_succ env cfg v | Cil2cfg.Vswitch (s, 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 s 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 Integer.lt (Integer.of_int len) size -> W.init_range wenv lv ty (Int64.of_int len) (Integer.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 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 res = R.empty cfg in let env = (kf, cfg, strategy, res, wenv) in List.iter (fun (pid,thm) -> W.add_axiom pid thm) (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 "" 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 frama-c-Fluorine-20130601/src/wp/GuiSource.ml0000644000175000017500000002003012155630215017444 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Source Interaction for WP --- *) (* -------------------------------------------------------------------------- *) open Cil_types open Cil_datatype open Pretty_source open Wpo type selection = | S_none | S_fun of Kernel_function.t | S_prop of Property.t | S_call of call and call = { s_caller : Kernel_function.t ; s_called : Kernel_function.t ; s_stmt : Stmt.t ; } let selection_of_localizable = function | PStmt( kf , stmt ) | PLval( Some kf , Kstmt stmt , _ ) | PTermLval( Some kf , Kstmt stmt , _ ) -> begin match stmt with | { skind=Instr(Call(_,e,_,_)) } -> begin match Kernel_function.get_called e with | None -> S_none | Some called -> S_call { s_called = called ; s_caller = kf ; s_stmt = stmt ; } end | _ -> S_none end | PVDecl (Some kf,{vglob=true}) -> S_fun kf | PIP ip -> S_prop ip | PVDecl _ | PLval _ | PTermLval _ | PGlobal _ -> S_none let kind_of_property = function | Property.IPLemma _ -> "lemma" | Property.IPCodeAnnot _ -> "annotation" | Property.IPPredicate( Property.PKRequires _ , _ , Kglobal , _ ) -> "precondition for callers" | _ -> "property" (* -------------------------------------------------------------------------- *) (* --- Popup Menu for WP --- *) (* -------------------------------------------------------------------------- *) 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 class popup () = object(self) val mutable click : selection -> unit = (fun _ -> ()) val mutable prove : selection -> unit = (fun _ -> ()) method on_click f = click <- f method on_prove f = prove <- f method private add_rte (menu : GMenu.menu GMenu.factory) (main : Design.main_window_extension_points) title action kf = ignore (menu#add_item title ~callback:(fun () -> !action kf ; main#redisplay ())) method private rte_popup menu main loc = match loc with | PVDecl (Some kf,{vglob=true}) -> if not (is_rte_generated kf) then self#add_rte menu main "Insert WP-safety guards" Db.RteGen.do_all_rte kf ; if not (is_rte_precond kf) then self#add_rte menu main "Insert all callees contract" Db.RteGen.do_precond kf; | PStmt(kf,({ skind=Instr(Call _) })) -> if not (is_rte_precond kf) then self#add_rte menu main "Insert callees contract (all calls)" Db.RteGen.do_precond kf; | _ -> () method private wp_popup (menu : GMenu.menu GMenu.factory) = function | S_none -> () | s -> let target = match s with | S_none -> "none" | S_prop ip -> kind_of_property ip | S_call _ -> "call preconditions" | S_fun _ -> "function annotations" in let title = Printf.sprintf "Prove %s by WP" target in ignore (menu#add_item title ~callback:(fun () -> prove s)) method register (menu : GMenu.menu GMenu.factory) (main : Design.main_window_extension_points) ~(button:int) (loc:Pretty_source.localizable) = begin match button with | 1 -> begin match selection_of_localizable loc with | S_none -> () | s -> click s end | 3 -> begin self#wp_popup menu (selection_of_localizable loc) ; self#rte_popup menu main loc ; end | _ -> () end end (* -------------------------------------------------------------------------- *) (* --- Source Highlighter for WP --- *) (* -------------------------------------------------------------------------- *) module PATH = Stmt.Set module DEPS = Property.Set let apply_tag name attr buffer start stop = let tg = Gtk_helper.make_tag buffer name attr in Gtk_helper.apply_tag buffer tg start stop let apply_goal = apply_tag "wp.goal" [`BACKGROUND "lightblue"] let apply_effect = apply_tag "wp.effect" [`BACKGROUND "lightblue"] let apply_path = apply_tag "wp.path" [`BACKGROUND "yellow"] let apply_depend = apply_tag "wp.depend" [`BACKGROUND "pink"] let instructions path = PATH.filter (fun s -> match s.skind with | Instr _ -> true | _ -> false) path let lemmas ls = List.fold_left (fun s l -> DEPS.add (LogicUsage.ip_lemma l) s) DEPS.empty ls class highlighter (main:Design.main_window_extension_points) = object(self) val mutable goal = None (* orange *) val mutable effect = None (* blue *) val mutable path = PATH.empty (* yellow *) val mutable deps = DEPS.empty (* green *) val mutable current = None method private clear = begin goal <- None ; effect <- None ; path <- PATH.empty ; deps <- DEPS.empty ; end method private scroll () = main#rehighlight () ; match goal with | None -> () | Some ip -> main#scroll (PIP ip) method set s = let moved = match current, s with | None , None -> false | Some s0 , Some s1 -> s0.po_gid <> s1.po_gid | None , Some _ | Some _ , None -> true in if moved then begin current <- s ; self#clear ; match s with | None -> Gtk_helper.later main#rehighlight ; | Some { Wpo.po_pid = pid ; Wpo.po_formula = f } -> begin match f with | GoalLemma l -> deps <- lemmas l.VC_Lemma.depends | GoalAnnot a -> effect <- a.VC_Annot.effect ; path <- instructions a.VC_Annot.path ; deps <- a.VC_Annot.deps ; end ; let ip = WpPropId.property_of_id pid in goal <- Some ip ; Gtk_helper.later self#scroll ; end method update = main#rehighlight () method highlight (buffer : GSourceView2.source_buffer) (loc : Pretty_source.localizable) ~(start:int) ~(stop:int) = begin match loc with | PStmt( _ , stmt ) -> begin match effect with | Some(s,_) when Stmt.equal stmt s -> apply_effect buffer start stop | _ -> if PATH.mem stmt path then apply_path buffer start stop end | PIP ip -> begin match goal with | Some g when Property.equal g ip -> apply_goal buffer start stop | _ -> if DEPS.mem ip deps then apply_depend buffer start stop end | PGlobal _|PVDecl _|PTermLval _|PLval _ -> () end end frama-c-Fluorine-20130601/src/wp/MemVar.mli0000644000175000017500000000401712155630215017106 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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-Aliasing Memory Model --- *) (* -------------------------------------------------------------------------- *) open Cil_types type param = ByValue | ByRef | InHeap module type VarUsage = sig val datatype : string val param : varinfo -> param end module Make(V : VarUsage)(M : Memory.Model) : Memory.Model frama-c-Fluorine-20130601/src/wp/wpPropId.mli0000644000175000017500000002052612155630215017466 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 LogicUsage (** 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 val source_of_id : prop_id -> Lexing.position (*----------------------------------------------------------------------------*) module PropId : 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 val is_loop_preservation : prop_id -> stmt option (** 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 list -> prop_id -> bool (** 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 (*----------------------------------------------------------------------------*) val prop_id_keys : prop_id -> string list * string list (* required , hints *) val get_propid : prop_id -> string (** Unique identifier of [prop_id] *) val pp_propid : Format.formatter -> prop_id -> unit (** Print unique id of [prop_id] *) val pretty : Format.formatter -> prop_id -> unit val pretty_context : Description.kf -> Format.formatter -> prop_id -> unit val pretty_local : Format.formatter -> prop_id -> unit (** Short description of the kind of PO *) val label_of_prop_id: prop_id -> 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_ids : kernel_function -> stmt -> code_annotation -> prop_id list 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_lemma_id : logic_lemma -> 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_stmt : Cil_types.stmt option ; a_kind : a_kind ; a_assigns : Cil_types.identified_term Cil_types.assigns ; } val pp_assigns_desc : Format.formatter -> assigns_desc -> unit type effect_source = FromCode | FromCall | FromReturn 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 axiom_info = prop_id * LogicUsage.logic_lemma val mk_axiom_info : LogicUsage.logic_lemma -> 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 (*----------------------------------------------------------------------------*) frama-c-Fluorine-20130601/src/wp/Partitioning.ml0000644000175000017500000001422112155630215020213 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Variables Partitioning --- *) (* -------------------------------------------------------------------------- *) open Qed.Logic open Lang open Lang.F type partition = { mutable color : var Vmap.t ; mutable depend : Vars.t Vmap.t ; mutable mem : var Tmap.t ; } let zero = Var.dummy let create () = { color = Vmap.empty ; depend = Vmap.empty ; mem = Tmap.empty ; } (* -------------------------------------------------------------------------- *) (* --- Current Partition --- *) (* -------------------------------------------------------------------------- *) let rec color w x = try let y = Vmap.find x w.color in let z = color w y in if z != y then w.color <- Vmap.add x z w.color ; z with Not_found -> x let depend w x = try Vmap.find (color w x) w.depend with Not_found -> Vars.empty (* -------------------------------------------------------------------------- *) (* --- Unification & Dependencies --- *) (* -------------------------------------------------------------------------- *) (* keep x, bind y *) let merge w x y = w.color <- Vmap.add y x w.color ; let xs = depend w x in let ys = depend w y in let zs = Vars.union xs ys in w.depend <- Vmap.add x zs (Vmap.remove y w.depend) let unify w x y = if x == zero then y else if y == zero then x else let x = color w x in let y = color w y in let cmp = Var.compare x y in if cmp < 0 then (merge w x y ; x) else if cmp > 0 then (merge w y x ; y) else x let add_depend w x xs = let x = color w x in let ys = depend w x in w.depend <- Vmap.add x (Vars.union xs ys) w.depend (* -------------------------------------------------------------------------- *) (* --- Segregation --- *) (* -------------------------------------------------------------------------- *) let is_varray x = match Var.sort x with Sarray _ -> true | _ -> false let color_of w xs c e = let ms,xs = Vars.partition is_varray (Vars.diff (F.varsp e) xs) in let c = Vars.fold (unify w) ms c in let d = Vars.fold (unify w) xs zero in if c == zero then d else (if d != zero then add_depend w c (Vars.singleton d) ; c) (* -------------------------------------------------------------------------- *) (* --- Collection --- *) (* -------------------------------------------------------------------------- *) let rec walk w xs p = match F.pred p with | Eq(a,b) | Leq(a,b) | Lt(a,b) | Neq(a,b) -> let ca = color_of w xs zero a in let cb = color_of w xs zero b in ignore (unify w ca cb) | Fun(_,es) -> ignore (List.fold_left (fun c e -> let ce = color_of w xs zero e in unify w c ce) zero es) | And ps | Or ps -> List.iter (walk w xs) ps | Not p -> walk w xs p | Imply(hs,p) -> List.iter (walk w xs) (p::hs) | Bind(_,x,p) -> walk w (Vars.add x xs) p | _ -> ignore (color_of w xs zero p) let collect w = walk w Vars.empty (* -------------------------------------------------------------------------- *) (* --- Partition --- *) (* -------------------------------------------------------------------------- *) type classeq = partition * Vars.t (* dependencies must be normalized *) let rec closure w x xs = let x = color w x in if Vars.mem x xs then xs else Vars.fold (closure w) (depend w x) (Vars.add x xs) let classes w = w.depend <- Vmap.map (fun _ xs -> Vars.map (color w) xs) w.depend ; Vars.fold (fun x cs -> ( w , closure w x Vars.empty ) :: cs) (Vmap.fold (fun _ x xs -> Vars.add (color w x) xs) w.color Vars.empty) [] (* Tautologies: False ==> P and P ==> True for all P *) (* Requires: filter false p ==> p *) (* Requires: p ==> filter true p *) let rec filter w positive xs p = match F.pred p with | And ps -> F.p_all (filter w positive xs) ps | Or ps -> F.p_any (filter w positive xs) ps | Not p -> F.p_not (filter w (not positive) xs p) | Imply(hs,p) -> let hs = List.map (filter w (not positive) xs) hs in F.p_hyps hs (filter w positive xs p) | Bind(q,x,p) -> F.p_bind q x (filter w positive (Vars.add x xs) p) | _ -> if Vars.exists (fun x -> Vars.mem (color w x) xs) (F.varsp p) then p else if positive then p_true else p_false let filter_hyp (w,xs) = filter w true xs let filter_goal (w,xs) = filter w false xs frama-c-Fluorine-20130601/src/wp/GuiList.ml0000644000175000017500000001322012155630215017122 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- PO List View --- *) (* -------------------------------------------------------------------------- *) open Gtk_helper open Wpo module Windex = Indexer.Make(Wpo.S) class model = object(self) val mutable index = Windex.empty method reload = index <- Windex.empty method add w = index <- Windex.add w index method size = Windex.size index method index w = Windex.index w index method get k = Windex.get k index method coerce = (self :> Wpo.t Custom.List.model) end class pane (enabled:GuiConfig.provers) = let model = new model in let list = new Custom.List.view ~headers:true ~rules:true model#coerce in object(self) method coerce = list#coerce method reload = list#reload method add wpo = begin model#add wpo ; list#insert_row wpo ; end method size = model#size method index = model#index method get = model#get method update_all = list#update_all method update w = list#update_row w (* -------------------------------------------------------------------------- *) (* --- Prover Columns Management --- *) (* -------------------------------------------------------------------------- *) val mutable provers : (VCS.prover * GTree.view_column) list = [] method private prover_of_column c = let id = c#misc#get_oid in try Some(fst(List.find (fun (_,c0) -> id = c0#misc#get_oid) provers)) with Not_found -> None method private column_of_prover p = try Some(snd(List.find (fun (p0,_) -> p=p0) provers)) with Not_found -> None method private create_prover p = begin let verdict = function | VCS.NoResult -> "" | VCS.Valid -> "gtk-yes" | VCS.Failed -> "gtk-dialog-warning" | VCS.Unknown -> "gtk-no" | VCS.Timeout -> "gtk-cut" | VCS.Stepout -> "gtk-cut" | VCS.Invalid -> "gtk-no" | VCS.Computing _ -> "gtk-execute" in let render w = match Wpo.get_result w p with | { VCS.verdict=VCS.NoResult } when p=VCS.Qed -> [ `PIXBUF(Gtk_helper.Icon.get Gtk_helper.Icon.Unmark) ] | r -> [ `STOCK_ID (verdict r.VCS.verdict) ] in let title = VCS.name_of_prover p in let column = list#add_column_pixbuf ~title [] render in if p <> VCS.Qed then provers <- (p,column) :: provers end method private configure dps = let open ProverWhy3 in begin let rec wanted p = function | [] -> false | dp :: dps -> dp.dp_prover = p || dp.dp_name = p || wanted p dps in (* Removing Useless Columns *) List.iter (fun (vcs,column) -> match vcs with | VCS.Why3 p when not (wanted p dps) -> ignore (list#view#remove_column column) | _ -> () ) provers ; (* Installing Missing Columns *) List.iter (fun dp -> let p = VCS.Why3 dp.dp_prover in match self#column_of_prover p with | None -> self#create_prover p | Some _ -> () ) dps ; end initializer begin let render w = [`TEXT (Pretty_utils.to_string Wpo.pp_index w.po_idx)] in ignore (list#add_column_text ~title:"Module" [] render) ; let render w = [`TEXT (Pretty_utils.to_string Wpo.pp_title w)] in ignore (list#add_column_text ~title:"Goal" [] render) ; let render w = [`TEXT (Wpo.get_model_name w)] in ignore (list#add_column_text ~title:"Model" [] render) ; List.iter self#create_prover [ VCS.Qed ; VCS.AltErgo ; VCS.Coq ; VCS.Why3ide ] ; list#add_column_empty ; list#set_selection_mode `MULTIPLE ; enabled#connect self#configure ; self#configure enabled#get ; end method private on_cell f w c = f w (self#prover_of_column c) method on_click f = list#on_click (self#on_cell f) method on_double_click f = list#on_double_click (self#on_cell f) method on_selection f = list#on_selection (fun () -> f list#count_selected) method iter_selected = list#iter_selected method count_selected = list#count_selected method show w = let col = list#view#get_column 1 in list#set_focus w col end frama-c-Fluorine-20130601/src/wp/cfgDump.mli0000644000175000017500000000330112155630215017277 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* Produce a CfgProof.computer that dumps a graph of generated PO *) val create : unit -> Generator.computer frama-c-Fluorine-20130601/src/wp/why3_xml.mll0000644000175000017500000001604312155630215017476 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2013 -- INRIA - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) { type element = { name : string; attributes : (string * string) list; elements : element list; } type t = { version : string; encoding : string; doctype : string; dtd : string; content : element; } let buf = Buffer.create 17 let rec pop_all group_stack element_stack = match group_stack with | [] -> element_stack | (elem,att,elems)::g -> let e = { name = elem; attributes = att; elements = List.rev element_stack; } in pop_all g (e::elems) exception Parse_error of string let parse_error s = raise (Parse_error s) } let space = [' ' '\t' '\r' '\n'] let digit = ['0'-'9'] let letter = ['a'-'z' 'A'-'Z'] let ident = (letter | digit | '_') + let sign = '-' | '+' let integer = sign? digit+ let mantissa = ['e''E'] sign? digit+ let real = sign? digit* '.' digit* mantissa? let escape = ['\\''"''n''t''r'] rule xml_prolog = parse | space+ { xml_prolog lexbuf } | "" { xml_doctype "1.0" "" lexbuf } | "" { xml_doctype "1.0" "" lexbuf } | "'])* "?>" { (* dprintf debug "[Xml warning] prolog ignored@."; *) xml_doctype "1.0" "" lexbuf } | _ { parse_error "wrong prolog" } and xml_doctype version encoding = parse | space+ { xml_doctype version encoding lexbuf } | "']* ">" { match elements [] [] lexbuf with | [x] -> { version = version; encoding = encoding; doctype = doctype; dtd = ""; content = x; } | _ -> parse_error "there should be exactly one root element" } | _ { parse_error "wrong DOCTYPE" } and elements group_stack element_stack = parse | space+ { elements group_stack element_stack lexbuf } | '<' (ident as elem) { attributes group_stack element_stack elem [] lexbuf } | "' { match group_stack with | [] -> (* dprintf debug *) (* "[Xml warning] unexpected closing Xml element `%s'@." *) (* celem; *) elements group_stack element_stack lexbuf | (elem,att,stack)::g -> (* if celem <> elem then *) (* dprintf debug *) (* "[Xml warning] Xml element `%s' closed by `%s'@." *) (* elem celem; *) let e = { name = elem; attributes = att; elements = List.rev element_stack; } in elements g (e::stack) lexbuf } | '<' { (* dprintf debug "[Xml warning] unexpected '<'@."; *) elements group_stack element_stack lexbuf } | eof { match group_stack with | [] -> element_stack | (_elem,_,_)::_ -> (* dprintf debug "[Xml warning] unclosed Xml element `%s'@." elem; *) pop_all group_stack element_stack } | _ as c { parse_error ("invalid element starting with " ^ String.make 1 c) } and attributes groupe_stack element_stack elem acc = parse | space+ { attributes groupe_stack element_stack elem acc lexbuf } | (ident as key) space* '=' { let v = value lexbuf in attributes groupe_stack element_stack elem ((key,v)::acc) lexbuf } | '>' { elements ((elem,acc,element_stack)::groupe_stack) [] lexbuf } | "/>" { let e = { name = elem ; attributes = acc; elements = [] } in elements groupe_stack (e::element_stack) lexbuf } | _ as c { parse_error ("'>' expected, got " ^ String.make 1 c) } | eof { parse_error "unclosed element, `>' expected" } and value = parse | space+ { value lexbuf } | '"' { Buffer.clear buf; string_val lexbuf } | _ as c { parse_error ("invalid value starting with " ^ String.make 1 c) } | eof { parse_error "unterminated keyval pair" } and string_val = parse | '"' { Buffer.contents buf } | "<" { Buffer.add_char buf '<'; string_val lexbuf } | ">" { Buffer.add_char buf '>'; string_val lexbuf } | """ { Buffer.add_char buf '"'; string_val lexbuf } | "'" { Buffer.add_char buf '\''; string_val lexbuf } | "&" { Buffer.add_char buf '&'; string_val lexbuf } | [^ '"'] as c { Buffer.add_char buf c; string_val lexbuf } | eof { parse_error "unterminated string" } { let from_file f = let c = open_in f in let lb = Lexing.from_channel c in let t = xml_prolog lb in close_in c; t } frama-c-Fluorine-20130601/src/wp/configure.ac0000644000175000017500000000544612155630215017511 0ustar mehdimehdi########################################################################## # # # This file is part of WP plug-in of Frama-C. # # # # Copyright (C) 2007-2013 # # CEA (Commissariat a l'energie atomique et aux energies # # 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),[WP plug-in],yes,yes) AC_ARG_ENABLE( wpcoq, [ --enable-wpcoq Wp precompiled coq libraries (default: yes)], WPCOQ=$enableval, WPCOQ=yes ) if test "$ENABLE_WP" != "no"; then plugin_use(wp,gui) plugin_use(wp,rte_annotation) if test "$WPCOQ" = "yes" ; then ## coq AC_CHECK_PROG(COQC,coqc,yes,no) if test "$COQC" = "yes" ; then COQVERSION=`coqc -v | sed -n -e 's|.*version* *\([[^ ]]*\) .*$|\1|p' ` case $COQVERSION in 8.4*|trunk) AC_MSG_RESULT(coqc version $COQVERSION found) ;; *) AC_MSG_RESULT(wp needs coq 8.4, found $COQVERSION) COQC="no" ;; esac else AC_MSG_NOTICE(rerun configure to make wp using coq 8.4) fi else COQC="no" fi AC_SUBST(COQC) check_plugin_dependencies fi write_plugin_config(Makefile) frama-c-Fluorine-20130601/src/wp/MemEmpty.ml0000644000175000017500000000673212155630215017311 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Empty Memory Model --- *) (* -------------------------------------------------------------------------- *) open Lang.F open Memory module Logic = Qed.Logic let datatype = "MemEmpty" let configure () = begin Context.set Lang.pointer (fun _typ -> Logic.Int) ; Context.set Cvalues.null (p_equal e_zero) ; end let theories () = [] module Chunk = struct type t = unit let self = "empty" let hash () = 0 let equal () () = true let compare () () = 0 let pretty _fmt () = () let tau_of_chunk () = Logic.Int let basename_of_chunk () = "u" end module Heap = Qed.Collection.Make(Chunk) module Sigma = Sigma.Make(Chunk)(Heap) type loc = unit type chunk = Chunk.t type sigma = Sigma.t type segment = loc rloc let pretty _fmt () = () let vars _l = Vars.empty let occurs _x _l = false let null = () let literal ~eid _ = ignore eid let cvar _x = () let pointer_loc _t = () let pointer_val () = e_zero let field _l _f = () let shift _l _obj _k = () let base_addr _l = () let block_length _s _obj _l = e_zero let cast _ _l = () let loc_of_int _ _ = () let int_of_loc _ () = e_zero let domain _obj _l = Heap.Set.empty let source = "Empty Model" let load _sigma _obj () = Warning.error ~source "Can not load value in Empty model" let copied _s _obj () () = [] let stored _s _obj () _ = [] let assigned _s _obj _sloc = [] let no_pointer () = Warning.error ~source "Can not compare pointers in Empty model" let is_null _ = no_pointer () let loc_eq _ _ = no_pointer () let loc_lt _ _ = no_pointer () let loc_leq _ _ = no_pointer () let loc_neq _ _ = no_pointer () let loc_diff _ _ _ = no_pointer () let valid _sigma _l = Warning.error ~source "No validity" let scope sigma _s _xs = sigma , [] let included _s1 _s2 = no_pointer () let separated _s1 _s2 = no_pointer () frama-c-Fluorine-20130601/src/wp/Matrix.ml0000644000175000017500000001333212155630215017012 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Array Dimensions --- *) (* -------------------------------------------------------------------------- *) open Ctypes open Lang.F type dim = int64 option type matrix = c_object * dim list let of_array = Ctypes.array_dimensions module KEY(E : sig val compare : c_object -> c_object -> int end) = struct type t = matrix let compare_dim d1 d2 = match d1 , d2 with | None,None -> 0 | Some _,None -> (-1) | None,Some _ -> 1 | Some _,Some _ -> 0 let compare (e1,ds1) (e2,ds2) = let cmp = E.compare e1 e2 in if cmp = 0 then Qed.Hcons.compare_list compare_dim ds1 ds2 else cmp let pretty fmt (obj,ds) = Ctypes.pretty fmt obj ; List.iter (function | None -> Format.pp_print_string fmt "[]" | Some d -> Format.fprintf fmt "[%s]" (Int64.to_string d) ) ds end module COBJ = struct let compare e1 e2 = match e1 , e2 with | C_int _ , C_int _ -> 0 | C_int _ , _ -> (-1) | _ , C_int _ -> 1 | C_float _ , C_float _ -> 0 | C_float _ , _ -> (-1) | _ , C_float _ -> 1 | C_pointer _ , C_pointer _ -> 0 | C_pointer _ , _ -> (-1) | _ , C_pointer _ -> 1 | C_comp a , C_comp b -> Cil_datatype.Compinfo.compare a b | C_comp _ , _ -> (-1) | _ , C_comp _ -> 1 | C_array _ , C_array _ -> assert false end module MACHINE = KEY(Ctypes) module NATURAL = KEY(COBJ) let natural_id = function | C_int _ -> "int" | C_float _ -> "float" | C_pointer _ -> "pointer" | C_array _ -> "array" | C_comp c -> Lang.comp_id c let add_rank buffer k = if k > 0 then Buffer.add_string buffer (string_of_int k) let add_dim buffer rank = function | None -> add_rank buffer rank ; Buffer.add_string buffer "w" ; 0 | Some _ -> succ rank let id ds = let buffer = Buffer.create 8 in add_rank buffer (List.fold_left (add_dim buffer) 0 ds) ; Buffer.contents buffer type denv = { size_var : var list ; (* size variables *) size_val : term list ; (* size values *) index_var : var list ; (* index variables *) index_val : term list ; (* index values *) index_range : pred list ; (* indices are in range of size variables *) index_offset : term list ; (* polynomial of indices *) monotonic : bool ; } let rec collect rank = function | [] -> { size_var = [] ; size_val = [] ; index_var = [] ; index_val = [] ; index_range = [] ; index_offset = [] ; monotonic = true ; } | d::ds -> let denv = collect (succ rank) ds in let k_base = match rank with 0 -> "i" | 1 -> "j" | _ -> "k" in let k_var = Lang.freshvar ~basename:k_base Qed.Logic.Int in let k_val = e_var k_var in let k_ofs = e_prod (k_val :: denv.size_val) in match d with | None -> { denv with index_var = k_var :: denv.index_var ; index_val = k_val :: denv.index_val ; index_offset = k_ofs :: denv.index_offset ; monotonic = false ; } | Some _ -> let n_base = match rank with 0 -> "n" | 1 -> "m" | _ -> "d" in let n_var = Lang.freshvar ~basename:n_base Qed.Logic.Int in let n_val = e_var n_var in let k_inf = p_leq e_zero k_val in let k_sup = p_lt k_val n_val in { size_var = n_var :: denv.size_var ; size_val = n_val :: denv.size_val ; index_var = k_var :: denv.index_var ; index_val = k_val :: denv.index_val ; index_offset = k_ofs :: denv.index_offset ; index_range = k_inf :: k_sup :: denv.index_range ; monotonic = denv.monotonic ; } let denv = collect 0 let rec dval = function | [] -> [] | None :: ds -> dval ds | Some n :: ds -> e_int64 n :: dval ds let size (_,ds) = dval ds let rec tau obj = function | [] -> Lang.tau_of_object obj | _ :: ds -> Qed.Logic.Array( Qed.Logic.Int , tau obj ds ) let rec do_merge ds1 ds2 = match ds1 , ds2 with | [] , [] -> [] | [] , _ | _ , [] -> raise Exit | d1::ds1 , d2::ds2 -> let d = match d1 , d2 with | None , _ | _ , None -> None | Some n1 , Some n2 -> if n1=n2 then d1 else raise Exit in d :: do_merge ds1 ds2 let merge ds1 ds2 = try Some(do_merge ds1 ds2) with Exit -> None frama-c-Fluorine-20130601/src/wp/script.mli0000644000175000017500000000440112155630215017220 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 val filter : string -> string option frama-c-Fluorine-20130601/src/wp/Matrix.mli0000644000175000017500000000527212155630215017167 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Array Dimensions --- *) (* -------------------------------------------------------------------------- *) open Ctypes open Lang.F type dim = int64 option type matrix = c_object * dim list module MACHINE : Model.Key with type t = matrix module NATURAL : Model.Key with type t = matrix val of_array : arrayinfo -> matrix val id : dim list -> string (** unique w.r.t [equal] *) val natural_id : c_object -> string (** name for elements in NATURAL *) val merge : dim list -> dim list -> dim list option type denv = { size_var : var list ; (** size variables *) size_val : term list ; (** size values *) index_var : var list ; (** index variables *) index_val : term list ; (** index values *) index_range : pred list ; (** indices are in range of size variables *) index_offset : term list ; (** polynomial of indices *) monotonic : bool ; (** all dimensions are defined *) } val denv : dim list -> denv val size : matrix -> term list val tau : c_object -> dim list -> tau frama-c-Fluorine-20130601/src/wp/MemTyped.mli0000644000175000017500000000364612155630215017452 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Typed Memory Model --- *) (* -------------------------------------------------------------------------- *) include Memory.Model type pointer = NoCast | Fits | Unsafe val pointer : pointer Context.value frama-c-Fluorine-20130601/src/wp/calculus.mli0000644000175000017500000000341412155630215017532 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (** 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 frama-c-Fluorine-20130601/src/wp/wpReport.ml0000644000175000017500000006050112155630215017370 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Fast Report for WP --- *) (* -------------------------------------------------------------------------- *) let ladder = [| 1.0 ; 2.0 ; 3.0 ; 5.0 ; 10.0 ; 15.0 ; 20.0 ; 30.0 ; 40.0 ; 60.0 ; 90.0 ; 120.0 ; 180.0 ; (* 1', 1'30, 2', 3' *) 300.0 ; 600.0 ; 900.0 ; 1800.0 ; (* 5', 10', 15', 30' *) 3600.0 |] (* 1h *) (* -------------------------------------------------------------------------- *) (* --- Statistics --- *) (* -------------------------------------------------------------------------- *) type res = VALID | UNSUCCESS | INCONCLUSIVE | NORESULT let result (r:VCS.result) = match r.VCS.verdict with | VCS.NoResult | VCS.Computing _ -> NORESULT | VCS.Failed -> INCONCLUSIVE | VCS.Invalid | VCS.Unknown | VCS.Timeout | VCS.Stepout -> UNSUCCESS | VCS.Valid -> VALID let best_result a b = match a,b with | NORESULT,c | c,NORESULT -> c | VALID,_ | _,VALID -> VALID | UNSUCCESS,_ | _,UNSUCCESS -> UNSUCCESS | INCONCLUSIVE,INCONCLUSIVE -> INCONCLUSIVE type stats = { mutable valid : int ; (* Result is Valid *) mutable unsuccess : int ; (* verdict is NoResult, Unknown, Timeout, or Stepout, Invalid *) mutable inconclusive : int ; (* verdict is Failed *) mutable total : int ; (* valid + unsuccess + inconclusive *) mutable steps : int ; mutable time : float ; } let stats () = { total=0 ; valid=0 ; unsuccess=0 ; inconclusive=0 ; steps=0 ; time=0.0 } let add_stat (r:res) (st:int) (tm:float) (s:stats) = begin s.total <- succ s.total ; match r with | VALID -> if tm > s.time then s.time <- tm ; if st > s.steps then s.steps <- st ; s.valid <- succ s.valid | NORESULT | UNSUCCESS -> s.unsuccess <- succ s.unsuccess | INCONCLUSIVE -> s.inconclusive <- succ s.inconclusive end let add_qedstat (ts:float) (s:stats) = if ts > s.time then s.time <- ts (* -------------------------------------------------------------------------- *) (* --- Stats by Prover --- *) (* -------------------------------------------------------------------------- *) type pstats = { main : stats ; prover : (VCS.prover,stats) Hashtbl.t ; } let pstats () = { main = stats () ; prover = Hashtbl.create 7 ; } let get_prover fs prover = try Hashtbl.find fs.prover prover with Not_found -> let s = stats () in Hashtbl.add fs.prover prover s ; s let add_results (plist:pstats list) (wpo:Wpo.t) = let ok = ref NORESULT in let tm = ref 0.0 in let sm = ref 0 in List.iter (fun (p,r) -> let re = result r in let st = Wpo.get_steps r in let tc = Wpo.get_time r in let ts = r.VCS.solver_time in if re <> NORESULT then begin List.iter (fun fs -> add_stat re st tc (get_prover fs p)) plist ; if p <> VCS.Qed && ts > 0.0 then List.iter (fun fs -> add_qedstat ts (get_prover fs VCS.Qed)) plist ; end ; ok := best_result !ok re ; if tc > !tm then tm := tc ; if st > !sm then sm := st ; ) (Wpo.get_results wpo) ; List.iter (fun fs -> add_stat !ok !sm !tm fs.main) plist (* -------------------------------------------------------------------------- *) (* --- Stats by Section --- *) (* -------------------------------------------------------------------------- *) type coverage = { mutable covered : Property.Set.t ; mutable proved : Property.Set.t ; } let coverage () = { covered = Property.Set.empty ; proved = Property.Set.empty } let add_cover (s:coverage) ok p = begin s.covered <- Property.Set.add p s.covered ; if ok then s.proved <- Property.Set.add p s.proved ; end type dstats = { dstats : pstats ; dcoverage : coverage ; mutable dmap : pstats Property.Map.t ; } let dstats () = { dstats = pstats () ; dcoverage = coverage () ; dmap = Property.Map.empty ; } (* -------------------------------------------------------------------------- *) (* --- Stats WP --- *) (* -------------------------------------------------------------------------- *) type entry = | Global of string (* [JS 2012/11/27] unused *) | Axiom of string | Fun of Kernel_function.t let decode_chapter= function | Global _-> "global" | Axiom _ -> "axiomatic" | Fun _ -> "function" module Smap = Map.Make (struct type t = entry let compare s1 s2 = match s1 , s2 with | Global a, Global b -> String.compare a b | Global _, _ -> (-1) | _ , Global _ -> 1 | Axiom a , Axiom b -> String.compare a b | Axiom _ , Fun _ -> (-1) | Fun _ , Axiom _ -> 1 | Fun f , Fun g -> Kernel_function.compare f g end) type fcstat = { global : pstats ; gcoverage : coverage ; mutable dsmap : dstats Smap.t ; } (* -------------------------------------------------------------------------- *) (* --- Computing Statistics --- *) (* -------------------------------------------------------------------------- *) let get_section gs s = try Smap.find s gs.dsmap with Not_found -> let ds = dstats () in gs.dsmap <- Smap.add s ds gs.dsmap ; ds let get_property ds p = try Property.Map.find p ds.dmap with Not_found -> let ps = pstats () in ds.dmap <- Property.Map.add p ps ds.dmap ; ps let add_goal (gs:fcstat) wpo = begin let section = match Wpo.get_index wpo with | Wpo.Axiomatic None -> Axiom "" | Wpo.Axiomatic (Some a) -> Axiom a | Wpo.Function(kf,_) -> Fun kf in let ds : dstats = get_section gs section in let (ok,prop) = Wpo.get_proof wpo in let ps : pstats = get_property ds prop in add_results [gs.global ; ds.dstats ; ps] wpo ; add_cover gs.gcoverage ok prop ; add_cover ds.dcoverage ok prop ; end let fcstat () = let fcstat : fcstat = { global = pstats () ; gcoverage = coverage () ; dsmap = Smap.empty ; } in Wpo.iter ~on_goal:(add_goal fcstat) () ; fcstat (* -------------------------------------------------------------------------- *) (* --- Iteration on Stats --- *) (* -------------------------------------------------------------------------- *) type istat = { fcstat: fcstat; chapters : (string * (entry * dstats) list) list; } (** start chapter stats *) let start_stat4chap fcstat = let chapter = ref "" in let decode_chapter e = let code = decode_chapter e in let is_new_code = (code <> !chapter) in if is_new_code then chapter := code; is_new_code in let close_chapter (na,ca,ga) = if ca = [] then !chapter,[],ga else !chapter,[],((na,List.rev ca)::ga) in let (_,_,ga) = let acc = Smap.fold (fun entry ds acc -> let is_new_chapter = decode_chapter entry in let (na,ca,ga) = if is_new_chapter then close_chapter acc else acc in na,((entry,ds)::ca),ga ) fcstat.dsmap ("",[],[]) in if !chapter <> "" then close_chapter acc else acc in if ga = [] then None else Some { fcstat = fcstat; chapters = List.rev ga; } (** next chapters stats *) let next_stat4chap istat = match istat.chapters with | ([] | _::[]) -> None | _::l -> Some { istat with chapters = l } type cistat = { cfcstat: fcstat; chapter : string; sections : (entry * dstats) list; } (** start section stats of a chapter*) let start_stat4sect istat = match istat.chapters with | [] -> None | (c,s)::_ -> Some { cfcstat = istat.fcstat; chapter = c; sections = s; } (** next section stats *) let next_stat4sect cistat = match cistat.sections with | ([] | _::[]) -> None | _::l -> Some { cistat with sections = l } type sistat = { sfcstat: fcstat; schapter : string ; section : (entry * dstats); properties : (Property.t * pstats) list; } (** start property stats of a section *) let start_stat4prop cistat = match cistat.sections with | [] -> None | ((_,ds) as s)::_ -> Some { sfcstat = cistat.cfcstat; schapter = cistat.chapter; section = s; properties = List.rev (Property.Map.fold (fun p ps acc -> (p,ps)::acc) ds.dmap []); } (** next property stats *) let next_stat4prop sistat = match sistat.properties with | ([] | _::[]) -> None | _::l -> Some { sfcstat = sistat.sfcstat; schapter = sistat.schapter; section = sistat.section; properties = l; } (** generic iterator *) let iter_stat ?first ?sep ?last ~from start next= if first<>None || sep<>None || last <> None then let items = ref (start from) in if !items <> None then begin let apply v = function | None -> () | Some app -> app v in let next app = let item = (Extlib.the !items) in apply item app; items := next item in next first; if sep<>None || last <> None then begin while !items <> None do next sep; done; apply () last; end end (* -------------------------------------------------------------------------- *) (* --- Rendering Numbers --- *) (* -------------------------------------------------------------------------- *) type config = { mutable status_passed : string ; mutable status_failed : string ; mutable status_inconclusive : string ; mutable status_untried : string ; mutable global_prefix : string ; mutable lemma_prefix : string ; mutable axiomatic_prefix : string ; mutable function_prefix : string ; mutable property_prefix : string ; mutable global_section: string ; mutable axiomatic_section: string ; mutable function_section : string ; mutable console : bool ; mutable zero : string ; } let pp_zero ~config fmt = if config.console then Format.fprintf fmt "%4s" config.zero else Format.pp_print_string fmt config.zero let percent ~config fmt number total = if total <= 0 || number < 0 then pp_zero ~config fmt else if number >= total then Format.pp_print_string fmt (if config.console then " 100" else "100") else let ratio = float_of_int number /. float_of_int total in Format.fprintf fmt "%4.1f" (100.0 *. ratio) let number ~config fmt k = if k = 0 then pp_zero ~config fmt else if config.console then Format.fprintf fmt "%4d" k else Format.pp_print_int fmt k let properties ~config fmt (s:coverage) = function | "" -> percent config fmt (Property.Set.cardinal s.proved) (Property.Set.cardinal s.covered) | "total" -> number config fmt (Property.Set.cardinal s.covered) | "valid" -> number config fmt (Property.Set.cardinal s.proved) | "failed" -> number config fmt (Property.Set.cardinal s.covered - Property.Set.cardinal s.proved) | _ -> raise Exit let stat ~config fmt s = function | "success" -> percent config fmt s.valid s.total | "total" -> number config fmt s.total | "valid" | "" -> number config fmt s.valid | "failed" -> number config fmt (s.unsuccess + s.inconclusive) | "status" -> let msg = if s.inconclusive > 0 then config.status_inconclusive else if s.unsuccess > 0 then config.status_failed else if s.valid >= s.total then config.status_passed else config.status_untried in Format.pp_print_string fmt msg | "inconclusive" -> number config fmt s.inconclusive | "unsuccess" -> number config fmt s.unsuccess | "time" -> if s.time > 0.0 then Rformat.pp_time_range ladder fmt s.time | "perf" -> if s.time > Rformat.epsilon then Format.fprintf fmt "(%a)" Rformat.pp_time s.time | "steps" -> if s.steps > 0 then Format.fprintf fmt "(%d)" s.steps | _ -> raise Exit let pstats ~config fmt s cmd arg = match cmd with | "wp" | "qed" -> stat ~config fmt (get_prover s VCS.Qed) arg | "alt-ergo" | "ergo" -> stat ~config fmt (get_prover s VCS.AltErgo) arg | "coq" -> stat ~config fmt (get_prover s VCS.Coq) arg | "z3" -> stat ~config fmt (get_prover s (VCS.Why3 "z3")) arg | "gappa" -> stat ~config fmt (get_prover s (VCS.Why3 "gappa")) arg | "simplify" -> stat ~config fmt (get_prover s (VCS.Why3 "simplify")) arg | "vampire" -> stat ~config fmt (get_prover s (VCS.Why3 "vampire")) arg | "zenon" -> stat ~config fmt (get_prover s (VCS.Why3 "zenon")) arg | "cvc3" -> stat ~config fmt (get_prover s (VCS.Why3 "cvc3")) arg | "yices" -> stat ~config fmt (get_prover s (VCS.Why3 "yices")) arg | _ -> stat ~config fmt s.main cmd let pcstats ~config fmt (s,c) cmd arg = match cmd with | "prop" -> properties ~config fmt c arg | _ -> pstats ~config fmt s cmd arg (* -------------------------------------------------------------------------- *) (* --- Rformat Environments --- *) (* -------------------------------------------------------------------------- *) let env_toplevel ~config gstat fmt cmd arg = try pcstats config fmt (gstat.global, gstat.gcoverage) cmd arg with Exit -> if arg="" then Wp_parameters.error ~once:true "Unknown toplevel-format '%%%s'" cmd else Wp_parameters.error ~once:true "Unknown toplevel-format '%%%s:%s'" cmd arg let env_chapter chapter_name fmt cmd arg = try match cmd with | "chapter" | "name" -> Format.pp_print_string fmt chapter_name | _ -> raise Exit with Exit -> if arg="" then Wp_parameters.error ~once:true "Unknown chapter-format '%%%s'" cmd else Wp_parameters.error ~once:true "Unknown chapter-format '%%%s:%s'" cmd arg let env_section ~config ~name sstat fmt cmd arg = try let entry,ds = match sstat.sections with | section_item::_others -> section_item | _ -> raise Exit in match cmd with | "chapter" -> let chapter = match entry with | Global _ -> config.global_section | Axiom _ -> config.axiomatic_section | Fun _ -> config.function_section in Format.pp_print_string fmt chapter | "name" | "section" | "global" | "axiomatic" | "function" -> if cmd <> "name" && cmd <> "section" && name <> cmd then Wp_parameters.error "Invalid section-format '%%%s' inside a section %s" cmd name; let prefix,name = match entry with | Global a-> config.global_prefix, a | Axiom "" -> config.lemma_prefix,"" | Axiom a -> config.axiomatic_prefix,a | Fun kf -> config.function_prefix, ( Kernel_function.get_name kf) in Format.fprintf fmt "%s%s" prefix name | _ -> pcstats config fmt (ds.dstats, ds.dcoverage) cmd arg with Exit -> if arg="" then Wp_parameters.error ~once:true "Unknown section-format '%%%s'" cmd else Wp_parameters.error ~once:true "Unknown section-format '%%%s:%s'" cmd arg let env_property ~config ~name pstat fmt cmd arg = try let entry = fst pstat.section in let p,stat = match pstat.properties with | property_item::_others -> property_item | _ -> raise Exit in match cmd with | "chapter" -> let chapter = match entry with | Global _ -> config.global_section | Axiom _ -> config.axiomatic_section | Fun _ -> config.function_section in Format.pp_print_string fmt chapter | "section" | "global" | "axiomatic" | "function" -> if cmd <> "section" && name <> cmd then Wp_parameters.error "Invalid property-format '%%%s' inside a section %s" cmd name; let prefix,name = match entry with | Global a-> config.global_prefix, a | Axiom "" -> config.lemma_prefix,"" | Axiom a -> config.axiomatic_prefix,a | Fun kf -> config.function_prefix, ( Kernel_function.get_name kf) in Format.fprintf fmt "%s%s" prefix name | "name" -> Format.fprintf fmt "%s%s" config.property_prefix (Property.Names.get_prop_name_id p) | "property" -> Description.pp_local fmt p | _ -> pstats config fmt stat cmd arg with Exit -> if arg="" then Wp_parameters.error ~once:true "Unknown property-format '%%%s'" cmd else Wp_parameters.error ~once:true "Unknown property-format '%%%s:%s'" cmd arg (* -------------------------------------------------------------------------- *) (* --- Statistics Printing --- *) (* -------------------------------------------------------------------------- *) let print_property (pstat:sistat) ~config ~name ~prop fmt = Rformat.pretty (env_property ~config ~name pstat) fmt prop let print_section (sstat:cistat) ~config ~name ~sect ~prop fmt = if sect <> "" then Rformat.pretty (env_section ~config ~name sstat) fmt sect ; if prop <> "" then let print_property pstat = print_property pstat ~config ~name ~prop fmt in iter_stat ~first:print_property ~sep:print_property ~from:sstat start_stat4prop next_stat4prop let print_chapter (cstat:istat) ~config ~chap ~sect ~glob ~axio ~func ~prop fmt = let chapter_item = match cstat.chapters with | chapter_item::_others -> chapter_item | _ -> raise Exit in let section_name = fst chapter_item in let section,chapter_name = match section_name with | "global" -> glob,config.global_section | "axiomatic" -> axio,config.axiomatic_section | "function" -> func,config.function_section | _ -> sect,"" in let section,section_name = if section <> "" then section,section_name else sect,"" in if chap <> "" then Rformat.pretty (env_chapter chapter_name) fmt chap ; if section <> "" || prop <> "" then let print_section sstat = print_section sstat ~config ~name:section_name ~sect:section ~prop fmt in iter_stat ~first:print_section ~sep:print_section ~from:cstat start_stat4sect next_stat4sect let print gstat ~config ~head ~tail ~chap ~sect ~glob ~axio ~func ~prop fmt = begin if head <> "" then Rformat.pretty (env_toplevel ~config gstat) fmt head ; if chap <> "" || sect <> "" || glob <> "" || axio <> "" || func <> "" || prop <> "" then let print_chapter cstat = print_chapter cstat ~config ~chap ~sect ~glob ~axio ~func ~prop fmt in iter_stat ~first:print_chapter ~sep:print_chapter ~from:gstat start_stat4chap next_stat4chap ; if tail <> "" then Rformat.pretty (env_toplevel ~config gstat) fmt tail ; end (* -------------------------------------------------------------------------- *) (* --- Report Printing --- *) (* -------------------------------------------------------------------------- *) type section = END | HEAD | TAIL | CHAPTER | SECTION | GLOB_SECTION | AXIO_SECTION | FUNC_SECTION | PROPERTY let export gstat specfile = let config = { console = false ; zero = "-" ; status_passed = " Ok " ; status_failed = "Failed" ; status_inconclusive = "*Bug**" ; status_untried = " " ; lemma_prefix = "Lemma " ; global_prefix = "(Global) " ; axiomatic_prefix = "Axiomatic " ; function_prefix = "" ; property_prefix = "" ; global_section = "Globals" ; axiomatic_section = "Axiomatics" ; function_section = "Functions" ; } in let head = Buffer.create 64 in let tail = Buffer.create 64 in let chap = Buffer.create 64 in (* chapter *) let sect = Buffer.create 64 in (* default section *) let glob = Buffer.create 64 in (* section *) let axio = Buffer.create 64 in (* section *) let func = Buffer.create 64 in (* section *) let sect_prop = Buffer.create 64 in (* default sub-section *) let _glob_prop = Buffer.create 64 in (* sub-section *) let _axio_prop = Buffer.create 64 in (* sub-section *) let _func_prop = Buffer.create 64 in (* sub-section *) let file = ref None in let section = ref HEAD in begin let cin = open_in specfile in try while true do let line = input_line cin in match Rformat.command line with | Rformat.ARG("AXIOMATIC_PREFIX",f) -> config.axiomatic_prefix <- f | Rformat.ARG("FUNCTION_PREFIX",f) -> config.function_prefix <- f | Rformat.ARG("PROPERTY_PREFIX",f) -> config.property_prefix <- f | Rformat.ARG("LEMMA_PREFIX",f) -> config.lemma_prefix <- f | Rformat.ARG("GLOBAL_SECTION",f) -> config.global_section <- f | Rformat.ARG("AXIOMATIC_SECTION",f) -> config.axiomatic_section <- f | Rformat.ARG("FUNCTION_SECTION",f) -> config.function_section <- f | Rformat.ARG("PASSED",s) -> config.status_passed <- s | Rformat.ARG("FAILED",s) -> config.status_failed <- s | Rformat.ARG("INCONCLUSIVE",s) -> config.status_inconclusive <- s | Rformat.ARG("UNTRIED",s) -> config.status_untried <- s | Rformat.ARG("ZERO",z) -> config.zero <- z | Rformat.ARG("FILE",f) -> file := Some f | Rformat.ARG("SUFFIX",e) -> let basename = Wp_parameters.ReportName.get () in let filename = basename ^ e in file := Some filename | Rformat.CMD "CONSOLE" -> config.console <- true | Rformat.CMD "END" -> section := END | Rformat.CMD "HEAD" -> section := HEAD | Rformat.CMD "TAIL" -> section := TAIL | Rformat.CMD "CHAPTER" -> section := CHAPTER | Rformat.CMD "SECTION" -> section := SECTION | Rformat.CMD "GLOBAL" -> section := GLOB_SECTION | Rformat.CMD "AXIOMATIC" -> section := AXIO_SECTION | Rformat.CMD "FUNCTION" -> section := FUNC_SECTION | Rformat.CMD "PROPERTY" -> section := PROPERTY | Rformat.CMD a | Rformat.ARG(a,_) -> Wp_parameters.error "Report '%s': unknown command '%s'" specfile a | Rformat.TEXT -> if !section <> END then let text = match !section with | HEAD -> head | CHAPTER -> chap | SECTION -> sect | GLOB_SECTION -> glob | AXIO_SECTION -> axio | FUNC_SECTION -> func | PROPERTY -> sect_prop | TAIL|END -> tail in Buffer.add_string text line ; Buffer.add_char text '\n' ; done with | End_of_file -> close_in cin | err -> close_in cin ; raise err end ; match !file with | None -> Log.print_on_output (print gstat ~config ~head:(Buffer.contents head) ~tail:(Buffer.contents tail) ~chap:(Buffer.contents chap) ~sect:(Buffer.contents sect) ~glob:(Buffer.contents glob) ~axio:(Buffer.contents axio) ~func:(Buffer.contents func) ~prop:(Buffer.contents sect_prop)) | Some report -> Wp_parameters.feedback "Report '%s'" report ; let cout = open_out report in let fout = Format.formatter_of_out_channel cout in try print gstat ~config ~head:(Buffer.contents head) ~tail:(Buffer.contents tail) ~chap:(Buffer.contents chap) ~sect:(Buffer.contents sect) ~glob:(Buffer.contents glob) ~axio:(Buffer.contents axio) ~func:(Buffer.contents func) ~prop:(Buffer.contents sect_prop) fout ; Format.pp_print_flush fout () ; close_out cout ; with err -> Format.pp_print_flush fout () ; close_out cout ; raise err (* -------------------------------------------------------------------------- *) frama-c-Fluorine-20130601/src/wp/normAtLabels.mli0000644000175000017500000000510512155630215020301 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of WP plug-in of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* CEA (Commissariat a l'energie atomique et aux energies *) (* 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 frama-c-Fluorine-20130601/src/gui/0000755000175000017500000000000012155634040015350 5ustar mehdimehdiframa-c-Fluorine-20130601/src/gui/warning_manager.ml0000644000175000017500000001273612155630233021052 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Log let scope = function | None -> "Global" | Some s -> Printf.sprintf "%s:%d" s.Lexing.pos_fname s.Lexing.pos_lnum module Legacy=struct type t = { widget: GTree.view; append : event -> unit; clear : unit -> unit;} let _make ~packing ~callback = let module MODEL = Gtk_helper.MAKE_CUSTOM_LIST(struct type t = event end) in let model = MODEL.custom_list () in let append m = model#insert m in let clear () = model#clear () in let sc = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing () in let view:GTree.view = GTree.view ~rules_hint:true ~headers_visible:false ~packing:sc#add () in let top = `YALIGN 0.0 in let severity_col_view = MODEL.make_view_column model (GTree.cell_renderer_pixbuf [top;`XALIGN 0.5]) (fun e -> match e with | {evt_kind=Error} -> [`STOCK_ID "gtk-dialog-error"] | {evt_kind=Warning} -> [`STOCK_ID "gtk-dialog-warning"] | _ -> [`STOCK_ID "gtk-dialog-info"]) ~title:"" in let scope_col_view = MODEL.make_view_column model (GTree.cell_renderer_text [top]) (fun {evt_source=src} -> [`TEXT (scope src)]) ~title:"Source" in let channel_col_view = MODEL.make_view_column model (GTree.cell_renderer_text [top]) (fun {evt_plugin=m} -> [`TEXT m]) ~title:"Plugin" in let message_col_view = MODEL.make_view_column model (GTree.cell_renderer_text [top]) (fun {evt_message=m} -> [`TEXT m]) ~title:"Message" in ignore (view#append_column severity_col_view) ; ignore (view#append_column scope_col_view) ; ignore (view#append_column channel_col_view) ; ignore (view#append_column message_col_view) ; let on_message_activated tree_path view_column = let v = model#custom_get_iter tree_path in match v with | None -> () | Some {MODEL.finfo=e} -> callback e view_column in ignore (view#connect#row_activated ~callback:on_message_activated); view#set_model (Some model#coerce); {widget = view; append = append; clear = clear} let _append t message = t.append message let _clear t = t.clear () end module New=struct type w = Log.event type t = { widget: (int*w) Gtk_helper.Custom.columns; append : event -> unit; clear : unit -> unit;} module Data = Indexer.Make( struct type t = int*w let compare (x,_) (y,_) = Pervasives.compare x y end) let make ~packing ~callback = let model = object(self) val mutable m = Data.empty val mutable age = 0 method data = m method size = Data.size m method index i = Data.index i m method get i = Data.get i m method add i = age<-age+1; m <- Data.add (age,i) m;age,i method reload = age<-0; m <- Data.empty method coerce = (self:> (int*w) Gtk_helper.Custom.List.model) end in let w = new Gtk_helper.Custom.List.view ~packing ~headers:true ~rules:true model#coerce in let append e = w#insert_row (model#add e) in let clear () = (* Post a reload request before clearing. The current model is used to know how many rows must be deleted. *) w#reload ; in let _ = w#add_column_pixbuf ~title:"Kind" [`YALIGN 0.0;`XALIGN 0.5] (fun (_,e) -> match e with | {evt_kind=Error} -> [`STOCK_ID "gtk-dialog-error"] | {evt_kind=Warning} -> [`STOCK_ID "gtk-dialog-warning"] | _ -> [`STOCK_ID "gtk-dialog-info"]) in let _ = w#add_column_text ~title:"Source" [`YALIGN 0.0] (fun (_,{evt_source=src}) -> [`TEXT (scope src)]) in let _ = w#add_column_text ~title:"Plugin" [`YALIGN 0.0] (fun (_,{evt_plugin=m}) -> [`TEXT m]) in let _ = w#add_column_text ~title:"Message" [`YALIGN 0.0] (fun (_,{evt_message=m}) -> [`TEXT m]) in w#on_click (fun (_,w) c -> callback w c); {widget=w;append=append;clear=clear} let append t message = t.append message let clear t = t.clear () end include New (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/gtk_helper.mli0000644000175000017500000004214212155630233020202 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Generic Gtk helpers. *) val framac_logo: GdkPixbuf.pixbuf option (** @since Boron-20100401 *) val framac_icon: GdkPixbuf.pixbuf option (** @since Boron-20100401 *) (** Some generic icon management tools. @since Carbon-20101201 *) module Icon: sig type kind = Frama_C | Unmark | Custom of string | Feedback of Property_status.Feedback.t (** Generic icons available in every proper install of Frama-C. To be able to use [Custom s] you must have called [register ~name:s ~file] orelse you will get an generic icon placeholder. *) val register: name:string -> file:string -> unit (** [register ~name ~file] registers the kind [Custom name] associated to the filename [file]. [$FRAMAC_SHARE/f] should point to an existing file containing an image loadable by GdkPixbuf. *) val get: kind -> GdkPixbuf.pixbuf (** @return the pixbuf associated to the given kind. If the given kind is [Custom s] and no one ever called [register ~name:s ~file] where [file] is such that [$(FRAMAC_SHARE)/f] is not a real image file loadable by GdkPixbuf, a generic icon placeholder is returned. *) val default: unit -> GdkPixbuf.pixbuf end (** Configuration module for the GUI: all magic visual constants should use this mechanism (window width, ratios, ...). @since Carbon-20101201 *) module Configuration: sig type configData = ConfInt of int | ConfBool of bool | ConfFloat of float | ConfString of string | ConfList of configData list val load : unit -> unit val save : unit -> unit val set : string -> configData -> unit (** Set a configuration element, with a key. Overwrites the previous values *) val find: string -> configData (** Find a configuration elements, given a key. Raises Not_found if it cannot find it *) val find_int: ?default:int -> string -> int (** Like find but extracts the integer. Raises Not_found if the key is found but is not an integer. Raises Not_found if no default is given and the key is not found. If a default is given and the key is not found then the default value is stored for the given key and returned. *) val use_int: string -> (int -> unit) -> unit (** Looks for an integer configuration element, and if it is found, it is given to the given function. Otherwise, does nothing *) val find_bool : ?default:bool -> string -> bool (** Same as {find_int}. *) val use_bool: string -> (bool -> unit) -> unit (** Same as {!use_int}. *) val find_float : ?default:float -> string -> float (** Same as {!find_int}. *) val use_float: string -> (float -> unit) -> unit (** Same as {!use_int}. *) val find_string: ?default:string -> string -> string (** Same as {!find_int}. *) val use_string: string -> (string -> unit) -> unit (** Same as {!use_int}. *) val find_list: string -> configData list val use_list: string -> (configData list -> unit) -> unit end (** {2 UTF8} *) val to_utf8 : string -> string (* ************************************************************************** *) (** {2 Tags} *) (* ************************************************************************** *) val make_tag : < tag_table : Gtk.text_tag_table; create_tag : ?name:string -> GText.tag_property list -> GText.tag ; .. > -> name:string -> GText.tag_property list -> GText.tag val apply_tag : GSourceView2.source_buffer -> GText.tag -> int -> int -> unit val remove_tag : GSourceView2.source_buffer -> GText.tag -> int -> int -> unit val cleanup_tag : GSourceView2.source_buffer -> GText.tag -> unit val cleanup_all_tags : GSourceView2.source_buffer -> unit (* ************************************************************************** *) (** {2 Channels} *) (* ************************************************************************** *) val make_formatter: ?flush:(unit -> unit) -> #GText.buffer -> Format.formatter (** Build a formatter that redirects its output to the given buffer. [flush] is called whenever the formatter is flushed. *) val channel_redirector: Unix.file_descr -> (string -> bool) -> unit (** Redirects all strings written to the file descriptor and call the given function on each. *) val log_redirector: ?flush:(unit->unit) -> (string -> unit) -> unit (** Redirects all strings written to the terminal and call the given function on each. *) val redirect : Format.formatter -> #GText.buffer -> unit (** Redirect the given formatter to the given buffer *) (* ************************************************************************** *) (** {2 Asynchronous command execution} *) (* ************************************************************************** *) val spawn_command: ?timeout:int -> ?stdout:Buffer.t -> ?stderr:Buffer.t -> string -> string array -> (Unix.process_status -> unit) -> unit (** Launches the given command and calls the given function when the process terminates. If timeout is > 0 (the default) then the process will be killed if it does not end before timeout seconds. In this case the returned process status will be [Unix.WSIGNALED Sys.sigalrm]. *) (* ************************************************************************** *) (** {2 Locks} *) (* ************************************************************************** *) val gui_unlocked: bool ref (** This is a mutex you may use to prevent running some code while the GUI is locked. *) val register_locking_machinery: ?lock_last:bool -> lock:(bool -> unit) -> unlock:(unit -> unit) -> unit -> unit (** Add hooks to the locking mechanism of the GUI. [lock_last] must be set to true if [lock] must be executed after all the others locking actions and [unlock] must be executed before all the others unlocking actions. Default is [false]. At least one "lock_last" action is allowed. @since Beryllium-20090901 @modify Boron-20100401 new optional argument [lock_last] and new argument [()] *) (* ************************************************************************** *) (** 2 Tooltips *) (* ************************************************************************** *) val do_tooltip: ?tooltip:string -> < coerce: GObj.widget; .. > -> unit (** Add the given tooltip to the given widget. It has no effect if no tooltip is given. *) (* ************************************************************************** *) (** {2 Chooser} *) (* ************************************************************************** *) type 'a chooser = GPack.box -> string -> (unit -> 'a) -> ('a -> unit) -> (unit -> unit) (** The created widget is packed in the box. The two following functions are supposed to be accessors(get and set) for the value to be displayed. The returned closure may be called to resynchronize the value in the widget from the get function. *) val on_bool: ?tooltip:string -> ?use_markup:bool -> bool chooser (** Pack a check button *) val range_selector: ?tooltip:string -> ?use_markup:bool -> GPack.box -> label:string -> lower:int -> upper:int -> (int -> unit) -> (unit -> int) -> unit -> unit val on_int: ?tooltip:string -> ?use_markup:bool -> ?lower:int -> ?upper:int -> ?sensitive:(unit -> bool) -> ?width:int -> int chooser (** Pack a spin button. By default, sensitivity is set to true when this function is called. *) val on_string: ?tooltip:string -> ?use_markup:bool -> ?validator:(string -> bool) -> ?width:int -> string chooser (** Pack a string chooser *) val on_string_set: ?tooltip:string -> ?use_markup:bool -> ?width:int -> string chooser (** Pack a string-set chooser *) val on_string_completion: ?tooltip:string -> ?use_markup:bool -> ?validator:(string -> bool) -> string list -> string chooser val on_combo: string list -> ?tooltip:string -> ?use_markup:bool -> ?width:int -> string chooser (** Pack a string-selector *) (* ************************************************************************** *) (** {2 Error manager} *) (* ************************************************************************** *) (** A utility class to catch exceptions and report proper error messages. *) class type host = object method error: 'a. ?parent:GWindow.window_skel -> ('a, Format.formatter, unit) format -> 'a method full_protect : 'a. cancelable:bool -> ?parent:GWindow.window_skel -> (unit -> 'a) -> 'a option method protect : cancelable:bool -> ?parent:GWindow.window_skel -> (unit -> unit) -> unit method private set_reset: (unit -> unit) -> unit end (** A utility class to catch exceptions and report proper error messages. The error dialog will be transient for the [GWindow.window_skel] argument. @since Beryllium-20090901 *) class error_manager : ?reset:(unit -> unit) -> GWindow.window_skel -> host (* ************************************************************************** *) (** {2 Source files chooser} *) (* ************************************************************************** *) (** @since Boron-20100401 *) class type source_files_chooser_host = object inherit host method main_window: GWindow.window_skel method reset: unit -> unit end (** Open a dialog box for choosing C source files and performing an action on them. @since Boron-20100401 *) val source_files_chooser: source_files_chooser_host -> string list (** list of default selected files *) -> (string list -> unit) -> unit (* ************************************************************************** *) (** {2 Miscellaneous} *) (* ************************************************************************** *) val later : (unit -> unit) -> unit val refresh_gui: unit -> unit (** Process pending events in the main Glib loop. This is intended to be called only when [!gui_unlocked == false]. @since Beryllium-20090901 *) val string_selector: string list -> (GObj.widget -> unit) -> GEdit.entry val expand_to_path : GTree.view -> Gtk.tree_path -> unit val make_string_list: packing:(GObj.widget -> unit) -> (string -> unit)* (unit -> unit)*(unit -> string list) (** @return (add, remove_selected, get_elements) *) val place_paned: GPack.paned -> float -> unit (** Sets the position of the paned widget to the given ratio *) val save_paned_ratio: string -> GPack.paned -> unit (** Saves the current ratio of the panel associated to the given key. *) val old_gtk_compat: ('a -> unit) -> 'a -> unit (** Catch exception [Not_found] and do nothing *) val trace_event: GObj.event_ops -> unit (** Trace all events on stderr for the given object. This is a debugging function: it should not be called during normal execution. *) val make_text_page: ?pos:int -> GPack.notebook -> string -> (GPack.notebook -> unit) * GText.view (** Insert a GText.view in a new page of the notebook with the given title, at position [pos] if specified, or last if not. It returns a new GText.view together with a function to reparent the inserted page in another notebook. The tab label of the created page will be highlighted whenever its contents changes. @since Beryllium-20090901 *) (** A functor to build custom Gtk lists. You'll probably prefer to use the highlevel custom models in the next module named Custom.List. It may be part of a future lablgtk release. Do not change anything without changing lablgtk svn.*) module MAKE_CUSTOM_LIST(A : sig type t end) : sig type custom_list = { finfo : A.t; fidx : int; } val inbound : int -> 'a array -> bool class custom_list_class : GTree.column_list -> object inherit [custom_list,custom_list,unit,unit] GTree.custom_tree_model method custom_decode_iter : custom_list -> unit -> unit -> custom_list method custom_encode_iter : custom_list -> custom_list * unit * unit method custom_get_iter : Gtk.tree_path -> custom_list option method custom_get_path : custom_list -> Gtk.tree_path method custom_iter_children : custom_list option -> custom_list option method custom_iter_has_child : custom_list -> bool method custom_iter_n_children : custom_list option -> int method custom_iter_next : custom_list -> custom_list option method custom_iter_nth_child : custom_list option -> int -> custom_list option method custom_iter_parent : custom_list -> custom_list option method custom_value : Gobject.g_type -> custom_list -> column:int -> Gobject.basic method insert : A.t -> unit method clear : unit -> unit end val custom_list : unit -> custom_list_class val make_view_column : custom_list_class -> ('b,'a) #GTree.cell_renderer_skel -> (A.t -> 'a list) -> title:string -> GTree.view_column end (** Simple and high level custom model interface *) module Custom: sig type ('a,'b) column = ?title:string -> 'b list -> ('a -> 'b list) -> GTree.view_column class type virtual ['a] custom = object inherit ['a,'a,unit,unit] GTree.custom_tree_model method reload : unit end class type ['a] columns = object method view : GTree.view (** the tree *) method scroll : GBin.scrolled_window (** scrolled tree (build on demand) *) method coerce : GObj.widget (** widget of the scroll *) method pack : (GObj.widget -> unit) -> unit (** packs the scroll *) method reload : unit (** Structure has changed *) method update_all : unit (** (only) Content of rows has changed *) method update_row : 'a -> unit method insert_row : 'a -> unit method set_focus : 'a -> GTree.view_column -> unit method on_click : ('a -> GTree.view_column -> unit) -> unit method on_right_click : ('a -> GTree.view_column -> unit) -> unit method on_double_click : ('a -> GTree.view_column -> unit) -> unit method set_selection_mode : Gtk.Tags.selection_mode -> unit method on_selection : (unit -> unit) -> unit method count_selected : int method iter_selected : ('a -> unit) -> unit method is_selected : 'a -> bool method add_column_text : ('a,GTree.cell_properties_text) column method add_column_pixbuf : ('a,GTree.cell_properties_pixbuf) column method add_column_toggle : ('a,GTree.cell_properties_toggle) column method add_column_empty : unit end module List: sig class type ['a] model = object method reload : unit method size : int method index : 'a -> int method get : int -> 'a end class ['a] view : ?packing:(GObj.widget->unit) -> ?width:int -> ?height:int -> ?headers:bool -> ?rules:bool -> 'a model -> object inherit ['a] columns end end module Tree: sig class type ['a] model = object method reload : unit method has_child : 'a -> bool method children : 'a option -> int method child_at : 'a option -> int -> 'a method parent : 'a -> 'a option method index : 'a -> int end class ['a] view : ?packing:(GObj.widget->unit) -> ?width:int -> ?height:int -> ?headers:bool -> ?rules:bool -> 'a model -> object inherit ['a] columns end end end (** Create a new window displaying a graph. @plugin development guide *) val graph_window: parent: GWindow.window -> title:string -> (packing:(GObj.widget -> unit) -> unit -> unit; ..>) -> unit (** Create a new window displaying a graph, by printing dot commands. *) val graph_window_through_dot: parent: GWindow.window -> title:string -> (Format.formatter -> unit) -> unit (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/toolbox.mli0000644000175000017500000002444312155630233017550 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** GUI Toolbox. This module implements GUI helpers upon [LablGtk]. It uses nothing from [Gtk_helper] but the [UTF-8] conversion facilities. *) (** {1 Concepts} *) class type widget = object method set_enabled : bool -> unit method coerce : GObj.widget end class ['a] signal : object method fire : 'a -> unit method set_enabled : bool -> unit method connect : ('a -> unit) -> unit method on_check : 'a -> (bool -> unit) -> unit method on_value : 'a -> (unit -> unit) -> unit method on_event : (unit -> unit) -> unit end class ['a] selector : 'a -> object inherit ['a] signal method set : 'a -> unit method get : 'a method send : ('a -> unit) -> unit -> unit end (** {1 Icons} *) type icon = [ GtkStock.id | `Share of string ] (** {1 Simple Widgets} *) type align = [`Left | `Right | `Center] type style = [`Label | `Descr | `Title ] (** Title label *) class label : ?style:style -> ?text:string -> ?align:align -> unit -> object method coerce : GObj.widget method set_text : string -> unit end class button : ?label:string -> ?icon:icon -> ?tooltip:string -> unit -> object inherit widget inherit [unit] signal method set_icon : icon option -> unit method set_label : string -> unit method set_relief : bool -> unit method default : unit -> unit end class toggle : ?label:string -> ?icon:icon -> ?tooltip:string -> unit -> object inherit widget inherit [bool] selector method set_icon : icon option -> unit method set_label : string -> unit method set_relief : bool -> unit end class checkbox : label:string -> ?tooltip:string -> unit -> object inherit widget inherit [bool] selector end class switchbox : ?tooltip:string -> unit -> object inherit widget inherit [bool] selector end class spinner : ?min:int -> ?max:int -> ?step:int -> value:int -> ?tooltip:string -> unit -> object inherit widget inherit [int] selector end class ['a] menulist : default:'a -> render:('a -> string) -> ?items:'a list -> unit -> object inherit widget inherit ['a] selector method set_items : 'a list -> unit method get_items : 'a list end (** Conceptual selector, to create toggles and radio buttons. *) class ['a] switch : 'a -> object inherit ['a] selector method add_toggle : ?label:string -> ?icon:icon -> ?tooltip:string -> value:'a -> unit -> widget method add_radio : label:string -> ?tooltip:string -> value:'a -> unit -> widget end (** {1 File Choosers} *) type filekind = [ `FILE | `DIR ] (** Dialog for choosing a file. The default file type is [`FILE]. *) class filechooser_dialog : ?kind:filekind -> ?title:string -> ?select:string -> ?parent:GWindow.window -> unit -> object inherit [string] signal method filter : descr:string -> patterns:string list -> unit method select : ?dir:string -> ?file:string -> unit -> unit end class filechooser_button : ?kind:filekind -> ?title:string -> ?select:string -> ?tooltip:string -> ?parent:GWindow.window -> unit -> object inherit widget inherit filechooser_dialog inherit [string] selector (** Holds the filename *) method tooltip : (string -> string) -> unit (** Set the pretty-printer for tooptip. *) method display : (string -> string) -> unit (** Set the pretty-printer for button. *) end (** {1 Contextual Menus} *) class popup : unit -> object method clear : unit (** Remove all items *) method add_item : label:string -> callback:(unit -> unit) -> unit (** Adds an item. *) method add_separator : unit (** Inserts a separator. Consecutives and trailing separators are eliminated. *) method popup : unit -> unit (** Run the menu. *) end (** {1 Forms and Toolbar Layouts} *) (** The expansible attribute of a field. *) type field = [ `Compact (** Fixed size. Does not expand. *) | `Field (** Single line field. Expands to the left. *) | `Editor (** Multiline field. Expands to both left and bottom. *) ] (** A simple button-rack horizontal box. *) class rack : widget list -> widget (** A form with various field types. The form consists of two columns, with one entry per line. Left columns is reserved for (optional) labels. Fields take place in right column. It is also possible to add widget that spans over the two columns. The form can be horizontaly devided into sections. Elements must be added from left-to-right, top-to-down order. *) class form : unit -> object inherit widget method add_newline : unit (** Inserts an emty line. *) method add_section : string -> unit (** Starts a new section. *) method add_label : string -> unit (** Inserts a field name. Moves to right column. *) method add_label_widget : GObj.widget -> unit (** Inserts a small (fixed) widget in place of a label. Moves to right column. *) method add_field : ?label:string -> ?field:field -> GObj.widget -> unit (** Inserts an entry in the form. Optional label is inserted in right column is specified. Default [field] is [`Field]. Moves to next line. *) method add_row : ?field:field -> GObj.widget -> unit (** Inserts a wide entry in the form, spanning the two columns. Default [field] is [`Field]. Moves to next line. *) end (** An editable list of items. *) class ['a] listbox : render:('a -> string) -> ?width:int -> ?height:int -> unit -> object inherit widget inherit ['a list] selector method get : 'a list method set : 'a list -> unit method insert : int -> 'a -> unit method on_insert_request : (int -> unit) -> unit end (** {1 Layouts} *) class ['a] notebook : ?tabs:Gtk.Tags.position -> default:'a -> unit -> object inherit widget inherit ['a] selector method add : ?label:string -> 'a -> GObj.widget -> unit method on_focus : 'a -> (bool -> unit) -> unit end class type entry = object method widget : GObj.widget (** Returns the widget *) method update : unit -> unit (** Signal *) method delete : unit -> unit (** When removed *) end class ['a] warray : ?dir:Gtk.Tags.orientation -> unit -> object inherit widget method create : ('a -> entry) -> unit method set : 'a list -> unit method get : 'a list method mem : 'a -> bool method append : 'a -> unit method insert : ?after:'a -> 'a -> unit method remove : 'a -> unit method update : unit -> unit end (** {1 Dialog} *) (** Dialog exit button categories *) type 'a action = [ | `CANCEL (** Cancel choice (same as closing the dialog or `MAIN `CANCEL) *) | `APPLY (** Default choice (same as `DEFAULT `APPLY) *) | `DEFAULT of 'a (** Default choice (right, small, default button) *) | `SELECT of 'a (** Secondary choice (right, small button) *) | `ALT of 'a (** Alternative choice (left, large button) *) | `ACTION of (unit -> unit) (** Button (left, large button) *) ] (** Dialog Window. Dialog window are asynchroneous and modal. To open the dialog, invoke [run]. The method returns immediately. When running, the main window is no more sensitive (dialog is modal). When an action-button is pressed, or the method [select] is invoked, the associated signal is emitted, and the dialog is dismissed. Then focus goes back to the main window, and the dialog can be re-emitted. *) class ['a] dialog : title:string -> window:GWindow.window -> ?resize:bool -> unit -> object constraint 'a = [> `CANCEL | `APPLY] method add_row : GObj.widget -> unit method add_block : GObj.widget -> unit method button : action:'a action -> ?label:string -> ?icon:icon -> ?tooltip:string -> unit -> unit (** Closes the dialog. *) method select : 'a -> unit (** Closes the dialog. *) method run : unit -> unit (** Opens the dialog (asynchroneously). *) inherit ['a] signal (** Emitted when the dialog is closed. *) end (** {1 Rich Text Renderer} *) class text : unit -> object inherit widget method clear : unit method fmt : Format.formatter (** The formatter used by [printf] method. *) method printf : 'a. ('a,Format.formatter,unit) format -> 'a (** Append material to the text buffer. The underlying formatter (method [fmt]) recognizes the following tags: - ["bf"] bold face - ["it"] italic style - ["ul"] underlined - ["st"] striked through - ["red"], ["orange"], ["green"] foreground color - ["fg:"] foreground color - ["bg:"] background color - ["link:"] clickable link, see method [on_link]. - ["mark:"] named text range, see methods [show], [set_properties]. Properties for any tag (except link and mark) can be modified with method [set_tag_properties]. [t#printf] is a shortcut for [Format.fprintf t#fmt]. *) method highlight : mark:string -> GText.tag_property list -> unit method focus : mark:string -> unit method on_link : (string -> unit) -> unit end frama-c-Fluorine-20130601/src/gui/gui_parameters.ml0000644000175000017500000000403412155630233020712 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.Register (struct let name = "GUI" let shortname = "gui" let help = "Graphical User Interface" end) (* Used mainly for debugging purposes. No need to show it to the user *) let () = Plugin.is_invisible () module Undo = True (struct let option_name = "-gui-undo" let help = "possible to click on the `undo' button (set by default)" end) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/source_manager.ml0000644000175000017500000001157712155630233020707 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) type tab = { tab_name : string ; tab_file : string ; tab_page : int ; tab_select : line:int -> unit ; } type t = { notebook : GPack.notebook; file_index : (string,tab) Hashtbl.t; name_index : (string,tab) Hashtbl.t; mutable pages : int ; } let make ?tab_pos ?packing () = let notebook = GPack.notebook ~scrollable:true ~show_tabs:true ?tab_pos ?packing () in notebook#set_enable_popup true ; { notebook = notebook ; file_index = Hashtbl.create 7; name_index = Hashtbl.create 7; pages = 0 ; } (* Try to convert a source file either as UTF-8 or as locale. *) let try_convert = Gtk_helper.to_utf8 let input_channel b ic = let buf = String.create 1024 and len = ref 0 in while len := input ic buf 0 1024; !len > 0 do Buffer.add_substring b buf 0 !len done let with_file name ~f = try let ic = open_in_gen [Open_rdonly] 0o644 name in try f ic; close_in ic with _exn -> close_in ic (*; !flash_info ("Error: "^Printexc.to_string exn)*) with _exn -> () let clear w = begin for _i=1 to w.pages do w.notebook#remove_page 0 done ; w.pages <- 0 ; Hashtbl.clear w.file_index ; Hashtbl.clear w.name_index ; end let later f = ignore (Glib.Idle.add (fun () -> f () ; false)) let select_file w filename = try let tab = Hashtbl.find w.file_index filename in later (fun () -> w.notebook#goto_page tab.tab_page) with Not_found -> () let select_name w title = try let tab = Hashtbl.find w.name_index title in later (fun () -> w.notebook#goto_page tab.tab_page) with Not_found -> () let load_file w ?title ~filename ?(line=(-1)) () = Gui_parameters.debug "Opening file %S line %d" filename line ; let tab = begin try Hashtbl.find w.file_index filename with Not_found -> let name = match title with None -> filename | Some s -> s in let label = GMisc.label ~text:name () in let sw = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(fun arg -> ignore (w.notebook#append_page ~tab_label:label#coerce arg)) () in let window = ((Source_viewer.make ~packing:sw#add) :> GText.view) in let page_num = w.notebook#page_num sw#coerce in let b = Buffer.create 1024 in with_file filename ~f:(input_channel b) ; let s = try_convert (Buffer.contents b) in Buffer.reset b; let (buffer:GText.buffer) = window#buffer in buffer#set_text s; let select_line ~line = w.notebook#goto_page page_num; if line >= 0 then let it = buffer#get_iter (`LINE (line-1)) in buffer#place_cursor ~where:it; let y = if buffer#line_count < 20 then 0.23 else 0.3 in window#scroll_to_mark ~use_align:true ~yalign:y `INSERT in let tab = { tab_file = filename ; tab_name = name ; tab_select = select_line ; tab_page = page_num ; } in w.pages <- succ page_num ; Hashtbl.add w.file_index filename tab ; Hashtbl.add w.name_index name tab ; tab end in (* Runs this at idle priority to let the text be displayed before. *) later (fun () -> tab.tab_select ~line) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/property_navigator.mli0000644000175000017500000000342112155630233022011 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Extension of the GUI in order to navigate in ACSL properties. No function is exported. *) (* Empty on purpose. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/filetree.mli0000644000175000017500000001466212155630233017663 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** The tree containing the list of modules and functions together with dynamic columns *) type filetree_node = File of string * Cil_types.global list | Global of Cil_types.global (** Caml type for the infos on a node of the tree. Not all globals appear in the filetree. Currently, the visible ones are: - functions definitions, or declarations if no definition exists - global variables - global annotations @since Nitrogen-20111001 *) class type t = object method model : GTree.model method flat_mode: bool (** Return [true] if the filetree currently displays all globals in flat mode (all children of the same node), [false] otherwise (children of the file they are declared in). If [true], the methods [set_file_attribute] and [get_files_globals] must not be used @since Nitrogen-20111001 *) method set_file_attribute: ?strikethrough:bool -> ?text:string -> string -> unit (** Manually set some attributes of the given filename. *) method set_global_attribute: ?strikethrough:bool -> ?text:string -> Cil_types.varinfo -> unit (** Manually set some attributes of the given variable. *) method add_global_filter: text:string -> key:string -> (Cil_types.global -> bool) -> (unit -> bool) * GMenu.check_menu_item (** [add_global_filter text key f] adds a filter for the visibility of the globals, according to [f]. If any of the filters registered through this method returns true, the global is not displayed in the filetree. [text] is used in the filetree menu, to label the entry permitting to activate or deactivate the filter. [key] is used to store the current state of the filter internally. The created menu is returned. @since Nitrogen-20111001 @modify Oxygen-20120901 Signature change for the filter argument, return the menu. *) method get_file_globals: string -> (string * bool) list (** Return the names and the attributes (currently only the strikethrough property) of the globals in the file passed as argument *) method add_select_function : (was_activated:bool -> activating:bool -> filetree_node -> unit) -> unit (** Register a callback that is called whenever an element of the file tree is selected or unselected. @modify Nitrogen-20111001 Changed argument from a list of globals to [filetree_node] *) method append_pixbuf_column: title:string -> (Cil_types.global list -> GTree.cell_properties_pixbuf list) -> (unit -> bool) -> ([`Visibility | `Contents] -> unit) (** [append_pixbuf_column title f visible] appends a new column with name [title] to the file tree and registers [f] as a callback computing the list of properties for this column. Do not forget that properties need to be set and unset explictely. The argument [visible] is used by the column to decide whether it should appear. The returned function can be used to force an update on the display of the column [`Visibility] means that the column must be show or hidden. [`Contents] means what it contains has changed. @modify Nitrogen-20111001 Add third argument, and change return type @modify Oxygen-20120901 Change return type *) method select_global : Cil_types.global -> bool (** Selects the given global in the tree view and run the associated callbacks. Return a boolean indicating whether the selection succeeded. (Currently, only variables and functions can be selected, provided they are not filtered out.) Unless you known what your are doing, prefer calling [main_ui#select_or_display_global], which is more resilient to globals not displayed in the filetree. @modify Nitrogen-20111001 Takes a [global] as argument, instead of a [varinfo]. Returns a boolean to indicate success or failure. *) method selected_globals : Cil_types.global list (** @since Carbon-20101201 @return the list of selected globals in the treeview. *) method view : GTree.view (** The tree view associated in which the file tree is packed. *) method reset : unit -> unit (** Resynchronize the tree view with the current project state. This is called in particular by the generic reset extension of {!Design} *) method register_reset_extension : (t -> unit) -> unit (** Register a function to be called whenever the reset method of the filetree is called. *) method refresh_columns : unit -> unit (** Refresh the state of all the non-source columns of the filetree, by hiding those that should be hidden, and displaying the others. Called by [reset] @since Nitrogen-20111001 *) end val make : GTree.view -> t (** Create a file tree packed in the given tree_view. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/design.mli0000644000175000017500000002357012155630233017333 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** The extensible GUI. @plugin development guide *) open Cil_types (** This is the type of source code buffers that can react to global selections and highlighters. @since Beryllium-20090901 *) class type reactive_buffer = object inherit Gtk_helper.error_manager method buffer : GSourceView2.source_buffer method locs : Pretty_source.Locs.state option method rehighlight : unit method redisplay : unit end (** This class type lists all the methods available to navigate the source code through the GUI *) class type view_code = object (** {3 Pretty-printed code} *) method scroll : Pretty_source.localizable -> unit (** Move the pretty-printed source viewer to the given localizable if possible. Return a boolean indicating whether the operation succeeded @modify Nitrogen-20111001 Now indicates whether the operation succeeded. *) method display_globals : global list -> unit (** Display the given globals in the pretty-printed source viewer. *) (** {3 Original code} *) method view_original_stmt : stmt -> location (** Display the given [stmt] in the original source viewer *) method view_original : location -> unit (** Display the given location in the original_source_viewer *) (** {3 Both pretty-printed and original code} *) method view_stmt : stmt -> unit (** Display the given [stmt] in the [source_viewer] and in the [original_source_viewer]. Equivalent to two successive calls to [scroll] and [view_original_stmt] @since Carbon-20101201 *) method select_or_display_global : global -> unit (** This function tries to select the global in the treeview. If this fails, for example because the global is not shown in the treeview because of filters, it falls back to displaying the global by hand. @since Nitrogen-20111001 *) end class protected_menu_factory: Gtk_helper.host -> GMenu.menu -> [ GMenu.menu ] GMenu.factory (** This is the type of extension points for the GUI. @modify Boron-20100401 new way of handling the menu and the toolbar @plugin development guide *) class type main_window_extension_points = object inherit view_code (** {3 Main Components} *) method toplevel : main_window_extension_points (** The whole GUI aka self *) method menu_manager: unit -> Menu_manager.menu_manager (** The object managing the menubar and the toolbar. @since Boron-20100401 *) method file_tree : Filetree.t (** The tree containing the list of files and functions *) method file_tree_view : GTree.view (** The tree view containing the list of files and functions *) method main_window : GWindow.window (** The main window *) method annot_window : GText.view (** The information panel. The text is automatically cleared whenever the selection is changed. You should not directly use the buffer contained in the annot_window to add text. Use the method [pretty_information]. *) method pretty_information : 'a. ('a, Format.formatter, unit) format -> 'a (** Pretty print a message in the [annot_window]. *) method lower_notebook : GPack.notebook (** The lower notebook with messages tabs *) (** {4 Source viewers} *) method source_viewer : GSourceView2.source_view (** The [GText.view] showing the AST. *) method reactive_buffer: reactive_buffer option (** The buffer containing the AST. @since Carbon-20101201 *) method original_source_viewer : Source_manager.t (** The multi-tab source file display widget containing the original source. *) (** {3 Dialog Boxes} *) method launcher : unit -> unit (** Display the analysis configuration dialog and offer the opportunity to launch to the user *) method error : 'a. ?parent:GWindow.window_skel -> ('a, Format.formatter, unit) format -> 'a (** Popup a modal dialog displaying an error message *) (** {3 Extension Points} *) method register_source_selector : (GMenu.menu GMenu.factory -> main_window_extension_points -> button:int -> Pretty_source.localizable -> unit) -> unit (** register an action to perform when button is released on a given localizable. If the button 3 is released, the first argument is popped as a contextual menu. @plugin development guide *) method register_source_highlighter : (GSourceView2.source_buffer -> Pretty_source.localizable -> start:int -> stop:int -> unit) -> unit (** register an highlighting function to run on a given localizable between start and stop in the given buffer. Priority of [Gtext.tags] is used to decide which tag is rendered on top of the other. *) method register_panel : (main_window_extension_points->(string*GObj.widget*(unit-> unit) option)) -> unit (** [register_panel (name, widget, refresh)] registers a panel in GUI. The arguments are the name of the panel to create, the widget containing the panel and a function to be called on refresh. *) (** {3 General features} *) method reset : unit -> unit (** Reset the GUI and its extensions to its initial state *) method rehighlight : unit -> unit (** Force to rehilight the current displayed buffer. Plugins should call this method whenever they have changed the states on which the function given to [register_source_highlighter] have been updated. *) method redisplay : unit -> unit (** @since Nitrogen-20111001 Force to redisplay the current displayed buffer. Plugins should call this method whenever they have changed the globals. For example whenever a plugin adds an annotation, the buffers need to be redisplayed. *) method protect : cancelable:bool -> ?parent:GWindow.window_skel -> (unit -> unit) -> unit (** Lock the GUI ; run the funtion ; catch all exceptions ; Unlock GUI The parent window must be set if this method is not called directly by the main window: it will ensure that error dialogs are transient for the right window. Set cancelable to [true] if the protected action should be cancellable by the user through button `Stop'. *) method full_protect : 'a . cancelable:bool -> ?parent:GWindow.window_skel -> (unit -> 'a) -> 'a option (** Lock the GUI ; run the funtion ; catch all exceptions ; Unlock GUI ; returns [f ()]. The parent window must be set if this method is not called directly by the main window: it will ensure that error dialogs are transient for the right window. Set cancelable to [true] if the protected action should be cancellable by the user through button `Stop'. *) method push_info : 'a. ('a, Format.formatter, unit) format -> 'a (** Pretty print a temporary information in the status bar *) method pop_info : unit -> unit (** Remove last temporary information in the status bar *) method help_message : 'a 'b. ( as 'a) -> ('b, Format.formatter, unit) format -> 'b (** Help message displayed when entering the widget *) end class main_window : unit -> main_window_extension_points val register_extension : (main_window_extension_points -> unit) -> unit (** Register an extension to the main GUI. It will be invoked at initialization time. @plugin development guide *) val register_reset_extension : (main_window_extension_points -> unit) -> unit (** Register a function to be called whenever the main GUI reset method is called. *) val apply_on_selected : (Pretty_source.localizable -> unit) -> unit (** @deprecated Nitrogen-20111001 Use History.apply_on_selected instead *) val reactive_buffer : main_window_extension_points -> ?parent_window:GWindow.window -> global list -> reactive_buffer (** This function creates a reactive buffer for the given list of globals. These buffers are cached and sensitive to selections and highlighters. @since Beryllium-20090901 *) (** Bullets at left-margins @since Nitrogen-20111001 *) module Feedback : sig val mark : GSourceView2.source_buffer -> start:int -> stop:int -> Property_status.Feedback.t -> unit val update: reactive_buffer -> Property.t -> unit end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/gtk_form.ml0000644000175000017500000001330312155630233017512 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ------------------------------------------------------------------------ *) (* --- Forms Factory --- *) (* ------------------------------------------------------------------------ *) type demon = (unit -> unit) list ref let demon () = ref [] let register demon f = demon := !demon @ [f] let refresh demon () = List.iter (fun f -> try f() with _ -> ()) !demon (* ------------------------------------------------------------------------ *) (* --- Utilities --- *) (* ------------------------------------------------------------------------ *) type 'a field = ?tooltip:string -> packing:(GObj.widget -> unit) -> (unit -> 'a) -> ('a -> unit) -> demon -> unit let mk_tooltip ?tooltip obj = match tooltip with | None -> () | Some text -> let tooltip = GData.tooltips () in tooltip#set_tip ~text obj#coerce (* ------------------------------------------------------------------------ *) (* --- Check Button --- *) (* ------------------------------------------------------------------------ *) let check ?label ?tooltip ~packing get set demon = let button = GButton.check_button ?label ~packing ~active:(get ()) () in mk_tooltip ?tooltip button ; ignore (button#connect#toggled ~callback:(fun () -> set button#active)); register demon (fun () -> button#set_active (get())) (* ------------------------------------------------------------------------ *) (* --- Menu Button --- *) (* ------------------------------------------------------------------------ *) let menu entries ?width ?tooltip ~packing get set demon = let strings = List.map fst entries in let combo_box, (_model, column) = GEdit.combo_box_text ~strings ?width ~wrap_width:1 ~packing () in let callback () = try match combo_box#active_iter with | None -> () | Some row -> let title = (combo_box#model#get ~row ~column) in let (_,item) = List.find (fun (t,_) -> t=title) entries in set item with Not_found -> () in let rec lookup k item = function | [] -> raise Not_found | (_,value) :: entries -> if value = item then k else lookup (succ k) item entries in let update () = try combo_box#set_active (lookup 0 (get ()) entries) with Not_found -> () in ignore (combo_box#connect#changed callback) ; mk_tooltip ?tooltip combo_box ; register demon update (* ------------------------------------------------------------------------ *) (* --- Spinner --- *) (* ------------------------------------------------------------------------ *) let spinner ?(lower=0) ?(upper=max_int) ?width ?tooltip ~packing get set demon = let spin = GEdit.spin_button ~digits:0 ?width ~packing () in spin#adjustment#set_bounds ~lower:(float lower) ~upper:(float upper) ~step_incr:1. () ; let callback () = set (spin#value_as_int) in let update () = spin#adjustment#set_value (float (get ())) in ignore (spin#connect#value_changed ~callback) ; mk_tooltip ?tooltip spin ; register demon update (* ------------------------------------------------------------------------ *) (* --- Forms --- *) (* ------------------------------------------------------------------------ *) class form ~packing = object val table = GPack.table ~rows:2 ~col_spacings:8 ~packing () val mutable top = 0 method label text = ignore (GMisc.label ~text ~packing:(table#attach ~top ~left:0 ~expand:`NONE) ()) method item obj = table#attach ~top ~left:1 ~expand:`X ~fill:`X obj ; top <- succ top method row obj = table#attach ~top ~left:0 ~right:2 ~expand:`X ~fill:`X obj ; top <- succ top end let label ~text ~packing () = ignore (GMisc.label ~xpad:3 ~text ~packing ()) let button ~label ?tooltip ~callback ~packing () = let b = GButton.button ~label ~packing () in mk_tooltip ?tooltip b ; ignore (b#connect#clicked ~callback) frama-c-Fluorine-20130601/src/gui/history.ml0000644000175000017500000001425512155630233017412 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 type history_elt = | Global of global | Localizable of Pretty_source.localizable module HistoryElt = struct include Datatype.Make (struct include Datatype.Undefined type t = history_elt let name = "History.history_elt" let reprs = List.map (fun g -> Global g) Cil_datatype.Global.reprs let mem_project = Datatype.never_any_project let equal e1 e2 = match e1, e2 with | Global g1, Global g2 -> Cil_datatype.Global.equal g1 g2 | Localizable l1, Localizable l2 -> Pretty_source.Localizable.equal l1 l2 | (Global _ | Localizable _), __ -> false end) (* Identify two elements that belong to the same function *) let in_same_fun e1 e2 = let f = function | Global (GVarDecl (_, vi, _) | GFun ({svar = vi}, _)) -> (try Some (Globals.Functions.get vi) with Not_found -> None) | Localizable l -> Pretty_source.kf_of_localizable l | _ -> None in match f e1 with | None -> false | Some f1 -> match f e2 with | None -> false | Some f2 -> Kernel_function.equal f1 f2 end type history = { back: history_elt list; current: history_elt option; forward: history_elt list; } let default_history = { back = []; current = None; forward = []; } module History = Datatype.Make (struct include Datatype.Undefined type t = history let name = "History.history" let reprs = [default_history] let mem_project = Datatype.never_any_project let pretty fmt h = Format.fprintf fmt "back %d, cur %b, forward %d" (List.length h.back) (h.current <> None) (List.length h.forward) end) include History module CurrentHistory = State_builder.Ref (History) (struct let name = "History.CurrentHistory" let dependencies = [Ast.self] let default _ = default_history end) (* This is correct because the implementation makes sur that [.current = None] implies [.forward = [] && .back = []] *) let is_empty () = (CurrentHistory.get ()).current = None let can_go_back () = (CurrentHistory.get ()).back <> [] let can_go_forward () = (CurrentHistory.get ()).forward <> [] let display_elt = ref (fun _ -> ()) let set_display_elt_callback f = display_elt := f let show_current () = let h = CurrentHistory.get () in Extlib.may !display_elt h.current; CurrentHistory.set h let back () = let h = CurrentHistory.get () in match h.current, h.back with | Some cur, prev :: prevs -> let h' = {back = prevs; current = Some prev; forward= cur::h.forward} in !display_elt prev; CurrentHistory.set h' | None, prev :: prevs -> let h' = { back = prevs; current = Some prev ; forward = h.forward } in !display_elt prev; CurrentHistory.set h' | _, [] -> () let forward () = let h = CurrentHistory.get () in match h.current, h.forward with | Some cur, next :: nexts -> let h' = { back = cur::h.back; current = Some next; forward = nexts} in !display_elt next; CurrentHistory.set h' | None, next :: nexts -> let h' = { back = h.back; current = Some next; forward = nexts } in !display_elt next; CurrentHistory.set h' | _, [] -> () let on_current_history () = let h = CurrentHistory.get () in fun f -> CurrentHistory.set h; f () let push cur = let h = CurrentHistory.get () in let h' = match h.current with | None -> { back = h.back; current = Some cur; forward = [] } | Some prev -> if HistoryElt.equal cur prev then h else if HistoryElt.in_same_fun cur prev then { h with current = Some cur } else { back = prev :: h.back; current = Some cur; forward = [] } in CurrentHistory.set h' let apply_on_selected f = match (CurrentHistory.get ()).current with | None | Some (Global _) -> () | Some (Localizable loc) -> f loc let create_buttons (menu_manager : Menu_manager.menu_manager) = let refresh = menu_manager#refresh in menu_manager#add_plugin ~title:"Navigation" [ Menu_manager.toolmenubar ~sensitive:can_go_back ~icon:`GO_BACK ~label:"Back" ~tooltip:"Go to previous visited source location" (Menu_manager.Unit_callback (fun () -> back (); refresh ())); Menu_manager.toolmenubar ~sensitive:can_go_forward ~icon:`GO_FORWARD ~label:"Forward" ~tooltip:"Go to next visited source location" (Menu_manager.Unit_callback (fun () -> forward (); refresh ())); ] (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/analyses_manager.mli0000644000175000017500000000330112155630233021361 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Nothing exported. Automatic registration. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/source_viewer.ml0000644000175000017500000000633012155630233020565 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* Build a read only text view for C source code. *) let set_language_to_C (buffer:GSourceView2.source_buffer) = let original_source_language_manager = GSourceView2.source_language_manager ~default:true in let original_lang = original_source_language_manager#guess_language ~content_type:"text/x-csrc" () in begin match original_lang with | Some _ -> buffer#set_language original_lang | None -> Gui_parameters.warning "Mime type 'text/x-csrc' not found" end; buffer#set_highlight_syntax true let make ~packing = (* let d = GWindow.font_selection_dialog ~title:"tutu" ~show:true () in d#selection#set_preview_text (Format.sprintf "%s %s %s %s" Utf8_logic.forall Utf8_logic.exists Utf8_logic.eq Utf8_logic.neq) ; *) let original_source_window = GSourceView2.source_view ~show_line_numbers:true ~editable:false ~packing () in (* let pixbuf = original_source_window#misc#render_icon ~size:`MENU `DIALOG_WARNING in original_source_window#set_marker_pixbuf "warning" pixbuf; *) original_source_window#misc#set_name "source"; let original_source_buffer = original_source_window#source_buffer in set_language_to_C original_source_buffer; (* ignore (original_source_buffer#create_marker ~typ:"warning" original_source_buffer#start_iter ) ;*) begin try original_source_window#set_highlight_current_line true with Not_found -> () (* very old gtksourceview do not have this property. *) end; original_source_window let buffer () = let original_source_buffer = GSourceView2.source_buffer () in set_language_to_C original_source_buffer; original_source_buffer frama-c-Fluorine-20130601/src/gui/source_viewer.mli0000644000175000017500000000362012155630233020735 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** The Frama-C source viewer. That is the buffer where Frama-C puts its pretty-printed AST. *) val make : packing:(GObj.widget -> unit) -> GSourceView2.source_view (** Build a new source viewer. *) val buffer : unit -> GSourceView2.source_buffer (** @return the buffer displaying the pretty-printed AST. *) frama-c-Fluorine-20130601/src/gui/book_manager.ml0000644000175000017500000001436012155630233020332 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module Q = Qstack.Make (struct type t = GSourceView2.source_view let equal x y = x == y end) type t = { notebook : GPack.notebook ; views : Q.t ; } let make ?tab_pos ?packing () = let notebook = GPack.notebook ~scrollable:true ~show_tabs:true ?tab_pos ?packing () in notebook#set_enable_popup true ; { notebook = notebook ; views = Q.create (); } let get_notebook t = t.notebook let set_current_view t n = if (n>=0) && (n < (Q.length t.views)) then t.notebook#goto_page n let prepend_source_tab w titre = Gui_parameters.debug "prepend_source_tab"; (* insert one extra tab in the source window w, with label *) let label = GMisc.label ~text:titre () in let sw = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(fun arg -> ignore (w.notebook#prepend_page ~tab_label:label#coerce arg)) () in let window = (Source_viewer.make ~packing:sw#add) in (* Remove default pango menu for textviews *) ignore (window#event#connect#button_press ~callback: (fun ev -> GdkEvent.Button.button ev = 3)); Q.add window w.views; w.notebook#goto_page 0; window let get_nth_page (t:t) n = let nb = t.notebook in nb#get_nth_page n (* Deprecated *) let current_page (t:t) = let nb = t.notebook in nb#current_page let last_page t = Q.length t.views - 1 (* ABP and methods to manage this memory *) let get_current_view (t:t) = let nb = t.notebook in let cp = nb#current_page in Gui_parameters.debug "get_current_view: %d" cp; Q.nth cp t.views let get_current_index (t:t) = let cp = t.notebook#current_page in Gui_parameters.debug "get_current_index: %d" cp; cp let delete_view (t:t) cp = let nb = t.notebook in Gui_parameters.debug "delete_current_view - cur is page %d" cp; Q.remove (Q.nth cp t.views) t.views; nb#remove_page cp; let last = pred (Q.length t.views) in Gui_parameters.debug "Going to page (delete_current_view) %d" last; nb#goto_page last (* delete within w the tab that contains window win *) let delete_view_and_loc w win () = Gui_parameters.debug "delete_view_and_loc "; let idx = Q.idx win w.views in delete_view w idx let delete_current_view t = delete_view t t.notebook#current_page let delete_all_views (t:t) = Q.iter (fun _ -> t.notebook#remove_page 0) t.views; Q.clear t.views let append_view (t:t) (v:GSourceView2.source_view) = let nb = t.notebook in let next = Q.length t.views in let text = Printf.sprintf "Page %d" next in let label = GMisc.label ~text:text () in let sw = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(fun arg -> ignore (nb#append_page ~tab_label:label#coerce arg)) () in sw#add (v:>GObj.widget); nb#goto_page next; Gui_parameters.debug "Going to page (append_view) %d" next; Q.add_at_end v t.views; Gui_parameters.debug "append_view - nb pages is %d" (Q.length t.views); Gui_parameters.debug "append_view - current nb page is %d" nb#current_page let get_nth_view t (n:int) = Q.nth n t.views let enable_popup (t:t) (b:bool) = let nb = t.notebook in nb#set_enable_popup b let set_scrollable (t:t) (b:bool) = let nb = t.notebook in nb#set_scrollable b (* get length of the current source_views list *) let length t = Q.length t.views let append_source_tab w titre = Gui_parameters.debug "append_source_tab"; (* insert one extra tab in the source window w, with some title *) let composed_label = GPack.hbox () in let _ = GMisc.label ~text:(titre) ~packing:composed_label#add () in let cbutton = GButton.button ~packing:composed_label#add () in cbutton#set_use_stock false ; cbutton#set_label "X"; cbutton#misc#set_size_request ~width:20 ~height:20 (); let sw = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(fun arg -> ignore (w.notebook#append_page ~tab_label:composed_label#coerce arg)) (* ~packing:(fun arg -> ignore (w.notebook#append_page ~tab_label:label#coerce arg)) *) () in let window = (Source_viewer.make ~packing:sw#add) in ignore (cbutton#connect#clicked ~callback:(fun () -> delete_view_and_loc w window ())); (* Remove default pango menu for textviews *) ignore (window#event#connect#button_press ~callback: (fun ev -> GdkEvent.Button.button ev = 3)); Q.add_at_end window w.views; let last = pred (Q.length w.views) in (* THIS CALLS THE SWITCH_PAGE CALLBACK IMMEDIATELY! *) w.notebook#goto_page last; window (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/help_manager.ml0000644000175000017500000001011612155630233020323 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let show main_ui = let authors = [ "Patrick Baudin" ; "François Bobot" ; "Richard Bonichon"; "Loïc Correnson"; "Pascal Cuoq"; "Zaynah Dargaye"; "Jean-Christophe Filliâtre"; "Philippe Herrmann"; "Florent Kirchner"; "Matthieu Lemerre"; "Claude Marché"; "Benjamin Monate"; "Yannick Moy"; "Anne Pacalet"; "Virgile Prévosto"; "Julien Signoles"; "Boris Yakobowski" ] in let copyright (* should be automatically generated *) = "\t © CEA and INRIA for the Frama-C kernel\n\ \t © CEA for the GUI and plug-ins constant propagation, from, inout, impact, \ metrics, occurrence pdg, postdominators, scope, security_slicing, \ semantic callgraph, slicing, sparecode, syntactic callgraph, users and value.\n\ \n\ See the particular header of each source file for details." in let license (* should be automatically generated *) = "Licences of the Frama-C kernel and plug-ins are either under LGPL v2.1, \ or BSD.\n\ See the particular header of each source file for details." in let dialog = GWindow.about_dialog ~parent:main_ui#main_window ?icon:Gtk_helper.framac_icon ?logo:Gtk_helper.framac_logo ~name:"Frama-C" ~authors ~copyright ~license ~website:"http://frama-c.com" ~website_label:"Questions and support" ~version:(Config.version ^ "\nBuilt on " ^ Config.date) ~comments:"Frama-C is a suite of tools dedicated to the analysis of the \ source code of software written in C." () in (* Buggy labgtk2 prevents this from working...*) ignore (dialog#connect#response ~callback:(fun _ -> try dialog#coerce#destroy () with Not_found -> ())); try ignore (dialog#run ()) with Not_found | Failure "dialog destroyed" -> (* raised because of a buggy lablgtk2 *) () (** Register this dialog in main window menu bar *) let () = Design.register_extension (fun window -> let menu_manager = window#menu_manager () in let _helpitem, helpmenu = menu_manager#add_menu "_Help" ~pos:(List.length menu_manager#factory#menu#children) in (* helpitem#set_right_justified true;*) ignore (menu_manager#add_entries helpmenu [ Menu_manager.menubar ~icon:`ABOUT "About" (Menu_manager.Unit_callback (fun () -> show window)); ]); ) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/analyses_manager.ml0000644000175000017500000001125112155630233021213 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let filter name extension = let f = GFile.filter ~name () in f#add_pattern ("*" ^ extension); f let run title filter_name extension loader (host_window: Design.main_window_extension_points) = let dialog = GWindow.file_chooser_dialog ~action:`OPEN ~title ~parent:host_window#main_window () in dialog#add_button_stock `CANCEL `CANCEL ; dialog#add_select_button_stock `EXECUTE `EXECUTE ; dialog#add_filter (filter filter_name extension); host_window#protect ~cancelable:true ~parent:(dialog :> GWindow.window_skel) (fun () -> match dialog#run () with | `EXECUTE -> let run f = loader f; !Db.Main.play (); host_window#reset () in Extlib.may run dialog#filename; | `DELETE_EVENT | `CANCEL -> ()); dialog#destroy () let run_script = run "Execute an OCaml script" "OCaml sources" ".ml" Dynamic.load_script let run_module = run "Load an OCaml object file" "OCaml objects" Dynamic.object_file_extension Dynamic.load_module let insert (main_ui: Design.main_window_extension_points) = let menu_manager = main_ui#menu_manager () in let stop = ref (fun () -> assert false) (* delayed *) in let stop_sensitive = ref false (* can the stop button be clicked? *) in let default_analyses_items = menu_manager#add_plugin [ Menu_manager.toolmenubar ~icon:`PROPERTIES ~label:"Analyses" ~tooltip:"Configure and run analyses" (Menu_manager.Unit_callback main_ui#launcher); Menu_manager.menubar ~icon:`EXECUTE "Compile and run an OCaml Script" (Menu_manager.Unit_callback (fun () -> run_script main_ui)); Menu_manager.menubar "Load and run an OCaml Module" (Menu_manager.Unit_callback (fun () -> run_module main_ui)); Menu_manager.toolbar ~sensitive:(fun () -> !stop_sensitive) ~icon:`STOP ~label:"Stop" ~tooltip:"Stop currently running analyses" (Menu_manager.Unit_callback (fun () -> !stop ())); ] in default_analyses_items.(0)#add_accelerator `CONTROL 'r'; let stop_button = Extlib.the default_analyses_items.(3)#tool_button in let old_progress = ref !Db.progress in stop := (fun () -> Db.progress := (fun () -> Db.progress := !old_progress; raise Db.Cancel)); Gtk_helper.register_locking_machinery ~lock_last:true ~lock:(fun cancelable -> if !stop_sensitive then Gui_parameters.warning "Inconsistent state for stop button. Ignoring."; old_progress := !Db.progress; menu_manager#set_sensitive false; if cancelable then (stop_button#misc#set_sensitive true; stop_sensitive := true); ) ~unlock:(fun () -> Db.progress := !old_progress; menu_manager#set_sensitive true; stop_button#misc#set_sensitive false; stop_sensitive := false; ) () let () = Design.register_extension insert (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/gtk_form.mli0000644000175000017500000000571512155630233017673 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** {b DEPRECATED.} Helpers around [Gtk_helper] to create side-panel widgets. This module should not be used anymore. The provided helpers allow for synchronizing plugin options with predefined widgets. However, the widgets should be now created with [Toolbox]. The synchronization can be achieved using [Toolbox.signal] as a replacement for above [demon]. *) (* ------------------------------------------------------------------------ *) (* --- Forms Factory --- *) (* ------------------------------------------------------------------------ *) type demon val demon : unit -> demon val register : demon -> (unit -> unit) -> unit val refresh : demon -> (unit -> unit) type 'a field = ?tooltip:string -> packing:(GObj.widget -> unit) -> (unit -> 'a) -> ('a -> unit) -> demon -> unit val check : ?label:string -> bool field val menu : (string * 'a) list -> ?width:int -> 'a field val spinner : ?lower:int -> ?upper:int -> ?width:int -> int field val label : text:string -> packing:(GObj.widget -> unit) -> unit -> unit val button : label:string -> ?tooltip:string -> callback:(unit -> unit) -> packing:(GObj.widget -> unit) -> unit -> unit class form : packing:(GObj.widget -> unit) -> object method label : string -> unit method item : GObj.widget -> unit method row : GObj.widget -> unit end frama-c-Fluorine-20130601/src/gui/toolbox.ml0000644000175000017500000010712212155630233017373 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Utils --- *) (* -------------------------------------------------------------------------- *) let on x f = match x with None -> () | Some x -> f x let apply fs x = List.iter (fun f -> f x) fs module Prop : sig val wrap : ('a -> 'b) -> 'a -> 'b end = struct type ('a,'b) cell = Value of 'b | Fun of ('a -> 'b) let make f = ref (Fun f) let get p x = match !p with | Value y -> y | Fun f -> let y = f x in p := Value y ; y let wrap f = get (make f) end (* -------------------------------------------------------------------------- *) (* --- Pango Properties --- *) (* -------------------------------------------------------------------------- *) let small_font = Prop.wrap (fun f -> let f = Pango.Font.copy f in let s = Pango.Font.get_size f in Pango.Font.set_size f (s-2) ; f) let bold_font = Prop.wrap (fun f -> let f = Pango.Font.copy f in Pango.Font.set_weight f `BOLD ; f) let modify_font widget phi = widget#misc#modify_font (phi widget#misc#pango_context#font_description) (* -------------------------------------------------------------------------- *) (* --- Gui ToolBox --- *) (* -------------------------------------------------------------------------- *) let set_tooltip obj tooltip = on tooltip obj#misc#set_tooltip_text class type widget = object method set_enabled : bool -> unit method coerce : GObj.widget end class virtual ['a] handler = object(self) method virtual connect : ('a -> unit) -> unit method on_check v f = self#connect (fun e -> f (e=v)) method on_value v f = self#connect (fun e -> if e=v then f ()) method on_event f = self#connect (fun _ -> f ()) end class ['a] signal = object val mutable enabled = true val mutable lock = false val mutable demon = [] inherit ['a] handler method fire (x:'a) = if enabled && not lock then try lock <- true ; apply demon x ; lock <- false with err -> lock <- false ; raise err method connect f = demon <- demon @ [f] method set_enabled e = enabled <- e end class ['a] selector default = object(self) val mutable current : 'a = default inherit ['a] signal method get = current method set x = current <- x ; self#fire x method send h () : unit = if not lock then try lock <- true ; let () = h current in lock <- false with err -> lock <- false ; raise err end class widget_skel obj = object method coerce : GObj.widget = obj#coerce method set_enabled (e:bool) : unit = obj#misc#set_sensitive e end (* -------------------------------------------------------------------------- *) (* --- Labels --- *) (* -------------------------------------------------------------------------- *) type align = [`Left | `Right | `Center] type style = [`Label | `Descr | `Title] let xalign = function `Left -> 0.0 | `Right -> 1.0 | `Center -> 0.5 class label ?(style=`Label) ?text ?(align=`Left) () = let w = GMisc.label ?text ~xalign:(xalign align) () in object initializer match style with | `Label -> () | `Descr -> w#set_line_wrap true ; modify_font w small_font | `Title -> modify_font w bold_font method coerce = w#coerce method set_text = w#set_text end (* -------------------------------------------------------------------------- *) (* --- Image --- *) (* -------------------------------------------------------------------------- *) type icon = [ GtkStock.id | `Share of string ] let pixbufs = Hashtbl.create 63 let pixbuf (f:string) = try Hashtbl.find pixbufs f with Not_found -> let pixbuf = try GdkPixbuf.from_file (Config.datadir ^ "/" ^ f) with Glib.GError _ -> Gui_parameters.warning ~once:true "Frama-C images not found. Is FRAMAC_SHARE correctly set?"; Gtk_helper.Icon.default () in Hashtbl.add pixbufs f pixbuf ; pixbuf let gimage (icon:icon) = match icon with | `Share f -> GMisc.image ~pixbuf:(pixbuf f) () | #GtkStock.id as stock -> GMisc.image ~stock () (* -------------------------------------------------------------------------- *) (* --- Buttons --- *) (* -------------------------------------------------------------------------- *) class button_skel ?icon ?tooltip (button:GButton.button_skel) = object(self) val mutable images = [] initializer begin self#set_icon icon ; set_tooltip button tooltip ; button#misc#set_can_focus false ; button#set_focus_on_click false ; end inherit widget_skel button method set_label = button#set_label method set_relief e = button#set_relief (if e then `NORMAL else `NONE) method set_icon = function | None -> button#unset_image () | Some icn -> let image = try List.assoc icn images with Not_found -> let img = gimage icn in images <- (icn,img)::images ; img in button#set_image image#coerce end class button ?label ?icon ?tooltip () = let button = GButton.button ?label ~show:true () in object(self) inherit [unit] signal as s inherit button_skel ?icon ?tooltip (button :> GButton.button_skel) as b method set_enabled e = s#set_enabled e ; b#set_enabled e method default = button#grab_default initializer ignore (button#connect#clicked self#fire) end (* -------------------------------------------------------------------------- *) (* --- On/Off Buttons --- *) (* -------------------------------------------------------------------------- *) class checkbox ~label ?tooltip () = let button = GButton.check_button ~label ~show:true () in object inherit [bool] selector false as s inherit widget_skel button as b method set_enabled e = s#set_enabled e ; b#set_enabled e method set a = s#set a ; button#set_active a initializer begin set_tooltip button tooltip ; ignore (button#connect#clicked (fun () -> s#set button#active)) ; end end class toggle ?label ?icon ?tooltip () = let button = GButton.button ?label ~show:true ~relief:`NONE () in object inherit [bool] selector false as s inherit button_skel ?icon ?tooltip (button :> GButton.button_skel) as b method set_enabled e = s#set_enabled e ; b#set_enabled e method set a = s#set a ; button#set_relief (if a then `NORMAL else `NONE) initializer ignore (button#connect#clicked (fun () -> s#set (not s#get))) end class radio ~label ?tooltip () = let button = GButton.radio_button ~label ~show:true () in object inherit [bool] selector false as s inherit widget_skel button method set e = s#set e ; if e then button#set_active true method group = function | None -> Some button#group | (Some g) as sg -> button#set_group g ; sg initializer begin set_tooltip button tooltip ; ignore (button#connect#clicked (fun () -> s#set button#active)) ; end end class switchbox ?tooltip () = let pix_on = pixbuf "feedback/switch-on.png" in let pix_off = pixbuf "feedback/switch-off.png" in let evt = GBin.event_box () in let img = GMisc.image ~pixbuf:pix_on ~packing:evt#add () in object(self) inherit [bool] selector false as s inherit widget_skel evt as b method set_enabled e = s#set_enabled e ; b#set_enabled e method set a = s#set a ; img#set_pixbuf (if a then pix_on else pix_off) initializer begin set_tooltip evt tooltip ; ignore (evt#event#connect#button_release (fun _evt -> self#set (not s#get) ; false)) ; end end (* -------------------------------------------------------------------------- *) (* --- Spinner --- *) (* -------------------------------------------------------------------------- *) class spinner ?min ?max ?(step=1) ~value ?tooltip () = let b = GEdit.spin_button ~digits:0 () in object inherit [int] selector value as s inherit widget_skel b method set_enabled e = s#set_enabled e ; b#misc#set_sensitive e method set a = s#set a ; b#set_value (float value) initializer begin set_tooltip b tooltip ; let fmap = function None -> None | Some x -> Some (float x) in b#adjustment#set_bounds ?lower:(fmap min) ?upper:(fmap max) ~step_incr:(float step) () ; b#set_value (float value) ; let callback () = s#set b#value_as_int in ignore (b#connect#value_changed ~callback) ; end end (* -------------------------------------------------------------------------- *) (* --- Switches --- *) (* -------------------------------------------------------------------------- *) class ['a] switch (default : 'a) = object(self) inherit ['a] selector default val mutable cases : (bool selector * 'a) list = [] val mutable group = None initializer self#connect (fun v -> List.iter (fun (w,v0) -> w#set (v=v0)) cases) method private add_case (w : bool selector) (v : 'a) = begin w#set ( v = self#get ) ; w#connect (fun e -> if e then self#set v) ; cases <- (w,v) :: cases ; end method add_toggle ?label ?icon ?tooltip ~value () = let toggle = new toggle ?label ?icon ?tooltip () in self#add_case (toggle :> bool selector) value ; (toggle :> widget) method add_radio ~label ?tooltip ~value () = let radio = new radio ~label ?tooltip () in self#add_case (radio :> bool selector) value ; group <- radio#group group ; (radio :> widget) method set_enabled e = List.iter (fun (w,_) -> w#set_enabled e) cases end (* -------------------------------------------------------------------------- *) (* --- PopDown --- *) (* -------------------------------------------------------------------------- *) class ['a] menulist ~default ~render ?(items=[]) () = let strings = List.map render items in let (cmb,(model,_)) as combo = GEdit.combo_box_text ~strings ~wrap_width:1 () in object(self) inherit widget_skel cmb as widget inherit ['a] selector default as select val mutable items = Array.of_list items method set_enabled e = select#set_enabled e ; widget#set_enabled e method get_items = Array.to_list items method set_items xs = begin items <- Array.of_list xs ; model#clear () ; Array.iter (fun x -> GEdit.text_combo_add combo (render x)) items ; let e = select#get in if not lock then begin lock <- true ; Array.iteri (fun i x -> if x=e then cmb#set_active i) items ; lock <- false ; end ; end method private clicked () = try if not lock then select#set items.(cmb#active) with _ -> () method set x = begin select#set x ; Array.iteri (fun i e -> if x=e then cmb#set_active i) items ; end initializer ignore (cmb#connect#changed self#clicked) ; end (* -------------------------------------------------------------------------- *) (* --- Popup Menu --- *) (* -------------------------------------------------------------------------- *) class popup () = let menu = GMenu.menu () in object val mutable empty = true val mutable separator = false method clear = List.iter menu#remove menu#children method add_separator = separator <- true method add_item ~label ~callback = if not empty && separator then ignore (GMenu.separator_item ~packing:menu#append ()) ; let item = GMenu.menu_item ~label ~packing:menu#append () in ignore (item#connect#activate ~callback) ; empty <- false ; separator <- false method popup () = let time = GMain.Event.get_current_time () in menu#popup ~button:3 ~time end (* -------------------------------------------------------------------------- *) (* --- Rack --- *) (* -------------------------------------------------------------------------- *) class rack (widgets : widget list) = let box = GPack.hbox ~homogeneous:true ~spacing:0 ~border_width:0 () in object initializer List.iter (fun w -> box#add w#coerce) widgets method set_enabled e = List.iter (fun w -> w#set_enabled e) widgets method coerce = box#coerce end (* -------------------------------------------------------------------------- *) (* --- File Chooser --- *) (* -------------------------------------------------------------------------- *) type filekind = [ `FILE | `DIR ] class filechooser_dialog ?(kind=`FILE) ?(title="Select File") ?(select="Select") ?parent () = let dialog = GWindow.dialog ~title ?parent ~modal:true () in let packing = dialog#vbox#pack ~expand:true in let action = match kind with `FILE -> `SAVE | `DIR -> `CREATE_FOLDER in let chooser = GFile.chooser_widget ~action ~packing () in object inherit [string] signal as signal initializer begin ignore (dialog#event#connect#delete (fun _ -> true)) ; dialog#add_button "Cancel" `DELETE_EVENT ; dialog#add_button select `SELECT ; ignore (GMisc.label ~packing:(dialog#action_area#pack ~expand:true) ()) ; end method filter ~descr ~patterns = if kind = `FILE then chooser#add_filter (GFile.filter ~name:descr ~patterns ()) method select ?dir ?file () = begin match dir , file with | None , None -> ignore (chooser#set_filename "") | None , Some path -> ignore (chooser#set_filename path) | Some dir , None -> ignore (chooser#set_current_folder dir) ; ignore (chooser#set_current_name "") | Some dir , Some file -> ignore (chooser#set_current_folder dir) ; ignore (chooser#set_current_name file) end ; let result = dialog#run () in dialog#misc#hide () ; match result with | `DELETE_EVENT -> () | `SELECT -> match chooser#get_filenames with | f::_ -> signal#fire f | _ -> () end class filechooser_button ?kind ?title ?select ?tooltip ?parent () = let box = GPack.hbox ~homogeneous:false ~spacing:0 ~border_width:0 () in let fld = GMisc.label ~text:"(none)" ~xalign:0.0 ~packing:(box#pack ~expand:true) () in let _ = GMisc.separator `VERTICAL ~packing:(box#pack ~expand:false ~padding:2) ~show:true () in let _ = GMisc.image ~packing:(box#pack ~expand:false) ~stock:`OPEN () in let button = GButton.button () in let dialog = new filechooser_dialog ?kind ?title ?select ?parent () in object(self) inherit widget_skel button inherit [string] selector "" as current val mutable disptip = fun f -> match tooltip , f with | None , "" -> "(none)" | None , _ -> f | Some d , "" -> d | Some d , f -> Printf.sprintf "%s: %s" d f val mutable display = function | "" -> "(none)" | path -> Filename.basename path initializer begin button#add box#coerce ; button#set_focus_on_click false ; ignore (button#connect#clicked self#select) ; dialog#connect current#set ; set_tooltip button tooltip ; current#connect (fun f -> button#misc#set_tooltip_text (disptip f) ; fld#set_text (display f)) ; end method tooltip p = disptip <- p ; fld#misc#set_tooltip_text (p current#get) method display p = display <- p ; fld#set_text (p current#get) method filter = dialog#filter method select ?dir ?file () = let file = match file with None -> current#get | Some f -> f in dialog#select ?dir ~file () end (* -------------------------------------------------------------------------- *) (* --- Forms --- *) (* -------------------------------------------------------------------------- *) type field = [ `Compact | `Field | `Editor ] let fexpand = function `Compact -> `NONE | `Field -> `X | `Editor -> `BOTH class form () = let box = GPack.table ~columns:2 ~col_spacings:16 ~homogeneous:false () in object(self) val mutable line = 0 val mutable left = false (* left column feeded on current line *) val mutable right = false (* right column feeded on current line *) val mutable xpadding = 0 (* set with sections *) inherit widget_skel box method private occupy_left = if left || right then line <- succ line ; left <- true ; right <- false method private occupy_right = if right then (line <- succ line ; left <- false) ; right <- true method private occupy_both = if left || right then line <- succ line ; left <- true ; right <- true method add_newline = self#occupy_both ; let w = GMisc.label ~text:"" () in box#attach ~left:0 ~right:1 ~top:line ~ypadding:12 ~expand:`Y w#coerce method add_section label = self#occupy_both ; let w = GMisc.label ~text:label ~xalign:0.0 ~yalign:1.0 () in modify_font w bold_font ; xpadding <- 24 ; box#attach ~left:0 ~right:1 ~top:line ~xpadding:0 ~ypadding:12 ~expand:`Y w#coerce method add_label_widget w = self#occupy_left ; box#attach ~left:0 ~top:line ~xpadding ~expand:`NONE w method add_label label = let w = GMisc.label ~text:label ~xalign:1.0 () in self#add_label_widget w#coerce method add_field ?label ?(field:field=`Field) w = on label self#add_label ; self#occupy_right ; box#attach ~left:1 ~top:line ~expand:(fexpand field) w method add_row ?(field:field=`Field) w = self#occupy_both ; box#attach ~left:0 ~right:1 ~top:line ~expand:(fexpand field) w end (* -------------------------------------------------------------------------- *) (* --- List --- *) (* -------------------------------------------------------------------------- *) module L = Gtk_helper.Custom.List let bound a x b = if x < a then a else if x > b then b else x class ['a] lmodel render = object val mutable store : 'a array = [| |] val mutable items : 'a array = [| |] method reload = items <- store method size = Array.length items method index k : int = k method get k : int = k method render k : GTree.cell_properties_text list = if 0 <= k && k <= Array.length items then [`TEXT (render items.(k))] else [`TEXT ""] method set_items xs = store <- Array.of_list xs method get_items = Array.to_list items method get_item k = items.(k) method insert_item k e = begin let n = Array.length items in let k = bound 0 k n in store <- Array.create (n+1) e ; if k>0 then Array.blit items 0 store 0 (k-1) ; if k string) ?width ?(height=80) () = let model = new lmodel render in let wlist = new L.view ~headers:false ~rules:false ?width ~height (model :> int L.model) in let witem = wlist#add_column_text [] model#render in let wbox = GPack.vbox ~homogeneous:false () in let hbox = GPack.hbox ~homogeneous:true ~spacing:0 () in let b_add = new button ~icon:`ADD () in let b_del = new button ~icon:`REMOVE () in let b_up = new button ~icon:`GO_UP () in let b_dn = new button ~icon:`GO_DOWN () in let insert = new signal in let change = new signal in object(self) val mutable enabled = false val mutable selected = (-1) initializer begin wbox#pack ~expand:true wlist#coerce ; hbox#pack ~padding:32 ~expand:false b_add#coerce ; hbox#pack ~padding:0 ~expand:false b_del#coerce ; hbox#pack ~padding:0 ~expand:false b_up#coerce ; hbox#pack ~padding:0 ~expand:false b_dn#coerce ; wbox#pack ~expand:false hbox#coerce ; wlist#on_click (fun k _ -> selected <- k ; self#buttons) ; b_up#connect self#up ; b_dn#connect self#dn ; b_add#connect self#add ; b_del#connect self#del ; end method private up () = begin model#move_up selected ; selected <- pred selected ; wlist#reload ; wlist#set_focus selected witem ; self#buttons ; change#fire model#get_items ; end method private dn () = begin model#move_down selected ; selected <- succ selected ; wlist#reload ; self#buttons ; wlist#set_focus selected witem ; self#buttons ; change#fire model#get_items ; end method private add () = let n = model#size in if 0 <= selected && selected <= n then insert#fire selected method private del () = begin model#remove_item selected ; wlist#reload ; self#buttons ; change#fire model#get_items ; end method private buttons = begin let n = model#size in wlist#view#misc#set_sensitive enabled ; b_add#set_enabled ( enabled ) ; b_del#set_enabled ( enabled && 0 <= selected && selected < n ) ; b_up#set_enabled ( enabled && 0 < selected && selected < n ) ; b_dn#set_enabled ( enabled && 0 <= selected && selected+1 < n ) ; end method coerce = wbox#coerce method set_enabled e = enabled <- e ; self#buttons method get = model#get_items method set xs = model#set_items xs ; wlist#reload ; change#fire xs method send r () : unit = r model#get_items method insert k x = begin model#insert_item k x ; wlist#reload ; wlist#set_focus k witem ; selected <- k ; self#buttons ; end method fire = change#fire method on_insert_request = insert#connect method connect = change#connect inherit [_] handler end (* -------------------------------------------------------------------------- *) (* --- Extensible Array --- *) (* -------------------------------------------------------------------------- *) class type entry = object method widget : GObj.widget method update : unit -> unit method delete : unit -> unit end class ['a] warray ?(dir=`VERTICAL) () = let box = GPack.box dir ~homogeneous:false () in object(self) val mutable rows : ('a * entry) list = [] val mutable creator : ('a -> entry) = (fun _ -> assert false) inherit widget_skel box method set xs = begin List.iter (fun (y,e) -> if not (List.mem y xs) then begin e#delete () ; let w = e#widget in box#remove w ; w#destroy () ; end) rows ; rows <- List.map (fun x -> let e = try List.assoc x rows with Not_found -> let e = creator x in box#pack ~expand:false e#widget ; e in x,e) xs ; ignore (List.fold_left (fun pos (_,w) -> box#reorder_child w#widget ~pos ; succ pos) 0 rows) end method get = List.map fst rows method mem x = List.mem_assoc x rows method private others x = List.fold_right (fun (y,_) ys -> if x=y then ys else y::ys) rows [] method append x = self#set ( self#others x @ [x] ) method insert ?after x = let ys = self#others x in let zs = match after with | None -> x :: ys | Some z -> let rec hook z x = function | [] -> [x] | y::ys -> if y = z then z :: x :: ys else y :: hook z x ys in hook z x ys in self#set zs method remove x = self#set (self#others x) method create f = creator <- f method update () = List.iter (fun (_,e) -> e#update ()) rows end (* -------------------------------------------------------------------------- *) (* --- Notebook --- *) (* -------------------------------------------------------------------------- *) class ['a] notebook ?tabs ~default () = let view = GPack.notebook ~enable_popup:false ~show_tabs:false ~show:true () in object(self) val mutable pages : 'a list = [] inherit ['a] selector default as select method add ?label page content = let tab_label = match label with | None -> None | Some text -> Some (GMisc.label ~text ())#coerce in pages <- pages @ [page] ; ignore (view#append_page ?tab_label content) ; self#set default method set page = let rec scan i p = function | q::qs -> if p=q then view#goto_page i else scan (succ i) p qs | [] -> () in scan 0 page pages method private switched i = try select#set (List.nth pages i) with Invalid_argument _ -> () method on_focus page f = select#connect (fun p -> f (page = p)) initializer begin ignore (view#connect#switch_page self#switched) ; on tabs (fun p -> view#set_show_tabs true ; view#set_tab_pos p) ; end method coerce = view#coerce method set_enabled = view#misc#set_sensitive end (* -------------------------------------------------------------------------- *) (* --- Dialogs --- *) (* -------------------------------------------------------------------------- *) type 'a action = [ | `CANCEL | `APPLY | `DEFAULT of 'a | `SELECT of 'a | `ALT of 'a | `ACTION of (unit -> unit) ] class ['a] dialog ~title ~window ?(resize=false) () = let shell = GWindow.window ~title ~kind:`TOPLEVEL ~modal:true ~show:false ~decorated:true ~position:`CENTER_ON_PARENT ~allow_grow:resize () in let hclip = GBin.alignment ~packing:shell#add () in let vbox = GPack.vbox ~homogeneous:false ~spacing:6 ~packing:hclip#add () in let vclip = GBin.alignment ~packing:(vbox#pack ~from:`END ~expand:false) () in let hbox = GPack.hbox ~homogeneous:false ~spacing:32 ~packing:vclip#add () in let alt_box = GPack.hbox ~homogeneous:true ~spacing:6 ~packing:(hbox#pack ~expand:true ~fill:false) () in let main_box = GPack.hbox ~homogeneous:true ~spacing:6 ~packing:(hbox#pack ~expand:true ~fill:false) () in object(self) constraint 'a = [> `CANCEL | `APPLY] inherit ['a] signal val mutable defw = (fun () -> ()) method add_row w = vbox#pack ~from:`START ~expand:false w method add_block w = vbox#pack ~from:`START ~expand:true w method button ~(action : 'a action) ?label ?icon ?tooltip () = let w = new button ?label ?icon ?tooltip () in let box = match action with | `DEFAULT _ | `APPLY -> defw <- w#default ; main_box | `SELECT _ | `CANCEL -> main_box | `ALT _ | `ACTION _ -> alt_box in box#pack ~expand:false w#coerce ; match action with | `ALT r | `SELECT r | `DEFAULT r -> w#connect (fun () -> self#select r) | `CANCEL -> w#connect (fun () -> self#select `CANCEL) | `APPLY -> w#connect (fun () -> self#select `APPLY) | `ACTION f -> w#connect f method select r = begin window#misc#set_sensitive true ; shell#misc#hide () ; self#fire r ; end method run () = begin window#misc#set_sensitive false ; shell#show () ; defw () ; end initializer begin hclip#set_top_padding 4 ; hclip#set_bottom_padding 4 ; hclip#set_left_padding 24 ; hclip#set_right_padding 24 ; ignore (shell#event#connect#delete (fun _ -> self#select `CANCEL ; true)) ; (* returning [true] prevent the dialog from being destroyed *) end end (* -------------------------------------------------------------------------- *) (* --- Text with Tagging Formatter --- *) (* -------------------------------------------------------------------------- *) type tag = | TAG of GText.tag | LINK of int * string | MARK of int * string | PLAIN let split tag = let rec lookup tag k n = if k < n then if tag.[k] = ':' then String.sub tag 0 k , String.sub tag (k+1) (n-k-1) else lookup tag (succ k) n else tag,"" in lookup tag 0 (String.length tag) let rec tags tgs = function | [] -> tgs | TAG t :: style -> tags (t::tgs) style | (LINK _ | MARK _ | PLAIN) :: style -> tags tgs style class text () = let buffer = GText.buffer () in let view = GText.view ~buffer ~editable:false ~cursor_visible:false ~justification:`LEFT ~wrap_mode:`NONE ~accepts_tab:false ~show:true () in let scroll = GBin.scrolled_window () in object(self) (* -------------------------------------------------------------------------- *) (* --- Text Formatter --- *) (* -------------------------------------------------------------------------- *) val text = Buffer.create 80 val css = Hashtbl.create 31 val marks = Hashtbl.create 131 val links = Hashtbl.create 131 val mutable printf = false val mutable style = [] val mutable fmtref = None val mutable demon = [] method fmt = match fmtref with Some fmt -> fmt | None -> let output_string s a b = if b > 0 then Buffer.add_substring text s a b in let output_flush () = if Buffer.length text > 0 then begin let s = Gtk_helper.to_utf8 (Buffer.contents text) in let tags = tags [] style in let iter = buffer#end_iter in Buffer.clear text ; printf <- true ; buffer#insert ~tags ~iter s ; printf <- false ; end in let output_open_tag t = output_flush () ; style <- self#open_tag t :: style ; "" in let output_close_tag _t = output_flush () ; match style with | [] -> "" | s::sty -> self#close_tag s ; style <- sty ; "" in let fmt = Format.make_formatter output_string output_flush in let tagger = Format.pp_get_formatter_tag_functions fmt () in Format.pp_set_formatter_tag_functions fmt { tagger with Format.mark_open_tag = output_open_tag ; Format.mark_close_tag = output_close_tag ; } ; Format.pp_set_print_tags fmt false ; Format.pp_set_mark_tags fmt true ; fmtref <- Some fmt ; fmt (* -------------------------------------------------------------------------- *) (* --- Tag Marking --- *) (* -------------------------------------------------------------------------- *) method private css_style t p = let sty = TAG (buffer#create_tag p) in Hashtbl.replace css t sty ; sty method private link_tag lnk = try Hashtbl.find links lnk with Not_found -> let tag = buffer#create_tag [] in let callback tag lnk ~origin evt iter = ignore origin ; self#cb_link tag lnk evt iter in ignore (tag#connect#event ~callback:(callback tag lnk)) ; Hashtbl.add links lnk tag ; tag method private open_tag t = try Hashtbl.find css t with Not_found -> match t with | "ul" -> self#css_style t [ `UNDERLINE `SINGLE ] | "st" -> self#css_style t [ `STRIKETHROUGH true ] | "bf" -> self#css_style t [ `WEIGHT `BOLD ] | "it" -> self#css_style t [ `STYLE `ITALIC ] | "red" -> self#css_style t [ `FOREGROUND "red" ] | "blue" -> self#css_style t [ `FOREGROUND "blue" ] | "green" -> self#css_style t [ `FOREGROUND "darkgreen" ] | "orange" -> self#css_style t [ `FOREGROUND "orange" ] | _ -> match split t with | "link",url -> LINK(buffer#end_iter#offset,url) | "mark",mrk -> MARK(buffer#end_iter#offset,mrk) | "fg",color -> self#css_style t [ `FOREGROUND color ] | "bg",color -> self#css_style t [ `BACKGROUND color ] | _ -> PLAIN method private close_tag = function | LINK(p,lnk) -> let start = buffer#get_iter (`OFFSET p) in let stop = buffer#end_iter in let tag = self#link_tag lnk in buffer#apply_tag tag ~start ~stop ; | MARK(p,mrk) -> let start = buffer#create_mark (buffer#get_iter (`OFFSET p)) in let stop = buffer#create_mark buffer#end_iter in let tag = buffer#create_tag [] in Hashtbl.replace marks mrk (tag,start,stop) | _ -> () (* -------------------------------------------------------------------------- *) (* --- Tag Callback --- *) (* -------------------------------------------------------------------------- *) method private cb_link tag lnk evt _iter = match GdkEvent.get_type evt with | `BUTTON_PRESS -> let evt = GdkEvent.Button.cast evt in if GdkEvent.Button.button evt = 1 then apply demon lnk ; true | `ENTER_NOTIFY -> tag#set_property (`FOREGROUND "blue") ; tag#set_property (`UNDERLINE `SINGLE) ; true | `LEAVE_NOTIFY -> tag#set_property (`FOREGROUND_SET false) ; tag#set_property (`UNDERLINE `NONE) ; true | _ -> true (* -------------------------------------------------------------------------- *) (* --- Text Initializer --- *) (* -------------------------------------------------------------------------- *) initializer begin view#misc#modify_font_by_name "Monospace 10" ; scroll#add view#coerce end (* -------------------------------------------------------------------------- *) (* --- User API --- *) (* -------------------------------------------------------------------------- *) method printf : 'b. ('b,Format.formatter,unit) format -> 'b = fun text -> Format.fprintf self#fmt text method clear = Hashtbl.clear marks ; Hashtbl.clear links ; Format.pp_print_flush self#fmt () ; buffer#delete ~start:buffer#start_iter ~stop:buffer#end_iter method on_link f = demon <- demon @ [f] method focus ~mark = try let _,mark,_ = Hashtbl.find marks mark in let iter = buffer#get_iter (`MARK mark) in ignore (view#scroll_to_iter ~use_align:true ~yalign:0.2 iter) with Not_found -> () method highlight ~mark properties = try let tag,_,_ = Hashtbl.find marks mark in List.iter tag#set_property properties with Not_found -> () method coerce = scroll#coerce method set_enabled (_:bool) = () (* ignored *) end frama-c-Fluorine-20130601/src/gui/gtk_helper.ml0000644000175000017500000012153312155630233020033 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Generic Gtk helpers. *) let framac_logo, framac_icon = try let img ext = Some (GdkPixbuf.from_file (Config.datadir ^ "/frama-c." ^ ext)) in img "gif", img "ico" with Glib.GError _ -> Gui_parameters.warning "Frama-C images not found. Is FRAMAC_SHARE correctly set?"; None, None module Icon = struct type kind = Frama_C | Unmark | Custom of string | Feedback of Property_status.Feedback.t let default_icon = [| "12 12 2 1"; ". c #ffffff"; "# c #000000"; "############"; "#..........#"; "#..........#"; "#..........#"; "#..........#"; "#..........#"; "#..........#"; "#..........#"; "#..........#"; "#..........#"; "#..........#"; "############"|] module F = Property_status.Feedback let builtins = [(Frama_C,"frama-c.ico"); (Unmark,"unmark.png"); (Feedback F.Never_tried,"feedback/never_tried.png"); (Feedback F.Unknown,"feedback/unknown.png"); (Feedback F.Valid,"feedback/surely_valid.png"); (Feedback F.Invalid,"feedback/surely_invalid.png"); (Feedback F.Considered_valid,"feedback/considered_valid.png"); (Feedback F.Valid_under_hyp,"feedback/valid_under_hyp.png"); (Feedback F.Invalid_under_hyp,"feedback/invalid_under_hyp.png"); (Feedback F.Invalid_but_dead,"feedback/invalid_but_dead.png"); (Feedback F.Unknown_but_dead,"feedback/unknown_but_dead.png"); (Feedback F.Valid_but_dead,"feedback/valid_but_dead.png"); (Feedback F.Inconsistent,"feedback/inconsistent.png"); ] type icon = Filename of string | Pixbuf of GdkPixbuf.pixbuf let h = Hashtbl.create 7 let () = List.iter (fun (k,f) -> Hashtbl.add h k (Filename f)) builtins let default () = GdkPixbuf.from_xpm_data default_icon let get k = try match Hashtbl.find h k with | Filename f -> let p = try GdkPixbuf.from_file (Config.datadir ^ "/" ^ f) with Glib.GError _ -> Gui_parameters.warning ~once:true "Frama-C images not found. Is FRAMAC_SHARE correctly set?"; default () in Hashtbl.replace h k (Pixbuf p); p | Pixbuf p -> p with Not_found -> assert false let register ~name ~file = Hashtbl.replace h (Custom name) (Filename file) end module Configuration = struct include Cilconfig let configuration_file =(* This is the user home directory *) Filename.concat (try Sys.getenv "USERPROFILE" (*Win32*) with Not_found -> try Sys.getenv "HOME" (*Unix like*) with Not_found -> ".") ".frama-c-gui.config" let load () = loadConfiguration configuration_file let save () = saveConfiguration configuration_file let () = Cmdline.at_normal_exit save let set = setConfiguration let find = findConfiguration let find_int ?default key = try findConfigurationInt key with Not_found -> match default with | None -> raise Not_found | Some v -> set key (ConfInt v); v let use_int = useConfigurationInt let find_float ?default key = try findConfigurationFloat key with Not_found -> match default with | None -> raise Not_found | Some v -> set key (ConfFloat v); v let use_float = useConfigurationFloat let find_bool ?default key = try findConfigurationBool key with Not_found -> match default with | None -> raise Not_found | Some v -> set key (ConfBool v); v let use_bool = useConfigurationBool let find_string ?default s = try findConfigurationString s with Not_found -> match default with | None -> raise Not_found | Some v -> set s (ConfString v); v let use_string = useConfigurationString let find_list = findConfigurationList let use_list = useConfigurationList end let to_utf8 s = try if Glib.Utf8.validate s then s else Glib.Convert.locale_to_utf8 s with Glib.Convert.Error _ -> try Glib.Convert.convert_with_fallback ~fallback:"#neither UTF-8 nor locale nor ISO-8859-15#" ~to_codeset:"UTF-8" ~from_codeset:"ISO_8859-15" s with Glib.Convert.Error _ as e -> Printexc.to_string e let apply_tag b tag pb pe = let b = (b:>GText.buffer) in let start = b#get_iter (`OFFSET pb) in let stop = b#get_iter (`OFFSET pe) in b#apply_tag ~start ~stop tag let remove_tag b tag pb pe = let b = (b:>GText.buffer) in let start = b#get_iter (`OFFSET pb) in let stop = b#get_iter (`OFFSET pe) in b#remove_tag ~start ~stop tag let cleanup_tag b tag = let b = (b:>GText.buffer) in b#remove_tag tag ~start:b#start_iter ~stop:b#end_iter (* This table shall not be projectified: it contains trans-project informations *) module IntHashtbl = Hashtbl.Make(struct type t = int let hash = Hashtbl.hash let equal : int -> int -> bool = (=) end) let tag_names = IntHashtbl.create 17 let cleanup_all_tags b = let b = (b:>GText.buffer) in let start = b#start_iter in let stop = b#end_iter in try let tags = IntHashtbl.find tag_names (Oo.id b) in Datatype.String.Set.iter (fun s -> b#remove_tag_by_name s ~start ~stop) tags with Not_found -> () let make_tag (buffer:< tag_table : Gtk.text_tag_table; create_tag : ?name:string -> GText.tag_property list -> GText.tag ; .. >) ~name l = match GtkText.TagTable.lookup buffer#tag_table name with | None -> let oid = Oo.id buffer in let old_set = try IntHashtbl.find tag_names oid with Not_found -> Datatype.String.Set.empty in IntHashtbl.replace tag_names oid (Datatype.String.Set.add name old_set); buffer#create_tag ~name l | Some t -> new GText.tag t let expand_to_path (treeview:GTree.view) path = treeview#expand_to_path path let make_formatter ?(flush= fun () -> ()) t = let t = (t:>GText.buffer) in let fmt_emit s start length = let subs = String.sub s start length in t#insert ~iter:t#end_iter subs in Format.make_formatter fmt_emit flush let redirect fmt (t:#GText.buffer) = let fmt_emit s start length = let subs = String.sub s start length in t#insert subs in let fmt_flush () = () in Format.pp_set_formatter_output_functions fmt fmt_emit fmt_flush let gui_unlocked = ref false module Lock = struct let last = ref (fun _ -> ()) module H = Hook.Build(struct type t = bool end) let extend is_last f = if is_last then last := f else H.extend f let apply b = H.apply b; !last b end module Unlock = struct let first = ref (fun () -> ()) module H = Hook.Make(struct end) let extend is_first f = if is_first then first := f else H.extend f let apply () = !first (); H.apply () end let register_locking_machinery ?(lock_last=false) ~lock ~unlock () = if lock_last then begin Lock.extend true lock; Unlock.extend true unlock end else begin Lock.extend false lock; Unlock.extend false unlock end exception Found of string * string let splitting_for_utf8 s = let idx = ref 0 in let buggy_string = "(* not a valid utf8 string *)" in let len = String.length s in try try for i = 1 to 6 do idx := i; if len = i then raise Exit; let pre = String.sub s 0 (len - i) in let suf = String.sub s (len - i) i in if Glib.Utf8.validate pre then raise (Found (pre, suf)) done; buggy_string, "" with Exit -> buggy_string, "" with Found(pre, suf) -> pre, suf let channel_redirector channel callback = let cout,cin = Unix.pipe () in Unix.dup2 cin channel ; let channel = Glib.Io.channel_of_descr cout in let len = 80 in let current_partial = ref "" in let buf = String.create len in ignore (Glib.Io.add_watch channel ~prio:0 ~cond:[`IN; `HUP; `ERR] ~callback: begin fun cond -> try if List.mem `IN cond then begin (* On Windows, you must use Io.read *) let len = Glib.Io.read channel ~buf ~pos:0 ~len in len >= 1 && (let full_string = !current_partial ^ String.sub buf 0 len in let to_emit, c = splitting_for_utf8 full_string in current_partial := c; callback to_emit) end else false with e -> ignore (callback ("Channel redirector got an exception: " ^ (Printexc.to_string e))); false end) let log_redirector ?(flush=fun () -> ()) emit_string = let output s offset length = emit_string (String.sub s offset length) in Log.set_output output flush let make_string_list ~packing = let (model,column) = GTree.store_of_list Gobject.Data.string [] in let insert s = let row = model#append () in model#set ~row ~column s in let get_all () = let l = ref [] in model#foreach (fun _ row -> l := model#get ~row ~column ::!l ; false); !l in let view = GTree.view ~model ~reorderable:true ~packing () in let view_column = GTree.view_column ~title:"Source file(s)" () in let str_renderer = GTree.cell_renderer_text [] in view_column#pack str_renderer; view_column#add_attribute str_renderer "text" column; let _ = view#append_column view_column in let remove_selected () = let path_list = view#selection#get_selected_rows in let row_refs = List.map model#get_row_reference path_list in List.iter (fun rr -> ignore (model#remove rr#iter)) row_refs in insert,remove_selected, get_all let model_of_list conv l = let cols = new GTree.column_list in let column = cols#add conv in let model = GTree.list_store cols in List.iter (fun data -> let row = model#append () in model#set ~row ~column data) l ; (model, column) let string_selector completions packing = let (model, col) = model_of_list Gobject.Data.string completions in let entry = GEdit.entry ~packing () in let c = GEdit.entry_completion ~model ~entry () in c#set_text_column col ; entry (* (GEdit.combo ~popdown_strings:completions ~packing ())#entry *) let mk_label ?(use_markup=false) ?xalign (container:GPack.box) label = let l = GMisc.label ~xpad:3 ~line_wrap:true ?xalign ~packing:(container#pack ~expand:true ~fill:true) in if use_markup then l ~markup:label () else l ~text:label () type 'a chooser = GPack.box -> string -> (unit -> 'a) -> ('a -> unit) -> (unit -> unit) (* ------------------------------------------------------------------------ *) (* --- Bundle of fields --- *) (* ------------------------------------------------------------------------ *) let do_tooltip ?tooltip obj = match tooltip with | None -> () | Some text -> let tooltip = GData.tooltips () in tooltip#set_tip ~text obj#coerce let on_bool ?tooltip ?use_markup (container:GPack.box) label get set = let result = ref (get ()) in let container = GPack.hbox ~packing:container#pack () in do_tooltip ?tooltip container; let button = GButton.check_button ~packing:container#pack ~active:!result () in ignore (mk_label ?use_markup container ~xalign:0. label); ignore (button#connect#toggled ~callback:(fun () -> set button#active)); let update () = button#set_active (get()) in (fun () -> update ()) let range_selector ?tooltip ?use_markup (container:GPack.box) ~label ~lower ~upper set get = let container = GPack.hbox ~packing:container#pack () in do_tooltip ?tooltip container; let x = GEdit.spin_button ~digits:0 ~packing:(container#pack ~padding:10) () in x#adjustment#set_bounds ~lower:(float lower) ~upper:(float upper) ~step_incr:1. (); x#adjustment#set_value (float (get ())); ignore (x#connect#value_changed ~callback: (fun () -> set x#value_as_int)); ignore (mk_label ?use_markup ~xalign:0. container label); (fun () -> x#adjustment#set_value (float (get ()))) let on_int ?tooltip ?use_markup ?(lower=0) ?(upper=max_int) ?(sensitive=(fun () -> true)) ?width (container:GPack.box) label get set = let container = GPack.hbox ~packing:container#pack () in do_tooltip ?tooltip container; let non_fixed = width=None in let spin = GEdit.spin_button ~digits:0 ?width ~packing:(container#pack ~expand:non_fixed ~fill:non_fixed) () in spin#adjustment#set_bounds ~lower:(float lower) ~upper:(float upper) ~step_incr:1. (); spin#adjustment#set_value (float (get())); ignore (spin#connect#value_changed ~callback: (fun () -> set spin#value_as_int)); let label = mk_label ?use_markup ~xalign:0. container label in (fun () -> label#misc#set_sensitive (sensitive ()); spin#misc#set_sensitive (sensitive ()); spin#adjustment#set_value (float (get()))) let on_string ?tooltip ?use_markup ?(validator=(fun _ -> true)) ?width (container:GPack.box) label get set = let container = GPack.hbox ~packing:container#pack () in do_tooltip ?tooltip container; let entry = GEdit.entry ~packing:container#pack ~text:(get()) ?width () in let callback _ = let text = entry#text in if validator text then set text else entry#set_text (get ()); false in ignore (entry#event#connect#focus_out ~callback); ignore (entry#connect#activate ~callback:(fun () -> ignore (callback ()))); ignore (mk_label ?use_markup ~xalign:0. container label); (fun () -> if not (Gobject.Property.get entry#as_widget GtkBase.Widget.P.has_focus) then entry#set_text (get ())) let on_string_set ?tooltip ?use_markup ?width (container:GPack.box) label get set = let container = GPack.hbox ~packing:container#pack () in do_tooltip ?tooltip container; let entry = GEdit.entry ~packing:container#pack ~text:(get()) ?width () in let callback _ = set entry#text; false in ignore (entry#event#connect#focus_out ~callback); ignore (entry#connect#activate ~callback:(fun () -> ignore (callback ()))); ignore (mk_label ?use_markup ~xalign:0. container (label ^ " (list)")); (fun () -> if not (Gobject.Property.get entry#as_widget GtkBase.Widget.P.has_focus) then entry#set_text (get())) let on_string_completion ?tooltip ?use_markup ?(validator=(fun _ -> true)) completions (container:GPack.box) label get set = let box = GPack.hbox ~packing:container#pack () in do_tooltip ?tooltip box; let entry = string_selector completions box#pack in ignore (mk_label ?use_markup ~xalign:0. box label); let () = entry#set_text (get()) in let callback _ = let text = entry#text in if validator text then set text else entry#set_text (get()); false in ignore (entry#event#connect#focus_out ~callback); ignore (entry#connect#activate ~callback:(fun () -> ignore (callback ()))); (fun () -> entry#set_text (get())) let on_combo values ?tooltip ?(use_markup=false) ?width (container:GPack.box) label get set = let rec select i (x:string) = function | [] -> (-1) | y::ys -> if x=y then i else select (succ i) x ys in let container = GPack.hbox ~packing:container#pack () in do_tooltip ?tooltip container; let non_fixed = width=None in let combo_box, (_model, column) = GEdit.combo_box_text ~strings:values ?width ~wrap_width:3 ~use_markup ~packing:(container#pack ~expand:non_fixed ~fill:non_fixed) () in let callback () = match combo_box#active_iter with | None -> () | Some row -> set (combo_box#model#get ~row ~column) in let update () = let result = ref (get ()) in let k = select 0 !result values in if k >= 0 then combo_box#set_active k in ignore (combo_box#connect#changed callback) ; ignore (mk_label ~use_markup ~xalign:0. container label) ; (fun () -> update ()) (* ------------------------------------------------------------------------ *) (* --- Misc --- *) (* ------------------------------------------------------------------------ *) let save_paned_ratio key (paned:GPack.paned) = let paned_min_pos = paned#min_position in let paned_max_pos = paned#max_position in let length = paned_max_pos - paned_min_pos in let ratio = if length = 0 then 0.5 else (float_of_int paned#position)/.(float_of_int length) in Configuration.set key (Configuration.ConfFloat ratio) let place_paned (paned:GPack.paned) factor = let paned_min_pos = paned#min_position in let offset = int_of_float (float (paned#max_position - paned_min_pos)*.factor) in paned#set_position (paned_min_pos + offset) let old_gtk_compat f x = try f x with Not_found -> () let trace_event (w:GObj.event_ops) = let string_of_event x = match GdkEvent.get_type x with | `NOTHING -> "nothing" | `DELETE -> "delete" | `DESTROY -> "destroy" | `EXPOSE -> "expose" | `MOTION_NOTIFY -> "motion-notify" | `BUTTON_PRESS -> "button-press" | `TWO_BUTTON_PRESS -> "2 button-press" | `THREE_BUTTON_PRESS -> "3 button-press" | `BUTTON_RELEASE -> "button-release" | `KEY_PRESS -> "key-press" | `KEY_RELEASE -> "key-release" | `ENTER_NOTIFY -> "enter-notfiy" | `LEAVE_NOTIFY -> "leave-notify" | `FOCUS_CHANGE -> "focus-change" | `CONFIGURE -> "configure" | `MAP -> "map" | `UNMAP -> "unmap" | `PROPERTY_NOTIFY -> "property-notify" | `SELECTION_CLEAR -> "selection-clear" | `SELECTION_REQUEST -> "selection-request" | `SELECTION_NOTIFY -> "selection-notify" | `PROXIMITY_IN -> "proximity-in" | `PROXIMITY_OUT -> "proximiy-out" | `DRAG_ENTER -> "drag-enter" | `DRAG_LEAVE -> "drag-leave" | `DRAG_MOTION -> "drag-motion" | `DRAG_STATUS -> "drag-status" | `DROP_START -> "drop-start" | `DROP_FINISHED -> "drop-finish" | `CLIENT_EVENT -> "client-event" | `VISIBILITY_NOTIFY -> "visibility-notify" | `NO_EXPOSE-> "no-expose" | `SCROLL -> "scroll" | `WINDOW_STATE -> "window-state" | `SETTING -> "setting" in ignore (w#connect#any ~callback:(fun e -> Format.eprintf "TRACING event: %s@." (string_of_event e); false)) module MAKE_CUSTOM_LIST(A:sig type t end) = struct type custom_list = {finfo: A.t; fidx: int (* invariant: root.(fidx)==myself *) } module H = Hashtbl let inbound i a = i>=0 && i None method custom_flags = [`LIST_ONLY] method custom_get_iter (path:Gtk.tree_path) : custom_list option = let indices: int array = GTree.Path.get_indices path in match indices with | [||] -> None | [|i|] -> self#find_opt i | _ -> failwith "Invalid Path of depth > 1 in a list" method custom_get_path (row:custom_list) : Gtk.tree_path = GTree.Path.create [row.fidx] method custom_value (_t:Gobject.g_type) (_row:custom_list) ~column:_ = assert false method custom_iter_next (row:custom_list) : custom_list option = let nidx = succ row.fidx in self#find_opt nidx method custom_iter_children (rowopt:custom_list option):custom_list option = match rowopt with | None -> self#find_opt 0 | Some _ -> None method custom_iter_has_child (_:custom_list) : bool = false method custom_iter_n_children (rowopt:custom_list option) : int = match rowopt with | None -> H.length roots | Some _ -> assert false method custom_iter_nth_child (rowopt:custom_list option) (n:int) : custom_list option = match rowopt with | None -> self#find_opt n | _ -> None method custom_iter_parent (_:custom_list) : custom_list option = None method insert (t:A.t) = let e = {finfo=t; fidx= last_idx } in self#custom_row_inserted (GTree.Path.create [last_idx]) e; H.add roots last_idx e; last_idx <- last_idx+1; method clear () = for i=last_idx-1 downto 0 do self#custom_row_deleted (GTree.Path.create [i]); done; last_idx <- 0; H.clear roots; end let custom_list () = new custom_list_class (new GTree.column_list) let make_view_column model renderer properties ~title = let m_renderer renderer (lmodel:GTree.model) iter = let (path:Gtk.tree_path) = lmodel#get_path iter in let props = match model#custom_get_iter path with | Some {finfo=v} -> properties v | None -> [] in renderer#set_properties props in let cview = GTree.view_column ~title ~renderer:(renderer,[]) () in cview#set_cell_data_func renderer (m_renderer renderer); cview end (* ************************************************************************** *) (** {2 Error manager} *) (* ************************************************************************** *) (** A utility class to catch exceptions and report proper error messages. *) class type host = object method error: 'a. ?parent:GWindow.window_skel -> ('a, Format.formatter, unit) format -> 'a method full_protect : 'a. cancelable:bool -> ?parent:GWindow.window_skel -> (unit -> 'a) -> 'a option method protect : cancelable:bool -> ?parent:GWindow.window_skel -> (unit -> unit) -> unit method private set_reset: (unit -> unit) -> unit end class error_manager ?reset (o_parent:GWindow.window_skel) : host = object (self: #host) val mutable reset = match reset with | None -> fun () -> () | Some f -> f method private set_reset f = reset <- f method private error_string ?parent message = let w = GWindow.message_dialog ~message ~message_type:`ERROR ~parent:(Extlib.opt_conv o_parent parent) ~buttons:GWindow.Buttons.ok ~title:"Error" ~position:`CENTER_ALWAYS ~modal:true () in w#show (); w#present (); ignore (w#run ()); w#destroy (); reset () method error ?parent fmt = let b = Buffer.create 80 in let bfmt = Format.formatter_of_buffer b in Format.kfprintf (function fmt -> Format.pp_print_flush fmt (); let content = Buffer.contents b in self#error_string ?parent content) bfmt fmt method private display_toplevel_error ?parent ~cancelable e = Cmdline.error_occured (); if cancelable then Project.Undo.restore (); self#error ?parent "%s" (Cmdline.protect e) method protect ~cancelable ?(parent:GWindow.window_skel option) f = ignore (self#full_protect ~cancelable ?parent f) method full_protect ~cancelable ?(parent:GWindow.window_skel option) f = let cancelable = cancelable && Gui_parameters.Undo.get () in try if cancelable then Project.Undo.breakpoint (); let old_gui_unlocked = !gui_unlocked in let res = Extlib.try_finally ~finally:(fun () -> if old_gui_unlocked then begin Unlock.apply (); gui_unlocked := true end) (fun () -> if old_gui_unlocked then begin Lock.apply cancelable; gui_unlocked := false; end; f ()) () in if cancelable then Project.Undo.clear_breakpoint (); Some res with | Cmdline.Exit -> if cancelable then Project.Undo.clear_breakpoint (); None | Sys.Break | Db.Cancel -> if cancelable then Project.Undo.restore (); self#error ?parent "Stopping current computation on user request."; None | Globals.No_such_entry_point msg -> (try Gui_parameters.abort "%s" msg with | Log.AbortError _ as e -> self#display_toplevel_error ?parent ~cancelable e; None | _ -> assert false) | e when Cmdline.catch_at_toplevel e -> self#display_toplevel_error ?parent ~cancelable e; None | e -> if Kernel.debug_atleast 1 then begin Cmdline.error_occured (); raise e end else begin self#display_toplevel_error ?parent ~cancelable e; None end end let make_text_page ?pos (notebook:GPack.notebook) title = let make_tab_label (notebook:GPack.notebook) = let flash_title = Format.sprintf "%s" title in let tab_label = GMisc.label ~markup:title () in let sw = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing: (fun w -> ignore (notebook#insert_page ?pos ~tab_label:tab_label#coerce w)) () in let flash b = tab_label#set_text (if b then flash_title else title); ignore(tab_label#set_use_markup true) in flash, sw in let flash,sw = make_tab_label notebook in let flash_ref = ref flash in let w = GText.view ~packing:sw#add () in let _ = w#set_editable false in let _ = w#misc#connect#map (fun () -> !flash_ref false) in let _ = w#event#connect#focus_in (fun _ -> !flash_ref false; false) in let _ = w#buffer#connect#changed (fun () -> !flash_ref true) in let reparent_page (notebook:GPack.notebook) = let flash, sw = make_tab_label notebook in flash_ref := flash; w#misc#reparent sw#coerce in reparent_page, w let refresh_gui () = while Glib.Main.iteration false do () done (* ************************************************************************* *) (** {2 Source File Chooser} *) (* ************************************************************************* *) class type source_files_chooser_host = object inherit host method main_window: GWindow.window_skel method reset: unit -> unit end let accepted_source_files () = let f = GFile.filter ~name:"Source files" () in List.iter (fun s -> f#add_pattern ("*" ^ s)) (File.get_suffixes ()); f let all_files () = let f = GFile.filter ~name:"All files" () in f#add_pattern "*.*"; f let source_files_chooser (main_ui: source_files_chooser_host) defaults f = let dialog = GWindow.dialog ~width:800 ~height:400 ~modal:true ~title:"Select C source files" ~parent:main_ui#main_window ~destroy_with_parent:true () in dialog#add_button_stock `CANCEL `CANCEL ; dialog#add_button_stock `OK `OPEN; let hbox = GPack.box `HORIZONTAL ~packing:dialog#vbox#add () in let filechooser = GFile.chooser_widget ~action:`OPEN ~packing:(hbox#pack ~expand:true ~fill:true) () in Configuration.use_string "last_opened_dir" (fun s -> ignore (filechooser#set_current_folder s)); filechooser#set_select_multiple true; filechooser#add_filter (accepted_source_files ()); filechooser#add_filter (all_files ()); let bbox = GPack.button_box ~layout:`START `VERTICAL ~packing:(hbox#pack ~expand:false ~fill:false) () in let add_button = GButton.button ~stock:`ADD ~packing:bbox#add () in let remove_button = GButton.button ~stock:`REMOVE ~packing:bbox#add () in let w = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(hbox#pack ~expand:true ~fill:true) () in let add,remove,get_all = make_string_list ~packing:w#add in let add_selected_files () = let f = filechooser#get_filenames in List.iter add f in List.iter add defaults; ignore (add_button#connect#pressed ~callback:add_selected_files); ignore (remove_button#connect#pressed ~callback:remove); ignore (filechooser#connect#file_activated ~callback:add_selected_files); (match dialog#run () with | `OPEN -> main_ui#protect ~cancelable:true ~parent:(dialog :> GWindow.window_skel) (fun () -> f (get_all ())) | `DELETE_EVENT | `CANCEL -> ()); Extlib.may (fun f -> Configuration.set "last_opened_dir" (Configuration.ConfString f)) filechooser#current_folder; dialog#destroy () let later f = let for_idle () = f () ; false in let prio = Glib.int_of_priority `LOW in ignore (Glib.Idle.add ~prio for_idle) let spawn_command ?(timeout=0) ?stdout ?stderr s args f = let check_result = Command.command_async s ?stdout ?stderr args in let has_timeout = timeout > 0 in let hang_on = float_of_int timeout in let starting_time = if has_timeout then Unix.time () else 0. in let for_idle () = match check_result () with | Command.Not_ready kill -> if has_timeout && Unix.time () -. starting_time >= hang_on then begin kill (); f (Unix.WSIGNALED Sys.sigalrm); false end else true | Command.Result p -> f p; false in let prio = Glib.int_of_priority `LOW in ignore (Glib.Idle.add ~prio for_idle) (* Simple custom model interfaces *) module Custom =struct type ('a,'b) column = ?title:string -> 'b list -> ('a -> 'b list) -> GTree.view_column let add_column view empty data ?title renderer render = begin let column = GTree.view_column ?title ~renderer:(renderer,[]) () in column#set_resizable true ; (* column#set_sizing `FIXED ; *) column#set_cell_data_func renderer (fun model iter -> let props = match data (model#get_path iter) with | None -> [] | Some e -> render e in renderer#set_properties props) ; view#append_column column ; begin match empty with | None -> () | Some e -> ignore (view#move_column e ~after:column) end ; column end class type virtual ['a] custom = object inherit ['a,'a,unit,unit] GTree.custom_tree_model method reload : unit end class type ['a] columns = object method view : GTree.view (** the tree *) method scroll : GBin.scrolled_window (** scrolled tree (build on demand) *) method coerce : GObj.widget (** widget of the scroll *) method pack : (GObj.widget -> unit) -> unit (** packs the scroll *) method reload : unit (** Structure has changed *) method update_all : unit (** (only) Content of rows has changed *) method update_row : 'a -> unit method insert_row : 'a -> unit method set_focus : 'a -> GTree.view_column -> unit method on_click : ('a -> GTree.view_column -> unit) -> unit method on_right_click : ('a -> GTree.view_column -> unit) -> unit method on_double_click : ('a -> GTree.view_column -> unit) -> unit method set_selection_mode : Gtk.Tags.selection_mode -> unit method on_selection : (unit -> unit) -> unit method count_selected : int method iter_selected : ('a -> unit) -> unit method is_selected : 'a -> bool method add_column_text : ('a,GTree.cell_properties_text) column method add_column_pixbuf : ('a,GTree.cell_properties_pixbuf) column method add_column_toggle : ('a,GTree.cell_properties_toggle) column method add_column_empty : unit end class ['a] makecolumns ?packing ?width ?height (view:GTree.view) (model : 'a #custom) = object(self) val mutable scroll = None initializer match packing with | Some packing -> self#pack packing | None -> () method scroll = match scroll with | None -> let s = GBin.scrolled_window ?width ?height () in s#add view#coerce ; scroll <- Some s ; s | Some s -> s method pack packing = packing self#scroll#coerce method view = view method coerce = self#scroll#coerce method update_all = GtkBase.Widget.queue_draw view#as_tree_view method update_row x = (*TODO : get the rectangle for raw and use queue_draw_area See : http://www.gtkforums.com/viewtopic.php?t=1716 Sadly this is not available in LablGtk2 yet...*) model#custom_row_changed (model#custom_get_path x) x method insert_row x = let path = model#custom_get_path x in model#custom_row_inserted path x method reload = begin (* Delete all nodes in view *) let root = GTree.Path.create [0] in model#foreach (fun _p _i -> (* Do not use p since the path is changed by the call to custom_row_deleted*) model#custom_row_deleted root; false) ; (* Then call model *) model#reload ; end method on_right_click f = let callback evt = let open GdkEvent in if Button.button evt = 3 then begin let x = int_of_float (Button.x evt) in let y = int_of_float (Button.y evt) in match view#get_path_at_pos ~x ~y with | Some (path,col,_,_) -> begin match model#custom_get_iter path with | None -> false | Some item -> let () = f item col in false end | _ -> false end else false in ignore (view#event#connect#button_release ~callback) method on_click f = let callback () = match view#get_cursor () with | Some path , Some col -> begin match model#custom_get_iter path with | None -> () | Some item -> f item col end | _ -> () in ignore (view#connect#cursor_changed ~callback) method on_double_click f = let callback path col = match model#custom_get_iter path with | None -> () | Some item -> f item col in ignore (view#connect#row_activated ~callback) method is_selected item = view#selection#path_is_selected (model#custom_get_path item) method on_selection f = ignore (view#selection#connect#changed ~callback:f) method set_selection_mode = view#selection#set_mode method count_selected = view#selection#count_selected_rows method iter_selected f = List.iter (fun p -> match model#custom_get_iter p with | None -> () | Some item -> f item) view#selection#get_selected_rows method set_focus item col = begin let path = model#custom_get_path item in view#scroll_to_cell path col ; view#selection#select_path path ; end val mutable empty : GTree.view_column option = None method add_column_text ?title props render = let cell = GTree.cell_renderer_text props in add_column view empty model#custom_get_iter ?title cell render method add_column_pixbuf ?title props render = let cell = GTree.cell_renderer_pixbuf props in add_column view empty model#custom_get_iter ?title cell render method add_column_toggle ?title props render = let cell = GTree.cell_renderer_toggle props in add_column view empty model#custom_get_iter ?title cell render method add_column_empty = let column = GTree.view_column ~title:"" () in empty <- Some column ; ignore (view#append_column column) end (* Helper for GTK Lists *) module List = struct class type ['a] model = object method reload : unit method size : int method index : 'a -> int method get : int -> 'a end class ['a] list_model (m : 'a model) = object method reload = m#reload inherit ['a,'a,unit,unit] GTree.custom_tree_model (new GTree.column_list) method custom_flags = [`LIST_ONLY] method custom_decode_iter a () () = a method custom_encode_iter a = (a,(),()) method custom_get_iter path = let idx:int array = GtkTree.TreePath.get_indices path in match idx with | [||] -> None | [|i|] -> (try let e = m#get i in Some e with Not_found -> None) | _ -> failwith "Invalid path of depth>1 in a list" method custom_get_path e = GtkTree.TreePath.create [m#index e] method custom_value (_:Gobject.g_type) (_:'a) ~column:_ = failwith "GwList: empty columns" method custom_iter_children e = match e with | None when (m#size > 0) -> Some(m#get 0) | _ -> None method custom_iter_has_child (_:'a) = false method custom_iter_n_children = function | Some _ -> failwith "GwList: no children" | None -> m#size method custom_iter_nth_child r k = match r with | Some _ -> failwith "GwList: no nth-child" | None -> if k < m#size then Some (m#get k) else None method custom_iter_parent (_:'a) = None method custom_iter_next e = let r = try let k = succ (m#index e) in if k < m#size then Some (m#get k) else None with Not_found -> None in r end class ['a] view ?packing ?width ?height ?(headers=true) ?(rules=true) (m : 'a model) = let model = new list_model m in let view = GTree.view ~model ~headers_visible:headers ~rules_hint:rules ~show:true () in object inherit ['a] makecolumns ?packing ?width ?height view model end end module Tree=struct class type ['a] model = object method reload : unit method has_child : 'a -> bool method children : 'a option -> int method child_at : 'a option -> int -> 'a method parent : 'a -> 'a option method index : 'a -> int end let rec get_iter m r idx k = if k >= Array.length idx then r else let a = m#child_at r idx.(k) in get_iter m (Some a) idx (succ k) let rec get_path ks m a = let ks = m#index a :: ks in match m#parent a with | None -> ks | Some b -> get_path ks m b class ['a] tree_model (m : 'a model) = object method reload = m#reload inherit ['a,'a,unit,unit] GTree.custom_tree_model (new GTree.column_list) method custom_decode_iter a () () = a method custom_encode_iter a = (a,(),()) method custom_get_iter path = let idx = GtkTree.TreePath.get_indices path in if Array.length idx = 0 then None else let a = m#child_at None idx.(0) in get_iter m (Some a) idx 1 method custom_get_path e = let ks = get_path [] m e in GtkTree.TreePath.create ks method custom_value (_:Gobject.g_type) (_:'a) ~column:(_:int) : Gobject.basic = Format.eprintf "Value ?@." ; assert false method custom_iter_children r = let node = match r with None -> true | Some f -> m#has_child f in if node && m#children r > 0 then Some (m#child_at r 0) else None method custom_iter_has_child r = m#has_child r && m#children (Some r) > 0 method custom_iter_n_children = m#children method custom_iter_nth_child r k = if k < m#children r then Some (m#child_at r k) else None method custom_iter_parent r = m#parent r method custom_iter_next e = let p = m#parent e in let k = succ (m#index e) in if k < m#children p then Some (m#child_at p k) else None end class ['a] view ?packing ?width ?height ?(headers=true) ?(rules=true) (m : 'a model) = let model = new tree_model m in let view = GTree.view ~model ~headers_visible:headers ~rules_hint:rules ~show:true () in object inherit ['a] makecolumns ?packing ?width ?height view model end end end let graph_window ~parent ~title make_view = let height = int_of_float (float parent#default_height *. 3. /. 4.) in let width = int_of_float (float parent#default_width *. 3. /. 4.) in let graph_window = GWindow.window ~width ~height ~title ~allow_shrink:true ~allow_grow:true ~position:`CENTER () in let view = make_view ~packing:graph_window#add () in graph_window#show(); view#adapt_zoom(); () ;; let graph_window_through_dot ~parent ~title dot_formatter = let make_view ~packing () = let temp_file = try Extlib.temp_file_cleanup_at_exit "framac_property_status_navigator_graph" "dot" with Extlib.Temp_file_error s -> Gui_parameters.abort "cannot create temporary file: %s" s in let fmt = Format.formatter_of_out_channel (open_out temp_file) in dot_formatter fmt; Format.pp_print_flush fmt (); let view = snd (Dgraph.DGraphContainer.Dot.from_dot_with_commands ~packing temp_file) in view in try graph_window ~parent ~title make_view with Dgraph.DGraphModel.DotError _ as exn -> Gui_parameters.error "@[cannot display dot graph:@ %s@]" (Printexc.to_string exn) ;; (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/project_manager.mli0000644000175000017500000000336112155630233021216 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 exported. Extension of the GUI in order to support project switching. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/launcher.ml0000644000175000017500000002544512155630233017515 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Gtk_helper module Kernel_hook = Hook.Make(struct end) class type basic_main = object inherit host method main_window: GWindow.window method reset: unit -> unit end let run (host:basic_main) dialog () = ignore (host#protect ~cancelable:true ~parent:(dialog :> GWindow.window_skel) (fun () -> dialog#destroy (); Kernel_hook.apply (); !Db.Main.play ())); (* Even if the above operation failed, we try to reset the gui, as the plugins might have done something before crashing *) ignore (host#protect ~cancelable:false ~parent:(dialog :> GWindow.window_skel) host#reset); Kernel_hook.clear () let add_parameter (box:GPack.box) p = let name = p.Parameter.name in let tooltip = p.Parameter.help in let is_set = p.Parameter.is_set in let use_markup = is_set () in let highlight s = "" ^ s ^ "" in let hname = highlight name in (match p.Parameter.accessor with | Parameter.Bool ({ Parameter.get = get; set = set }, None) -> let name = if use_markup then hname else name in (* fix bts#510: a parameter [p] must be set if and only if it is set by the user in the launcher. In particular, it must not be reset to its old value if setting another parameter [p'] modifies [p] via hooking. *) let old = get () in let set r = if r <> old then set r in Kernel_hook.extend (on_bool ~tooltip ~use_markup box name get set); | Parameter.Bool ({ Parameter.get = get; set = set }, Some negative_name) -> let use_markup = is_set () in let name, _negative_name = if use_markup then hname, highlight negative_name else name, negative_name in let old = get () in let set r = if r <> old then set r in Kernel_hook.extend (on_bool ~tooltip ~use_markup box name (*negative_name*) get set); | Parameter.Int ({ Parameter.get = get; set = set }, range) -> let use_markup = is_set () in let name = if use_markup then hname else name in let lower, upper = range () in let old = get () in let set r = if r <> old then set r in Kernel_hook.extend (on_int ~tooltip ~use_markup ~lower ~upper ~width:120 box name get set); | Parameter.String({ Parameter.get = get; set = set }, possible_values) -> let use_markup = is_set () in let hname = if use_markup then hname else name in let old = get () in let widget_value = ref old in let w_set r = widget_value := r in let w_get () = !widget_value in (match possible_values () with | [] -> let _refresh = on_string ~tooltip ~use_markup ~width:250 box hname w_get w_set in Kernel_hook.extend (fun () -> if !widget_value <> old then set !widget_value) | v -> let validator s = let b = List.mem s v in if not b then Gui_parameters.error "invalid input `%s' for %s" s name; b in let _refresh = on_string_completion ~tooltip ~use_markup ~validator v box hname w_get w_set in Kernel_hook.extend (fun () -> if !widget_value <> old then set !widget_value)) | Parameter.String_set { Parameter.get = get; set = set } | Parameter.String_list { Parameter.get = get; set = set } -> let use_markup = is_set () in let name = if use_markup then hname else name in let old = get () in let widget_value = ref old in let w_set r = widget_value := r in let w_get () = !widget_value in let _refresh = on_string_set ~tooltip ~use_markup ~width:400 box name w_get w_set in Kernel_hook.extend (fun () -> if !widget_value <> old then set !widget_value) ); use_markup let mk_text ~highlight text = let markup = if highlight then Format.sprintf "%s" text else text in let label = GMisc.label ~markup () in label#coerce let set_expander_text exp s ~tooltip highlight = let text = mk_text ~highlight s in Gtk_helper.do_tooltip ?tooltip text; exp#set_label_widget text; exp#set_expanded highlight let add_group (box:GPack.box) label options = let box, set_expander_text = if label = "" then box, fun _ -> () else let expander = GBin.expander ~packing:box#pack () in let frame = GBin.frame ~border_width:5 ~packing:expander#add () in GPack.vbox ~packing:frame#add (), set_expander_text expander ~tooltip:None label in let highlight = List.fold_right (fun p b -> let is_set = add_parameter box p in b || is_set) options false in set_expander_text highlight; highlight let box_plugin p = let frame = GBin.frame ~border_width:5 () in let vbox = GPack.vbox ~packing:frame#add () in let markup = "" ^ String.capitalize p.Plugin.p_help ^ "" in ignore (GMisc.label ~markup ~packing:(vbox#pack ~padding:15) ()); let sorted_groups = List.sort (fun (s1, _) (s2, _) -> String.compare s1 s2) (Hashtbl.fold (fun l g acc -> if g = [] then acc else (String.capitalize l, g) :: acc) p.Plugin.p_parameters []) in let highlight = List.fold_left (fun b (l, g) -> let is_set = add_group vbox l g in b || is_set) false sorted_groups in frame, highlight (* Sort plugins, kernel first *) let compare_plugin_name n1 n2 = if n1 = "Kernel" then if n2 = "Kernel" then 0 else -1 else if n2 = "Kernel" then 1 else String.compare n1 n2 (* -------------------------------------------------------------------------- *) (* --- --- *) (* -------------------------------------------------------------------------- *) type plugin_options = string (* plugin name *) * bool (* highlighted *) * GBin.frame let listview_plugins ~(packing:?from:Gtk.Tags.pack_type -> ?expand:bool -> ?fill:bool -> ?padding:int -> GObj.widget -> unit) plugins = let module Data = Indexer.Make( struct type t = plugin_options let compare (x,_,_) (y,_,_) = compare_plugin_name x y end) in let model = object(self) val mutable m = Data.empty method data = m method size = Data.size m method index i = Data.index i m method get i = Data.get i m method add i = m <- Data.add i m; i method reload = m <- Data.empty method coerce = (self:> plugin_options Gtk_helper.Custom.List.model) end in let scrolling_list_plugins = GBin.scrolled_window ~packing:(packing ~expand:false ~padding:5) ~vpolicy:`AUTOMATIC ~hpolicy:`NEVER () in let w = new Gtk_helper.Custom.List.view ~headers:false model#coerce in scrolling_list_plugins#add_with_viewport (w#view :> GObj.widget); let box = GPack.vbox () in let scrolling_right = GBin.scrolled_window ~packing:(packing ~expand:true ~padding:5) ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC () in scrolling_right#add_with_viewport (box :> GObj.widget); let append e = w#insert_row (model#add e) in let _ = w#add_column_text (*~title:"Plugins"*) [`YALIGN 0.0] (fun (name, highlight, _expander) -> let bold = [`FOREGROUND (if highlight then "blue" else "black")] in `TEXT name :: bold ) in w#on_click (fun (_, _, expander) _col -> List.iter box#remove (box#all_children); box#pack (expander :> GObj.widget)); (* scrolling#add_with_viewport (hbox :> GObj.widget); *) List.iter (fun (pname, p) -> let frame, highlight = box_plugin p in append (pname, highlight, frame); ) plugins; (w#view#get_column 0)#set_sizing `AUTOSIZE (* -------------------------------------------------------------------------- *) (* --- --- *) (* -------------------------------------------------------------------------- *) let show ?height ?width ~(host:basic_main) () = let dialog = GWindow.dialog ~title:"Launching analysis" ~modal:true ~position:`CENTER_ON_PARENT ~allow_shrink:true ?width ?height ~parent:host#main_window ~allow_grow:true () in ignore (dialog#misc#connect#size_allocate (fun ({Gtk.width=w;Gtk.height=h}) -> Configuration.set "launcher_width" (Configuration.ConfInt w); Configuration.set "launcher_height" (Configuration.ConfInt h))); ignore (GMisc.label ~text:"Customize parameters, then click on `Execute'" ~packing:(dialog#vbox#pack ~padding:10) ()); let hbox = GPack.hbox ~packing:(dialog#vbox#pack ~fill:true ~expand:true) () in (* Action buttons *) let buttons = GPack.button_box `HORIZONTAL ~layout:`END ~packing:dialog#action_area#pack () in let cancel = GButton.button ~label:"Cancel" ~stock:`CANCEL ~packing:buttons#pack () in ignore (cancel#connect#released dialog#destroy); let button_run = GButton.button ~label:"Configure analysis" ~stock:`EXECUTE ~packing:buttons#pack () in ignore (button_run#connect#released (run host dialog)); let plugins = ref [] in Plugin.iter_on_plugins (fun p -> plugins := (String.capitalize p.Plugin.p_name, p) :: !plugins); plugins := List.sort (fun (n1, _) (n2, _) -> compare_plugin_name n1 n2)!plugins; listview_plugins ~packing:hbox#pack !plugins; dialog#show () (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/history.mli0000644000175000017500000000613312155630233017557 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** {1 Source code navigation history.} @since Nitrogen-20111001 *) type history_elt = | Global of Cil_types.global | Localizable of Pretty_source.localizable val is_empty: unit -> bool (** Does the history contain an event. *) val can_go_back: unit -> bool (** Are there past events in the history. *) val can_go_forward: unit -> bool (** Are there events to redo in the history. *) val back: unit -> unit (** If possible, go back one step in the history. *) val forward: unit -> unit (** If possible (ie. if [back] has been called), go forward one step in the history. *) val push: history_elt -> unit (** Add the element to the current history; clears the forward history, and push the old current element to the past history. *) val show_current: unit -> unit (** Redisplay the current history point, if available. Useful to refresh the gui. *) val on_current_history: unit -> ((unit -> unit) -> unit) (** [on_current_history ()] returns a closure [at] such that [at f] will execute [f] in a context in which the history will be the one relevant when [on_current_history] was executed. *) val apply_on_selected: (Pretty_source.localizable -> unit) -> unit (** [apply_on_selected f] applies [f] to the currently selected [Pretty_source.localizable]. Does nothing if nothing is selected. *) (**/**) val set_display_elt_callback: (history_elt -> unit) -> unit val create_buttons: Menu_manager.menu_manager -> Menu_manager.item array (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/file_manager.ml0000644000175000017500000001403412155630233020315 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let add_files (host_window: Design.main_window_extension_points) = Gtk_helper.source_files_chooser (host_window :> Gtk_helper.source_files_chooser_host) (Kernel.Files.get ()) (fun filenames -> Kernel.Files.set filenames; if Ast.is_computed () then Gui_parameters.warning "Input files unchanged. Ignored." else begin File.init_from_cmdline (); host_window#reset () end) let filename: string option ref = ref None (* [None] for opening the 'save as' dialog box; [Some f] for saving in file [f] *) let reparse (host_window: Design.main_window_extension_points) = host_window#protect ~cancelable:true (fun () -> let files = Kernel.Files.get () in Kernel.Files.set []; Kernel.Files.set files; Ast.compute (); !Db.Main.play (); Source_manager.clear host_window#original_source_viewer); host_window#reset () let save_in (host_window: Design.main_window_extension_points) parent name = try Project.save_all name; filename := Some name with Project.IOError s -> host_window#error ~parent "Cannot save: %s" s (** Save a project file. Choose a filename *) let save_file_as (host_window: Design.main_window_extension_points) = let dialog = GWindow.file_chooser_dialog ~action:`SAVE ~title:"Save the current session" ~parent:host_window#main_window () in (*dialog#set_do_overwrite_confirmation true ; only in later lablgtk2 *) dialog#add_button_stock `CANCEL `CANCEL ; dialog#add_select_button_stock `SAVE `SAVE ; host_window#protect ~cancelable:true ~parent:(dialog :> GWindow.window_skel) (fun () -> match dialog#run () with | `SAVE -> Extlib.may (save_in host_window (dialog :> GWindow.window_skel)) dialog#filename | `DELETE_EVENT | `CANCEL -> ()); dialog#destroy () let save_file (host_window: Design.main_window_extension_points) = match !filename with | None -> save_file_as host_window | Some f -> save_in host_window (host_window#main_window :> GWindow.window_skel) f (** Load a project file *) let load_file (host_window: Design.main_window_extension_points) = let dialog = GWindow.file_chooser_dialog ~action:`OPEN ~title:"Load a saved session" ~parent:host_window#main_window () in dialog#add_button_stock `CANCEL `CANCEL ; dialog#add_select_button_stock `OPEN `OPEN ; host_window#protect ~cancelable:true ~parent:(dialog:>GWindow.window_skel) (fun () -> match dialog#run () with | `OPEN -> begin match dialog#filename with | None -> () | Some f -> Project.load_all f end | `DELETE_EVENT | `CANCEL -> ()); dialog#destroy () let insert (host_window: Design.main_window_extension_points) = let menu_manager = host_window#menu_manager () in let _, filemenu = menu_manager#add_menu "_File" in let file_items = menu_manager#add_entries filemenu [ Menu_manager.toolmenubar ~icon:`FILE ~label:"Source files" ~tooltip:"Create a new session from existing C files" (Menu_manager.Unit_callback (fun () -> add_files host_window)); Menu_manager.toolmenubar ~icon:`REFRESH ~label:"Reparse" ~tooltip:"Reparse source files, and replay analyses" (Menu_manager.Unit_callback (fun () -> reparse host_window)); Menu_manager.toolmenubar `REVERT_TO_SAVED "Load session" (Menu_manager.Unit_callback (fun () -> load_file host_window)); Menu_manager.toolmenubar `SAVE "Save session" (Menu_manager.Unit_callback (fun () -> save_file host_window)); Menu_manager.menubar ~icon:`SAVE_AS "Save session as" (Menu_manager.Unit_callback (fun () -> save_file_as host_window)); ] in file_items.(3)#add_accelerator `CONTROL 's'; file_items.(2)#add_accelerator `CONTROL 'l'; let stock = `QUIT in let quit_item = menu_manager#add_entries filemenu [ Menu_manager.menubar ~icon:stock "Exit Frama-C" (Menu_manager.Unit_callback Cmdline.bail_out) ] in quit_item.(0)#add_accelerator `CONTROL 'q'; ignore (menu_manager#add_entries filemenu ~pos:0 [ Menu_manager.toolbar ~icon:stock ~label:"Exit" ~tooltip:"Exit Frama-C" (Menu_manager.Unit_callback Cmdline.bail_out)]) (** Register this dialog in main window menu bar *) let () = Design.register_extension insert (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/launcher.mli0000644000175000017500000000413712155630233017661 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** The Frama-C launcher. That is the dialog box for configuring and running Frama-C with new parameter values. *) (** Subtype of {!Design.main_window_extension_points} which is required to show the launcher. *) class type basic_main = object inherit Gtk_helper.host method main_window: GWindow.window method reset: unit -> unit end val show: ?height:int -> ?width:int -> host:basic_main -> unit -> unit (** Display the Frama-C launcher. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/debug_manager.ml0000644000175000017500000000652312155630233020470 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* Require Dgraph included in Ocamlgraph, thus GnomeCanvas *) open Dgraph let graph_view ~packing mk_dot = let f = try Extlib.temp_file_cleanup_at_exit "framac_graph_view" "dot" with Extlib.Temp_file_error s -> Gui_parameters.abort "cannot create temporary file: %s" s in mk_dot f; snd (DGraphContainer.Dot.from_dot_with_commands ~status:DGraphContainer.Global ~packing f) let state_dependency_graph ~packing () = graph_view ~packing State_dependency_graph.dump (* [JS 2011/07/05] to be reimplemented *) let status_dependency_graph ~packing:_ () = assert false (* let g = Properties_status.Consolidation_tree.get_full_graph () in graph_view ~packing (Properties_status.Consolidation_tree.dump g)*) let graph_window main_window title mk_view = let height = int_of_float (float main_window#default_height *. 3. /. 4.) in let width = int_of_float (float main_window#default_width *. 3. /. 4.) in let window = GWindow.window ~width ~height ~title ~allow_shrink:true ~allow_grow:true ~position:`CENTER () in let view = mk_view ~packing:window#add () in window#show (); view#adapt_zoom () open Menu_manager let () = Design.register_extension (fun window -> let mk_graph = graph_window window#main_window in ignore ((window#menu_manager ())#add_debug ~show:(fun () -> Kernel.debug_atleast 1) [ (let s = "State Dependency Graph" in menubar s (Unit_callback (fun () -> mk_graph s state_dependency_graph))); (let s = "Status Graph" in menubar s (Unit_callback (fun () -> mk_graph s status_dependency_graph))) ])) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/project_manager.ml0000644000175000017500000002403712155630233021050 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let compare_prj (_p1, n1) (_p2, n2) = String.compare n1 n2 let projects_list () = let projects = Project.fold_on_projects (fun acc p -> (p, Project.get_unique_name p) :: acc) [] in List.sort compare_prj projects (* use the same order than the projects list. is not possible with an hashtbl. So we use a reference over a set of couple *) module PrjRadiosSet = Set.Make (struct type t = (Project.t * string) * GMenu.radio_menu_item let compare (p1, _) (p2, _) = compare_prj p1 p2 end) let project_radios : PrjRadiosSet.t ref = ref PrjRadiosSet.empty (** Create a new project *) let new_project main_ui = Gtk_helper.source_files_chooser (main_ui :> Gtk_helper.source_files_chooser_host) [] (fun filenames -> let project = Project.create "interactive" in let init () = Kernel.Files.set filenames; File.init_from_cmdline () in Project.on project init (); Project.set_current project) let delete_project project = let name = Project.get_unique_name project in let ok = GToolbox.question_box ~title:(Format.sprintf "Deleting project %S" name) ~buttons:[ "Confirm"; "Cancel" ] (Format.sprintf "Do you want to destroy project %S?" name) in if ok = 1 then begin (try Project.remove ~project () with Project.Cannot_remove _ -> let p = Project.create "default" in Project.on p File.init_from_cmdline (); try Project.remove () with Project.Cannot_remove _ -> assert false) end module Filenames = Hashtbl.Make(Project) let filenames : string Filenames.t = Filenames.create 7 let save_in (host_window: Design.main_window_extension_points) parent project name = try Project.save ~project name; Filenames.replace filenames project name with Project.IOError s -> host_window#error ~parent "Cannot save: %s" s let save_project_as (main_ui: Design.main_window_extension_points) project = let dialog = GWindow.file_chooser_dialog ~action:`SAVE ~title:("Save project " ^ Project.get_unique_name project) ~parent:main_ui#main_window () in (*dialog#set_do_overwrite_confirmation true ; only in later lablgtk2 *) dialog#add_button_stock `CANCEL `CANCEL ; dialog#add_select_button_stock `SAVE `SAVE ; main_ui#protect ~cancelable:true ~parent:(dialog :> GWindow.window_skel) (fun () -> match dialog#run () with | `SAVE -> Extlib.may (save_in main_ui (dialog :> GWindow.window_skel) project) dialog#filename | `DELETE_EVENT | `CANCEL -> ()); dialog#destroy () let save_project (host_window: Design.main_window_extension_points) project = try save_in host_window (host_window#main_window :> GWindow.window_skel) project (Filenames.find filenames project) with Not_found -> save_project_as host_window project let load_project (host_window: Design.main_window_extension_points) = let dialog = GWindow.file_chooser_dialog ~action:`OPEN ~title:"Load a saved project" ~parent:host_window#main_window () in dialog#add_button_stock `CANCEL `CANCEL ; dialog#add_select_button_stock `OPEN `OPEN ; host_window#protect ~cancelable:true ~parent:(dialog:>GWindow.window_skel) (fun () -> match dialog#run () with | `OPEN -> begin match dialog#filename with | None -> () | Some f -> (try ignore (Project.load f) with Project.IOError s | Failure s -> host_window#error ~parent:(dialog:>GWindow.window_skel) "Cannot load: %s" s) end | `DELETE_EVENT | `CANCEL -> ()); dialog#destroy () let rename_project (main_ui: Design.main_window_extension_points) project = let old = Project.get_unique_name project in let s = GToolbox.input_string ~title:"Renaming project" (Format.sprintf "New name for project %S:" old) in match s with | None -> () | Some s -> try ignore (Project.from_unique_name s); main_ui#error "Project of name %S already exists" s with Not_found -> Project.set_name project s let reset (menu: GMenu.menu) = (* Do not reset all if there is no change. *) let pl = projects_list () in let same_projects = (* use that project_radios and pl are sorted in the same way *) try let rest = PrjRadiosSet.fold (fun (p1, _) acc -> match acc with | [] -> raise Exit | p2 :: acc -> if compare_prj p1 p2 = 0 then acc else raise Exit) !project_radios pl in rest = [] with Exit -> false in if same_projects then begin (* update the item status according to the current project anyway *) PrjRadiosSet.iter (fun ((p, _), r) -> r#set_active (Project.is_current p)) !project_radios; false end else begin PrjRadiosSet.iter (fun (_, r) -> menu#remove (r :> GMenu.menu_item)) !project_radios; project_radios := PrjRadiosSet.empty; true end let rec duplicate_project window menu project = let new_p = Project.create_by_copy ~src:project (Project.get_name project) in try (* update the menu *) let group = let _, i = PrjRadiosSet.choose !project_radios in i#group in ignore (mk_project_entry window menu ~group new_p) with Not_found -> (* menu not built (action called from the toolbar) *) () and mk_project_entry window menu ?group p = let p_item = GMenu.radio_menu_item ?group ~active:(Project.is_current p) ~packing:menu#append () in let callback () = if p_item#active then Project.set_current p in let pname = Project.get_unique_name p in ignore (p_item#connect#toggled ~callback); project_radios := PrjRadiosSet.add ((p, pname), p_item) !project_radios; let box = GPack.hbox ~packing:p_item#add () in ignore (GMisc.label ~text:pname ~packing:box#pack ()); let buttons_box = GPack.hbox ~packing:(box#pack ~from:`END) () in let tooltips = GData.tooltips () in let add_action stock text callback = let item = GButton.button ~packing:buttons_box#pack () in tooltips#set_tip item#coerce ~text; item#set_relief `NONE; let image = GMisc.image ~stock () in item#set_image image#coerce; image#set_icon_size `MENU; ignore (item#connect#clicked ~callback) in add_action `COPY "Duplicate project" (fun () -> duplicate_project window menu p); add_action `DELETE "Delete project" (fun () -> delete_project p); add_action `SAVE "Save project" (fun () -> save_project window p); add_action `SAVE_AS "Save project as" (fun () -> save_project_as window p); add_action `SELECT_FONT "Rename project" (fun () -> rename_project window p); p_item let make_project_entries window menu = match projects_list () with | [] -> assert false | (pa, _name) :: tl -> let mk = mk_project_entry window menu in let pa_item = mk pa in let group = pa_item#group in List.iter (fun (pa, _) -> ignore (mk ~group pa)) tl open Menu_manager (** Register this dialog in main window menu bar *) let () = Design.register_extension (fun window -> let menu_manager = window#menu_manager () in let item, menu = menu_manager#add_menu "_Project" in let constant_items = menu_manager#add_entries menu [ menubar ~icon:`NEW "New project" (Unit_callback (fun () -> new_project window)); menubar ~icon:`REVERT_TO_SAVED "Load project" (Unit_callback (fun () -> load_project window)); menubar ~icon:`COPY "Duplicate current project" (Unit_callback (fun () -> duplicate_project window menu(Project.current()))); menubar ~icon:`DELETE "Delete current project" (Unit_callback (fun () -> delete_project (Project.current ()))); menubar ~icon:`SELECT_FONT "Rename current project" (Unit_callback (fun () -> rename_project window (Project.current ()))); ] in let new_item = constant_items.(0) in new_item#add_accelerator `CONTROL 'n'; constant_items.(3)#add_accelerator `CONTROL 'd'; ignore (GMenu.separator_item ~packing:menu#append ()); let callback () = let is_reset = reset menu in if is_reset then make_project_entries window menu in ignore (item#connect#activate ~callback)) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/gui_parameters.mli0000644000175000017500000000335212155630233021065 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** GUI as a plug-in. *) include Plugin.S module Undo: Plugin.Bool (** Option -undo. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/file_manager.mli0000644000175000017500000000331212155630233020463 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Nothing exported. Automatic registration. *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/design.ml0000644000175000017500000013454412155630233017166 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Main GUI skeleton *) open Cil_types open Cil_datatype open Cil open Pretty_source open Gtk_helper let use_external_viewer = false let apply_on_selected = Gui_parameters.deprecated "Design.apply_on_selected" ~now:"History.apply_on_selected" History.apply_on_selected class type reactive_buffer = object inherit error_manager method buffer : GSourceView2.source_buffer method locs : Pretty_source.Locs.state option method rehighlight: unit method redisplay: unit end class type view_code = object method scroll : Pretty_source.localizable -> unit method view_stmt : stmt -> unit method view_original_stmt : stmt -> location method view_original : location -> unit method display_globals : global list -> unit method select_or_display_global : global -> unit end class type main_window_extension_points = object inherit Launcher.basic_main inherit view_code method toplevel : main_window_extension_points method menu_manager: unit -> Menu_manager.menu_manager method file_tree : Filetree.t method file_tree_view : GTree.view method annot_window : GText.view method pretty_information: 'a. ('a, Format.formatter, unit) format -> 'a (** Pretty print a message in the [annot_window]. *) method launcher : unit -> unit method source_viewer : GSourceView2.source_view method display_globals : global list -> unit method register_source_selector : (GMenu.menu GMenu.factory -> main_window_extension_points -> button:int -> Pretty_source.localizable -> unit) -> unit method register_source_highlighter : (GSourceView2.source_buffer -> localizable -> start:int -> stop:int -> unit) -> unit method register_panel : (main_window_extension_points -> (string * GObj.widget *(unit-> unit) option)) -> unit method rehighlight : unit -> unit method redisplay : unit -> unit method reactive_buffer: reactive_buffer option method original_source_viewer : Source_manager.t method reset : unit -> unit method error : 'a. ?parent:GWindow.window_skel -> ('a, Format.formatter, unit) format -> 'a method push_info : 'a. ('a, Format.formatter, unit) format -> 'a method pop_info : unit -> unit method help_message : 'a 'b. ( as 'a) -> ('b, Format.formatter, unit) format -> 'b method lower_notebook : GPack.notebook end (** The list of registered extension *) let (handlers:(main_window_extension_points -> unit) list ref) = ref [] (** Insert an extension *) let register_extension f = handlers := f::!handlers (** Apply all extensions *) let process_extensions window = List.iter (fun f -> f window) (List.rev !handlers) (** The list of reset extensions. Such extensions are used for example when the current project is changed. *) let (reset_handlers:(main_window_extension_points -> unit) list ref) = ref [] (** Insert a reset extension *) let register_reset_extension f = reset_handlers := f::!reset_handlers (** Apply all reset extensions *) let reset_extensions window = List.iter (fun f -> f window) (List.rev !reset_handlers) (** Memoization of displayed globals *) module Globals_GUI = struct include Hashtbl.Make (struct type t = global list let equal x y = try List.for_all2 (==) x y with Invalid_argument _ -> false let hash = Hashtbl.hash end) let tbl = create 17 let find k = let r = find tbl k in r#rehighlight; r let add k = add tbl k let clear () = clear tbl end let filetree_selector (main_ui:main_window_extension_points) ~was_activated ~activating globals = (*Format.printf "filetree selector:%b@." (not was_activated && activating);*) if not was_activated && activating then begin let source = main_ui#source_viewer in (match globals with | Filetree.File (f, l) -> Source_manager.load_file main_ui#original_source_viewer ~filename:f ~line:1 () ; main_ui#display_globals l | Filetree.Global g -> main_ui#display_globals [g] ); source#scroll_to_mark ~use_align:true ~xalign:0. ~yalign:0.5 `INSERT; let print_one_global prefix (v,loc) = main_ui#protect ~cancelable:false (fun () -> main_ui#view_original loc; main_ui#pretty_information "%s '%s'@." prefix v.vname) in main_ui#annot_window#buffer#set_text ""; begin match globals with | Filetree.Global g -> begin History.push (History.Global g); match g with | GFun ({svar=v},loc) -> print_one_global "Function" (v,loc) | GVar (v,_,loc) -> print_one_global "Variable" (v,loc) | GVarDecl (_, v, loc) -> if Cil.isFunctionType v.vtype then print_one_global "Declared function" (v,loc) else print_one_global "Variable" (v,loc) | _ -> () (* cannot currently happen, we do not display the other globals in the filetree *) end | Filetree.File (f, globals) -> let first_global = ref None in let (gfun,gtype,gcomp,genum,gvardecl,gvar) = List.fold_right (fun g (gfun,gtype,gcomp,genum,gvardecl,gvar) -> match g with | GFun ({svar=v},loc) -> (match !first_global with | None -> first_global:=Some (v,loc) | Some _ -> ()); (g::gfun,gtype,gcomp,genum,gvardecl,gvar) | GType _ -> (gfun,g::gtype,gcomp,genum,gvardecl,gvar) | GCompTagDecl _ -> (gfun,gtype,g::gcomp,genum,gvardecl,gvar) | GEnumTagDecl _ -> (gfun,gtype,gcomp,g::genum,gvardecl,gvar) | GVarDecl _ -> (gfun,gtype,gcomp,genum,g::gvardecl,gvar) | GVar _ -> (gfun,gtype,gcomp,genum,gvardecl,g::gvar) | _ -> (gfun,gtype,gcomp,genum,gvardecl,gvar)) globals ([],[],[],[],[],[]) in main_ui#pretty_information "@[File %s@]@." f; let printing (head:string) (f:Format.formatter -> 'a -> unit) (l:'a list) = if l <> [] then main_ui#pretty_information "@[%s @[%a@]@]@." head (Pretty_utils.pp_list ~sep:",@ " f) l in printing "Functions:" (fun fmt -> (function GFun ({svar=v},_) -> Varinfo.pretty_vname fmt v | _ -> assert false)) gfun; printing "Types:" (function fmt -> (function (GType ({tname=name},_)) -> Format.pp_print_string fmt name | _ -> assert false)) gtype; printing "Composite types:" (function fmt -> (function GCompTagDecl ({cname=name},_) |GCompTag ({cname=name},_)-> Format.pp_print_string fmt name | _ -> assert false)) gcomp; printing "Enums:" (function fmt -> (function GEnumTagDecl ({ename=name},_) | GEnumTag ({ename=name},_)-> Format.pp_print_string fmt name |_ -> assert false)) genum; printing "Declared variables:" (function fmt -> (function GVarDecl (_,v,_) -> Varinfo.pretty_vname fmt v | _ -> assert false)) gvardecl; printing "Variables:" (fun fmt -> (function GVar(v,_,_) -> Varinfo.pretty_vname fmt v | _ -> assert false)) gvar; end end let pretty_predicate_status fmt p = let s = Property_status.get p in Format.fprintf fmt "Status: %a@." Property_status.pretty s let to_do_on_select (menu_factory:GMenu.menu GMenu.factory) (main_ui:main_window_extension_points) ~button selected = let current_statement_msg ?loc kf stmt = main_ui#pretty_information "Function: %t@." (fun fmt -> match kf with | None -> Format.pp_print_string fmt "" | Some kf -> Kernel_function.pretty fmt kf); match stmt with | Kglobal -> () | Kstmt ki -> let loc = match loc with | None -> main_ui#view_original_stmt ki | Some loc -> main_ui#view_original loc; loc in let skind = if Gui_parameters.debug_atleast 1 then match ki with | {skind=Block _} -> "Block " | {skind=Instr (Skip _)} -> "Skip " | _ -> "" else "" in main_ui#pretty_information "%sStatement: %d (line %d in %s)@." skind ki.sid (fst loc).Lexing.pos_lnum (fst loc).Lexing.pos_fname in History.push (History.Localizable selected); let annot = main_ui#annot_window#buffer in if button = 1 then begin annot#set_text ""; match selected with | PStmt (kf, stmt) -> main_ui#protect ~cancelable:false (fun () -> current_statement_msg (Some kf) (Kstmt stmt); (* Code annotations for this statement *) Annotations.iter_code_annot (fun e a -> let pos, a = "Before", a in let user = if Emitter.equal e Emitter.end_user then "user" else "alarm" in main_ui#pretty_information "@[%s(%s): @[%a@]@]@.%a@." pos user Printer.pp_code_annotation a (Pretty_utils.pp_list ~sep:"@\n" pretty_predicate_status) (Property.ip_of_code_annot kf stmt a)) stmt) | PIP (Property.IPCodeAnnot (kf,stmt,ca) as ip) -> current_statement_msg ?loc:(Cil_datatype.Code_annotation.loc ca) (Some kf) (Kstmt stmt); main_ui#pretty_information "Code annotation id: %d@.%a@." ca.annot_id pretty_predicate_status ip | PIP(Property.IPAllocation _ as ip) -> main_ui#pretty_information "This is an allocation clause@.%a@." pretty_predicate_status ip | PIP(Property.IPAssigns _ as ip) -> main_ui#pretty_information "This is an assigns clause@.%a@." pretty_predicate_status ip | PIP(Property.IPFrom _ as ip) -> main_ui#pretty_information "This si a from clause@.%a@." pretty_predicate_status ip | PIP (Property.IPPredicate (Property.PKRequires _,_,_,_) as ip) -> main_ui#pretty_information "This is a requires clause.@.%a@." pretty_predicate_status ip | PIP (Property.IPPredicate (Property.PKTerminates,_,_,_) as ip) -> main_ui#pretty_information "This is a terminates clause.@.%a@." pretty_predicate_status ip | PIP (Property.IPPredicate (Property.PKEnsures (_,Normal),_,_,_) as ip) -> main_ui#pretty_information "This is an ensures clause.@.%a@." pretty_predicate_status ip | PIP (Property.IPPredicate (Property.PKEnsures (_,Exits),_,_,_) as ip) -> main_ui#pretty_information "This is an exits clause.@.%a@." pretty_predicate_status ip | PIP (Property.IPPredicate (Property.PKEnsures (_,Returns),_,_,_) as ip) -> main_ui#pretty_information "This is a returns clause.@.%a@." pretty_predicate_status ip | PIP (Property.IPPredicate (Property.PKEnsures (_,Breaks),_,_,_) as ip) -> main_ui#pretty_information "This is a breaks clause.@.%a@." pretty_predicate_status ip | PIP (Property.IPPredicate (Property.PKEnsures (_,Continues),_,_,_) as ip) -> main_ui#pretty_information "This is a continues clause.@.%a@." pretty_predicate_status ip | PIP (Property.IPPredicate(Property.PKAssumes _,_,_,_)) -> main_ui#pretty_information "This is an assumes clause.@." | PIP (Property.IPDecrease (_,Kglobal,_,_) as ip) -> main_ui#pretty_information "This is a decreases clause.@.%a@." pretty_predicate_status ip | PIP (Property.IPDecrease (_,Kstmt _,_,_) as ip) -> main_ui#pretty_information "This is a loop variant.@.%a@." pretty_predicate_status ip | PIP(Property.IPDisjoint _ as ip) -> main_ui#pretty_information "This is a disjoint behaviors clause.@.%a@." pretty_predicate_status ip | PIP(Property.IPComplete _ as ip) -> main_ui#pretty_information "This is a complete behaviors clause.@.%a@." pretty_predicate_status ip | PIP(Property.IPAxiom _) -> main_ui#pretty_information "This is an axiom.@."; | PIP(Property.IPAxiomatic _) -> main_ui#pretty_information "This is an axiomatic.@."; | PIP(Property.IPLemma _) -> main_ui#pretty_information "This is a lemma.@."; | PIP(Property.IPBehavior _) -> main_ui#pretty_information "This is a behavior.@."; | PIP(Property.IPReachable _) | PIP(Property.IPOther _) -> (* these properties are not selectable *) assert false | PGlobal _g -> main_ui#pretty_information "This is a global.@."; | PLval (kf, ki,lv) -> begin try let ty = typeOfLval lv in if isFunctionType ty then main_ui#pretty_information "This is a C function of type %a@." Printer.pp_typ ty else begin current_statement_msg kf ki; match lv with | Var vi,NoOffset -> main_ui#pretty_information "Variable %a has type \"%a\".@\nIt is a %s variable.@\n\ %tIt is %sreferenced and its address is %staken.@." Varinfo.pretty_vname vi Printer.pp_typ vi.vtype (if vi.vglob then "global" else "local") (fun fmt -> match vi.vdescr with None -> () | Some s -> Format.fprintf fmt "This is a temporary variable for \"%s\".@\n" s) (if vi.vreferenced then "" else "not ") (if vi.vaddrof then "" else "not ") | _ -> main_ui#pretty_information "This is an lvalue of type %a@." Printer.pp_typ (typeOfLval lv) end with Not_found -> main_ui#error "Error in lval Db.KernelFunction.find" end | PTermLval _ -> main_ui#pretty_information "This is a logical left-value.@." | PVDecl (kf,vi) -> main_ui#view_original vi.vdecl; if vi.vglob then main_ui#pretty_information "This is the declaration of %s %a.@\nIt is %sreferenced and \ its address is %staken.@." (if Cil.isFunctionType vi.vtype then "function" else "global variable") Varinfo.pretty_vname vi (if vi.vreferenced then "" else "not ") (if vi.vaddrof then "" else "not ") else main_ui#pretty_information "This is the declaration of local %a in function %a%t@." Varinfo.pretty_vname vi Kernel_function.pretty (Extlib.the kf) (fun fmt -> match vi.vdescr with None -> () | Some s -> Format.fprintf fmt "@\nThis is a temporary variable for \"%s\".@." s) end else if button = 3 then begin match selected with | PVDecl _ -> () | PStmt _ -> () | PLval (_kf, _ki, lv) -> (* Do special actions for functions *) (* popup a menu to jump the definitions of the given varinfos *) let ty = typeOfLval lv in let do_menu vi = try ignore (menu_factory#add_item ("Go to definition of " ^ (Pretty_utils.escape_underscores (Pretty_utils.sfprintf "%a" Varinfo.pretty_vname vi))) ~callback: (fun () -> let kf = Globals.Functions.get vi in let glob = Kernel_function.get_global kf in ignore (main_ui#select_or_display_global glob))) with Not_found -> () (* Should not happend since [ty] below has a function type *) in (match lv with | Var v,NoOffset when isFunctionType ty -> (* only simple literal calls can be resolved syntactically *) do_menu v | _ -> ()) | PTermLval _ | PGlobal _ | PIP _ -> () end (** Global selectors and highlighters *) let highlighter = ref [] let (selector: (GMenu.menu GMenu.factory -> main_window_extension_points -> button:int -> Pretty_source.localizable -> unit) list ref) = ref [] class protected_menu_factory (host:Gtk_helper.host) (menu:GMenu.menu) = object inherit [GMenu.menu] GMenu.factory menu as super method add_item ?key ?callback ?submenu string = let callback = match callback with None -> None | Some cb -> Some (fun () -> ignore (host#full_protect ~cancelable:true cb)) in super#add_item ?key ?callback ?submenu string method add_check_item ?active ?key ?callback string = let callback = match callback with None -> None | Some cb -> Some (fun b -> ignore (host#full_protect ~cancelable:false (fun () -> cb b))) in super#add_check_item ?active ?key ?callback string end class reactive_buffer_cl (main_ui:main_window_extension_points) ?(parent_window=main_ui#main_window) globs :reactive_buffer = object(self) inherit error_manager ~reset:main_ui#reset (parent_window:>GWindow.window_skel) val buffer = Source_viewer.buffer () val mutable locs = None method buffer = buffer method locs = locs method rehighlight = Extlib.may Pretty_source.hilite locs method redisplay = self#init method private init = let highlighter localizable ~start ~stop = List.iter (fun f -> f buffer localizable ~start ~stop) !highlighter in let selector ~button localizable = let popup_factory = new protected_menu_factory (self:>Gtk_helper.host) (GMenu.menu ()) in List.iter (fun f -> f popup_factory main_ui ~button localizable) !selector; if button = 3 && popup_factory#menu#children <> [] then popup_factory#menu#popup ~button ~time:(GtkMain.Main.get_current_event_time ()) in Extlib.may Locs.finalize locs; locs <- Some( Pretty_source.display_source globs buffer ~host:(self:>Gtk_helper.host) ~highlighter ~selector) initializer self#init; Globals_GUI.add globs (self:> reactive_buffer) end let reactive_buffer main_ui ?parent_window globs = try Globals_GUI.find globs with Not_found -> new reactive_buffer_cl main_ui ?parent_window globs module Feedback = struct module F = Property_status.Feedback let category = function | F.Never_tried -> "never_tried" | F.Considered_valid -> "considered_valid" | F.Valid -> "surely_valid" | F.Invalid -> "surely_invalid" | F.Invalid_but_dead -> "invalid_but_dead" | F.Valid_but_dead -> "valid_but_dead" | F.Unknown_but_dead -> "unknown_but_dead" | F.Unknown -> "unknown" | F.Valid_under_hyp -> "valid_under_hyp" | F.Invalid_under_hyp -> "invalid_under_hyp" | F.Inconsistent -> "inconsistent" let declare_markers (source:GSourceView2.source_view) = List.iter (fun v -> source#set_mark_category_pixbuf ~category:(category v) (Some (Gtk_helper.Icon.get (Gtk_helper.Icon.Feedback v)))) [ F.Never_tried; F.Considered_valid; F.Valid; F.Invalid; F.Invalid_but_dead; F.Valid_but_dead; F.Unknown; F.Unknown_but_dead; F.Valid_under_hyp; F.Invalid_under_hyp; F.Inconsistent ] let mark (source:GSourceView2.source_buffer) ~start ~stop:_ validity = begin let iter = source#get_iter_at_char start in let category = category validity in source#remove_source_marks iter iter () ; ignore (source#create_source_mark ~category iter) ; end let update (reactive_buffer:reactive_buffer) prop = Extlib.may (fun loc_table -> let validity = F.get prop in let loc = Pretty_source.PIP prop in let loc = locate_localizable loc_table loc in Extlib.may (fun (start,stop) -> mark reactive_buffer#buffer ~start ~stop validity) loc) reactive_buffer#locs end (** The main application window *) class main_window () : main_window_extension_points = let final_w,width = try true,Configuration.find_int "window_width" with Not_found -> false,(Gdk.Screen.width ())*7/8 in let final_h,height =try true,Configuration.find_int "window_height" with Not_found -> false,(Gdk.Screen.height ())*7/8 in let max_width = (* maximum width for this height *) height * 8 / 5 (* 16/10 ratio *) in let width, height = if width > max_width then (if final_w then width else max_width), height else let max_height = width * 3 / 4 in let new_height = min height max_height in width, if final_h then height else new_height in let main_window = GWindow.window ?icon:framac_icon ~title:"Frama-C" ~width ~height ~position:`CENTER ~allow_shrink:true ~allow_grow:true ~show:false () in let () = main_window#set_default_size ~width ~height in let watch_cursor = Gdk.Cursor.create `WATCH in let arrow_cursor = Gdk.Cursor.create `ARROW in (* On top one finds the menubar *) let toplevel_vbox = GPack.box `VERTICAL ~packing:main_window#add () in (* toplevel_vbox->*bottom_hbox *) let bottom_hbox = GPack.box `HORIZONTAL ~packing:(toplevel_vbox#pack ~expand:false ~fill:false ~from:`END) () in (* status bar (at bottom) *) (* toplevel_vbox->bottom_hbox-> *statusbar *) let statusbar = GMisc.statusbar ~has_resize_grip:false ~packing:bottom_hbox#add () in let status_context = statusbar#new_context "messages" in (* progress bar (at bottom) *) (* toplevel_vbox->bottom_hbox-> [statusbar;*progress_bar] *) let progress_bar = GRange.progress_bar ~pulse_step:0.01 ~packing:(bottom_hbox#pack ~fill:false) () in (* Split below the bars *) (* toplevel_vbox->[*toplevel_hpaned;bottom_hbox] *) let toplevel_hpaned = GPack.paned `HORIZONTAL ~packing:(toplevel_vbox#pack ~expand:true ~fill:true ~from:`END) () in (* Save the handle ratio whenever it is changed *) let _ = toplevel_hpaned#event#connect#button_release ~callback:(fun _ -> save_paned_ratio "toplevel_hpaned" toplevel_hpaned; false) in let filetree_panel_vpaned = GPack.paned `VERTICAL ~packing:(toplevel_hpaned#add1) () in let _ = filetree_panel_vpaned#event#connect#button_release ~callback:(fun _ -> save_paned_ratio "filetree_panel_vpaned" filetree_panel_vpaned; false) in (* The left filetree inside an automatic scrolled window and a nice frame *) let filetree_frame = GBin.frame ~shadow_type:`ETCHED_OUT ~packing:filetree_panel_vpaned#add1 () in let filetree_scrolled_window = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:filetree_frame#add () in let file_tree_view = GTree.view ~packing:filetree_scrolled_window#add () in let () = file_tree_view#selection#set_mode `SINGLE in let () = file_tree_view#set_rules_hint true in let () = file_tree_view#set_headers_clickable true in (* splits between messages and sources *) let vb_message_sources = GPack.paned `VERTICAL ~border_width:3 ~packing:toplevel_hpaned#add2 () in let _ = vb_message_sources#event#connect#button_release ~callback:(fun _ -> save_paned_ratio "vb_message_sources" vb_message_sources; false) in (* splits between messages and sources *) let hb_sources = GPack.paned `HORIZONTAL ~border_width:3 ~packing:vb_message_sources#add1 () in (* Save the handle ratio whenever it is changed *) let _ = hb_sources#event#connect#button_release ~callback:(fun _ -> save_paned_ratio "hb_sources" hb_sources; false) in (* lower notebook *) let fr2 = GBin.frame ~shadow_type:`ETCHED_OUT ~packing:vb_message_sources#add2 () in let lower_notebook = GPack.notebook ~scrollable:true ~show_tabs:true ~packing:fr2#add () in (* lower text view and its scroll view: annotations and messages *) let _,annot_window = Gtk_helper.make_text_page lower_notebook "Information" in let pretty_information fmt = Format.fprintf (Gtk_helper.make_formatter annot_window#buffer) fmt in (* upper text view: source code *) let fr1 = GBin.frame ~shadow_type:`ETCHED_OUT ~packing:hb_sources#add1 () in let sw = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:fr1#add () in let source_viewer = Source_viewer.make ~packing:sw#add in let () = begin source_viewer#set_show_line_numbers false ; source_viewer#set_show_line_marks true ; Feedback.declare_markers source_viewer ; end in let original_source_viewer = Source_manager.make ~packing:hb_sources#add2 () in (* Remove default pango menu for textviews *) let () = ignore (source_viewer#event#connect#button_press ~callback: (fun ev -> GdkEvent.Button.button ev = 3)); ignore (annot_window#event#connect#button_press ~callback: (fun ev -> GdkEvent.Button.button ev = 3)); (* startup configuration *) source_viewer#buffer#place_cursor ~where:source_viewer#buffer#start_iter in object (self:#main_window_extension_points) val mutable launcher = [] val mutable panel = [] val mutable main_window_metrics = { Gtk.width=0; height=0; x=0; y=0} val mutable file_tree = None val mutable current_buffer_state : reactive_buffer option = None val mutable menu_manager = None method toplevel = (self:>main_window_extension_points) method main_window = main_window method menu_manager () = match menu_manager with | None -> (* toplevel_vbox->[*self#menu_manager();toplevel_hpaned;bottom_hbox] *) let m = new Menu_manager.menu_manager ~packing:(toplevel_vbox#pack ~expand:false ~fill:false ~from:`START) ~host:(self :> Gtk_helper.host) in menu_manager <- Some m; m | Some s -> s method file_tree = Extlib.the file_tree method file_tree_view = file_tree_view method annot_window = annot_window method pretty_information : 'a. ('a, Format.formatter, unit) format -> 'a = pretty_information method source_viewer = source_viewer method register_source_selector f = selector := f::!selector method register_source_highlighter f = highlighter := f::!highlighter method register_panel f = panel <- f::panel method private initialize_panels () = let to_refresh = ref [] in let sw = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:filetree_panel_vpaned#add2 () in let vbox = GPack.vbox ~packing:sw#add_with_viewport () in let targets = [ { Gtk.target = "application/x" ; Gtk.flags = [] ; Gtk.info = 0 }] in let dragged_frame = ref None in List.iter (fun f -> let text,widget,refresh = f (self:>main_window_extension_points) in let key_config = text in let expander = GBin.expander ~expanded:(Configuration.find_bool ~default:true key_config) ~packing:vbox#pack () in let label_hb = GPack.hbox () in let _label = GMisc.label ~markup:(""^text^"") ~packing:label_hb#pack () in expander#set_label_widget (label_hb#coerce); ignore (expander#connect#activate (fun () -> (* Save expansion of panels*) Configuration.set key_config (Configuration.ConfBool (not expander#expanded)))); let frame = GBin.frame ~packing:expander#add () in frame#add widget; (* Drag stuff *) expander#drag#source_set ~modi:[`BUTTON1] ~actions:[`MOVE] targets; ignore (expander#drag#connect#beginning (fun _ -> dragged_frame:=Some (frame,text))); ignore (expander#drag#connect#ending (fun _ -> dragged_frame:=None)); (* Refreshers *) Extlib.may (fun refresh -> to_refresh:= (fun ()-> if !Gtk_helper.gui_unlocked && expander#expanded then refresh ()) ::!to_refresh) refresh) panel; (* Drop machinery *) let dropper (widget:GObj.widget) = widget#drag#dest_set ~flags:[`ALL] ~actions:[`MOVE] targets; ignore (widget#drag#connect#drop (fun drag_context ~x:_ ~y:_ ~time:_ -> match !dragged_frame with | None (* Not dropping a panel *) -> true | Some (frame,title) -> (*Format.printf "Hello %d %d %ld@." x y time;*) let w = drag_context#source_widget in let new_w = GWindow.window ~position:`MOUSE ~title ~show:true () in let b = GPack.vbox ~packing:new_w#add () in frame#misc#reparent b#coerce; ignore (new_w#connect#destroy (fun () -> frame#misc#reparent w; w#misc#show ())); w#misc#hide (); true)); ignore (widget#drag#connect#motion (fun drag_context ~x:_ ~y:_ ~time -> (*Format.printf "Motion %d %d %ld@." x y time;*) drag_context#status ~time (Some `MOVE); true)); ignore (widget#drag#connect#leave (fun drag_context ~time -> (*Format.printf "Motion %d %d %ld@." x y time;*) drag_context#status ~time (Some `MOVE))); in dropper main_window#coerce; dropper source_viewer#coerce; let refresh_all _ = (List.iter (fun f -> f ()) !to_refresh;true) in ignore (Glib.Timeout.add ~ms:500 ~callback:refresh_all) method launcher () = Launcher.show ~width:(try Configuration.find_int "launcher_width" with Not_found -> main_window_metrics.Gtk.width/2) ~height:(try Configuration.find_int "launcher_height" with Not_found -> 2*main_window_metrics.Gtk.height/3) ~host:(self:>Launcher.basic_main) () method original_source_viewer = original_source_viewer method reactive_buffer = current_buffer_state method display_globals globs = Gui_parameters.debug "display_globals"; let buff = reactive_buffer self#toplevel globs in current_buffer_state <- Some buff; self#source_viewer#set_buffer (buff#buffer:>GText.buffer); self#rehighlight () (* This should not be needed, but for some reason gtk does not highlight the buffer by default *) (* Cf .mli doc. In the first case, the callbacks of the filetree are called, but not in the second case. As of 2011-05-16, the only callback is registered here (in design.ml) and calls filetree_selector *) method select_or_display_global g = if not (self#toplevel#file_tree#select_global g) then filetree_selector self#toplevel ~was_activated:false ~activating:true (Filetree.Global g) method redisplay () = Extlib.may (fun f -> f#redisplay) current_buffer_state; History.show_current () method rehighlight () = Extlib.may (fun f -> f#rehighlight) current_buffer_state; (* self#file_tree#model#foreach (fun p i -> self#file_tree#model#row_changed p i;false) *) (* General idea: if there is a current buffer AND [loc] is inside, scroll to [loc]. Otherwise, open a relevant buffer by finding a varinfo or a global for [loc], then scroll to [loc]. *) method scroll loc = (* Used to avoid having two different history events, one created by [select_global], the other by [scroll] *) let history = History.on_current_history () in let update_source_view () = match Pretty_source.kf_of_localizable loc with | Some kf -> let g = Kernel_function.get_global kf in self#select_or_display_global g | None -> match loc with | PGlobal g -> self#select_or_display_global g | _ -> if Gui_parameters.debug_atleast 3 then self#error "Gui: does not know how to scroll to loc" (* In this case, there is nothing we can do: we do not know which file/global to open to scroll in *) in (* We need a non-empty [current_buffer_state] to do something later *) (match current_buffer_state with | Some _ -> () | None -> update_source_view () ); match current_buffer_state with | None -> () | Some state -> (* [current_buffer_state] contains [loc], [o] is the offset, let's scroll to it *) let show o = history (fun () -> History.push (History.Localizable loc)); let iter = self#source_viewer#buffer#get_iter (`OFFSET o) in ignore (self#source_viewer#backward_display_line_start iter); self#source_viewer#buffer#place_cursor iter; ignore (self#source_viewer#scroll_to_mark ~use_align:true ~yalign:0.5 ~xalign:0. `INSERT) in match Pretty_source.locate_localizable (Extlib.the state#locs) loc with | Some (b,_) -> show b | None -> (* Searching in [current_buffer_state] did not work, let's try to open a good one *) update_source_view (); let state = Extlib.the current_buffer_state in match Pretty_source.locate_localizable (Extlib.the state#locs) loc with | Some (b, _) -> show b | None -> if Gui_parameters.debug_atleast 3 then self#error "Unable to scroll to loc, probably \ not shown in the buffer" (* Can appear eg. for an if (i<5) inside a loop, which is not shown in general in the source code *) method view_stmt stmt = let kf = Kernel_function.find_englobing_kf stmt in let loc = PStmt (kf, stmt) in self#scroll loc; ignore (self#view_original_stmt stmt) method view_original loc = if not (Location.equal loc Location.unknown) then Source_manager.load_file self#original_source_viewer ~filename:(fst loc).Lexing.pos_fname ~line:(fst loc).Lexing.pos_lnum () method view_original_stmt st = let loc = Stmt.loc st in if use_external_viewer then begin if not (Location.equal loc Location.unknown) then let args_for_emacs = Format.sprintf "emacsclient -n +%d %s" (fst loc).Lexing.pos_lnum (fst loc).Lexing.pos_fname (* Format.sprintf "mate -a -l %d %s" line file *) in if Gui_parameters.debug_atleast 1 then self#push_info "Running %s" args_for_emacs; ignore (Sys.command args_for_emacs); if Gui_parameters.debug_atleast 1 then self#pop_info () end else self#view_original loc; loc method private info_string s = ignore (status_context#push s) method pop_info () = status_context#pop (); method private push_info_buffer : 'a. ?buffer:Buffer.t -> ('a, Format.formatter, unit) format -> 'a = fun ?buffer fmt -> let b = match buffer with | None -> Buffer.create 80 | Some b -> b in let bfmt = Format.formatter_of_buffer b in Format.kfprintf (function fmt -> Format.pp_print_flush fmt (); let content = Buffer.contents b in self#info_string content) bfmt fmt method push_info fmt = self#push_info_buffer fmt method help_message w fmt = let buffer = Buffer.create 80 in let bfmt = Format.formatter_of_buffer buffer in Format.kfprintf (function _ -> ignore (w#event#connect#leave_notify (fun _ -> self#pop_info ();true)); ignore (w#event#connect#enter_notify (fun _ -> Format.pp_print_flush bfmt (); self#push_info_buffer ~buffer "" ;false))) bfmt fmt inherit error_manager (main_window:>GWindow.window_skel) (* These private method might be exported when necessary *) method private toplevel_vbox = toplevel_vbox method private toplevel_hpaned = toplevel_hpaned method private statusbar = statusbar method lower_notebook = lower_notebook method reset () = Gui_parameters.debug "Redisplaying gui"; Globals_GUI.clear (); current_buffer_state <- None; self#file_tree#reset (); (self#menu_manager ())#refresh (); reset_extensions self#toplevel; if History.is_empty () then ( self#default_screen ()) else History.show_current () method private default_screen () = try (* If some files have been specified on the command-line, we try to find the main (if possible a definition, not a prototype), and display it *) let main, _ = Globals.entry_point () in self#select_or_display_global (Kernel_function.get_global main) with Globals.No_such_entry_point _ | Not_found -> source_viewer#buffer#set_text "Please select a file in the left panel\nor start a new project." initializer self#set_reset self#reset; let menu_manager = self#menu_manager () (* create the menu_manager *) in main_window#add_accel_group menu_manager#factory#accel_group; let lock_gui lock = (* lock left part of the GUI. *) filetree_panel_vpaned#misc#set_sensitive (not lock); if lock then ignore (Glib.Timeout.add ~ms:25 ~callback:(fun () -> progress_bar#pulse (); not !Gtk_helper.gui_unlocked)); Gdk.Window.set_cursor main_window#misc#window (if lock then watch_cursor else arrow_cursor); if lock then begin progress_bar#misc#show (); ignore (status_context#push "Computing") end else begin status_context#pop(); progress_bar#misc#hide () end in register_locking_machinery ~lock:(fun _cancelable -> lock_gui true) ~unlock:(fun () -> lock_gui false) (); ignore (main_window#connect#destroy ~callback:Cmdline.bail_out); (* Set the relative position for all paned whenever the main window is resized *) ignore (main_window#misc#connect#size_allocate (fun ({Gtk.width=w;Gtk.height=h} as rect) -> Configuration.set "window_width" (Configuration.ConfInt w); Configuration.set "window_height" (Configuration.ConfInt h); if main_window_metrics.Gtk.width <> w || main_window_metrics.Gtk.height <> h then begin place_paned hb_sources (Configuration.find_float ~default:0.5 "hb_sources"); place_paned vb_message_sources (Configuration.find_float ~default:0.71 "vb_message_sources"); place_paned filetree_panel_vpaned (Configuration.find_float ~default:0.5 "filetree_panel_vpaned"); place_paned toplevel_hpaned (Configuration.find_float ~default:0.18 "toplevel_hpaned"); end; main_window_metrics <- rect)); file_tree <- Some (Filetree.make file_tree_view); self#file_tree#add_select_function (filetree_selector self#toplevel); process_extensions self#toplevel; self#register_source_selector to_do_on_select; self#initialize_panels (); main_window#show (); Gdk.Window.set_cursor main_window#misc#window arrow_cursor; let warning_manager = let packing w = ignore (lower_notebook#insert_page ~pos:1 ~tab_label:(GMisc.label ~text:"Messages" ())#coerce w) in let callback e _column = Extlib.may (fun pos -> Extlib.may self#scroll (Pretty_source.loc_to_localizable pos); self#view_original (pos,pos)) e.Log.evt_source in Warning_manager.make ~packing ~callback in let display_warnings () = Messages.reset_once_flag (); Warning_manager.clear warning_manager; Messages.iter (fun event -> Warning_manager.append warning_manager event); in display_warnings (); (* Gestion of navigation history *) ignore (History.create_buttons (self#menu_manager ())); History.set_display_elt_callback (function | History.Global g -> self#select_or_display_global g | History.Localizable l -> self#scroll l ); register_reset_extension (fun _ -> display_warnings ()); self#default_screen (); menu_manager#refresh (); Project.register_after_set_current_hook ~user_only:true (fun _ -> self#reset ()) end let make_splash () = GMain.Rc.add_default_file (Config.datadir ^"/frama-c.rc"); GMain.Rc.add_default_file (Config.datadir ^"/frama-c-user.rc"); (*print_endline ("BOOT: " ^ (Glib.Main.setlocale `ALL None));*) let (_:string) = GtkMain.Main.init ~setlocale:false () in (*print_endline ("START: " ^ (Glib.Main.setlocale `ALL None));*) let w = GWindow.window ~title:"Splash" ~width:640 ~height:480 ~position:`CENTER_ALWAYS ~show:false ?icon:framac_icon () in let _ = w#event#connect#delete ~callback:(fun _ -> Cmdline.bail_out ()) in let tid = Glib.Timeout.add ~ms:500 ~callback:(fun () -> w#show (); false) in let bx = GPack.vbox ~packing:w#add () in let notebook = GPack.notebook ~packing:bx#add () in let close_button = GButton.button ~packing:(bx#pack ~expand:false ~fill:false) ~stock:`CANCEL () in ignore (close_button#connect#released ~callback:Cmdline.bail_out); let reparent,stdout = Gtk_helper.make_text_page ~pos:2 notebook "Console" in if Gui_parameters.Debug.get () = 0 then begin Gtk_helper.log_redirector (fun s -> stdout#buffer#insert ~iter:stdout#buffer#end_iter s); let it = make_tag stdout#buffer "italic" [`STYLE `OBLIQUE] in let tag_stack = Stack.create () in let open_tag s = (match s with | "i" -> Stack.push (it,(stdout#buffer#get_iter `INSERT)#offset) tag_stack; | _ -> ()); "" in let close_tag s = (match s with | "i" -> let stop = stdout#buffer#end_iter in let tag,start_offset = Stack.pop tag_stack in let start = stdout#buffer#get_iter (`OFFSET start_offset) in (* Format.printf "start:%d stop:%d@." start#offset stop#offset; *) stdout#buffer#apply_tag tag ~start ~stop | _ -> ()); "" in Kernel.register_tag_handlers (open_tag,close_tag) end; let force () = Glib.Timeout.remove tid; w#show () in tid, stdout, w, reparent, force let toplevel play = Gtk_helper.Configuration.load (); Db.progress := Gtk_helper.refresh_gui; let in_idle () = let tid, splash_out, splash_w, reparent_console, force_s= make_splash () in let error_manager = new Gtk_helper.error_manager (splash_w:>GWindow.window_skel) in let init_crashed = ref true in error_manager#protect ~cancelable:true ~parent:(splash_w:>GWindow.window_skel) (fun () -> (try play (); (* This is a good point to start using real asynchronous tasks management: plug-ins launched from command line have finished their asynchronous tasks thanks to the default Task.on_idle. *) Task.on_idle := (fun f -> ignore (Glib.Timeout.add ~ms:50 ~callback:f)); Ast.compute () with e -> (* An error occured: we need to enforce the splash screen realization before we create the error dialog widget.*) force_s (); raise e); init_crashed := false); if Ast.is_computed () then (* if the ast has parsed, but a plugin has crashed, we display the gui *) error_manager#protect ~cancelable:false (fun () -> let main_ui = new main_window () in Gtk_helper.gui_unlocked := true; Glib.Timeout.remove tid; reparent_console main_ui#lower_notebook; splash_w#destroy (); (* Display the console if a crash has occurred. Otherwise, display the information panel *) if !init_crashed then (main_ui#lower_notebook#goto_page 2; (* BY TODO: this should scroll to the end of the console. It does not work at all after the reparent, and only partially before (scrollbar is wrong) *) let end_console = splash_out#buffer#end_iter in ignore (splash_out#scroll_to_iter ~yalign:0. end_console) ) else main_ui#lower_notebook#goto_page 0 ) in ignore (Glib.Idle.add (fun () -> in_idle (); false)); GMain.Main.main () let () = Db.Toplevel.run := toplevel (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/help_manager.mli0000644000175000017500000000331212155630233020474 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Nothing exported. Automatic registration. *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/property_navigator.ml0000644000175000017500000005354212155630233021651 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Design open Cil_types open Property_status (* Collect all properties that have a status *) let all_properties () = let globals = ref Property.Set.empty in let functions = ref Kernel_function.Map.empty in (* Dispatch properties into globals and per-function map *) Property_status.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 ); !functions, !globals type property = { module_name:string; function_name:string; kind:string; status_name:string; consolidated_status:Consolidation.consolidated_status option; consolidated_status_name:string; status_icon:Gtk_helper.Icon.kind; visible:bool; ip: Property.t; } let kf_name_and_module kf = let name = Kernel_function.get_name kf in let loc = Kernel_function.get_location kf in let file = Filename.basename (fst loc).Lexing.pos_fname in name, file let make_property ip = let status = Property_status.get ip in let status_name = Pretty_utils.sfprintf "%a" Property_status.pretty status in let con_status = Consolidation.get ip in let consolidated_status_name = Pretty_utils.sfprintf "%a" Consolidation.pretty con_status in let function_name, module_name = match Property.get_kf ip with | None -> "", "" (* TODO: it would be great to find the location of global invariants or lemmas, but there isn't enough information in the ast *) | Some kf -> kf_name_and_module kf in let kind = Pretty_utils.sfprintf "@[%a@]" Property.pretty ip in let status_icon = Gtk_helper.Icon.Feedback (Feedback.get ip) in { module_name = module_name; function_name = function_name; visible = true; ip=ip; kind=kind; status_name = status_name ; consolidated_status = Some con_status ; consolidated_status_name = consolidated_status_name ; status_icon = status_icon ; } module Refreshers: sig module OnlyCurrent: State_builder.Ref with type data = bool module Ensures: State_builder.Ref with type data = bool module Preconditions: State_builder.Ref with type data = bool module Behaviors: State_builder.Ref with type data = bool module Allocations: State_builder.Ref with type data = bool module Assigns: State_builder.Ref with type data = bool module From: State_builder.Ref with type data = bool module Assert: State_builder.Ref with type data = bool module Invariant: State_builder.Ref with type data = bool module Variant: State_builder.Ref with type data = bool module Terminates: State_builder.Ref with type data = bool module StmtSpec: State_builder.Ref with type data = bool module Reachable: State_builder.Ref with type data = bool module Other: State_builder.Ref with type data = bool module Axiomatic: State_builder.Ref with type data = bool (*module Pragma: State_builder.Ref with type data = bool*) module RteNotGenerated: State_builder.Ref with type data = bool module RteGenerated: State_builder.Ref with type data = bool module Valid: State_builder.Ref with type data = bool module ValidHyp: State_builder.Ref with type data = bool module Unknown: State_builder.Ref with type data = bool module Invalid: State_builder.Ref with type data = bool module InvalidHyp: State_builder.Ref with type data = bool module Considered_valid: State_builder.Ref with type data = bool module Untried: State_builder.Ref with type data = bool module Dead: State_builder.Ref with type data = bool module Inconsistent: State_builder.Ref with type data = bool val pack: GPack.box -> unit val apply: unit -> unit end = struct (* Function to be called during the idle time of the GUI *) let refreshers = ref [] let add_refresher f = refreshers := f::!refreshers module Add (X: sig val name: string val hint: string end) = struct open Gtk_helper let key_name = Configuration.load (); let s = String.copy X.name in for i = 0 to String.length s - 1 do let c = s.[i] in if c < 'A' || c > 'z' || (c > 'Z' && c < 'a') then s.[i] <- '_' done; "property_panel." ^ s include State_builder.Ref (Datatype.Bool) (struct let name = "show " ^ X.name let dependencies = [] let default () = let v = Configuration.find_bool ~default:true key_name in v end) let set v = Configuration.set key_name (Configuration.ConfBool v); set v let add hb = add_refresher (Gtk_helper.on_bool ~tooltip:X.hint hb X.name get set) end let apply () = List.iter (fun f -> f ()) !refreshers module OnlyCurrent = Add( struct let name = "Current function" let hint = "Restrict properties to those of current function" end) module Preconditions = Add( struct let name = "Preconditions" let hint = "Show functions preconditions" end) module Ensures = Add( struct let name = "Postconditions" let hint = "Show functions postconditions" end) module Behaviors = Add( struct let name = "Behaviors" let hint = "Show functions behaviors" end) module Allocations = Add( struct let name = "Allocations" let hint = "Show functions assigns" end) module Assigns = Add( struct let name = "Assigns" let hint = "Show functions assigns" end) module From = Add( struct let name = "From" let hint = "Show functional dependencies in functions assigns" end) module Assert = Add( struct let name = "Assert" let hint = "Show assertions" end) module Invariant = Add( struct let name = "Invariant" let hint = "Show loop invariants" end) module Variant = Add( struct let name = "Variant" let hint = "Show loop termination argument" end) module Terminates = Add( struct let name = "Terminates" let hint = "Show functions termination clauses" end) module StmtSpec = Add( struct let name = "Stmt contract" let hint = "Show statements contracts" end) module Axiomatic = Add( struct let name = "Axiomatic" let hint = "Show global axiomatics" end) module Reachable = Add( struct let name = "Reachable" let hint = "Show 'reachable' hypotheses" end) module Other = Add( struct let name = "Other" let hint = "Show other properties" end) (*module Pragma = Add(struct let name = "pragma" end) *) module RteNotGenerated = Add( struct let name = "Non generated" let hint = "Show RTEs assertions that remain to generate" end) module RteGenerated = Add( struct let name = "Generated" let hint = "Show RTEs assertions that have been generated" end) module Valid = Add( struct let name = "Valid" let hint = "Show properties that are proven valid" end) module ValidHyp = Add( struct let name = "Valid under hyp." let hint = "Show properties that are are valid, but depend on \ some hypotheses" end) module Unknown = Add( struct let name = "Unknown" let hint = "Show properties with an 'unknown' status" end) module Invalid = Add( struct let name = "Invalid" let hint = "Show properties that are proven invalid" end) module InvalidHyp = Add( struct let name = "Invalid under hyp." let hint = "Show properties that are are invalid, but depend on \ some hypotheses" end) module Considered_valid = Add( struct let name = "Considered valid" let hint = "Show properties that are considered valid because \ the platform has no way to prove them" end) module Untried = Add( struct let name = "Untried" let hint = "Show properties whose proof have not been attempted" end) module Dead = Add( struct let name = "Dead" let hint = "Show properties on unreachable code" end) module Inconsistent = Add( struct let name = "Inconsistent" let hint = "Show properties that have an inconsistent status" end) let pack hb = OnlyCurrent.add hb; Preconditions.add hb; Ensures.add hb; Behaviors.add hb; Allocations.add hb; Assigns.add hb; From.add hb; Assert.add hb; Invariant.add hb; Variant.add hb; Terminates.add hb; Reachable.add hb; StmtSpec.add hb; Axiomatic.add hb; Other.add hb; (*Pragma.add hb;*) RteNotGenerated.add hb; RteGenerated.add hb; ignore (GMisc.separator ~packing:hb#pack `HORIZONTAL ()); Valid.add hb; ValidHyp.add hb; Unknown.add hb; Invalid.add hb; InvalidHyp.add hb; Considered_valid.add hb; Untried.add hb; Dead.add hb; Inconsistent.add hb; end open Refreshers (* Process the rte statuses for the given kf, and add the result in the accumulator. Filter the statuses according to user-selected filters*) let aux_rte kf acc (name, _, rte_status_get: Db.RteGen.status_accessor) = let st = rte_status_get kf in match st, RteGenerated.get (), RteNotGenerated.get () with | true, true, _ | false, _, true -> (* Considered that leaf functions are not verified internally *) let status_name, status = if st then if Kernel_function.is_definition kf then "Generated", Feedback.Valid else "Considered generated", Feedback.Considered_valid else "Not generated", Feedback.Invalid in let function_name, module_name = kf_name_and_module kf in let status_icon = Gtk_helper.Icon.Feedback status in let ip = Property.ip_other name None Kglobal in { module_name = module_name; function_name = function_name; visible = true; ip=ip; kind=Pretty_utils.sfprintf "@[%a@]" Property.pretty ip; status_name = status_name ; consolidated_status = None ; consolidated_status_name = status_name ; status_icon = status_icon ; } :: acc | true, false, _ | false, _, false -> acc let make_panel (main_ui:main_window_extension_points) = let container = GPack.hbox () in let sc_buttons = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`NEVER () in let vb = GPack.vbox () in let refresh_button = GButton.button ~label:"Refresh" ~packing:vb#pack () in Refreshers.pack vb; sc_buttons#add_with_viewport vb#coerce; container#pack sc_buttons#coerce; let module MODEL = Gtk_helper.MAKE_CUSTOM_LIST(struct type t = property end) in let model = MODEL.custom_list () in let append m = if m.visible then model#insert m in let clear () = model#clear () in (* TOOD: this avoids some problems when changing projects, where the property navigator displays outdated information. A better solution would be to projectify what is being displayed *) Design.register_reset_extension (fun _ -> clear ()); let sc = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(container#pack ~expand:true ~fill:true) () 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 with | Some { MODEL.finfo = { ip = ip } } -> let format_graph ppf = Consolidation_graph.dump (Consolidation_graph.get ip) ppf in Gtk_helper.graph_window_through_dot main_ui#main_window "Dependencies" format_graph | None -> ())); 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={ip = ip;}} -> ignore (main_ui#scroll (Pretty_source.PIP ip)) | None -> () end; true); let top = `YALIGN 0.0 in let make_view_column renderer properties ~title = let cview = MODEL.make_view_column model renderer properties ~title in cview#set_resizable true; ignore (view#append_column cview) in (* Function name column viewer *) make_view_column (GTree.cell_renderer_text [top]) (function{function_name=m} -> [`TEXT m]) ~title:"Function"; (* Module name column viewer *) make_view_column (GTree.cell_renderer_text [top]) (function{module_name=m} -> [`TEXT m]) ~title:"File"; (* Kind name column viewer *) make_view_column (GTree.cell_renderer_text [top]) (function{kind=k} -> [`TEXT k]) ~title:"Kind"; (* Status colored column viewer *) make_view_column (GTree.cell_renderer_pixbuf [top]) (function {status_icon=status_icon} -> [`PIXBUF (Gtk_helper.Icon.get status_icon)]) ~title:"Status"; (* Consolidated status name column viewer *) make_view_column (GTree.cell_renderer_text [top]) (function{consolidated_status_name=k}-> [`TEXT k]) ~title:"Consolidated Status"; (* (Local) status name column viewer *) make_view_column (GTree.cell_renderer_text [top]) (function{status_name=k}-> [`TEXT k]) ~title:"Local Status"; view#set_model (Some model#coerce); let visible ip = match ip with | Property.IPOther _ -> Other.get () | Property.IPReachable _ -> Reachable.get () | Property.IPBehavior (_,Kglobal,_) -> Behaviors.get () | Property.IPBehavior (_,Kstmt _,_) -> Behaviors.get () && StmtSpec.get () | Property.IPPredicate(Property.PKRequires _,_,Kglobal,_) -> Preconditions.get () | Property.IPPredicate(Property.PKRequires _,_,Kstmt _,_) -> Preconditions.get () && StmtSpec.get () | Property.IPPredicate(Property.PKAssumes _,_,_,_) -> false | Property.IPPredicate(Property.PKEnsures _,_,Kglobal,_) -> Ensures.get () | Property.IPPredicate(Property.PKEnsures _,_,Kstmt _,_) -> Ensures.get() && StmtSpec.get() | Property.IPPredicate(Property.PKTerminates,_,_,_) -> Terminates.get () | Property.IPAxiom _ -> false | Property.IPAxiomatic _ -> Axiomatic.get () && not (OnlyCurrent.get ()) | Property.IPLemma _ -> Axiomatic.get () && not (OnlyCurrent.get ()) | Property.IPComplete _ -> Behaviors.get () | Property.IPDisjoint _ -> Behaviors.get () | Property.IPCodeAnnot(_,_,{annot_content = AAssert _}) -> Assert.get () | Property.IPCodeAnnot(_,_,{annot_content = AInvariant _}) -> Invariant.get () | Property.IPCodeAnnot(_,_,{annot_content = APragma p}) -> Logic_utils.is_property_pragma p (* currently always false. *) | Property.IPCodeAnnot(_, _, _) -> assert false | Property.IPAllocation (_,Kglobal,_,_) -> Allocations.get () | Property.IPAllocation (_,Kstmt _,Property.Id_code_annot _,_) -> Allocations.get () | Property.IPAllocation (_,Kstmt _,Property.Id_behavior _,_) -> Allocations.get() && StmtSpec.get() | Property.IPAssigns (_,Kglobal,_,_) -> Assigns.get () | Property.IPAssigns (_,Kstmt _,Property.Id_code_annot _,_) -> Assigns.get () | Property.IPAssigns (_,Kstmt _,Property.Id_behavior _,_) -> Assigns.get() && StmtSpec.get() | Property.IPFrom _ -> From.get () | Property.IPDecrease _ -> Variant.get () in let visible_status_aux = function | Consolidation.Never_tried -> Untried.get () | Consolidation.Considered_valid -> Considered_valid.get () | Consolidation.Valid _ -> Valid.get () | Consolidation.Valid_under_hyp _ -> ValidHyp.get () | Consolidation.Unknown _ -> Unknown.get () | Consolidation.Invalid _ -> Invalid.get () | Consolidation.Invalid_under_hyp _ -> InvalidHyp.get () | Consolidation.Invalid_but_dead _ | Consolidation.Valid_but_dead _ | Consolidation.Unknown_but_dead _ -> Dead.get () | Consolidation.Inconsistent _ -> Inconsistent.get () in let visible_status = Extlib.may_map visible_status_aux ~dft:true in let fill_model () = let add_ip ip = if visible ip then let p = make_property ip in if visible_status p.consolidated_status then append p in let by_kf, globals = all_properties () in (* Add global properties at the top of the list *) Property.Set.iter add_ip globals; (* Will the results for this kf be ultimately displayed *) let display kf = not (Cil.is_unused_builtin (Kernel_function.get_vi kf)) && not (OnlyCurrent.get ()) || (let kfvi = Kernel_function.get_vi kf in List.exists (function | GFun ({svar = fvi},_) | GVarDecl (_, fvi, _) -> Cil_datatype.Varinfo.equal fvi kfvi | _ -> false ) main_ui#file_tree#selected_globals) in let rte_get_all_statuses = !Db.RteGen.get_all_status () in (* All non-filtered RTE statuses for a given function *) let rte_kf kf = List.fold_left (aux_rte kf) [] rte_get_all_statuses in (* Add RTE statuses for all functions. We cannot simply iterate over [by_kf], as functions without any property will not be present in it *) let with_rte = let aux kf acc = if display kf then let props = try !(Kernel_function.Map.find kf by_kf) with Not_found -> Property.Set.empty in (kf, (props, rte_kf kf)) :: acc else acc in Globals.Functions.fold aux [] in (* Sort functions by names *) let cmp (k1, _) (k2, _) = String.compare (Kernel_function.get_name k1) (Kernel_function.get_name k2) in let by_kf = List.sort cmp with_rte in (* Add the properties for all the relevant functions *) List.iter (fun (kf, (ips, rtes)) -> if display kf then begin Property.Set.iter add_ip ips; List.iter append rtes; end ) by_kf in ignore (let callback _ = main_ui#protect ~cancelable:false (fun () -> clear (); Refreshers.apply (); fill_model ()) in refresh_button#connect#released ~callback); (* To fill at startup: let (_:GtkSignal.id) = view#misc#connect#after#realize fill_model in *) let (_:int) = main_ui#lower_notebook#append_page ~tab_label:(GMisc.label ~text:"Properties" ())#coerce (container#coerce) in register_reset_extension (fun _ -> Refreshers.apply ()) (* Graphical markers in text showing the status of properties. Aka. "bullets" in left margin *) let highlighter (buffer:GSourceView2.source_buffer) localizable ~start ~stop = match localizable with | Pretty_source.PIP (Property.IPPredicate (Property.PKAssumes _,_,_,_)) -> (* Assumes clause do not get a bullet: there is nothing to prove about them.*) () | Pretty_source.PIP ppt -> Design.Feedback.mark buffer ~start ~stop (Property_status.Feedback.get ppt) | Pretty_source.PStmt(_,({ skind=Instr(Call(_,e,_,_)) } as stmt)) -> let display ips = if ips <> [] then let ips = List.map snd ips in let validity = Property_status.Feedback.get_conjunction ips in (* Use [start=stop] for a call with a statement contract. Without this, the bullet is put at the beginning of the spec, instead of in front of the call itself *) Design.Feedback.mark buffer ~start:stop ~stop validity in (match e.enode with | Lval (Var vkf, NoOffset) -> let kf = Globals.Functions.get vkf in let ips = Statuses_by_call.all_call_preconditions_at ~warn_missing:false kf stmt in display ips | _ -> (* Try to resolve which functions were called through Value. *) if Db.Value.is_computed () then let _, fs = !Db.Value.expr_to_kernel_function (Kstmt stmt) ~with_alarms:CilE.warn_none_mode ~deps:None e in let ips = Kernel_function.Hptset.fold (fun kf ips -> Statuses_by_call.all_call_preconditions_at ~warn_missing:false kf stmt @ ips) fs [] in display ips else () ) | Pretty_source.PStmt _ | Pretty_source.PGlobal _| Pretty_source.PVDecl _ | Pretty_source.PTermLval _| Pretty_source.PLval _ -> () let extend (main_ui:main_window_extension_points) = make_panel main_ui; main_ui#register_source_highlighter highlighter let () = Design.register_extension extend (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/book_manager.mli0000644000175000017500000000531012155630233020476 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Undocumented. Do not use this module if you don't know what you are doing. *) (* [JS 2011/10/03] Yet useless for the Frama-C platform. It seems to be only used by a CEA private plug-in (AP via LC). To the authors/users of this module: please document it. *) type t val make: ?tab_pos:Gtk.Tags.position -> ?packing:(GObj.widget -> unit) -> unit -> t val get_notebook: t -> GPack.notebook val append_source_tab : t -> string -> GSourceView2.source_view val prepend_source_tab : t -> string -> GSourceView2.source_view val get_nth_page: t -> int -> GObj.widget val current_page: t -> int val last_page: t -> int val set_current_view: t -> int -> unit val get_current_view: t -> GSourceView2.source_view val get_current_index: t -> int val delete_current_view: t -> unit val delete_view: t -> int -> unit val delete_all_views: t -> unit val append_view: t -> GSourceView2.source_view -> unit val get_nth_view: t -> int -> GSourceView2.source_view val enable_popup : t -> bool -> unit val set_scrollable : t -> bool -> unit val length: t -> int (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/filetree.ml0000644000175000017500000006716212155630233017515 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Extlib open Gtk_helper type filetree_node = | File of string * Cil_types.global list | Global of Cil_types.global let same_node n1 n2 = match n1, n2 with | File (f1, _), File (f2, _) -> f1 = f2 | Global g1, Global g2 -> Cil_datatype.Global.equal g1 g2 | _ -> false let _pretty_node fmt = function | File (s, _) -> Format.pp_print_string fmt s | Global (GFun ({svar = vi},_) | GVar(vi,_,_) | GVarDecl(_, vi,_)) -> Format.fprintf fmt "%s" vi.vname | _ -> () class type t = object method model : GTree.model method flat_mode: bool method set_file_attribute: ?strikethrough:bool -> ?text:string -> string -> unit method set_global_attribute: ?strikethrough:bool -> ?text:string -> varinfo -> unit method add_global_filter: text:string -> key:string -> (Cil_types.global -> bool) -> (unit -> bool) * GMenu.check_menu_item method get_file_globals: string -> (string * bool) list method add_select_function : (was_activated:bool -> activating:bool -> filetree_node -> unit) -> unit method append_pixbuf_column: title:string -> (global list -> GTree.cell_properties_pixbuf list) -> (unit -> bool) -> ([`Visibility | `Contents] -> unit) method select_global : Cil_types.global -> bool method selected_globals : Cil_types.global list method view : GTree.view method reset : unit -> unit method register_reset_extension : (t -> unit) -> unit method refresh_columns : unit -> unit end (* crude way to to debug inefficiencies with the gtk interface let c = ref 0 let gtk s = incr c; Format.printf "[%d %s]@." !c s *) module MAKE(TREE:sig type t val sons: t -> t array end) = struct type custom_tree = {finfo: TREE.t; mutable sons: custom_tree array; mutable parent: custom_tree option; fidx: int (* invariant: parent.(fidx)==myself *) } let inbound i a = i>=0 && i None | _ -> if inbound indices.(0) roots then let result = ref (roots.(indices.(0))) in try for depth=1 to Array.length indices - 1 do let index = indices.(depth) in if inbound index !result.sons then result:=!result.sons.(index) else raise Not_found done; Some !result with Not_found -> None else None method custom_get_path (row:custom_tree) : Gtk.tree_path = let current_row = ref row in let path = ref [] in while !current_row.parent <> None do path := !current_row.fidx::!path; current_row := match !current_row.parent with Some p -> p | None -> assert false done; GTree.Path.create ((!current_row.fidx)::!path) method custom_value (_t:Gobject.g_type) (_row:custom_tree) ~column:_ = assert false method custom_iter_next (row:custom_tree) : custom_tree option = let nidx = succ row.fidx in match row.parent with | None -> if inbound nidx roots then Some roots.(nidx) else None | Some parent -> if inbound nidx parent.sons then Some parent.sons.(nidx) else None method custom_iter_children (rowopt:custom_tree option) :custom_tree option = match rowopt with | None -> if inbound 0 roots then Some roots.(0) else None | Some row -> if inbound 0 row.sons then Some row.sons.(0) else None method custom_iter_has_child (row:custom_tree) : bool = Array.length row.sons > 0 method custom_iter_n_children (rowopt:custom_tree option) : int = match rowopt with | None -> Array.length roots | Some row -> Array.length row.sons method custom_iter_nth_child (rowopt:custom_tree option) (n:int) : custom_tree option = match rowopt with | None when inbound n roots -> Some roots.(n) | Some row when inbound n row.sons -> Some (row.sons.(n)) | _ -> None method custom_iter_parent (row:custom_tree) : custom_tree option = row.parent method custom_foreach f = let f p _ = f p (match self#custom_get_iter p with | Some v -> v | None -> assert false) in parent#foreach f method append_tree (t:TREE.t) = let rec make_forest root sons = Array.mapi (fun i t -> let result = {finfo=t; fidx=i; parent = Some root; sons = [||] } in let sons = make_forest result (TREE.sons t) in result.sons<-sons; result) sons in let pos = num_roots in num_roots <- num_roots+1; let root = { finfo = t; sons = [||]; parent = None; fidx = pos } in let sons = make_forest root (TREE.sons t) in root.sons <- sons; roots <- Array.init num_roots (fun n -> if n = num_roots - 1 then root else roots.(n)) method clear () = self#custom_foreach (fun p _ -> self#custom_row_deleted p; false) end let custom_tree () = new custom_tree_class (new GTree.column_list) end module MYTREE = struct type storage = { mutable name : string; mutable globals: global array; mutable strikethrough: bool} type t = MFile of storage*t list | MGlobal of storage let storage_type = function | MFile (s, _) -> File (s.name, Array.to_list s.globals) | MGlobal { globals = [| g |] } -> Global g | MGlobal _ -> assert false let sons t = match t with | MFile (_,s) -> Array.of_list s | MGlobal _ -> [| |] let sons_info = function | MFile (_, l) -> List.map (function | MGlobal { name = n; strikethrough = st } -> (n, st) | MFile _ -> assert false (* should not happen, a file is never under a file in the tree *) ) l | MGlobal _ -> [] let get_storage t = match t with | MFile (s,_) -> s | MGlobal s -> s let is_function_global = function | GFun _ -> true | GVarDecl (_, vi, _) -> Cil.isFunctionType vi.vtype | _ -> false let is_builtin_global = function | GFun ({svar={vattr=attrs}},_) | GVarDecl (_, {vattr=attrs}, _) -> Cil.hasAttribute "FC_BUILTIN" attrs | _ -> false let is_function t = match t with | MFile _ -> false | MGlobal {globals = [| g |]} -> is_function_global g | MGlobal _ -> false let default_storage s globals = { name = s; globals = globals; strikethrough = false; } let ga_name = function | Dfun_or_pred (li, _) -> Some li.l_var_info.lv_name | Dvolatile _ -> Some "volatile clause" | Daxiomatic (s, _, _) -> Some s | Dtype (lti, _) -> Some lti.lt_name | Dlemma (s, _, _, _, _, _) -> Some s | Dinvariant (li, _) -> Some li.l_var_info.lv_name | Dtype_annot (li, _) -> Some li.l_var_info.lv_name | Dmodel_annot (mf, _) -> Some mf.mi_name | Dcustom_annot _ -> Some "custom clause" let make_list_globals hide globs = let l = List.fold_left (* Correct the function sons_info above if a [File] constructor can appear in [sons] *) (fun acc glob -> match glob with | GFun ({svar={vname=name}},_) | GVar({vname=name},_,_) -> if hide glob then acc else MGlobal(default_storage name [|glob|]) :: acc | GVarDecl(_, vi,_) -> (* we have a found the prototype, but there is a definition somewhere else. Skip the prototype. *) if hide glob || (Cil.isFunctionType vi.vtype && Kernel_function.is_definition (Globals.Functions.get vi)) then acc else MGlobal(default_storage vi.vname [|glob|]) :: acc | GAnnot (ga, _) -> if hide glob then acc else (match ga_name ga with | None -> acc | Some s -> MGlobal(default_storage s [|glob|]) :: acc) | _ -> acc) [] globs in let name g = String.lowercase ((get_storage g).name) in let sort = List.sort (fun g1 g2 -> String.compare (name g1) (name g2)) in sort l let make_file hide (display_name, globs) = let storage = default_storage display_name (Array.of_list globs) in let sons = make_list_globals hide globs in storage, sons end module MODEL=MAKE(MYTREE) (* Primitives to handle the filetree menu (which allows to hide some entries) *) module MenusHide = struct let hide key () = Configuration.find_bool ~default:false key let menu_item (menu: GMenu.menu) ~label ~key = let mi = GMenu.check_menu_item ~label () in mi#set_active (hide key ()); menu#add (mi :> GMenu.menu_item); mi let mi_set_callback (mi: GMenu.check_menu_item) ~key reset = mi#connect#toggled ~callback: (fun () -> let v = mi#active in Configuration.set key (Configuration.ConfBool v); reset ()) end let key_flat_mode = "filetree_flat_mode" let flat_mode = MenusHide.hide key_flat_mode module State = struct (* Caching between what is selected in the filetree and the gtk to the gtk node *) type cache = { cache_files: (Gtk.tree_path * MODEL.custom_tree) Datatype.String.Hashtbl.t; cache_vars: (Gtk.tree_path * MODEL.custom_tree) Varinfo.Hashtbl.t; cache_global_annot: (Gtk.tree_path * MODEL.custom_tree) Global_annotation.Hashtbl.t; } let default_cache () = { cache_files = Datatype.String.Hashtbl.create 17; cache_vars = Varinfo.Hashtbl.create 17; cache_global_annot = Global_annotation.Hashtbl.create 17; } let path_from_node cache = function | File (s, _) -> (try Some (Datatype.String.Hashtbl.find cache.cache_files s) with Not_found -> None) | Global (GFun ({svar = vi},_) | GVar(vi,_,_) | GVarDecl(_, vi,_)) -> (try Some (Varinfo.Hashtbl.find cache.cache_vars vi) with Not_found -> None) | Global (GAnnot (ga, _)) -> (try Some (Global_annotation.Hashtbl.find cache.cache_global_annot ga) with Not_found -> None) | _ -> None let fill_cache cache path row = match row.MODEL.finfo with | MYTREE.MFile (storage,_) -> Datatype.String.Hashtbl.add cache.cache_files storage.MYTREE.name (path,row) | MYTREE.MGlobal storage -> match storage.MYTREE.globals with (* Only one element in this array by invariant: this is a leaf*) | [| GFun ({svar=vi},_) | GVar(vi,_,_) | GVarDecl(_,vi,_) |] -> Varinfo.Hashtbl.add cache.cache_vars vi (path,row) | [| GAnnot (ga, _) |] -> Global_annotation.Hashtbl.add cache.cache_global_annot ga (path,row) | _ -> (* no cache for other globals yet *) () let default_filetree () = let m1 = MODEL.custom_tree () in m1, default_cache (), None (* Reference containing, per project, the state of the filetree: - GTK model of the filetree - caching from nodes to paths - node currently selected *) module Ref = State_builder.Ref (Datatype.Make (struct include Datatype.Undefined type t = MODEL.custom_tree_class * cache * filetree_node option let name = "Filetree.FileTree_Datatype" (** Prevent serialization of this state containing closures *) let reprs = [ default_filetree () ] let mem_project = Datatype.never_any_project end)) (struct let name = "Filetree.State" let dependencies = [ Ast.self; Globals.FileIndex.self ] let default = default_filetree end) (* Extract Cil globals. We remove builtins that are not used in this project, as well as files that do not contain anything afterwards *) let cil_files () = let files = Globals.FileIndex.get_files () in let globals_of_file f = let name, all = Globals.FileIndex.find f in let is_unused = function | GFun ({svar = vi},_) | GVarDecl (_, vi, _) | GVar (vi, _, _) -> Cil.is_unused_builtin vi | _ -> false in name, Extlib.filter_out is_unused all in Extlib.filter_map' globals_of_file (fun (_, gl) -> gl <> []) files (** Make and fill the custom model with default values. *) let compute hide_filters = Gui_parameters.debug "Resetting GUI filetree"; let hide g = List.exists (fun filter -> filter g) hide_filters in Ref.clear (); let model, cache, _ = Ref.get () in (* Let's fill up the model with all files and functions. *) let files = cil_files () in if flat_mode () then let files = MYTREE.make_list_globals hide (List.concat (List.map snd files)) in List.iter model#append_tree files else List.iter (fun v -> let name, globals = MYTREE.make_file hide v in model#append_tree (MYTREE.MFile (name, globals))) (List.sort (fun (s1, _) (s2, _) -> String.compare s1 s2) files); (* Let's build the table from globals to rows in the model *) model#custom_foreach (fun path tree -> (*gtk "cache";*) fill_cache cache path tree; false); Ref.mark_as_computed () let get () = if not (Ref.is_computed ()) then compute [] (* Failsafe: everything is shown *); Ref.get () end let make (tree_view:GTree.view) = (* Menu for configuring the filetree *) let menu = GMenu.menu () in let button_menu = GButton.button ~relief:`HALF ~label:"Source file" () in (* Buttons to show/hide variables and/or functions *) let key_hide_variables = "filetree_hide_variables" in let key_hide_functions = "filetree_hide_functions" in let key_hide_builtins = "filetree_hide_builtins" in let key_hide_annotations = "filetree_hide_annotattions" in let hide_variables = MenusHide.hide key_hide_variables in let hide_functions = MenusHide.hide key_hide_functions in let hide_builtins = MenusHide.hide key_hide_builtins in let hide_annotations = MenusHide.hide key_hide_annotations in let initial_filter g = match g with | GFun _ | GVarDecl _ when MYTREE.is_function_global g -> hide_functions () || (if MYTREE.is_builtin_global g then hide_builtins () else false) | GVar _ | GVarDecl _ -> hide_variables () || (if MYTREE.is_builtin_global g then hide_builtins () else false) | GAnnot _ -> hide_annotations () | _ -> false in let mhide_variables = MenusHide.menu_item menu ~label:"Hide variables" ~key:key_hide_variables in let mhide_functions = MenusHide.menu_item menu ~label:"Hide functions" ~key:key_hide_functions in let mhide_builtins = MenusHide.menu_item menu ~label:"Hide built-ins" ~key:key_hide_builtins in let mhide_annotations = MenusHide.menu_item menu ~label:"Hide global annotations" ~key:key_hide_annotations in let mflat_mode = MenusHide.menu_item menu ~label:"Flat mode" ~key:key_flat_mode in (* Initial filetree nodes to display *) State.compute [initial_filter]; let init_model, init_path_cache, _= State.get () in let set_row model ?strikethrough ?text (path,raw_row) = let row = raw_row.MODEL.finfo in may (fun b -> (MYTREE.get_storage row).MYTREE.strikethrough <- b) strikethrough; may (fun b -> (MYTREE.get_storage row).MYTREE.name <- b) text; (* gtk "set_row"; *) model#custom_row_changed path raw_row in let myself = object(self) val mutable reset_extensions = [] val mutable select_functions = [] val mutable path_cache = init_path_cache val mutable model_custom = init_model (* prevent double selection and restore activated path *) val mutable hide_globals_filters = [initial_filter] val mutable force_selection = false (* Forward reference to the first column. Always set *) val mutable source_column = None val mutable columns_visibility = [] method activated = let _, _, n = State.get () in n method refresh_columns () = List.iter (fun f -> f `Visibility) columns_visibility method append_pixbuf_column ~title (f:(global list -> GTree.cell_properties_pixbuf list)) visible = let column = GTree.view_column ~title () in column#set_resizable true; let renderer = GTree.cell_renderer_pixbuf [] in column#pack renderer; column#set_cell_data_func renderer (fun model row -> if visible () then let (path:Gtk.tree_path) = model#get_path row in (* gtk "cell renderer"; *) match model_custom#custom_get_iter path with | Some {MODEL.finfo=v} -> renderer#set_properties (f (Array.to_list((MYTREE.get_storage v).MYTREE.globals))) | None -> ()); ignore (tree_view#append_column column); let filter_active, mi = self#filter_from_column visible title f in (* We return a function showing or masking the column*) let refresh = let prev = ref true in fun r -> let visible = visible () in if !prev != visible then ( (* Column freshly appeared or disappeared. Update it *) prev := visible; column#set_visible visible; mi#misc#set_sensitive visible; (* A filter is active for the column. The visible nodes have probably changed, destroy the filetree and rebuild it *) if filter_active () then self#reset (); ) (* Column state has not changed. If it is visible and its contents have changed, the nodes to display may change *) else if visible && r = `Contents && filter_active () then self#reset () in refresh `Visibility; columns_visibility <- refresh :: columns_visibility; refresh method private filter_from_column col_visible title f = let opt_active = ref (fun () -> false) in let hide_global g = col_visible () && (! opt_active)() && f [g] = [(`STOCK_ID "" : GTree.cell_properties_pixbuf)] in let text = Printf.sprintf "Selected by %s only" title in let key = "filter_" ^ title in let visible, mi = self#add_global_filter ~text ~key hide_global in opt_active := visible; (visible, mi) method view = tree_view method model = model_custom method reset () = self#reset_internal (); self#refresh_columns (); method register_reset_extension f = reset_extensions <- f :: reset_extensions method set_file_attribute ?strikethrough ?text filename = try set_row model_custom ?strikethrough ?text (Datatype.String.Hashtbl.find path_cache.State.cache_files filename) with Not_found -> () (* Some files might not be in the list because of our filters. Ignore *) method set_global_attribute ?strikethrough ?text v = try set_row model_custom ?strikethrough ?text (Varinfo.Hashtbl.find path_cache.State.cache_vars v) with Not_found -> () (* Some globals might not be in the list because of our filters. Ignore *) method flat_mode = flat_mode () method get_file_globals file = try let _, raw_row = Datatype.String.Hashtbl.find path_cache.State.cache_files file in MYTREE.sons_info raw_row.MODEL.finfo with Not_found -> [] (* Some files may be hidden if they contain nothing interesting *) method private enable_select_functions () = let select path path_currently_selected = let fail e = Gui_parameters.error "selector handler got an internal error, please report: %s" (Printexc.to_string e) in try (* gtk "select"; *) let {MODEL.finfo=t} = Extlib.the (model_custom#custom_get_iter path) in let selected_node = MYTREE.storage_type t in let was_activated = match self#activated with | None -> false | Some old_node -> same_node selected_node old_node in if (force_selection || not was_activated) && not path_currently_selected then begin (*Format.printf "##Select %a: %b %b %b, %s@." pretty_node selected_node force_selection was_activated path_currently_selected (GTree.Path.to_string path) *) State.Ref.set (model_custom, path_cache, Some selected_node); let old_force_selection = force_selection in List.iter (fun f -> try f ~was_activated:(not old_force_selection && was_activated) ~activating:true selected_node with e-> fail e) select_functions; end; force_selection <- false; true with e -> Gui_parameters.error "gui could not select row in filetree, please report: %s" (Printexc.to_string e); true in tree_view#selection#set_select_function select method add_select_function f = select_functions <- select_functions@[f]; method private varinfo_of_global g = match g with | GVar (vi, _, _) | GVarDecl (_, vi, _) | GFun ({svar = vi}, _) -> Some vi | _ -> None method unselect = tree_view#selection#unselect_all (); let model, cache, _= State.get () in State.Ref.set (model, cache, None) (* Display a path of the gtk filetree, by expanding and centering the needed nodes *) method private show_path_in_tree path = expand_to_path tree_view path; tree_view#selection#select_path path; tree_view#scroll_to_cell ~align:(0., 0.) path (Extlib.the source_column); tree_view#misc#grab_focus () (* TODO: keep the structure of the tree, ie. reexpand all the nodes that are currently expanded (not only the currently selected) *) method private reset_internal () = (* Save the current selection, to restore it later *) let _, _, prev_active = State.get () in (* We force a full recomputation using our filters for globals *) State.compute hide_globals_filters; let mc,cache,_ = State.get () in tree_view#set_model (Some (mc:>GTree.model)); model_custom <- mc; path_cache <- cache; List.iter (fun f -> f (self :> t)) reset_extensions; State.Ref.set (mc, cache, prev_active); force_selection <- true; match prev_active with | None -> () | Some node -> match State.path_from_node path_cache node with | None -> () | Some (path, _) -> self#show_path_in_tree path; method select_global g = match State.path_from_node path_cache (Global g) with | None -> (* selection failed *) self#unselect; false | Some (path, _) -> self#show_path_in_tree path; true method selected_globals = match self#activated with | None -> [] | Some (File (_, g)) -> g | Some (Global g) -> [g] method add_global_filter ~text ~key f = hide_globals_filters <- f :: hide_globals_filters; let mi = MenusHide.menu_item menu ~label:text ~key in ignore (MenusHide.mi_set_callback mi ~key self#reset_internal); (MenusHide.hide key, mi) initializer (* Source column *) let source_renderer = GTree.cell_renderer_text [`YALIGN 0.0] in let m_source_renderer renderer (lmodel:GTree.model) iter = let (path:Gtk.tree_path) = lmodel#get_path iter in (* gtk "source renderer"; *) match self#model#custom_get_iter path with | Some p -> let special, text, strike, underline = match p.MODEL.finfo with | MYTREE.MFile ({MYTREE.name=m; strikethrough=strike},_) -> if m = "" (* Unknown location *) then true, "Unknown file", strike, false else false, m, strike, false | MYTREE.MGlobal ({MYTREE.name=m; strikethrough=strike}) as s -> false, m, strike, MYTREE.is_function s in renderer#set_properties [ `TEXT text; `STRIKETHROUGH strike; `WEIGHT (if special then `LIGHT else `NORMAL); `UNDERLINE (if underline then `LOW else `NONE) ] | None -> () in let column = GTree.view_column ~title:"Source file" ~renderer:((source_renderer:>GTree.cell_renderer),[]) () in source_column <- Some column; column#set_cell_data_func source_renderer (m_source_renderer source_renderer); column#set_resizable true; column#set_clickable true; column#set_widget (Some button_menu#coerce); ignore (column#connect#clicked ~callback: (fun () -> menu#popup ~button:0 ~time:(GtkMain.Main.get_current_event_time ()); )); ignore (MenusHide.mi_set_callback mhide_functions key_hide_functions self#reset_internal); ignore (MenusHide.mi_set_callback mhide_variables key_hide_variables self#reset_internal); ignore (MenusHide.mi_set_callback mhide_builtins key_hide_builtins self#reset_internal); ignore (MenusHide.mi_set_callback mhide_annotations key_hide_annotations self#reset_internal); ignore (MenusHide.mi_set_callback mflat_mode key_flat_mode self#reset_internal); menu#add (GMenu.separator_item () :> GMenu.menu_item); let _ = tree_view#append_column column in tree_view#set_model (Some (init_model:>GTree.model)); self#enable_select_functions (); end in (myself:>t) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/warning_manager.mli0000644000175000017500000000403612155630233021215 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Handle Frama-C warnings in the GUI. *) type t (** Type of the widget containing the warnings. *) val make : packing:(GObj.widget -> unit) -> callback:(Log.event -> GTree.view_column -> unit) -> t (** Build a new widget for storing the warnings. *) val append: t -> Log.event -> unit (** Append a new message warning. *) val clear: t -> unit (** Clear all the stored warnigns. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/pretty_source.mli0000644000175000017500000000746712155630233021000 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Utilities to pretty print source with located elements in a Gtk TextBuffer. *) open Cil_types (** The kind of object that can be selected in the source viewer. *) type localizable = | PStmt of (kernel_function * stmt) | PLval of (kernel_function option * kinstr * lval) | PTermLval of (kernel_function option * kinstr * term_lval) | PVDecl of (kernel_function option * varinfo) (** Declaration and definition of variables and function. Check the type of the varinfo to distinguish between the various possibilities. *) | PGlobal of global (** all globals but variable declarations and function definitions. *) | PIP of Property.t module Localizable: Datatype.S with type t = localizable module Locs: sig type state (** To call when the source buffer is about to be discarded *) val finalize: state -> unit end val display_source : global list -> GSourceView2.source_buffer -> host:Gtk_helper.host -> highlighter:(localizable -> start:int -> stop:int -> unit) -> selector:(button:int -> localizable -> unit) -> Locs.state (** The selector and the highlighter are always host#protected. The selector will not be called when [not !Gtk_helper.gui_unlocked]. This returns a [state] to pass to the functions defined hereafter. *) val hilite : Locs.state -> unit val locate_localizable : Locs.state -> localizable -> (int*int) option (** @return Some (start,stop) in offset from start of buffer if the given localizable has been displayed according to [Locs.locs]. *) val kf_of_localizable : localizable -> kernel_function option val ki_of_localizable : localizable -> kinstr val varinfo_of_localizable : localizable -> varinfo option val localizable_from_locs : Locs.state -> file:string -> line:int -> localizable list (** Returns the lists of localizable in [file] at [line] visible in the current [Locs.state]. This function is inefficient as it iterates on all the current [Locs.state]. *) val loc_to_localizable: Lexing.position -> localizable option (** return the (hopefully) most precise localizable that contains the given Lexing.position. @since Nitrogen-20111001 *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/menu_manager.ml0000644000175000017500000002772012155630233020350 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) type where = | Toolbar of GtkStock.id * string * string | Menubar of GtkStock.id option * string | ToolMenubar of GtkStock.id * string * string type callback_state = | Unit_callback of (unit -> unit) | Bool_callback of (bool -> unit) * (unit -> bool) type entry = { e_where: where; e_callback: callback_state; e_sensitive: unit -> bool } let toolbar ?(sensitive=(fun _ -> true)) ~icon ~label ?(tooltip=label) callback = { e_where = Toolbar (icon, label, tooltip); e_callback = callback; e_sensitive = sensitive } let menubar ?(sensitive=(fun _ -> true)) ?icon text callback = { e_where = Menubar (icon, text); e_callback = callback; e_sensitive = sensitive } let toolmenubar ?(sensitive=(fun _ -> true)) ~icon ~label ?(tooltip=label) callback = { e_where = ToolMenubar (icon, label, tooltip); e_callback = callback; e_sensitive = sensitive } type button_type = | BStandard of GButton.tool_button | BToggle of GButton.toggle_tool_button let bt_type_as_skel = function | BStandard b -> (b :> GButton.tool_button_skel) | BToggle b -> (b :> GButton.tool_button_skel) type menu_item_type = | MStandard of GMenu.menu_item | MCheck of GMenu.check_menu_item let mitem_type_as_skel = function | MCheck m -> (m :> GMenu.menu_item_skel) | MStandard m -> (m :> GMenu.menu_item_skel) class item ?menu ?menu_item ?button group = object (self) method menu_item = match menu_item with Some (MStandard m) -> Some m | _ -> None method check_menu_item = match menu_item with Some (MCheck m) -> Some m | _ -> None method menu_item_skel = match menu_item with Some m -> Some (mitem_type_as_skel m) | _ -> None method tool_button = match button with Some (BStandard b) -> Some b | _ -> None method toggle_tool_button = match button with Some (BToggle b) -> Some b | _ -> None method tool_button_skel = match button with Some b -> Some (bt_type_as_skel b) | None -> None method add_accelerator modifier c = Extlib.may (fun (i : GMenu.menu_item_skel) -> i#add_accelerator ~group ~flags:[ `VISIBLE ] ~modi:[ modifier ] (int_of_char c)) self#menu_item_skel method menu: GMenu.menu option = menu end (* the analyses-menu will be at the last position of the menubar *) let add_submenu container ~pos label = let item = let packing item = container#insert item ~pos in GMenu.menu_item ~use_mnemonic:true ~packing ~label () in let m = GMenu.menu () in item#set_submenu m; item, m (* external set_menu : Obj.t -> unit = "ige_mac_menu_set_menu_bar" *) class menu_manager ?packing ~host:(_:Gtk_helper.host) = let menubar = GMenu.menu_bar ?packing () in (* let () = set_menu (Obj.field (Obj.repr ((menubar)#as_widget)) 1) in *) let factory = new GMenu.factory menubar in let toolbar = GButton.toolbar ?packing () in object (self) val mutable first_tool_separator = None val analyses_menu = snd (add_submenu menubar ~pos:(-1) "_Analyses") val debug_item_and_menu = add_submenu menubar ~pos:(-1) "_Debug" val mutable debug_actions = [] val mutable menubar_items = [] val mutable toolbar_buttons = [] val mutable set_active_states = [] (** {2 API for plug-ins} *) method add_plugin ?title = self#add_entries ?title analyses_menu method add_debug ?title ?(show=fun () -> true) entries = let items = self#add_entries ?title (snd debug_item_and_menu) entries in let action item = if show () then begin Extlib.may (fun i -> i#misc#show ()) item#menu_item; Extlib.may (fun i -> i#misc#show ()) item#tool_button end else begin Extlib.may (fun i -> i#misc#hide ()) item#menu_item; Extlib.may (fun i -> i#misc#hide ()) item#tool_button end in let l = List.rev debug_actions in Array.iter (fun i -> action i; debug_actions <- (fun () -> action i) :: l) items; items (** {2 High-level API} *) method add_menu ?(pos=List.length menubar#children - 2) s = add_submenu ~pos factory#menu s method add_entries ?title ?pos container entries = (* Toolbar *) let toolbar_pos = (* The first group will be at the end of the toolbar. By default, add all the others just before this very first group. *) ref (match pos, first_tool_separator with | None, None -> 0 | None, Some sep -> max 0 (toolbar#get_item_index sep) | Some p, _ -> p) in let toolbar_packing w = toolbar#insert ~pos:!toolbar_pos w; incr toolbar_pos in let add_tool_separator () = if !toolbar_pos > 0 || first_tool_separator = None then begin let s = GButton.separator_tool_item ~packing:toolbar_packing () in match first_tool_separator with | None -> first_tool_separator <- Some s | Some _ -> () end in let extra_tool_separator () = match pos with | Some 0 -> add_tool_separator () | _ -> () in let add_item_toolbar stock label tooltip callback sensitive = (* let tooltip = try if (GtkStock.Item.lookup stock).GtkStock.label = "" then Some tooltip else None with Not_found -> Some tooltip in *) let b = match callback with | Unit_callback callback -> let b = GButton.tool_button ~label:tooltip ~stock ~packing:toolbar_packing () in b#set_label label; ignore (b#connect#clicked ~callback); BStandard b | Bool_callback (callback, active) -> let b = GButton.toggle_tool_button ~active:(active ()) ~label:tooltip ~stock ~packing:toolbar_packing () in b#set_label tooltip; ignore (b#connect#toggled ~callback:(fun () -> callback b#get_active)); set_active_states <- (fun () -> b#set_active (active ())) :: set_active_states; BToggle b in (bt_type_as_skel b)#set_tooltip (GData.tooltips ()) tooltip ""; toolbar_buttons <- (b, sensitive) :: toolbar_buttons; b in (* Menubar *) let menu_pos = ref (match pos with None -> -1 | Some p -> p) in let container_packing w = container#insert ~pos:!menu_pos w; if !menu_pos <> -1 then incr menu_pos in let (!!) = Lazy.force in let menubar_packing, in_menu = let aux = lazy (* if [title] is not None, we want to create the submenu only once, and late enough *) (match title with | None -> container_packing, container | Some s -> let sub = snd (add_submenu container ~pos:!menu_pos s) in (fun w -> sub#append w), sub ) in lazy (fst !!aux), lazy (snd !!aux) in let add_menu_separator = fun () -> if !menu_pos > 0 || (!menu_pos = -1 && container#children <> []) then ignore (GMenu.separator_item ~packing:container_packing ()) in let add_item_menu stock_opt label callback sensitive = let item = match stock_opt, callback with | None, Unit_callback callback -> let mi = GMenu.menu_item ~packing:!!menubar_packing ~label () in ignore (mi#connect#activate callback); MStandard mi | Some stock, Unit_callback callback -> let image = GMisc.image ~stock () in let mi = (GMenu.image_menu_item ~image ~packing:!!menubar_packing ~label () :> GMenu.menu_item) in ignore (mi#connect#activate callback); MStandard mi | _, Bool_callback (callback, active) -> let mi = GMenu.check_menu_item ~packing:!!menubar_packing ~label ~active:(active ()) () in ignore (mi#connect#activate (fun () -> callback mi#active)); set_active_states <- (fun () -> mi#set_active (active ())) :: set_active_states; MCheck mi in menubar_items <- (item, sensitive) :: menubar_items; item in let extra_menu_separator () = match pos with | Some 0 -> add_menu_separator () | _ -> () in (* Entries *) let add_item { e_where = kind; e_callback = callback; e_sensitive = sensitive} = match kind with | Toolbar(stock, label, tooltip) -> let button = add_item_toolbar stock label tooltip callback sensitive in new item ~button factory#accel_group | Menubar(stock_opt, label) -> let menu_item = add_item_menu stock_opt label callback sensitive in new item ~menu:!!in_menu ~menu_item factory#accel_group | ToolMenubar(stock, label, tooltip) -> let button = add_item_toolbar stock label tooltip callback sensitive in let menu_item = add_item_menu (Some stock) label callback sensitive in new item ~menu:!!in_menu ~menu_item ~button factory#accel_group in let edit_menubar = List.exists (function { e_where = Menubar _ | ToolMenubar _ } -> true | _ -> false) entries in let edit_toolbar = List.exists (function { e_where = Toolbar _ | ToolMenubar _ } -> true | _ -> false) entries in if edit_menubar then add_menu_separator (); if edit_toolbar then add_tool_separator (); let entries = List.map add_item entries in if edit_menubar then extra_menu_separator (); if edit_toolbar then extra_tool_separator (); Array.of_list entries method set_sensitive b = List.iter (fun (i, f) -> (bt_type_as_skel i)#misc#set_sensitive (b && f ())) toolbar_buttons; List.iter (fun (i, f) -> (mitem_type_as_skel i)#misc#set_sensitive (b && f())) menubar_items (** {2 Low-level API} *) method factory = factory method menubar = menubar method toolbar = toolbar method refresh () = List.iter (fun (i, f) -> (bt_type_as_skel i)#misc#set_sensitive (f ())) toolbar_buttons; List.iter (fun (i, f) -> (mitem_type_as_skel i)#misc#set_sensitive (f())) menubar_items; List.iter (fun f -> f ()) set_active_states; initializer let reset () = self#refresh (); List.iter (fun f -> f ()) debug_actions; let debug_item = fst debug_item_and_menu in if !Plugin.positive_debug_ref > 0 then debug_item#misc#show () else debug_item#misc#hide () in reset (); Db.Main.extend reset end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/menu_manager.mli0000644000175000017500000001457112155630233020521 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Handle the menubar and the toolbar. @since Boron-20100401 *) (** Where to put a new entry. @since Boron-20100401 *) type where = | Toolbar of GtkStock.id * string * string (** Label then tooltip *) | Menubar of GtkStock.id option (** Stock used for the icon *) * string (** Label *) | ToolMenubar of GtkStock.id * string * string (** Label then tooltip *) (** Callback for the buttons that can be in the menus. Standard buttons/menus have a callback with no argument. Buttons/menus with states are displayed with checkboxes in menus, or as toggle buttons in toolbars. They receive the after-click state as argument. The state of the button with the second argument of [Bool_callback]. Currently checks menus cannot have images in Gtk, sor the [GtkStock.id] fields of [where] are ignored. @since Nitrogen-20111001 *) type callback_state = | Unit_callback of (unit -> unit) | Bool_callback of (bool -> unit) * (unit -> bool) (** @since Boron-20100401 @modify Nitrogen-20111001 *) type entry = private { e_where: where; e_callback: callback_state (** callback called when the button is clicked *); e_sensitive: unit -> bool (** should the button be activated when the gui is refreshed *); } (** {2 Smart constructors for menu entries.} If not supplied, the [active] parameter is the function that always returns [true]. @since Nitrogen-20111001 *) val toolbar: ?sensitive:(unit -> bool) -> icon:GtkStock.id -> label:string -> ?tooltip:string -> callback_state -> entry val menubar: ?sensitive:(unit -> bool) -> ?icon:GtkStock.id -> string -> callback_state -> entry val toolmenubar: ?sensitive:(unit -> bool) -> icon:GtkStock.id -> label:string -> ?tooltip:string -> callback_state -> entry (** The item type corresponding to an entry. @since Boron-20100401 *) class type item = object method menu_item: GMenu.menu_item option (** @since Boron-20100401 *) method check_menu_item: GMenu.check_menu_item option (** @since Nitrogen-20111001 *) method menu_item_skel: GMenu.menu_item_skel option (** @since Nitrogen-20111001 *) method menu: GMenu.menu option (** Return the menu in which the item has been inserted, if meaningful @since Nitrogen-20111001 *) method add_accelerator: Gdk.Tags.modifier -> char -> unit (** Add an accelerator iff there is a menu item. @since Boron-20100401 *) method tool_button: GButton.tool_button option (** @since Boron-20100401 *) method toggle_tool_button: GButton.toggle_tool_button option (** @since Nitrogen-20111001 *) method tool_button_skel: GButton.tool_button_skel option (** @since Nitrogen-20111001 *) end (** How to handle a Frama-C menu. @since Boron-20100401 *) class menu_manager: ?packing:(GObj.widget -> unit) -> host:Gtk_helper.host -> object (** {2 API for plug-ins} *) method add_plugin: ?title:string -> entry list -> item array (** Add entries dedicated to a plug-in. If [title] is specified, then the entries are added in a dedicated sub-menu of name [title]. The elements of the returned array are in the same order that the ones in the input list. @since Boron-20100401 *) method add_debug: ?title:string -> ?show:(unit -> bool) -> entry list -> item array (** Add entries to the menu dedicated to debugging tools. If [title] is specified, then the entries are added in a dedicated sub-menu of name [title]. If [show] is specified, then the entries are only shown when this function returns [true] (it returns [true] by default). The elements of the returned array are in the same order that the ones in the input list. @since Boron-20100401 *) (** {2 High-level API} *) method add_menu: ?pos:int -> string -> GMenu.menu_item * GMenu.menu (** @since Boron-20100401 *) method add_entries: ?title:string -> ?pos:int -> GMenu.menu -> entry list -> item array (** Add entries in the given menu. If [title] is specified, then the entries are added in a dedicated sub-menu of name [title]. The elements of the returned array are in the same order that the ones in the input list. @since Boron-20100401 *) method set_sensitive: bool -> unit (** Set the sensitive property of all the entries. @since Boron-20100401 *) (** {2 Low-level API} *) method factory: GMenu.menu_shell GMenu.factory (** @since Boron-20100401 *) method menubar: GMenu.menu_shell (** @since Boron-20100401 *) method toolbar: GButton.toolbar (** @since Boron-20100401 *) method refresh: unit -> unit (** Reset the activation state of the buttons @since Nitrogen-20111001 *) end (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/source_manager.mli0000644000175000017500000000432212155630233021046 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** The source viewer multi-tabs widget window. *) type t val make: ?tab_pos:Gtk.Tags.position -> ?packing:(GObj.widget -> unit) -> unit -> t val load_file: t -> ?title:string -> filename:string -> ?line:int -> unit -> unit (** If [line] is 0 then the last line of the text is shown. If [line] is less that 0 then no scrolling occurs (default). If [title] is not provided the page title is the filename. *) val select_file: t -> string -> unit (** Selection by page filename *) val select_name: t -> string -> unit (** Selection by page title *) val clear : t -> unit (** Remove all pages added by [load_file] *) frama-c-Fluorine-20130601/src/gui/debug_manager.mli0000644000175000017500000000330112155630233020630 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Nothing exported. Automatic registration. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/gui/pretty_source.ml0000644000175000017500000006754612155630233020633 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Format open Cil_types open Gtk_helper open Cil_datatype (** The kind of object that can be selected in the source viewer *) type localizable = | PStmt of (kernel_function * stmt) | PLval of (kernel_function option * kinstr * lval) | PTermLval of (kernel_function option * kinstr * term_lval) | PVDecl of (kernel_function option * varinfo) | PGlobal of global | PIP of Property.t module Localizable = Datatype.Make (struct include Datatype.Undefined type t = localizable let name = "Pretty_source.Localizable" let reprs = List.map (fun g -> PGlobal g) Global.reprs let equal l1 l2 = match l1,l2 with | PStmt (_,ki1), PStmt (_,ki2) -> ki1.sid = ki2.sid | PLval (_,ki1,lv1), PLval (_,ki2,lv2) -> Kinstr.equal ki1 ki2 && lv1 == lv2 | PTermLval (_,ki1,lv1), PTermLval (_,ki2,lv2) -> Kinstr.equal ki1 ki2 && Logic_utils.is_same_tlval lv1 lv2 (* [JS 2008/01/21] term_lval are not shared: cannot use == *) | PVDecl (_,v1), PVDecl (_,v2) -> Varinfo.equal v1 v2 | PIP ip1, PIP ip2 -> Property.equal ip1 ip2 | PGlobal g1, PGlobal g2 -> Cil_datatype.Global.equal g1 g2 | (PStmt _ | PLval _ | PTermLval _ | PVDecl _ | PIP _ | PGlobal _), _ -> false let mem_project = Datatype.never_any_project let pretty fmt = function | PStmt (_, s) -> Format.fprintf fmt "LocalizableStmt %d (%a)" s.sid Printer.pp_location (Cil_datatype.Stmt.loc s) | PLval (_, ki, lv) -> Format.fprintf fmt "LocalizableLval %a (%a)" Printer.pp_lval lv Cil_datatype.Location.pretty (Cil_datatype.Kinstr.loc ki) | PTermLval (_, ki, tlv) -> Format.fprintf fmt "LocalizableTermLval %a (%a)" Printer.pp_term_lval tlv Cil_datatype.Location.pretty (Cil_datatype.Kinstr.loc ki) | PVDecl (_, vi) -> Format.fprintf fmt "LocalizableVDecl %a" Printer.pp_varinfo vi | PGlobal g -> Format.fprintf fmt "LocalizableGlobal %a" Printer.pp_global g | PIP ip -> Format.fprintf fmt "LocalizableIP %a" Description.pp_property ip end) let kf_of_localizable loc = match loc with | PLval (kf_opt, _, _) | PTermLval(kf_opt, _,_) | PVDecl (kf_opt, _) -> kf_opt | PStmt (kf, _) -> Some kf | PIP ip -> Property.get_kf ip | PGlobal (GFun ({svar = vi}, _)) -> Some (Globals.Functions.get vi) | PGlobal _ -> None let ki_of_localizable loc = match loc with | PLval (_, ki, _) | PTermLval(_, ki,_) -> ki | PVDecl (_, _) -> Kglobal | PStmt (_, st) -> Kstmt st | PIP ip -> Property.get_kinstr ip | PGlobal _ -> Kglobal let varinfo_of_localizable loc = match kf_of_localizable loc with | Some kf -> Some (Kernel_function.get_vi kf) | None -> match loc with | PGlobal (GVar (vi, _, _) | GVarDecl (_, vi, _) | GFun ({svar = vi }, _)) -> Some vi | _ -> None module Locs:sig type state val add: state -> int * int -> localizable -> unit val iter : state -> (int * int -> localizable -> unit) -> unit val create : unit -> state val find : state -> int -> (int * int) * localizable val hilite : state -> unit val set_hilite : state -> (unit -> unit) -> unit val add_finalizer: state -> (unit -> unit) -> unit val finalize: state -> unit val size : state -> int end = struct type state = { table : (int*int,localizable) Hashtbl.t; mutable hiliter : unit -> unit; mutable finalizers: (unit -> unit) list; } let create () = {table = Hashtbl.create 97; hiliter = (fun () -> ()); finalizers = []; } let hilite state = state.hiliter () let set_hilite state f = state.hiliter <- f let add_finalizer state f = state.finalizers <- f :: state.finalizers let finalize state = List.iter (fun f -> f ()) (List.rev state.finalizers) (* Add a location range only if it is not already there. Visually only the innermost pretty printed entity is kept. For example: 'loop assigns x;' will be indexed as an assigns and not as a code annotation. *) let add state loc v = if not (Hashtbl.mem state.table loc) then Hashtbl.add state.table loc v let find state p = let best = ref None in let update ((b,e) as loc) sid = if b <= p && p <= e then match !best with | None -> best := Some (loc, sid) | Some ((b',e'),_) -> if e-b < e'-b' then best := Some (loc, sid) in Hashtbl.iter update state.table ; match !best with None -> raise Not_found | Some (loc,sid) -> loc, sid let iter state f = (*Kernel.debug "Iterate on %d locations" (Hashtbl.length locs);*) Hashtbl.iter f state.table (*Kernel.debug "DONE: Iterate on %d locations" (Hashtbl.length locs);*) let size state = Hashtbl.length state.table end let hilite state = Locs.hilite state module LocsArray:sig type t val create: Locs.state -> t val length : t -> int val get : t -> int -> (int * int) * localizable val find_next : t -> int -> (localizable -> bool) -> int end = struct (* computes an ordered array containing all the elements of a Locs.state, the order (<) being such that loc1 < loc2 if either loc1 starts before loc2, or loc1 and loc2 start at the same position but loc1 spawns further than loc2. *) type t = ((int*int) * localizable option) array let create state = let arr = Array.make (Locs.size state) ((0,0), None) in let index = ref 0 in Locs.iter state (fun (pb,pe) v -> Array.set arr !index ((pb,pe), Some v) ; incr index ) ; Array.sort (fun ((pb1,pe1),_) ((pb2,pe2),_) -> if (pb1 = pb2) then if (pe1 = pe2) then 0 else (* most englobing comes first *) Pervasives.compare pe2 pe1 else Pervasives.compare pb1 pb2 ) arr ; arr let length arr = Array.length arr (* get loc at index i; raises Not_found if none exists *) let get arr i = if i >= Array.length arr then raise Not_found else match Array.get arr i with | ((_,_),None) -> raise Not_found | ((pb,pe),Some v) -> ((pb,pe),v) (* find the next loc in array starting at index i which satifies the predicate; raises Not_found if none exists *) let find_next arr i predicate = let rec fnext i = let ((pb',_pe'),v) = get arr i in if predicate v then pb' else fnext (i+1) in fnext i end module Tag = struct exception Wrong_decoder let make_modem charcode = let h = Hashtbl.create 17 in let current = ref 0 in (function lv -> incr current; Hashtbl.add h !current lv; sprintf "%c%x" charcode !current), (function code -> Scanf.sscanf code "%c%x" (fun c code -> if c=charcode then try Hashtbl.find h code with Not_found -> assert false else raise Wrong_decoder)) let encode_stmt,decode_stmt = make_modem 's' let encode_lval,decode_lval = make_modem 'l' let encode_termlval,decode_termlval = make_modem 't' let encode_vdecl,decode_vdecl = make_modem 'd' let encode_global,decode_global = make_modem 'g' let encode_ip,decode_ip = make_modem 'i' let create = function | PStmt sid -> encode_stmt sid | PLval lval -> encode_lval lval | PTermLval lval -> encode_termlval lval | PVDecl vi -> encode_vdecl vi | PGlobal g -> encode_global g | PIP ip -> encode_ip ip let get s = try PStmt (decode_stmt s) with Wrong_decoder -> try PLval (decode_lval s) with Wrong_decoder -> try PTermLval (decode_termlval s) with Wrong_decoder -> try PVDecl (decode_vdecl s) with Wrong_decoder -> try PGlobal (decode_global s) with Wrong_decoder -> try PIP (decode_ip s) with Wrong_decoder -> assert false end class tagPrinterClass : Printer.extensible_printer = object(self) inherit Printer.extensible_printer () as super method private current_kinstr = match self#current_stmt with | None -> Kglobal | Some st -> Kstmt st method private current_sid = match super#current_stmt with | None -> assert false | Some st -> st.sid method private current_kf = match super#current_function with | None -> None | Some fd -> Some (Globals.Functions.get fd) val mutable localize_predicate = true (* wrap all identified predicates *) val mutable current_ca = None method private current_behavior_or_loop = match current_ca with None -> Property.Id_behavior (Extlib.the self#current_behavior) | Some ca -> Property.Id_code_annot ca method next_stmt next fmt current = Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PStmt (Extlib.the self#current_kf,current))) (super#next_stmt next) current method lval fmt lv = match self#current_kinstr with | Kglobal -> super#lval fmt lv (* Do not highlight the lvals in initializers. *) | Kstmt _ as ki -> Format.fprintf fmt "@{<%s>" (Tag.create (PLval (self#current_kf,ki,lv))); (match lv with | Var vi, (Field _| Index _ as o) -> (* Small hack to be able to click on the arrays themselves in the easy cases *) self#lval fmt (Var vi, NoOffset); self#offset fmt o | _ -> super#lval fmt lv ); Format.fprintf fmt "@}" method term_lval fmt lv = (* similar to pLval *) match self#current_kinstr with | Kglobal -> super#term_lval fmt lv (* Do not highlight the lvals in initializers. *) | Kstmt _ as ki -> Format.fprintf fmt "@{<%s>" (Tag.create (PTermLval (self#current_kf,ki,lv))); (match lv with | TVar vi, (TField _| TIndex _ as o) -> self#term_lval fmt (TVar vi, TNoOffset); self#term_offset fmt o | _ -> super#term_lval fmt lv ); Format.fprintf fmt "@}" method vdecl fmt vi = Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PVDecl (self#current_kf,vi))) super#vdecl vi method code_annotation fmt ca = match ca.annot_content with | APragma p when not (Logic_utils.is_property_pragma p) -> (* Not currently localizable. Will be linked to the next stmt *) super#code_annotation fmt ca | AAssert _ | AInvariant _ | APragma _ | AVariant _ -> let ip = Property.ip_of_code_annot_single (Extlib.the self#current_kf) (Extlib.the self#current_stmt) ca in localize_predicate <- false; Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PIP ip)) super#code_annotation ca; localize_predicate <- true | AStmtSpec _ -> (* tags will be set in the inner nodes. *) super#code_annotation fmt ca | AAllocation _ | AAssigns _ -> (* tags will be set in the inner nodes. *) current_ca <- Some ca; super#code_annotation fmt ca; current_ca <- None method global fmt g = match g with (* these globals are already covered by PVDecl *) | GVarDecl _ | GVar _ | GFun _ -> super#global fmt g | _ -> Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PGlobal g)) super#global g method requires fmt p = localize_predicate <- false; let b = Extlib.the self#current_behavior in Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PIP (Property.ip_of_requires (Extlib.the self#current_kf) self#current_kinstr b p))) super#requires p; localize_predicate <- true method behavior fmt b = Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PIP (Property.ip_of_behavior (Extlib.the self#current_kf) self#current_kinstr b))) super#behavior b method decreases fmt t = localize_predicate <- false; Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PIP (Property.ip_of_decreases (Extlib.the self#current_kf) self#current_kinstr t))) super#decreases t; localize_predicate <- true method terminates fmt t = localize_predicate <- false; Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PIP (Property.ip_of_terminates (Extlib.the self#current_kf) self#current_kinstr t))) super#terminates t; localize_predicate <- true method complete_behaviors fmt t = Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PIP (Property.ip_of_complete (Extlib.the self#current_kf) self#current_kinstr t))) super#complete_behaviors t method disjoint_behaviors fmt t = Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PIP (Property.ip_of_disjoint (Extlib.the self#current_kf) self#current_kinstr t))) super#disjoint_behaviors t method assumes fmt p = localize_predicate <- false; let b = Extlib.the self#current_behavior in Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PIP (Property.ip_of_assumes (Extlib.the self#current_kf) self#current_kinstr b p))) super#assumes p; localize_predicate <- true method post_cond fmt pc = localize_predicate <- false; let b = Extlib.the self#current_behavior in Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PIP (Property.ip_of_ensures (Extlib.the self#current_kf) self#current_kinstr b pc))) super#post_cond pc; localize_predicate <- true method assigns s fmt a = match Property.ip_of_assigns (Extlib.the self#current_kf) self#current_kinstr self#current_behavior_or_loop a with None -> super#assigns s fmt a | Some ip -> Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PIP ip)) (super#assigns s) a method from s fmt ((_, f) as from) = match f with | FromAny -> super#from s fmt from | From _ -> let ip = Property.ip_of_from (Extlib.the self#current_kf) self#current_kinstr self#current_behavior_or_loop from in Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PIP ip)) (super#from s) from method global_annotation fmt a = match Property.ip_of_global_annotation_single a with | None -> super#global_annotation fmt a | Some ip -> Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PIP ip)) super#global_annotation a method allocation ~isloop fmt a = match Property.ip_of_allocation (Extlib.the self#current_kf) self#current_kinstr self#current_behavior_or_loop a with None -> super#allocation ~isloop fmt a | Some ip -> localize_predicate <- true; Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PIP ip)) (super#allocation ~isloop) a; localize_predicate <- false; initializer force_brace <- true (* Not used anymore: all identified predicates are selectable somewhere up - assert and loop invariants are PCodeAnnot - contracts members have a dedicated tag. *) (* method pIdentified_predicate fmt ip = if localize_predicate then Format.fprintf fmt "@{<%s>%a@}" (Tag.create (PPredicate (self#current_kf,self#current_kinstr,ip))) super#identified_predicate ip else super#identified_predicate fmt ip *) end exception Found of int*int (* This function identifies two distinct localizable that happen to have the same location in the source code, typically because one of them is not printed. Feel free to add other heuristics if needed. *) let equal_or_same_loc loc1 loc2 = Localizable.equal loc1 loc2 || match loc1, loc2 with | PIP (Property.IPReachable (_, Kstmt s, _)), PStmt (_, s') | PStmt (_, s'), PIP (Property.IPReachable (_, Kstmt s, _)) when Cil_datatype.Stmt.equal s s' -> true | PIP (Property.IPReachable (Some kf, Kglobal, _)), (PVDecl (_, vi) | PGlobal (GFun ({ svar = vi }, _))) | (PVDecl (_, vi) | PGlobal (GFun ({ svar = vi }, _))), PIP (Property.IPReachable (Some kf, Kglobal, _)) when Kernel_function.get_vi kf = vi -> true | _ -> false let locate_localizable state loc = try Locs.iter state (fun (b,e) v -> if equal_or_same_loc v loc then raise (Found(b,e))); None with Found (b,e) -> Some (b,e) let localizable_from_locs state ~file ~line = let loc_localizable = function | PStmt (_,st) | PLval (_,Kstmt st,_) | PTermLval(_,Kstmt st,_) -> Stmt.loc st | PIP ip -> (match Property.get_kinstr ip with | Kglobal -> (match Property.get_kf ip with None -> Location.unknown | Some kf -> Kernel_function.get_location kf) | Kstmt st -> Stmt.loc st) | PVDecl (_,vi) -> vi.vdecl | PGlobal g -> Global.loc g | (PLval _ | PTermLval _) as localize -> (match kf_of_localizable localize with | None -> Location.unknown | Some kf -> Kernel_function.get_location kf) in let r = ref [] in Locs.iter state (fun _ v -> let loc,_ = loc_localizable v in if line = loc.Lexing.pos_lnum && loc.Lexing.pos_fname = file then r := v::!r); !r let buffer_formatter state source = let starts = Stack.create () in let emit_open_tag s = (* Kernel.debug "EMIT TAG";*) Stack.push (source#end_iter#offset, Tag.get s) starts; "" in let emit_close_tag _s = (try let (p,sid) = Stack.pop starts in Locs.add state (p, source#end_iter#offset) sid with Stack.Empty -> Gui_parameters.debug "empty stack in emit_tag"); "" in let gtk_fmt = Gtk_helper.make_formatter source in Format.pp_set_tags gtk_fmt true; Format.pp_set_print_tags gtk_fmt false; Format.pp_set_mark_tags gtk_fmt true; Format.pp_set_formatter_tag_functions gtk_fmt {(Format.pp_get_formatter_tag_functions gtk_fmt ()) with Format.mark_open_tag = emit_open_tag; Format.mark_close_tag = emit_close_tag;}; Format.pp_set_margin gtk_fmt 79; gtk_fmt let display_source globals (source:GSourceView2.source_buffer) ~(host:Gtk_helper.host) ~highlighter ~selector = let state = Locs.create () in (* let highlighter _ ~start:_ ~stop:_ = () in *) host#protect ~cancelable:false (fun () -> Gtk_helper.refresh_gui (); source#set_text ""; source#remove_source_marks ~start:source#start_iter ~stop:source#end_iter (); let hiliter () = let event_tag = Gtk_helper.make_tag source ~name:"events" [] in Gtk_helper.cleanup_all_tags source; let locs_array = LocsArray.create state in let index_max = LocsArray.length locs_array in let index = ref 0 in while(!index < index_max) do ( try let ((pb,pe),v) = LocsArray.get locs_array !index in Gtk_helper.refresh_gui (); match v with | PStmt (_,ki) -> (try let pb,pe = match ki with | {skind = Instr _ | Return _ | Goto _ | Break _ | Continue _} -> pb,pe | {skind = If _ | Loop _ | Switch _ } -> (* These statements contain other statements. We highlight only until the start of the first included statement. *) pb, (try LocsArray.find_next locs_array (!index+1) (fun p -> match p with | PStmt _ -> true | _ -> false (* Do not stop on expressions*)) with Not_found -> pb+1) | {skind = Block _ | TryExcept _ | TryFinally _ | UnspecifiedSequence _} -> pb, (try LocsArray.find_next locs_array (!index+1) (fun _ -> true) with Not_found -> pb+1) in highlighter v ~start:pb ~stop:pe with Not_found -> ()) | PTermLval _ | PLval _ | PVDecl _ | PGlobal _ | PIP _ -> highlighter v ~start:pb ~stop:pe with Not_found -> () ) ; incr index done; (* Kernel.debug "Highlighting done (%d occurrences)" (Locs.size ());*) (* React to events on the text *) source#apply_tag ~start:source#start_iter ~stop:source#end_iter event_tag; (* Kernel.debug "Event tag done";*) in Locs.set_hilite state hiliter; (* Kernel.debug "Display source starts";*) let gtk_fmt = buffer_formatter state (source:>GText.buffer) in let tagPrinter = new tagPrinterClass in let display_global g = Gtk_helper.refresh_gui (); tagPrinter#global gtk_fmt g; Format.pp_print_flush gtk_fmt () in (* Kernel.debug "Before Display globals %d" (List.length globals);*) let counter = ref 0 in begin try List.iter (fun g -> incr counter; if !counter > 20 then raise Exit; display_global g) globals; with Exit -> Format.fprintf gtk_fmt "@.<>@." !counter; (*let ca = source#create_child_anchor source#end_iter in source_view#add_child_at_anchor (GButton.button ~text:"See 10 more globals" ~callback:(fun _ -> call_cc next_10) ()) ca *) end; (* Kernel.debug "Displayed globals";*) source#place_cursor source#start_iter; (* Highlight the localizable *) hiliter (); let last_shown_area = Gtk_helper.make_tag source ~name:"last_shown_area" [`BACKGROUND "light green"] in let event_tag = Gtk_helper.make_tag source ~name:"events" [] in let id = event_tag#connect#event ~callback: (fun ~origin:_ ev it -> if !Gtk_helper.gui_unlocked then if GdkEvent.get_type ev = `BUTTON_PRESS then begin let coords = GtkText.Iter.get_offset it in try let ((pb,pe), selected) = Locs.find state coords in (* Highlight the pointed term *) source#remove_tag ~start:source#start_iter ~stop:source#end_iter last_shown_area; apply_tag source last_shown_area pb pe; let event_button = GdkEvent.Button.cast ev in let button = GdkEvent.Button.button event_button in host#protect ~cancelable:false (fun () -> selector ~button selected); with Not_found -> () (* no statement at this offset *) end; false) in Locs.add_finalizer state (fun () -> GtkSignal.disconnect event_tag#as_tag id); ); state module LineToLocalizable = Datatype.Hashtbl(Datatype.Int.Hashtbl)(Datatype.Int) (struct let module_name = "Pretty_source.LineToLocalizable" end) module FileToLines = Datatype.Hashtbl(Datatype.String.Hashtbl)(Datatype.String) (struct let module_name = "Pretty_source.FilesToLine" end) module MappingLineLocalizable = struct module LineToLocalizableAux = LineToLocalizable.Make( Datatype.Pair(Location)(Localizable)) include State_builder.Hashtbl(FileToLines)(LineToLocalizableAux) (struct let size = 5 let dependencies = [Ast.self] let name = "Pretty_source.line_to_localizable" end) end class pos_to_localizable = object (self) inherit Visitor.frama_c_inplace method add_range loc (localizable : localizable) = if not (Location.equal loc Location.unknown) then ( let p1, p2 = loc in assert (p1.Lexing.pos_fname = p2.Lexing.pos_fname); let file = p1.Lexing.pos_fname in let hfile = try MappingLineLocalizable.find file with Not_found -> let h = LineToLocalizable.create 17 in MappingLineLocalizable.add file h; h in for i = p1.Lexing.pos_lnum to p2.Lexing.pos_lnum do LineToLocalizable.add hfile i (loc, localizable); done ); method vstmt_aux s = Gui_parameters.debug ~level:3 "Locs for Stmt %d" s.sid; self#add_range (Stmt.loc s) (PStmt (Extlib.the self#current_kf, s)); Cil.DoChildren method vglob_aux g = Gui_parameters.debug ~level:3 "Locs for global %a" Printer.pp_global g; (match g with | GFun ({ svar = vi }, loc) -> self#add_range loc (PVDecl (Some (Globals.Functions.get vi), vi)) | GVar (vi, _, loc) -> self#add_range loc (PVDecl (None, vi)) | GVarDecl (_, vi, loc) -> if Cil.isFunctionType vi.vtype then self#add_range loc (PVDecl (Some (Globals.Functions.get vi), vi)) else self#add_range loc (PVDecl (None, vi)) | _ -> self#add_range (Global.loc g) (PGlobal g) ); Cil.DoChildren end let loc_to_localizable loc = if not (MappingLineLocalizable.is_computed ()) then ( Gui_parameters.debug "Computing inverse locs"; let vis = new pos_to_localizable in Visitor.visitFramacFile (vis :> Visitor.frama_c_visitor) (Ast.get ()); MappingLineLocalizable.mark_as_computed (); ); try (* Find the mapping from this file to locs-by-line *) let hfile = MappingLineLocalizable.find loc.Lexing.pos_fname in (* Find the localizable for this line *) let all = LineToLocalizable.find_all hfile loc.Lexing.pos_lnum in (* Try to a find the good localizable. When we have more than one matches with the exact same location, we pick the last one in the list. This will be the first statement that has been encountered, and this criterion seems to work well with temporaries introduced by Cil *) let last l = match List.rev l with [] -> None | (_, loc) :: _ -> Some loc in (match all, List.filter (fun ((loc', _), _) -> loc = loc') all with | [], _ -> None | _, (_ :: _ as exact) -> last exact (* a pos exactly corresponds *) | (l, _) :: __, [] -> (* No exact loc. We consider the innermost statements, ie those at the top of the list *) last (List.filter (fun (l', _) -> Location.equal l l') all) ) with Not_found -> Gui_parameters.debug "No pretty-printed loc found"; None (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/users/0000755000175000017500000000000012155634040015725 5ustar mehdimehdiframa-c-Fluorine-20130601/src/users/users_register.ml0000644000175000017500000001105512155630223021325 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** @plugin development guide *) include Plugin.Register (struct let name = "users" let shortname = "users" let help = "function callees" end) (** @plugin development guide *) module ForceUsers = False (struct let option_name = "-users" let help = "compute function callees" end) open Db module Users = Kernel_function.Make_Table (Kernel_function.Hptset) (struct let name = "Users" let size = 17 let dependencies = [ Value.self; ForceUsers.self ] end) let call_for_users (_state, call_stack) = match call_stack with | [] -> assert false | (current_function, _call_site) :: tail -> if tail = [] then begin (* End of Value analysis, we record that Users has run. We should not do this after the explicit call to Db.Value.compute later in this file, as Value can run on its own and execute Users while doing so.*) Users.mark_as_computed () end; let treat_element (user, _call_site) = ignore (Users.memo ~change:(Kernel_function.Hptset.add current_function) (fun _ -> Kernel_function.Hptset.singleton current_function) user) in List.iter treat_element tail let add_value_hook () = Db.Value.Call_Value_Callbacks.extend_once call_for_users let init () = if ForceUsers.get () then add_value_hook () 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 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.with_dependencies Db.Value.self) () end else feedback ~level:2 "requiring the computation of the value analysis"; add_value_hook (); !Db.Value.compute (); find kf end let () = Db.register (Db.Journalize("Users.get", Datatype.func Kernel_function.ty Kernel_function.Hptset.ty)) Db.Users.get get let print () = if ForceUsers.get () then result "@[====== 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 "@[%a: %a@]@ " Kernel_function.pretty kf (Pretty_utils.pp_iter ~pre:"" ~sep:"@ " ~suf:"" Kernel_function.Hptset.iter Kernel_function.pretty) callees)) let print_once, _self_print = State_builder.apply_once "Users_register.print" [ Users.self ] print let () = Db.Main.extend print_once (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/users/Users.mli0000644000175000017500000000336412155630223017536 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* $Id: Users.mli,v 1.5 2008-04-01 09:25:22 uid568 Exp $ *) (** Users analysis. *) (** No function is directly exported: they are registered in {!Db.Users}. *) frama-c-Fluorine-20130601/src/sparecode/0000755000175000017500000000000012155634040016531 5ustar mehdimehdiframa-c-Fluorine-20130601/src/sparecode/Sparecode.mli0000644000175000017500000000330112155630224021136 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Sparecode analysis. *) (** No function is directly exported: they are registered in !Db.Sparecode. *) frama-c-Fluorine-20130601/src/sparecode/globs.ml0000644000175000017500000001525112155630224020175 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 let dkey = Sparecode_params.register_category "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 let used_typeinfo = Hashtbl.create 257 let used_compinfo = Hashtbl.create 257 let used_enuminfo = Hashtbl.create 257 let clear_tables () = Hashtbl.clear used_variables; Hashtbl.clear var_init; Hashtbl.clear used_typeinfo; Hashtbl.clear used_compinfo; Hashtbl.clear used_enuminfo class collect_visitor = object (self) inherit Visitor.frama_c_inplace method vtype t = match t with | TNamed(ti,_) -> (* we use the type name because directe typeinfo comparision * doesn't wok. Anyway, CIL renames types if several type have the same * name... *) if Hashtbl.mem used_typeinfo ti.tname then SkipChildren else begin debug "add used typedef %s@." ti.tname; Hashtbl.add used_typeinfo ti.tname (); ignore (visitCilType (self:>Cil.cilVisitor) ti.ttype); DoChildren end | TEnum(ei,_) -> if Hashtbl.mem used_enuminfo ei.ename then SkipChildren else begin 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 "add used comp %s@." ci.cname; Hashtbl.add used_compinfo ci.cname (); List.iter (fun f -> ignore (visitCilType (self:>Cil.cilVisitor) f.ftype)) ci.cfields; DoChildren end | _ -> DoChildren method vvrbl v = if v.vglob && not (Hashtbl.mem used_variables v) then begin debug "add used var %s@." v.vname; Hashtbl.add used_variables v (); ignore (visitCilType (self:>Cil.cilVisitor) v.vtype); try let init = Hashtbl.find var_init v in ignore (visitCilInit (self:>Cil.cilVisitor) v NoOffset init) with Not_found -> () end; DoChildren method vglob_aux g = match g with | GFun (f, _) -> debug "add function %s@." f.svar.vname; Hashtbl.add used_variables f.svar (); Cil.DoChildren | GAnnot _ -> Cil.DoChildren | GVar (v, init, _) -> 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 end class filter_visitor prj = object inherit Visitor.generic_frama_c_visitor (Cil.copy_visit prj) method vglob_aux g = match g with | GFun (_f, _loc) (* function definition *) -> Cil.DoChildren (* keep everything *) | GVar (v, _, _loc) (* variable definition *) | GVarDecl (_, v, _loc) -> (* variable/function declaration *) if Hashtbl.mem used_variables v then DoChildren else begin debug "remove var %s@." v.vname; ChangeTo [] end | GType (ti, _loc) (* typedef *) -> if Hashtbl.mem used_typeinfo ti.tname then DoChildren else begin 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 "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 "remove enum %s@." ei.ename; DoChildren (* ChangeTo [] *) end | _ -> Cil.DoChildren end module Result = State_builder.Hashtbl (Datatype.String.Hashtbl) (Project.Datatype) (struct let name = "Sparecode without unused globals" let size = 7 let dependencies = [ Ast.self ] (* delayed, see below *) end) let () = Cmdline.run_after_extended_stage (fun () -> State_dependency_graph.add_codependencies ~onto:Result.self [ !Db.Pdg.self; !Db.Outputs.self_external ]) let rm_unused_decl = Result.memo (fun new_proj_name -> clear_tables (); let visitor = new collect_visitor in Visitor.visitFramacFileSameGlobals 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 = Plugin.get_selection_context () in Project.copy ~selection:ctx new_prj; new_prj) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/sparecode/sparecode_params.ml0000644000175000017500000000455512155630224022404 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.Register (struct let name = "sparecode" let shortname = "sparecode" let help = "code cleaner" end) module Analysis = False(struct let option_name = "-sparecode" let help = "perform a spare code analysis" end) let () = Analysis.add_aliases ["-sparecode-analysis"] module Annot = True(struct let option_name = "-sparecode-annot" let help = "select more things to keep every reachable annotation" end) module GlobDecl = False(struct let option_name = "-rm-unused-globals" let help = ("only remove unused global types and variables "^ "(automatically done by -sparecode-analysis)") end) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/sparecode/marks.mli0000644000175000017500000000375012155630224020356 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 type proj type fct val select_useful_things : select_annot:bool -> select_slice_pragma:bool -> kernel_function -> proj val get_marks : proj -> kernel_function -> fct option val key_visible : fct -> PdgIndex.Key.t -> bool (** Useful mainly if there has been some Pdg.Top *) val kf_visible : proj -> kernel_function -> bool (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/sparecode/register.ml0000644000175000017500000001227212155630224020713 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** {2 Internal State} *) module Result_pair = Datatype.Pair_with_collections(Datatype.Bool)(Datatype.Bool) (struct let module_name = "Sparecode.Register.Result_pair.t" end) module Result = State_builder.Hashtbl (Datatype.Hashtbl (Result_pair.Hashtbl) (Result_pair) (struct let module_name = "Sparecode" end)) (Project.Datatype) (struct let name = "Sparecode" let size = 7 let dependencies = [ Ast.self; Db.Value.self ] (* delayed, see below *) end) let () = Cmdline.run_after_extended_stage (fun () -> State_dependency_graph.add_codependencies ~onto:Result.self [ !Db.Pdg.self; !Db.Outputs.self_external ]) module P = Sparecode_params (** {2 State_builder} *) let unjournalized_rm_unused_globals new_proj_name project = P.feedback "remove unused global declarations from project '%s'" (Project.get_name project); P.result "removed unused global declarations in new project '%s'" new_proj_name; Project.on project Globs.rm_unused_decl new_proj_name let journalized_rm_unused_globals = Journal.register "!Db.Sparecode.rm_unused_globals" (Datatype.func2 ~label1:("new_proj_name", None) Datatype.string ~label2:("project", Some Project.current) Project.ty Project.ty) 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 journalized_rm_unused_globals new_proj_name project let run select_annot select_slice_pragma = P.feedback "remove unused code..."; (*let initial_file = Ast.get () in*) let kf_entry, _library = Globals.entry_point () 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..."; 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 = Plugin.get_selection_context () in Project.copy ~selection:ctx new_prj; new_prj let journalized_get = Journal.register "!Db.Sparecode.get" (Datatype.func2 ~label1:("select_annot", None) Datatype.bool ~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)) (* add labels *) let get ~select_annot ~select_slice_pragma = journalized_get select_annot select_slice_pragma (** {2 Initialisation of the sparecode plugin } *) let () = (* journalization already done. *) Db.register Db.Journalization_not_required Db.Sparecode.get get; Db.register Db.Journalization_not_required Db.Sparecode.rm_unused_globals rm_unused_globals let main () = if Sparecode_params.Analysis.get () then begin let select_annot = Sparecode_params.Annot.get () in let select_slice_pragma = true in let new_proj = !Db.Sparecode.get select_annot select_slice_pragma in File.pretty_ast ~prj:new_proj () end else if Sparecode_params.GlobDecl.get () then begin let new_proj = rm_unused_globals () in File.pretty_ast ~prj:new_proj () end let () = Db.Main.extend main (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/sparecode/marks.ml0000644000175000017500000003423112155630224020203 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let debug n format = Sparecode_params.debug ~level:n format let fatal fmt = Sparecode_params.fatal fmt (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (** 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 type t = bool * prop_mode type call_info = unit let bottom = false,Loc let top = true,Glob let visible (b,_) = b let mk glob = if glob then top else (true, Loc) let merge (b1,p1) (b2,p2) = let b = b1 || b2 in let p = match p1, p2 with | Glob, _ | _, Glob -> Glob | Loc, Loc -> Loc in (b, p) let equal (b1,p1:t) (b2,p2) = (b1 = b2) && (p1 = p2) let combine old_m new_m = let new_m = merge old_m new_m in let m_to_prop = if equal old_m new_m then bottom else new_m in (new_m, m_to_prop) let is_bottom b = (b = bottom) let pretty fmt (b,p) = Format.fprintf fmt "%s(%s)" (if b then "true" else "false") (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 * their inputs. We will check calls later on. * But when we select annotations, we want to preserve all the calls that can * lead to them : so, we propagate... * *) let call_in_to_check = ref [] let called_top = ref [] module Config = struct 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 := (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 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@." end module ProjBoolMarks = Pdg.Register.F_Proj (Config) type proj = ProjBoolMarks.t * unit KfTopVisi.t type fct = ProjBoolMarks.fct let new_project () = (ProjBoolMarks.empty (), KfTopVisi.create 10) (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (** 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 match key with | PdgIndex.Key.CallStmt call_id -> let call = PdgIndex.Key.call_from_id call_id in call_visible fm call | _ -> let m = PdgIndex.FctIndex.find_info fm key in 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 (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (** 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 | [] -> 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 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, * but they are not automatically propagated because when a function is visible * it doesn't mean that all the calls to that function are visible. * * So we first split the todo list ([!call_in_to_check]) into the nodes to mark * which correspond to inputs of visible calls * and the others that do not yet correspond to visible call * but we keep them because it can happen later *) let rec process_call_inputs proj = let rec process (to_select, unused) todo = match todo with | [] -> (to_select, unused) | (pdg_caller, call, sel, m) as e :: calls -> let kf_caller = PdgTypes.Pdg.get_kf pdg_caller in let visible, select = match call with | Some call -> let fm = match get_marks proj kf_caller with | None -> fatal "the caller should have marks@." | Some fm -> fm in 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); KfTopVisi.get proj kf_caller, None in let res = if visible then let to_select = add_pdg_selection to_select pdg_caller select in (to_select, unused) else (to_select, e::unused) in process res calls in let to_select, new_list = process ([], []) !call_in_to_check in match to_select with | [] -> call_in_to_check := [] (* nothing more to mark : finished ! we can forget [new_list] *) | _ -> call_in_to_check := new_list; List.iter (fun (pdg, sel) -> select_pdg_elements proj pdg sel) to_select; process_call_inputs proj (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (** Main selection: select starting points and propagate. *) (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) 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 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 * can be visible *) class annot_visitor ~filter pdg = object (self) inherit Visitor.frama_c_inplace val mutable to_select = [] method get_select = to_select method vcode_annot annot = let () = if filter annot then try let stmt = Extlib.the self#current_stmt in debug 1 "selecting annotation : %a @." Printer.pp_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 Not_found -> () (* unreachable *) in Cil.SkipChildren end let select_annotations ~select_annot ~select_slice_pragma proj = let visit_fun kf = 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 | Cil_types.AAssert _-> (* Never select alarms, they are not useful *) (match Alarms.find annot with | None -> select_annot | Some _ -> false) | _ -> 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 finalize proj = debug 1 "finalize call input propagation@."; process_call_inputs proj; assert (!call_in_to_check = []) 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 %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: *) frama-c-Fluorine-20130601/src/sparecode/sparecode_params.mli0000644000175000017500000000364012155630224022547 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.S module Analysis: Plugin.Bool (** Whether to perform spare code detection or not. *) module Annot : Plugin.Bool (** keep more things to keep all reachable annotations. *) module GlobDecl : Plugin.Bool (** remove unused global types and variables *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/sparecode/transform.ml0000644000175000017500000001443712155630224021107 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 module BoolInfo = struct type proj = Marks.proj type fct = Marks.fct option * Kernel_function.t exception EraseAssigns exception EraseAllocation let fct_info project kf = match Marks.get_marks project kf with | None -> if Marks.kf_visible project kf then [None, kf] else [] | Some fm -> [Some fm, kf] let key_visible txt fm key = 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 -> 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 in try ignore (Visitor.visitFramacTerm visitor t); true with M.Invisible -> false let body_visible _fm = true 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 annot = Db.Value.is_reachable_stmt stmt && Alarms.find annot = None (* Keep annotations on reachable, but not alarms: they can be resynthesized, and the alarms table is not synchronized in the new project anyway *) (* TODO: does not seem really coherent with the fact that almost everything else in the logic is cleared... *) let fun_precond_visible _ _p = (* TODO : we say that they are removed in order to get correct results, * but in fact, we should select them ! *) false let fun_postcond_visible _ _p = (* TODO : we say that they are removed in order to get correct results, * but in fact, we should select them ! *) false let fun_variant_visible _ _p = (* TODO : we say that they are removed in order to get correct results, * but in fact, we should select them ! *) false let fun_frees_visible _ _b = (* TODO : we say that they are removed in order to get correct results, * but in fact, we should select them ! *) false let fun_allocates_visible _ _b = (* TODO : we say that they are removed in order to get correct results, * but in fact, we should select them ! *) false let fun_assign_visible fm_kf (b,_) = (* [VP 2011-02-01] Removing all assigns is incorrect! this would lead to say assigns \nothing for all functions. *) term_visible fm_kf b.it_content let fun_deps_visible fm_kf t = term_visible fm_kf t.it_content let res_call_visible (fm,_) call_stmt = let key = PdgIndex.Key.call_outret_key call_stmt in 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 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 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_Statement -> true let cond_edge_visible _ s = Db.Value.condition_truth_value s end module Info = Filter.F (BoolInfo) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/impact/0000755000175000017500000000000012155634040016041 5ustar mehdimehdiframa-c-Fluorine-20130601/src/impact/pdg_aux.ml0000644000175000017500000001050012155630240020014 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 PdgIndex (** [find_call_input_nodes pdg_caller s ?z input] find all the nodes of [pdg_caller] that define the pdg input [input] above the call statement [s]. If [input] is an implicit input, its value is refined according to [z]. *) (* Copied from pdg/sets.ml, as it is currently not exported *) let find_call_input_nodes pdg_caller call_stmt ?(z=Locations.Zone.top) in_key = match in_key with | PdgIndex.Signature.InCtrl | PdgIndex.Signature.InNum _ -> let idx = PdgTypes.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 ] | PdgIndex.Signature.InImpl zone -> let zone' = Locations.Zone.narrow zone z in let nodes, _undef = !Db.Pdg.find_location_nodes_at_stmt pdg_caller call_stmt ~before:true zone' in nodes let node_undef_list_to_set = List.fold_left (fun set (n, _) -> PdgTypes.NodeSet.add n set) PdgTypes.NodeSet.empty let all_call_input_nodes pdg_caller (kf_callee, pdg_callee) call_stmt = let real_inputs = let inout = !Db.Operational_inputs.get_internal_precise ~stmt:call_stmt kf_callee in inout.Inout_type.over_inputs_if_termination in let test_in acc (in_key, in_node) = let default ?z () = let in_nodes = find_call_input_nodes pdg_caller call_stmt ?z in_key in let in_nodes = node_undef_list_to_set in_nodes in (in_node, in_nodes) :: acc in match in_key with | Signature.InCtrl | Signature.InNum _ -> default () | Signature.InImpl z -> if Locations.Zone.intersects z real_inputs then default ~z:real_inputs () else acc in try let sgn = FctIndex.sgn (PdgTypes.Pdg.get_index pdg_callee) in PdgIndex.Signature.fold_all_inputs test_in [] sgn with PdgTypes.Pdg.Top -> Options.warning ~source:(fst (Cil_datatype.Stmt.loc call_stmt)) ~once:true "skipping impact within imprecisely analyzed function %a" Kernel_function.pretty kf_callee; [] let all_call_out_nodes pdg_called pdg_caller call_stmt = try let _, call_sgn = FctIndex.find_call (PdgTypes.Pdg.get_index pdg_caller) call_stmt in let test_out acc (out_key, call_out_node) = let out_nodes, _ = !Db.Pdg.find_output_nodes pdg_called out_key in let out_nodes = node_undef_list_to_set out_nodes in (call_out_node, out_nodes) :: acc in PdgIndex.Signature.fold_all_outputs test_out [] call_sgn with PdgTypes.Pdg.Top -> Options.warning ~source:(fst (Cil_datatype.Stmt.loc call_stmt)) ~once:true "cannot propagate impact into imprecisely analyzed caller function %a" Kernel_function.pretty (Kernel_function.find_englobing_kf call_stmt); [] frama-c-Fluorine-20130601/src/impact/Impact.mli0000644000175000017500000000336712155630240017770 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* $Id: Impact.mli,v 1.1 2008-04-08 14:59:02 uid568 Exp $ *) (** Impact analysis. *) (** No function is directly exported: they are registered in {!Db.Impact}. *) frama-c-Fluorine-20130601/src/impact/options.ml0000644000175000017500000000563712155630240020077 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.Register (struct let name = "impact" let shortname = "impact" let help = "impact analysis (experimental)" end) module Pragma = StringSet (struct let option_name = "-impact-pragma" let arg_name = "f1, ..., fn" let help = "use the impact pragmas in the code of functions f1,...,fn" end) module Print = False (struct let option_name = "-impact-print" let help = "print the impacted stmt" end) module Reason = False (struct let option_name = "-impact-graph" let help = "build a graph that explains why a statement is in the set \ of impacted nodes" end) module Slicing = False (struct let option_name = "-impact-slicing" let help = "slice from the impacted stmt" end) module Skip = StringSet (struct let arg_name = "v1,...,vn" let help = "consider that those variables are not impacted" let option_name = "-impact-skip" end) let () = Plugin.set_negative_option_name "-impact-not-in-callers" module Upward = True (struct let option_name = "-impact-in-callers" let help = "compute compute impact in callers as well as in callees" end) let is_on () = not (Pragma.is_empty ()) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/impact/compute_impact.mli0000644000175000017500000000452112155630240021555 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 type nodes = PdgTypes.NodeSet.t type result = nodes Kernel_function.Map.t val initial_nodes: skip:Locations.Zone.t -> kernel_function -> stmt -> PdgTypes.Node.t list val impacted_nodes: ?skip:Locations.Zone.t -> ?reason:bool -> kernel_function -> stmt list -> result * (** Initial *) nodes Kernel_function.Map.t * Reason_graph.reason val impacted_stmts: ?skip:Locations.Zone.t -> reason:bool -> kernel_function -> stmt list -> stmt list val result_to_nodes: result -> PdgTypes.NodeSet.t val nodes_to_stmts: nodes -> stmt list val impact_in_kf: result -> Cil_types.kernel_function -> nodes val skip: unit -> Locations.Zone.t (** computed from the option [-impact-skip] *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/impact/register_gui.mli0000644000175000017500000000342112155630240021232 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Extension of the GUI for the impact plugin. *) (** No function is directly exported: this module simply extends the GUI. *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/impact/compute_impact.ml0000644000175000017500000006616212155630240021415 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Db open PdgIndex open Reason_graph (** Computation of the PDG nodes that are impacted by the "execution" of some initial PDG nodes. This is implemented as a forward inter-procedural analysis on top of the PDG plugin. *) module NS = PdgTypes.NodeSet type nodes = NS.t module NM = PdgTypes.Node.Map module KFS = Kernel_function.Hptset module KFM = Kernel_function.Map let kfmns_find_default key m = try KFM.find key m with Not_found -> NS.empty (* Data associated to PDG nodes that are impacted, and that have not been treated yet. *) type todo = { kf: kernel_function (* kernel_function in which the node can be found *); pdg: Pdg.t (* pdg of this kernel_function *); init: bool (* is this node in the worklist only because it is part of the nodes initially selected as source? The initial nodes are not in the final result, but must be present in intermediate results for technical reasons *); } (* Nodes that are impacted, and that will have to be considered at some point.*) and todolist = todo NM.t (* All nodes that have been found to be impacted. Presented as a map from Kf, because this information cannot be recovered from the PDG nodes. (Also, this speeds up somes operations *) type result = nodes KFM.t (* Modelization of a call. The first function (the caller) calls the second (the callee) at the given statement. *) module KfKfCall = Datatype.Triple_with_collections (Kernel_function)(Kernel_function)(Cil_datatype.Stmt) (struct let module_name = "Impact.Compute.KfKfCall" end) (** Worklist maintained by the plugin to build its results *) type worklist = { mutable todo: todolist (** nodes that are impacted, but that have not been propagated yet. *); mutable result: result (** impacted nodes. This field only grows. An invariant is that nodes in [todolist] are not already in [result], except with differing [init] fields. *); mutable downward_calls: (PdgTypes.Node.t * nodes) list KfKfCall.Map.t (** calls for which an input may be impacted. If so, we must compute the impact within the called function. For each call, we associate to each PDG input of the callee the nodes that define the input in the caller. The contents of this field grow. *); mutable callers: KFS.t (** all the callers of the functions in which the initial nodes are located. Constant after initialization, used to initialize [upward_calls] below. *); mutable upward_calls: (PdgTypes.Node.t * nodes) list Lazy.t KfKfCall.Map.t (** calls for which an output may be impacted. If so, we must compute the impact after the call in the caller (which is part of the [callers] field by construction). For each output node at the call point in the caller, associate all the nodes of the callee that define this output. The field is lazy: if the impact "dies" before before reaching the call, we may avoid a costly computation. Constant once initialized. *); mutable fun_changed_downward: KFS.t (** Functions in which a new pdg node has been found since the last iteration. The impact on downward calls with those callers will have to be computed again. *); mutable fun_changed_upward: KFS.t (** Functions in which a new pdg node has been found. The impact on upward calls to those callees will have to be computed again. *); mutable skip: Locations.Zone.t (** Locations for which the impact is dismissed. Nodes that involve only those zones are skipped. Constant after initialization *); mutable initial_nodes: nodes KFM.t (** Nodes that are part of the initial impact query, or directly equivalent to those (corresponding nodes in a caller). *); mutable unimpacted_initial: nodes KFM.t (** Initial nodes (as defined above) that are not "self-impacting" so far. Those nodes will not be part of the final results. *); mutable reason: reason (** Reasons why nodes in [result] are marked as impacted. *); compute_reason: bool (** compute the field [reason]; may be costly *); } (** Extract the node of the kf that are only part of the initial impact *) let unimpacted_initial_by_kf wl kf = kfmns_find_default kf wl.unimpacted_initial (** Extract the current results for a given function *) let result_by_kf wl kf = kfmns_find_default kf wl.result (* -------------------------------------------------------------------------- *) (* --- Adding nodes to the worklist, or to the results --- *) (* -------------------------------------------------------------------------- *) (** Mark that [n] comes from an indirect impact, ie. remove it from the set of initial nodes that are not impacted. *) let remove_from_unimpacted_initial wl kf n = let unimpacted = unimpacted_initial_by_kf wl kf in if NS.mem n unimpacted then begin Options.debug ~level:2 "node of initial impact %a is indirectly impacted" PdgTypes.Node.pretty n; wl.unimpacted_initial <- KFM.add kf (NS.remove n unimpacted) wl.unimpacted_initial; end ;; (** Add a node to the sets of impacted nodes. Update the various fields of the worklist that need it. [init] indicates that the node is added only because it belongs to the set of initial nodes. *) let add_to_result wl n kf init = if init = false then remove_from_unimpacted_initial wl kf n; (* if useful, mark that a new node was found in [kf] *) if not (KFS.mem kf wl.fun_changed_downward) then (* wl.fun_changed_upward is not updated, because we merge wl.fun_changed_downward with wl.fun_changed_upward when needed *) wl.fun_changed_downward <- KFS.add kf wl.fun_changed_downward; let set = result_by_kf wl kf in let s' = NS.add n set in wl.result <- KFM.add kf s' wl.result (** return [true] if the location in [n] is contained in [skip], in which case the node should be skipped entirely *) (* TODO: For nodes InNum, we should evaluate the corresponding formal and see if its value matches [skip]. *) let node_to_skip skip n = match !Pdg.node_key n with | Key.SigKey (Signature.In (Signature.InImpl z)) | Key.SigKey (Signature.Out (Signature.OutLoc z)) | Key.SigCallKey (_, Signature.In (Signature.InImpl z)) | Key.SigCallKey (_, Signature.Out (Signature.OutLoc z)) -> Locations.Zone.equal Locations.Zone.bottom (Locations.Zone.diff z skip) | _ -> false (** Auxiliary function, used to refuse some nodes that should not go in the results *) let filter wl n = match !Pdg.node_key n with | Key.SigKey (Signature.In Signature.InCtrl) -> false (* do not consider node [InCtrl] TODO: find when this may happen *) | Key.VarDecl _ -> false (* do not consider variable declarations. This is probably impossible in a forward analysis anyway. *) | _ -> if node_to_skip wl.skip n then ( Options.debug ~once:true ~level:2 "skipping node %a as required" PdgTypes.Node.pretty n; false) else true (** Add a new edge in the graph explaining the results *) let add_to_reason wl ~nsrc ~ndst rt = if wl.compute_reason && filter wl ndst then let reason = Reason.Set.add (nsrc, ndst, rt) wl.reason in wl.reason <- reason ;; (** Add some nodes to the [todo] field of the worklist, while enforcing some invariants. Some kind of pdg nodes must not appear in it, plus the nodes must not be in result already. *) let add_to_do_aux ~init wl kf pdg n = if filter wl n then let pp fmt = Format.fprintf fmt "node %a (in %a)" PdgTypes.Node.pretty n Kernel_function.pretty kf; in let add () = let todo = { kf = kf; pdg = pdg; init = init } in wl.todo <- NM.add n todo wl.todo in try let cur = NM.find n wl.todo in (* Node is already in the todo list. Check init field *) if cur.init = true && init = false then begin (* overwrite the existing binding in the todo list *) Options.debug ~level:2 "todo list node %t is now init=false" pp; add (); end with Not_found -> (* Node is not in todo list. Check if it is already in results *) if NS.mem n (result_by_kf wl kf) then begin (* Already in results. Check if [init] flag matches. *) if init = false && NS.mem n (unimpacted_initial_by_kf wl kf) then begin (* Node was already there with [init=true]. Compute impact again with [init=false] *) Options.debug ~level:2 "adding again node %t, with init=false" pp; add () end end else begin (* General case *) Options.debug ~level:2 "adding %t" pp; add () end ;; (** Build the initial value of the [todo] field, from a list of initial nodes *) let initial_to_do_list wl kf pdg nodes = List.iter (fun n -> add_to_do_aux true wl kf pdg n) nodes (** Mark a new node as impacted, and simultaneouly mark that it is equivalent to nodes that are all initial nodes *) let add_to_do_part_of_initial wl kf pdg n = add_to_do_aux ~init:true wl kf pdg n; let initial_nodes = kfmns_find_default kf wl.initial_nodes in if not (NS.mem n initial_nodes) then begin (* n has never been marked as initial. Mark it in both initial and unimpacted_initial fields (it may leave the second later) *) Options.debug ~level:2 "node %a is a part of the initial impact" PdgTypes.Node.pretty n; let unimpacted_kf = unimpacted_initial_by_kf wl kf in let new_unimpacted = NS.add n unimpacted_kf in let new_initial = NS.add n initial_nodes in wl.unimpacted_initial <- KFM.add kf new_unimpacted wl.unimpacted_initial; wl.initial_nodes <- KFM.add kf new_initial wl.initial_nodes; end ;; (** From now on, most functions will pass [init = false] to [add_to_do_aux]. We define an alias instead *) let add_to_do = add_to_do_aux ~init:false (* -------------------------------------------------------------------------- *) (* --- Basic propagation --- *) (* -------------------------------------------------------------------------- *) (** Purely intra-procedural propagation from one impacted node. Just follow the PDG once, for all kind of dependencies. *) let intraprocedural_one_node wl node kf pdg = PdgTypes.Pdg.fold_direct_codpds pdg (fun () (dpd, _zopt) n -> add_to_reason wl ~nsrc:node ~ndst:n (Intraprocedural dpd); add_to_do wl kf pdg n; ) () node; Options.debug ~level:3 "intraprocedural part done" (* -------------------------------------------------------------------------- *) (* --- Downward call propagation --- *) (* -------------------------------------------------------------------------- *) (** Add a downward call to the worklist the first time it is encountered. This functions implicitly caches the mapping from the PDG nodes of the caller to the ones of the callee, as this information is expensive to compute *) let add_downward_call wl (caller_kf, pdg) (called_kf, called_pdg) stmt = if not (KfKfCall.Map.mem (caller_kf, called_kf, stmt) wl.downward_calls) then let deps = Pdg_aux.all_call_input_nodes pdg (called_kf, called_pdg) stmt in wl.downward_calls <- KfKfCall.Map.add (caller_kf, called_kf, stmt) deps wl.downward_calls (** Propagate impact from node [node] if it corresponds to a call statement. This is a partially inter-procedural propagation: some nodes of the callee are directly in the worklist, and the call is registered in the field [downward_calls]. *) let downward_one_call_node wl node caller_kf pdg = match !Pdg.node_key node with | Key.SigKey (Signature.In Signature.InCtrl) (* never in the worklist *) | Key.VarDecl _ (* never in the worklist *) | Key.CallStmt _ (* pdg returns a SigCallKey instead *) -> assert false | Key.SigKey _ | Key.Stmt _ | Key.Label _ -> (* Only intraprocedural part needed, done by [intraprocedural_one_node] *) () | Key.SigCallKey(id, key) -> let stmt = Key.call_from_id id in let called_kfs = Value.call_to_kernel_function stmt in KFS.iter (fun called_kf -> let called_pdg = !Pdg.get called_kf in let nodes_callee, pdg_ok = Options.debug ~level:3 "%a: considering call to %a" PdgTypes.Node.pretty node Kernel_function.pretty called_kf; try (match key with | Signature.In (Signature.InNum n) -> (try [!Pdg.find_input_node called_pdg n] with Not_found -> []) | Signature.In Signature.InCtrl -> (try [!Pdg.find_entry_point_node called_pdg] with Not_found -> []) | Signature.In (Signature.InImpl _) -> assert false | Signature.Out _ -> [] ), true with | Pdg.Top -> Options.warning "no precise pdg for function %s. \n\ Ignoring this function in the analysis (potentially incorrect results)." (Kernel_function.get_name called_kf); [], false | Pdg.Bottom -> (*Function that fails or never returns immediately *) [], false | Not_found -> assert false in Options.debug ~level:4 "Direct call nodes %a" (Pretty_utils.pp_list ~sep:" " PdgTypes.Node.pretty) nodes_callee; List.iter (fun n -> add_to_reason wl ~nsrc:node ~ndst:n InterproceduralDownward; add_to_do wl called_kf called_pdg n ) nodes_callee; if pdg_ok then add_downward_call wl (caller_kf, pdg) (called_kf, called_pdg) stmt ) called_kfs; Options.debug ~level:3 "propagation of call %a done" PdgTypes.Node.pretty node (** Propagate impact for one call registered in [downward_calls]. If the set of impacted nodes in the caller intersect the nodes [deps] that define the input [node] of the call, add [node] to the impacted nodes. *) let downward_one_call_inputs wl kf_caller kf_callee (node, deps) = Options.debug ~level:3 "Inputs from call %a -> %a" Kernel_function.pretty kf_caller Kernel_function.pretty kf_callee; let results_for_kf_caller = result_by_kf wl kf_caller in if NS.intersects deps results_for_kf_caller then let inter = NS.inter deps results_for_kf_caller in NS.iter (fun nsrc -> add_to_reason wl ~nsrc ~ndst:node InterproceduralDownward) inter; add_to_do wl kf_callee (!Db.Pdg.get kf_callee) node; Options.debug ~level:3 "call done" (** Propagate impact for all calls registered in [downward_calls]. For each caller, if new impacted nodes have been found, try to propagate the call. Then, zero out the list of functions that must be considered again. *) let downward_calls_inputs wl = let aux (kf_caller, kf_callee, _stmt) ldeps = if KFS.mem kf_caller wl.fun_changed_downward then List.iter (downward_one_call_inputs wl kf_caller kf_callee) ldeps in KfKfCall.Map.iter aux wl.downward_calls; wl.fun_changed_downward <- KFS.empty (* -------------------------------------------------------------------------- *) (* --- Upward call propagation --- *) (* -------------------------------------------------------------------------- *) (** Fill out the field [upward_calls] of the worklist. This is done by visiting (transitively) all the callers of functions in [kfs], and registering all the calls found this way. The callers found are added to the field [callers]. For each find, we find the nodes of the callee that define a given output in the caller using [Pdg_aux.all_call_out_nodes]. [kfs] must be all the functions containing the initial nodes of the analysis. *) let all_upward_callers wl kfs = let aux_call (caller, pdg_caller) (callee, pdg_callee) callsite = Options.debug ~level:2 ~source:(fst (Cil_datatype.Stmt.loc callsite)) "Found call %a -> %a" Kernel_function.pretty caller Kernel_function.pretty callee; let nodes = lazy (Pdg_aux.all_call_out_nodes pdg_callee pdg_caller callsite) in wl.upward_calls <- KfKfCall.Map.add (caller, callee, callsite) nodes wl.upward_calls in let rec fixpoint todo = try let kf = KFS.choose todo in let todo = KFS.remove kf todo in let todo = if not (KFS.mem kf wl.callers) then ( Options.debug "Found caller %a" Kernel_function.pretty kf; let pdg_kf = !Pdg.get kf in List.fold_left (fun todo (caller, callsites) -> let pdg_caller = !Pdg.get caller in List.iter (aux_call (caller, pdg_caller) (kf, pdg_kf)) callsites; KFS.add caller todo ) todo (!Value.callers kf); ) else todo in wl.callers <- KFS.add kf wl.callers; fixpoint todo with Not_found -> () in fixpoint kfs (** Upward propagation in all the callers. For all upward-registered calls, find if new impacted nodes have been found in the callee. If so, check if they intersect with the nodes of the callee defining the output. Then, mark the (caller) output node as impacted. At the end, zero out the list of function that must be examined again. *) let upward_in_callers wl = let aux (caller, callee, _callsite) l = if KFS.mem callee wl.fun_changed_upward then List.iter (fun (n, nodes) -> let results_for_callee = result_by_kf wl callee in if NS.intersects nodes results_for_callee then let inter = NS.inter nodes results_for_callee in NS.iter (fun nsrc -> add_to_reason wl ~nsrc ~ndst:n InterproceduralUpward ) inter; let unimpacted_callee = unimpacted_initial_by_kf wl callee in let init = NS.for_all(fun n -> NS.mem n unimpacted_callee) inter in if init then add_to_do_part_of_initial wl caller (!Pdg.get caller) n else add_to_do wl caller (!Pdg.get caller) n ) (Lazy.force l) in KfKfCall.Map.iter aux wl.upward_calls; wl.fun_changed_upward <- KFS.empty (* -------------------------------------------------------------------------- *) (* --- Initialization --- *) (* -------------------------------------------------------------------------- *) (** Compute the initial state of the worklist. *) let initial_worklist ?(skip=Locations.Zone.bottom) ?(reason=false) nodes kf = let initial = KFM.add kf (List.fold_left (fun s n -> NS.add n s) NS.empty nodes) KFM.empty; in let wl = { todo = NM.empty; result = KFM.empty; downward_calls = KfKfCall.Map.empty; callers = KFS.empty; upward_calls = KfKfCall.Map.empty; initial_nodes = initial; unimpacted_initial = initial; fun_changed_downward = KFS.empty; fun_changed_upward = KFS.empty; skip = skip; reason = Reason.Set.empty; compute_reason = reason; } in (* Fill the [todo] field *) initial_to_do_list wl kf (!Db.Pdg.get kf) nodes; let initial_callers = if Options.Upward.get () then KFS.singleton kf else KFS.empty in (* Fill the [callers] and [upward_calls] fields *) all_upward_callers wl initial_callers; wl (** To compute the impact of a statement, find the initial PDG nodes that must be put in the worklist. The only subtlety consists in skipping input nodes on statements that are calls; otherwise, we would get an impact in the callees of the call. *) let initial_nodes ~skip kf stmt = Options.debug ~level:3 "computing initial nodes for %d" stmt.sid; let pdg = !Pdg.get kf in if Db.Value.is_reachable_stmt stmt then try let all = !Pdg.find_simple_stmt_nodes pdg stmt in let filter n = match PdgTypes.Node.elem_key n with | Key.SigCallKey (_, Signature.In _) -> false | _ -> not (node_to_skip skip n) in List.filter filter all with | PdgTypes.Pdg.Top -> Options.warning "analysis of %a is too imprecise, impact cannot be computed@." Kernel_function.pretty kf; [] | Not_found -> assert false else begin Options.debug ~level:3 "stmt %d is dead. skipping." stmt.sid; [] end (* -------------------------------------------------------------------------- *) (* --- Fixpoint --- *) (* -------------------------------------------------------------------------- *) (** Choose one node to process in the todo list, if one remains *) let pick wl = try let (n, _ as r) = NM.choose wl.todo in wl.todo <- NM.remove n wl.todo; Some r with Not_found -> None (** Empty the [todo] field of the worklist by applying as many basic steps as possible: intra-procedural steps, plus basic inter-procedural steps on downward calls. *) let rec intraprocedural wl = match pick wl with | None -> () | Some (node, { kf = kf; pdg = pdg; init = init }) -> add_to_result wl node kf init; !Db.progress (); Options.debug ~level:2 "considering new node %a in %a: %a%t" PdgTypes.Node.pretty node Kernel_function.pretty kf PdgTypes.Node.pretty_node node (fun fmt -> if init then Format.pp_print_string fmt " (init)"); intraprocedural_one_node wl node kf pdg; downward_one_call_node wl node kf pdg; intraprocedural wl let something_to_do wl = not (NM.is_empty wl.todo) (** Make the worklist reach a fixpoint, by propagating all possible source of impact as much as possible. Due to the way calls are treated (by intersecting new impacted nodes with constant sets of nodes), it is more efficient to saturate the field [result] before calling [downward_calls_inputs] and [upward_in_callers]. We also make sure all downward propagation is done before starting upward propagation. *) let rec fixpoint wl = if something_to_do wl then begin intraprocedural wl; (* Save functions on which the results have changed, as [downward_calls_inputs] clears the field [fun_changed_downward] *) wl.fun_changed_upward <- KFS.union wl.fun_changed_downward wl.fun_changed_upward; downward_calls_inputs wl; if something_to_do wl then fixpoint wl else ( upward_in_callers wl; fixpoint wl ) end let remove_unimpacted _kf impact initial = match impact, initial with | None, None | Some _, None | None, Some _ (* impossible *) -> impact | Some impact, Some initial -> Some (NS.diff impact initial) (** Impact of a set of nodes. Once the worklist has reached its fixpoint, remove the initial nodes that are not self-impacting from the result, and return this result. *) let impact ?skip ?reason nodes kf = let wl = initial_worklist ?skip ?reason nodes kf in fixpoint wl; let without_init = KFM.merge remove_unimpacted wl.result wl.unimpacted_initial in without_init, wl.unimpacted_initial, wl.reason (* -------------------------------------------------------------------------- *) (* --- High-level API --- *) (* -------------------------------------------------------------------------- *) (** Impact of a list of statements coming from the same function *) let impacted_nodes ?(skip=Locations.Zone.bottom) ?(reason=false) kf stmts = let nodes = List.map (initial_nodes ~skip kf) stmts in let nodes = List.concat nodes in Options.debug "about to compute impact for stmt(s) %a, %d initial nodes" (Pretty_utils.pp_list ~sep:",@ " Stmt.pretty_sid) stmts (List.length nodes); let r, initial, reason_graph = impact ~skip ~reason nodes kf in (* TODOTODO *) let pp_kf fmt (kf, ns) = Format.fprintf fmt "@[%a: %a@]@ " Kernel_function.pretty kf (Pretty_utils.pp_iter ~sep:",@ " ~pre:"" ~suf:"" NS.iter PdgTypes.Node.pretty) ns in let iter f = KFM.iter (fun kf ns -> f (kf, ns)) in Options.debug ~level:1 "@[Results:@ %a@]" (Pretty_utils.pp_iter ~sep:"@ " ~pre:"" ~suf:"" iter pp_kf) r; if reason then Reason_graph.print_dot_graph reason_graph; r, initial, reason_graph (** Transform the result of an analysis into a set of PDG nodes *) let result_to_nodes (res: result) : nodes = KFM.fold (fun _ s acc -> NS.union s acc) res NS.empty (** Transform a set of PDG nodes into a set of statements *) let nodes_to_stmts ns = let get_stmt node = Key.stmt (!Pdg.node_key node) in let set = (* Do not generate a list immediately, some nodes would be duplicated *) NS.fold (fun n acc -> Extlib.may_map ~dft:acc (fun s -> Stmt.Set.add s acc) (get_stmt n) ) ns Stmt.Set.empty in Stmt.Set.elements set (** Impact of a list of statements as a set of statements *) let impacted_stmts ?(skip=Locations.Zone.bottom) ~reason kf stmts = let r, _, _ = impacted_nodes ~skip ~reason kf stmts in nodes_to_stmts (result_to_nodes r) (** Nodes impacted in a given function *) let impact_in_kf (res: result) kf = kfmns_find_default kf res (** Computation of the [skip] field from a list of variables *) let skip_vars vars = let aux vi = let b = Base.create_varinfo vi in Locations.Zone.defaultall b in List.fold_left (fun acc v -> Locations.Zone.join acc (aux v)) Locations.Zone.bottom vars (** Computation of the [skip] field from the [-impact-skip] option *) let skip () = let vars = Options.Skip.fold (fun name l -> Globals.Vars.find_from_astinfo name VGlobal :: l) [] in skip_vars vars (* TODO: dynamically register more high-level functions *) (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/impact/options.mli0000644000175000017500000000423112155630240020235 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.S module Pragma: Plugin.String_set (** Use pragmas of given function. *) module Print: Plugin.Bool (** Print the impacted stmt on stdout. *) module Reason: Plugin.Bool (** Build the graphs that explains why a node is impacted. *) module Slicing: Plugin.Bool (** Slicing from the impacted stmt. *) module Skip: Plugin.String_set (** Consider that the variables in the string are not impacted *) module Upward: Plugin.Bool (** Also compute impact within callers *) val is_on: unit -> bool (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/impact/reason_graph.ml0000644000175000017500000001360412155630240021045 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module NS = PdgTypes.NodeSet (** Why is a node impacted. The reasons will be given as [n is impacted by the effect of [n'], and the impact is of type reason]. *) type reason_type = | Intraprocedural of PdgTypes.Dpd.t (** The effect of [n'] in [f] impact [n], which is also in [f]. *) | InterproceduralDownward (** the effect of [n'] in [f] has an effect on a callee [f'] of [f], in which [n] is located. *) | InterproceduralUpward (** the effect of [n'] in [f] has an effect on a caller [f'] of [f] (once the call to [f] has ended), [n] being in [f']. *) module ReasonType = Datatype.Make( struct type t = reason_type let name = "Impact.Reason_graph.reason_type" let reprs = [InterproceduralDownward] include Datatype.Serializable_undefined let compare (v1: t) (v2: t) = Extlib.compare_basic v1 v2 let hash (v: t) = Hashtbl.hash v let equal (v1: t) (v2: t) = v1 == v2 end) (** Reasons for impact are expressed as sets [(n', n, reason)] *) module Reason = Datatype.Triple_with_collections(PdgTypes.Node)(PdgTypes.Node)(ReasonType) (struct let module_name = "Impact.Reason_graph.Reason.t" end) type reason = Reason.Set.t let empty = Reason.Set.empty module Printer = struct type t = Reason.Set.t module V = struct type t = PdgTypes.Node.t let pretty fmt n = PdgIndex.Key.pretty fmt (PdgTypes.Node.elem_key n) end module E = struct type t = V.t * V.t * reason_type let src (e, _, _) = e let dst (_, e, _) = e end let iter_vertex f graph = let all = Reason.Set.fold (fun (src, dst, _) acc -> NS.add src (NS.add dst acc)) graph NS.empty in NS.iter f all let iter_edges_e f graph = Reason.Set.iter f graph let vertex_name n = Format.sprintf "n%d" (PdgTypes.Node.id n) let graph_attributes _ = [`Label "Impact graph"] let default_vertex_attributes _g = [`Style `Filled] let default_edge_attributes _g = [] let vertex_attributes v = let txt = Pretty_utils.to_string V.pretty v in let txt = if String.length txt > 100 then String.sub txt 0 100 else txt in let txt = Pretty_utils.sfprintf "%S" txt in let txt = String.sub txt 1 (String.length txt - 2) in [`Label txt] let edge_attributes (_, _, reason) = let color = match reason with | Intraprocedural _ -> 0x2F9F9F | InterproceduralUpward -> 0x9F2F9F | InterproceduralDownward -> 0x9F9F2F in let attribs = [`Color color] in match reason with | Intraprocedural dpd -> `Label (Pretty_utils.to_string PdgTypes.Dpd.pretty dpd) :: attribs | _ -> attribs let get_subgraph n = match PdgIndex.Key.stmt (PdgTypes.Node.elem_key n) with | None -> None | Some stmt -> let kf = Kernel_function.find_englobing_kf stmt in let name = Kernel_function.get_name kf in let attrs = { Graph.Graphviz.DotAttributes.sg_name = name; sg_attributes = [`Label name]; } in Some attrs end module Dot = Graph.Graphviz.Dot(Printer) (* May raise [Sys_error] *) let to_dot_file ~temp reason = let dot_file = try let f name ext = if temp then Extlib.temp_file_cleanup_at_exit name ext else Filename.temp_file name ext in f "impact_reason" ".dot" with Extlib.Temp_file_error s -> Options.abort "cannot create temporary file: %s" s in let cout = open_out dot_file in Kernel.Unicode.without_unicode (Dot.output_graph cout) reason; close_out cout; dot_file let print_dot_graph reason = try let dot_file = to_dot_file ~temp:false reason in Options.result "Graph output in file '%s'" dot_file with Sys_error _ as exn -> Options.error "Could not generate impact graph: %s" (Printexc.to_string exn) (* Very basic textual debugging function *) let print_reason reason = let pp_node = !Db.Pdg.pretty_node false in let pp fmt (nsrc, ndst, reason) = Format.fprintf fmt "@[%a -> %a (%s)@]" pp_node nsrc pp_node ndst (match reason with | Intraprocedural dpd -> Pretty_utils.sfprintf "intra %a" PdgTypes.Dpd.pretty dpd | InterproceduralDownward -> "downward" | InterproceduralUpward -> "upward" ) in Options.result "Impact graph:@.%a" (Pretty_utils.pp_iter ~pre:"@[" ~sep:"@ " ~suf:"@]" Reason.Set.iter pp) reason frama-c-Fluorine-20130601/src/impact/register.ml0000644000175000017500000001360712155630240020224 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Cil_types open Cil_datatype open Db open Visitor open Options let print_results fmt a = List.iter (fun s -> Format.fprintf fmt "@\nsid %d: %a" s.sid (Printer.without_annot Printer.pp_stmt) s) a let compute_from_stmt stmt = let kf = Kernel_function.find_englobing_kf stmt in let skip = Compute_impact.skip () in let reason = Options.Reason.get () in Compute_impact.impacted_stmts ~skip ~reason kf [stmt] let compute_multiple_stmts skip kf ls = debug "computing impact of statement(s) %a" (Pretty_utils.pp_list ~sep:",@ " Stmt.pretty_sid) ls; let reason = Options.Reason.get () in let res, _, _ = Compute_impact.impacted_nodes ~skip ~reason kf ls in let res_nodes = Compute_impact.result_to_nodes res in let res_stmts = Compute_impact.nodes_to_stmts res_nodes in if Print.get () then begin result "impacted statements of stmt(s) %a are:%a" (Pretty_utils.pp_list ~sep:",@ " Stmt.pretty_sid) ls print_results res_stmts end; res_nodes let slice (stmts:stmt list) = feedback ~level:2 "beginning slicing"; let name = "impact slicing" in let slicing = !Db.Slicing.Project.mk_project name in let select sel ({ sid = id } as stmt) = let kf = Kernel_function.find_englobing_kf stmt in debug ~level:3 "selecting sid %d (of %s)" id (Kernel_function.get_name kf); !Db.Slicing.Select.select_stmt sel ~spare:false stmt kf in let sel = List.fold_left select Db.Slicing.Select.empty_selects stmts in debug ~level:2 "applying slicing request"; !Db.Slicing.Request.add_persistent_selection slicing sel; !Db.Slicing.Request.apply_all_internal slicing; !Db.Slicing.Slice.remove_uncalled slicing; let extracted_prj = !Db.Slicing.Project.extract name slicing in !Db.Slicing.Project.print_extracted_project ?fmt:None ~extracted_prj ; feedback ~level:2 "slicing done" (* TODO: change function to generate on-the-fly the relevant pdg nodes *) let all_pragmas_kf _kf l = List.fold_left (fun acc (s, a) -> match a.annot_content with | APragma (Impact_pragma IPstmt) -> s :: acc | APragma (Impact_pragma (IPexpr _)) -> Options.not_yet_implemented "impact pragmas: expr" | _ -> assert false) [] l let compute_pragmas () = Ast.compute (); let pragmas = ref [] in let visitor = object inherit Visitor.frama_c_inplace as super method vfunc f = pragmas := []; super#vfunc f method vstmt_aux s = pragmas := List.map (fun a -> s, a) (Annotations.code_annot ~filter:Logic_utils.is_impact_pragma s) @ !pragmas; DoChildren end in (* fill [pragmas] with all the pragmas of all the selected functions *) let pragmas = Pragma.fold (fun f acc -> try let kf = Globals.Functions.find_def_by_name f in match kf.fundec with | Definition(f, _) -> ignore (visitFramacFunction visitor f); if !pragmas != [] then (kf, !pragmas) :: acc else acc | Declaration _ -> assert false with Not_found -> abort "function %s not found." f ) [] in let skip = Compute_impact.skip () in (* compute impact analyses on each kf *) let nodes = List.fold_left (fun nodes (kf, pragmas) -> let pragmas_stmts = all_pragmas_kf kf pragmas in PdgTypes.NodeSet.union nodes (compute_multiple_stmts skip kf pragmas_stmts) ) PdgTypes.NodeSet.empty pragmas in let stmts = Compute_impact.nodes_to_stmts nodes in if Options.Slicing.get () then ignore (slice stmts); stmts; ;; let main () = if is_on () then begin feedback "beginning analysis"; assert (not (Pragma.is_empty ())); ignore (!Impact.compute_pragmas ()); feedback "analysis done" end let () = Db.Main.extend main let () = (* compute_pragmas *) Db.register (Db.Journalize ("Impact.compute_pragmas", Datatype.func Datatype.unit (Datatype.list Stmt.ty))) Impact.compute_pragmas compute_pragmas; (* from_stmt *) Db.register (Db.Journalize ("Impact.from_stmt", Datatype.func Stmt.ty (Datatype.list Stmt.ty))) Impact.from_stmt compute_from_stmt; (* slice *) Db.register (Db.Journalize ("Impact.slice", Datatype.func (Datatype.list Stmt.ty) Datatype.unit)) Impact.slice slice (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/impact/register_gui.ml0000644000175000017500000002532412155630240021067 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Pretty_source open Gtk_helper open Db open Cil_types module SelectedStmt = struct include State_builder.Option_ref (Cil_datatype.Stmt) (struct let name = "Impact_gui.SelectedStmt" let dependencies = [ Ast.self ] end) let set s = set s; Project.clear ~selection:(State_selection.only_dependencies self) (); end let () = Cmdline.run_after_extended_stage (fun () -> State_dependency_graph.add_codependencies ~onto:SelectedStmt.self [ !Db.Pdg.self ]) module Highlighted_stmt : sig val add: Kernel_function.t -> stmt -> unit val mem: Kernel_function.t -> stmt -> bool val mem_kf: Kernel_function.t -> bool end = struct open Cil_datatype module Tbl = Kernel_function.Make_Table (Stmt.Set) (struct let name = "Impact_gui.Highlighted_stmt" let size = 7 let dependencies = [ SelectedStmt.self ] end) let add kf s = ignore (Tbl.memo ~change:(fun set -> Stmt.Set.add s set) (fun _ -> Stmt.Set.singleton s) kf) let mem kf s = try let set = Tbl.find kf in Stmt.Set.mem s set with Not_found -> false let mem_kf = Tbl.mem end module ImpactedNodes = State_builder.Ref(Kernel_function.Map.Make(PdgTypes.NodeSet))(struct let name = "Impact.Register_gui.ImpactedNodes" let dependencies = [SelectedStmt.self] let default () = Kernel_function.Map.empty end) module ReasonGraph = State_builder.Ref(Reason_graph.Reason.Set)(struct let name = "Impact.Register_gui.ReasonGraph" let dependencies = [SelectedStmt.self] let default () = Reason_graph.empty end) module InitialNodes = State_builder.Ref(PdgTypes.NodeSet)(struct let name = "Impact.Register_gui.InitialNodes" let dependencies = [SelectedStmt.self] let default () = PdgTypes.NodeSet.empty end) let impact_in_kf kf = Compute_impact.impact_in_kf (ImpactedNodes.get ()) kf (* Update the 'Impact' column of the gui filetree. *) let update_column = ref (fun _ -> ()) (* Are results shown? *) module Enabled = struct include State_builder.Ref (Datatype.Bool) (struct let name = "Impact_gui.State" let dependencies = [] let default () = false end) end (* Should perform slicing after impact? *) module Slicing = State_builder.Ref (Datatype.Bool) (struct let name = "Impact_gui.Slicing" let dependencies = [] let default () = false end) (* Follow Focus mode *) module FollowFocus = State_builder.Ref (Datatype.Bool) (struct let name = "Impact_gui.FollowFocus" let dependencies = [] let default () = false end) let apply_on_stmt f = function | PStmt (kf,s) -> f kf s | _ -> () let impact_highlighter buffer loc ~start ~stop = if Enabled.get () then let tag name color = let t = make_tag buffer name [`BACKGROUND color ] in apply_tag buffer t start stop in let hilight kf s = if Highlighted_stmt.mem kf s then tag "hilighed_impact" "green" else SelectedStmt.may (fun sel -> if Cil_datatype.Stmt.equal sel s then tag "selected_impact" "cyan") in apply_on_stmt hilight loc let reason_graph_window main_window reason = try let dot_file = Reason_graph.to_dot_file ~temp:true reason in let reason_graph ~packing = snd (Dgraph.DGraphContainer.Dot.from_dot_with_commands ~packing dot_file) in let height = int_of_float (float main_window#default_height *. 3. /. 4.) in let width = int_of_float (float main_window#default_width *. 3. /. 4.) in let window = GWindow.window ~width ~height ~allow_shrink:true ~allow_grow:true ~position:`CENTER () in let view = reason_graph ~packing:window#add in window#show (); view#adapt_zoom () with | Dgraph.DGraphModel.DotError _ as exn -> Options.error "@[cannot display impact graph:@ %s@]" (Printexc.to_string exn) | Sys_error _ as exn -> Options.error "issue when generating impact graph: %s" (Printexc.to_string exn) let impact_statement s = let kf = Kernel_function.find_englobing_kf s in let skip = Compute_impact.skip () in let reason = Options.Reason.get () in let impact, initial, reason = Compute_impact.impacted_nodes ~skip ~reason kf [s] in SelectedStmt.set s; ImpactedNodes.set impact; InitialNodes.set (Kernel_function.Map.find kf initial); ReasonGraph.set reason; let stmts = ref [] in Kernel_function.Map.iter (fun kf s -> let stmts' = Compute_impact.nodes_to_stmts s in stmts := stmts' :: !stmts; List.iter (Highlighted_stmt.add kf) stmts' ) impact; let impact = List.concat !stmts in if Slicing.get () then !Db.Impact.slice impact; Enabled.set true; impact let impact_statement = Dynamic.register ~comment:"Compute the impact of the statement in the Gui" ~plugin:"impact" "impact_statement_gui" (Datatype.func Cil_datatype.Stmt.ty (Datatype.list Cil_datatype.Stmt.ty)) ~journalize:true impact_statement let impact_statement_ui (main_ui:Design.main_window_extension_points) s = let val_computed = Db.Value.is_computed () in ignore (impact_statement s); if not val_computed then main_ui#reset () else ( !update_column `Contents; main_ui#rehighlight () ); if Options.Reason.get () then let g = ReasonGraph.get () in if not (Reason_graph.Reason.Set.is_empty g) then reason_graph_window main_ui#main_window g let pretty_info = ref false let impact_selector (popup_factory:GMenu.menu GMenu.factory) main_ui ~button localizable = match localizable with | PStmt (kf, s) -> if button = 3 || FollowFocus.get () then ( let callback () = ignore (impact_statement_ui main_ui s) in ignore (popup_factory#add_item "_Impact analysis" ~callback); if FollowFocus.get () then ignore (Glib.Idle.add (fun () -> callback (); false)) ); if button = 1 then (* Initial nodes, at the source of the impact *) (match SelectedStmt.get_option () with | Some s' when Cil_datatype.Stmt.equal s s' -> if !pretty_info then main_ui#pretty_information "@[Impact initial nodes:@ %a@]@." (Pretty_utils.pp_iter PdgTypes.NodeSet.iter ~sep:",@ " (!Db.Pdg.pretty_node false)) (InitialNodes.get ()); | _ -> ()); let nodes = impact_in_kf kf in let nodes = PdgTypes.NodeSet.filter (fun node -> match PdgIndex.Key.stmt (!Pdg.node_key node) with | None -> false | Some s' -> Cil_datatype.Stmt.equal s s') nodes in if not (PdgTypes.NodeSet.is_empty nodes) then if !pretty_info then main_ui#pretty_information "@[Impact:@ %a@]@." (Pretty_utils.pp_iter ~sep:",@ " PdgTypes.NodeSet.iter (!Db.Pdg.pretty_node false)) nodes; | PVDecl (_, vi) | PGlobal (GFun ({ svar = vi }, _)) when Cil.isFunctionType vi.vtype -> if button = 1 then let kf = Globals.Functions.get vi in let nodes = impact_in_kf kf in let nodes = PdgTypes.NodeSet.filter (fun node -> match PdgIndex.Key.stmt (!Pdg.node_key node) with | None -> true | Some _ -> false ) nodes in if not (PdgTypes.NodeSet.is_empty nodes) then if !pretty_info then main_ui#pretty_information "@[Function global impact:@ %a@]@." (Pretty_utils.pp_iter ~sep:",@ " PdgTypes.NodeSet.iter (!Db.Pdg.pretty_node false)) nodes | _ -> () let impact_panel main_ui = let w = GPack.vbox () in (* check buttons *) let enabled_button = on_bool w "Enable" Enabled.get (fun b -> Enabled.set b; !update_column `Visibility; main_ui#rehighlight ()) in let slicing_button = on_bool w "Slicing after impact" Slicing.get Slicing.set in let follow_focus_button = on_bool w "Follow focus" FollowFocus.get FollowFocus.set in (* panel refresh *) let refresh () = enabled_button (); slicing_button (); follow_focus_button () in "Impact", w#coerce, Some refresh let file_tree_decorate (file_tree:Filetree.t) = update_column := file_tree#append_pixbuf_column ~title:"Impact" (fun globs -> let is_hilighted = function | GFun ({svar = v }, _) -> Highlighted_stmt.mem_kf (Globals.Functions.get v) | _ -> false in let id = (* lazyness of && is used for efficiency *) if Enabled.get () && SelectedStmt.get_option () <> None && List.exists is_hilighted globs then "gtk-apply" else "" in [ `STOCK_ID id ]) (fun () -> Enabled.get () && SelectedStmt.get_option () <> None); !update_column `Visibility let main main_ui = main_ui#register_source_selector impact_selector; main_ui#register_source_highlighter impact_highlighter; main_ui#register_panel impact_panel; file_tree_decorate main_ui#file_tree let () = Design.register_extension main (* Local Variables: compile-command: "make -C ../.." End: *) frama-c-Fluorine-20130601/src/impact/pdg_aux.mli0000644000175000017500000000445312155630240020177 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (** Useful functions that are not directly accessible through the other Pdg modules. *) (** [all_call_input_nodes caller callee call_stmt] find all the nodes above [call_stmt] in the pdg of [caller] that define the inputs of [callee]. Each input node in [callee] is returned with the set of nodes that define it in [caller]. The zones potentially not defined in [caller] are skipped, as they are not useful for an impact analysis *) val all_call_input_nodes: Db.Pdg.t -> kernel_function * Db.Pdg.t -> stmt -> (PdgTypes.Node.t * PdgTypes.NodeSet.t) list val all_call_out_nodes : Db.Pdg.t -> (*kernel_function *) Db.Pdg.t -> stmt -> (PdgTypes.Node.t * PdgTypes.NodeSet.t) list frama-c-Fluorine-20130601/src/metrics/0000755000175000017500000000000012155634040016232 5ustar mehdimehdiframa-c-Fluorine-20130601/src/metrics/metrics_cilast.ml0000644000175000017500000004164712155630235021607 0ustar mehdimehdi(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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_datatype open Cil_types open Metrics_base open Metrics_parameters ;; (** Syntactic metrics ================= The goal is to collect various (syntactic) information about the source code (slocs, assignments, loops, ...). From those one can compute McCabe's 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: BasicMetrics.t (* 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 (* Various metrics computing visitor on Cil AST. These metrics are a necessary step to compute cyclomatic complexity. *) open BasicMetrics ;; class slocVisitor : sloc_visitor = object(self) inherit Visitor.frama_c_inplace (* Global metrics store for this Cil AST *) val global_metrics = ref BasicMetrics.empty_metrics (* Local metrics in computation *) val local_metrics = ref BasicMetrics.empty_metrics (* Local metrics are kept stored after computation in this map of maps. Its storing hierachy is as follows: filename -> function_name -> metrics *) val mutable metrics_map: (BasicMetrics.t Datatype.String.Map.t) Datatype.String.Map.t = Datatype.String.Map.empty val mutable seen_vars = Varinfo.Set.empty; val fundecl_calls: int VInfoMap.t ref = ref VInfoMap.empty; val fundef_calls: int VInfoMap.t ref = ref VInfoMap.empty; (* Getters/setters *) method fundecl_calls = !fundecl_calls method fundef_calls = !fundef_calls method get_metrics = !global_metrics method private update_metrics_map filename strmap = metrics_map <- Datatype.String.Map.add filename strmap metrics_map (* Utility method to increase metrics counts *) method private incr_both_metrics f = apply_then_set f global_metrics; apply_then_set f local_metrics method private add_map map vinfo value = map := VInfoMap.add vinfo value !map method private stats_of_filename filename = try Datatype.String.Map.find filename metrics_map with | Not_found -> Metrics.fatal "Metrics for file %s not_found@." filename method pp_file_metrics fmt filename = Format.fprintf fmt "@[%a@]" (fun fmt filename -> let fun_tbl = self#stats_of_filename filename in Datatype.String.Map.iter (fun _fun_name fmetrics -> Format.fprintf fmt "@ %a" pp_base_metrics fmetrics) fun_tbl; ) filename method pp_detailed_text_metrics fmt = Datatype.String.Map.iter (fun filename _func_tbl -> Format.fprintf fmt "%a" self#pp_file_metrics filename) metrics_map method print_stats fmt = Format.pp_set_formatter_tag_functions fmt Metrics_base.html_tag_functions; Format.pp_set_tags fmt true; let pr_hdr fmt hdr_name = Format.fprintf fmt "@{%s@}" hdr_name in Datatype.String.Map.iter (fun filename func_tbl -> Metrics.result ~level:2 "%a" self#pp_file_metrics filename; if func_tbl <> Datatype.String.Map.empty then begin Format.fprintf fmt "@[@{

    %s@}
    @ \ @{\ @[@ \ @[@{@ \ @{@[@ \ %a@ %a@ %a@ %a@ %a@ %a@ %a@ %a@ %a@ @]@}@ \ %a@ \ @}@]@]@ @} \ @]@ " filename pr_hdr "Function" pr_hdr "#If stmts" pr_hdr "#Assignments" pr_hdr "#Loops" pr_hdr "#Calls" pr_hdr "#Gotos" pr_hdr "#Pointer dereferencing" pr_hdr "#Exits" pr_hdr "Cyclomatic value" (fun fmt fun_tbl -> Datatype.String.Map.iter (fun _fname fmetrics -> Format.fprintf fmt "%a" pp_base_metrics_as_html_row fmetrics; ) fun_tbl ) func_tbl; end else Metrics.warning "Filename <%s> has no functions@." filename) metrics_map (* Save the local metrics currently computed. Clears it before starting a new metrics computation (e.g. when entering a new function definition. Global metrics are never reset as they define metrics on the whole Cil.file. *) method private record_and_clear_function_metrics metrics = let filename = metrics.cfile_name in let funcname = metrics.cfunc_name in (try let fun_tbl = Datatype.String.Map.find filename metrics_map in self#update_metrics_map filename (Datatype.String.Map.add funcname !local_metrics fun_tbl); with | Not_found -> let new_stringmap = Datatype.String.Map.add funcname !local_metrics Datatype.String.Map.empty in self#update_metrics_map filename new_stringmap; ); local_metrics := empty_metrics; method vvdec vi = if not (Varinfo.Set.mem vi seen_vars) then ( if Cil.isFunctionType vi.vtype then ( if consider_function vi then global_metrics := incr_funcs !global_metrics; ) else ( if vi.vglob && not vi.vgenerated then ( global_metrics:= incr_glob_vars !global_metrics; ) ); seen_vars <- Varinfo.Set.add vi seen_vars; ); Cil.SkipChildren method vfunc fdec = if consider_function fdec.svar then begin (* Here, we get to a fundec definition.this function has a body, let's put it to the "function with source" table. *) local_metrics := {!local_metrics with cfile_name = file_of_fundef fdec; cfunc_name = fdec.svar.vname; cfuncs = 1; (* Only one function is indeed being defined here *)}; let fvinfo = fdec.svar in (if not (VInfoMap.mem fvinfo !fundef_calls) then (* Never seen before, including never been called *) self#add_map fundef_calls fvinfo 0); (* On return record the analysis of the function. *) Cil.ChangeDoChildrenPost (fdec, fun _ -> begin if !local_metrics <> empty_metrics then self#record_and_clear_function_metrics !local_metrics; fdec; end ); end else Cil.SkipChildren method vlval (host, _) = begin match host with | Mem _ -> self#incr_both_metrics incr_ptrs; | _ -> () end; Cil.DoChildren method vstmt s = self#incr_both_metrics incr_slocs; let do_children = match s.skind with | If _ -> self#incr_both_metrics incr_ifs; self#incr_both_metrics incr_dpoints; true | Loop _ -> self#incr_both_metrics incr_loops; true | Goto _ -> self#incr_both_metrics incr_gotos; true | Return _ -> self#incr_both_metrics incr_exits; true | Switch (_, _, _slist, _) -> true (* The catching block is one more possible flow alternative *) | TryFinally _ | TryExcept _ -> self#incr_both_metrics incr_dpoints; true | UnspecifiedSequence l -> List.iter (fun (s,_,_,_,_) -> ignore (Visitor.visitFramacStmt (self:>Visitor.frama_c_visitor) s)) l; false | _ -> true in (* Default cases are not path choice points, as normal labels. Non-default cases are ... just like if statements. *) let rec has_case_label labels = match labels with | (Case _) :: _-> self#incr_both_metrics incr_dpoints; | _ :: labels -> has_case_label labels | [] -> () in has_case_label s.labels; if do_children then Cil.DoChildren else Cil.SkipChildren method vexpr e = begin (* Logical ands and ors are lazy and generate two different paths *) match e.enode with | BinOp ((LAnd | LOr), _, _, _) -> self#incr_both_metrics incr_dpoints; | _ -> () end; Cil.DoChildren method private 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,_) -> begin match an with | Dfun_or_pred (li, _) -> li.l_var_info.lv_name | Dvolatile (_, _, _, _) -> " (Volatile) " | 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 | Dmodel_annot (mi, _) -> mi.mi_name | Dcustom_annot (_c, _n, _) -> " (Custom) " end method private 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 vinst i = begin match i with | Call(_, e, _, _) -> self#incr_both_metrics incr_calls; (match e.enode with | Lval(Var vinfo, NoOffset) -> if consider_function vinfo then begin let update_call_map funcmap = self#add_map funcmap vinfo (1 + try VInfoMap.find vinfo !funcmap with Not_found-> 0) in if vinfo.vdefined then update_call_map fundef_calls else update_call_map fundecl_calls end | _ -> ()); | Set _ -> self#incr_both_metrics incr_assigns; | _ -> () end; Cil.DoChildren end let dump_html fmt cil_visitor = (* Activate tagging for html *) Format.pp_set_formatter_tag_functions fmt html_tag_functions; Format.pp_set_tags fmt true; let pr_row s fmt n = Format.fprintf fmt "@{@[@ \ @{
    %s@}@ \ @{%d@}@]@ @} " s n in let pr_stats fmt visitor = let metrics = visitor#get_metrics in Format.fprintf fmt "@[@{%a@}@]" (fun fmt metrics -> List.iter2 (fun text value -> pr_row text fmt value) ["SLOC"; "Number of if statements"; "Number of assignments"; "Number of loops"; "Number of calls"; "Number of gotos"; "Number of pointer accesses";] [metrics.cslocs; metrics.cifs; metrics.cassigns; metrics.cloops; metrics.ccalls; metrics.cgotos; metrics.cptrs;]) metrics in let pr_prelude fmt cil_visitor = Format.fprintf fmt "@[\ @{
    @ \ @{

    @{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 pp_funinfo fmt cil_visitor = let function_definitions = VInfoMap.to_varinfo_map cil_visitor#fundef_calls in let function_declarations = VInfoMap.to_varinfo_map cil_visitor#fundecl_calls in let nfundef = Metrics_base.map_cardinal_varinfomap function_definitions in let nfundecl = Metrics_base.map_cardinal_varinfomap function_declarations in let fundef_hdr = Format.sprintf "Defined functions (%d)" nfundef and fundecl_hdr = Format.sprintf "Undefined functions (%d)" nfundecl and entry_pts_hdr = Format.sprintf "Potential entry points (%d)" (Metrics_base.number_entry_points Varinfo.Map.fold function_definitions) in Format.fprintf fmt "@[<v 0>@[<v 1>%a@ @[%a@]@]@ @ \ @[<v 1>%a@ @[%a@]@]@ @ \ @[<v 1>%a@ @[%a@]@]@ \ @]" (Metrics_base.mk_hdr 1) fundef_hdr (Metrics_base.pretty_set Varinfo.Map.iter) function_definitions (Metrics_base.mk_hdr 1) fundecl_hdr (Metrics_base.pretty_set Varinfo.Map.iter) function_declarations (Metrics_base.mk_hdr 1) entry_pts_hdr (Metrics_base.pretty_entry_points Varinfo.Map.iter) function_definitions ;; let pp_with_funinfo fmt cil_visitor = Format.fprintf fmt "@[<v 0>%a@ %a@]" pp_funinfo cil_visitor pp_base_metrics cil_visitor#get_metrics ;; let get_metrics () = let file = Ast.get () in (* Do as before *) let cil_visitor = new slocVisitor in Visitor.visitFramacFileSameGlobals (cil_visitor:>Visitor.frama_c_visitor) file; cil_visitor#get_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 -> pp_with_funinfo fmt cil_visitor ); close_out oc; with Sys_error _ -> Metrics.failure "Cannot open file %s.@." out_fname else Metrics.result "%a" pp_with_funinfo cil_visitor end ;; (* Local Variables: compile-command: "make -C ../.." End: *) �����������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/metrics_base.ml�����������������������������������������������0000644�0001750�0001750�00000023655�12155630235�021241� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 (* vname, vaddrof *) open Cil_datatype ;; (* Formatting html with Format.formatters *) let html_tag_functions = let mark_open_tag t = Format.sprintf "<%s>" t and mark_close_tag t = try let index = String.index t ' ' in Format.sprintf "</%s>" (String.sub t 0 index) with | Not_found -> Format.sprintf "</%s>" t and print_open_tag _ = () and print_close_tag _ = () in { Format.mark_open_tag = mark_open_tag; Format.mark_close_tag = mark_close_tag; Format.print_open_tag = print_open_tag; Format.print_close_tag = print_close_tag; } ;; (* Utility function to have underlines the same length as the title. Underlines follow reStructuredText header conventions. *) let mk_hdr level ppf hdr_strg = let c = match level with | 1 -> '=' | 2 -> '-' | 3 -> '~' | _ -> assert false in let len = String.length hdr_strg in let underline = String.make len c in Format.fprintf ppf "@[<v 0>%s@ %s@]" hdr_strg underline ; ;; (** Defining base metrics and operations on those *) module BasicMetrics = struct (** Record type to compute cyclomatic complexity *) type t = { cfile_name : string; cfunc_name : string; cslocs: int; cifs: int; cloops: int; ccalls: int; cgotos: int; cassigns: int; cexits: int; cfuncs: int; cptrs: int; cdecision_points: int; cglob_vars: int; } ;; let empty_metrics = { cfile_name = ""; cfunc_name = ""; cslocs = 0; cifs = 0; cloops = 0; ccalls = 0; cgotos = 0; cassigns = 0; cexits = 0; cfuncs = 0; cptrs = 0; cdecision_points = 0; cglob_vars = 0; } ;; let apply_then_set f metrics = metrics := f !metrics ;; let incr_slocs metrics = { metrics with cslocs = succ metrics.cslocs ;} ;; let incr_assigns metrics = { metrics with cassigns = succ metrics.cassigns ;} ;; let incr_calls metrics = { metrics with ccalls = succ metrics.ccalls ;} ;; let incr_exits metrics = { metrics with cexits = succ metrics.cexits ;} ;; let incr_funcs metrics = { metrics with cfuncs = succ metrics.cfuncs ;} ;; let incr_gotos metrics = { metrics with cgotos = succ metrics.cgotos ;} ;; let incr_ifs metrics = { metrics with cifs = succ metrics.cifs ;} ;; let incr_loops metrics = { metrics with cloops = succ metrics.cloops ;} ;; let incr_ptrs metrics = { metrics with cptrs = succ metrics.cptrs ;} ;; let incr_dpoints metrics = { metrics with cdecision_points = succ metrics.cdecision_points ;} ;; let incr_glob_vars metrics = { metrics with cglob_vars = succ metrics.cglob_vars ;} ;; (* Compute cyclomatic complexity of a given metrics record *) let cyclo metrics = metrics.cdecision_points - metrics.cexits + 2 ;; let labels = [ "Sloc"; "Decision point"; "Global variables"; "If"; "Loop"; "Goto"; "Assignment"; "Exit point"; "Function"; "Function call"; "Pointer dereferencing"; "Cyclomatic complexity"; ] ;; let str_values metrics = List.map string_of_int [ metrics.cslocs; metrics.cdecision_points; metrics.cglob_vars; metrics.cifs; metrics.cloops; metrics.cgotos; metrics.cassigns; metrics.cexits; metrics.cfuncs; metrics.ccalls; metrics.cptrs; cyclo metrics; ] ;; let to_list metrics = List.map2 (fun x y -> [ x; y; ]) labels (str_values metrics) ;; (* Pretty print metrics as text eg. in stdout *) let pp_base_metrics fmt metrics = let heading = if metrics.cfile_name = "" && metrics.cfunc_name = "" then (* It is a global metrics *) "Global metrics" else Format.sprintf "Stats for function <%s/%s>" metrics.cfile_name metrics.cfunc_name in Format.fprintf fmt "@[<v 0>%a @ %a@]" (mk_hdr 1) heading ((fun l1 ppf l2 -> List.iter2 (fun x y -> Format.fprintf ppf "%s = %s@ " x y) l1 l2) labels) (str_values metrics) ;; (* Dummy utility functions for pretty printing simple types *) let pp_strg fmt s = Format.fprintf fmt "%s" s and pp_int fmt n = Format.fprintf fmt "%d" n ;; type cell_type = | Classic | Entry | Result ;; let cell_type_to_string = function | Entry -> "entry" | Result -> "result" | Classic -> "classic" ;; let pp_cell_type_html fmt cell_type = Format.fprintf fmt "class=\"%s\"" (cell_type_to_string cell_type) ;; (* Pretty print a HTML cell given a pretty printing function [pp_fun] and a value [pp_arg] *) let pp_cell cell_type pp_fun fmt pp_arg = Format.fprintf fmt "@{<td %a>%a@}" pp_cell_type_html cell_type pp_fun pp_arg ;; let pp_cell_default = pp_cell Classic;; let pp_base_metrics_as_html_row fmt metrics = Format.fprintf fmt "\ @[<v 0>\ @{<tr>@[<v 2>@ \ @[<v 0>%a@ %a@ %a@ %a@ %a@ %a@ %a@ %a@ %a@ @]@]\ @}@ @]" (pp_cell Entry pp_strg) metrics.cfunc_name (pp_cell_default pp_int) metrics.cifs (pp_cell_default pp_int) metrics.cassigns (pp_cell_default pp_int) metrics.cloops (pp_cell_default pp_int) metrics.ccalls (pp_cell_default pp_int) metrics.cgotos (pp_cell_default pp_int) metrics.cptrs (pp_cell_default pp_int) metrics.cexits (pp_cell Result pp_int) (cyclo metrics) ;; end (* End of BasicMetrics *) (** {3 Filename utilities} *) exception No_suffix;; let get_suffix filename = try let slen = String.length filename in let last_idx = pred slen in let last_dot_idx = String.rindex_from filename last_idx '.' in if last_dot_idx < last_idx then String.sub filename (succ last_dot_idx) (slen - last_dot_idx - 1) else "" with | Not_found -> raise No_suffix ;; type output_type = | Html | Text ;; let get_file_type filename = try match get_suffix filename with | "html" | "htm" -> Html | "txt" | "text" -> Text | s -> Metrics_parameters.Metrics.fatal "Unknown file extension %s. Cannot produce output.@." s with | No_suffix -> Metrics_parameters.Metrics.fatal "File %s has no suffix. Cannot produce output.@." filename ;; (** Map of varinfos sorted by name (and not by ids) *) module VInfoMap = struct include Map.Make ( struct let compare v1 v2 = Pervasives.compare v1.vname v2.vname;; type t = Cil_types.varinfo end ) let map_cardinal (map:'a t) = fold (fun _funcname _ cardinal -> succ cardinal) map 0 ;; let to_varinfo_map vmap = fold (fun k v mapacc -> Varinfo.Map.add k v mapacc) vmap Varinfo.Map.empty ;; end ;; (** Other pretty-printing and formatting utilities *) let pretty_set iter fmt s = Format.fprintf fmt "@["; iter (fun f n -> Format.fprintf fmt "%s %s(%d call%s);@ " f.Cil_types.vname (if f.vaddrof then "(address taken) " else "") n (if n > 1 then "s" else "")) s; Format.fprintf fmt "@]" ;; let is_entry_point vinfo times_called = times_called = 0 && not vinfo.vaddrof ;; let number_entry_points fold fs = fold (fun fvinfo n acc -> if is_entry_point fvinfo n then succ acc else acc) fs 0 ;; let pretty_entry_points iter fmt fs = let print fmt = iter (fun fvinfo n -> if is_entry_point fvinfo n then Format.fprintf fmt "%s;@ " fvinfo.vname) in Format.fprintf fmt "@[<hov 1>%a@]" print fs; ;; let map_cardinal_varinfomap (map:'a Varinfo.Map.t) = Varinfo.Map.fold (fun _funcname _ cardinal -> succ cardinal) map 0 ;; (* Utilities for CIL ASTs *) let file_of_vinfodef fvinfo = let kf = Globals.Functions.get fvinfo in let decl_loc1, _decl_loc2 = match kf.fundec with | Definition (_, loc) -> loc | Declaration (_, _, _, loc) -> loc in decl_loc1.Lexing.pos_fname ;; let file_of_fundef (fun_dec: Cil_types.fundec) = file_of_vinfodef fun_dec.svar ;; (* Utilities for Cabs ASTs *) let extract_fundef_name sname = match sname with | _spec, (the_name, _, _, _) -> the_name ;; let get_filename fdef = match fdef with | Cabs.FUNDEF(_, _, _, (loc1, _), _loc2) -> loc1.Lexing.pos_fname | _ -> assert false ;; let consider_function vinfo = not (!Db.Value.mem_builtin vinfo.vname || Ast_info.is_frama_c_builtin vinfo.vname || Cil.is_unused_builtin vinfo ) let float_to_string f = let s = Format.sprintf "%F" f in let len = String.length s in let plen = pred len in if s.[plen] = '.' then String.sub s 0 plen else Format.sprintf "%.2f" f ;; �����������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/Metrics.mli���������������������������������������������������0000644�0001750�0001750�00000003362�12155630235�020351� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* $Id: Metrics.mli,v 1.2 2008-11-04 10:05:05 uid568 Exp $ *) (** Metrics plugin. *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.. -j" End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/metrics_gui.mli�����������������������������������������������0000644�0001750�0001750�00000005012�12155630235�021247� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** {1 GUI utilities for Metrics} *) (** Initialize the main Metrics panel into an upper and lower part. @returns a box containing the lower part of the panel where metrics can display their results. *) val init_panel : unit -> GPack.box ;; (** @returns a value allowing to register the panel into the main GUI *) val coerce_panel_to_ui : < coerce : 'a; .. > -> 'b -> string * 'a * 'c option ;; (** Diplay the list of list of strings in a LablgGTK table object *) val display_as_table : string list list -> GPack.box -> unit ;; (** Reset metrics panel to pristine conditions by removeing children from bottom container *) val reset_panel : 'a -> unit ;; (** register_metrics [metrics_name] [display_function] () adds a selectable choice for the metrics [metrics_name] and add a hook calling [display_function] whenever this metrics is selected and launched. *) val register_metrics : string -> (GPack.box -> unit) -> unit ;; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/metrics_cilast.mli��������������������������������������������0000644�0001750�0001750�00000005303�12155630235�021745� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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.BasicMetrics.t (* 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 ;; val get_metrics : unit -> Metrics_base.BasicMetrics.t ;; (** Compute metrics on whole CIL AST *) val compute_on_cilast: unit -> unit ;; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/metrics_cabs.mli����������������������������������������������0000644�0001750�0001750�00000004717�12155630235�021406� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Metrics computing on Cabs Syntactic metrics usually makes more sense on Cabs as they reference the original program. However, one loses CIL facilities for this purpose. Thus, working on Cabs is less developer-friendly. *) (** Main entry point to compute various metrics on Cabs AST instead of CIL AST. *) val compute_on_cabs: unit -> unit ;; module Halstead : sig type halstead_metrics = { distinct_operators : float; total_operators : float; distinct_operands : float; total_operands : float; program_length : float; program_volume : float; program_level : float; vocabulary_size : float; difficulty_level : float; effort_to_implement : float; time_to_implement : float; bugs_delivered : float; } ;; val get_metrics : unit -> halstead_metrics ;; val to_list : halstead_metrics -> string list list ;; end �������������������������������������������������frama-c-Fluorine-20130601/src/metrics/metrics_coverage.mli������������������������������������������0000644�0001750�0001750�00000005353�12155630235�022266� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) type reachable_functions = { syntactic : Cil_datatype.Varinfo.Set.t; semantic : Cil_datatype.Varinfo.Set.t; } ;; val percent_coverage : reachable_functions -> float ;; val compute : unit -> reachable_functions * (Cil_datatype.Varinfo.Hashtbl.key * Cil_types.init) list ;; 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 compute_coverage_by_fun: Cil_datatype.Varinfo.Set.t -> (Cil_types.kernel_function * int * int * float) list 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: *) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/metrics_gui.ml������������������������������������������������0000644�0001750�0001750�00000011030�12155630235�021073� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) type ('a, 'b, 'c) metrics_panel = { top : 'a option; bottom : 'b option; actions : 'c list; } ;; (* The option type for top and bottom GTK objects is compulsory in order not to have warnings at runtim. Creation of GTK objects cannot be made before the general window is initialized. The option type with a None value marks the fact that this value is not initialized either (it will only be at register time). *) let get_panel, set_panel, add_panel_action = let panel = ref { top = None; bottom = None; actions = []; } in (fun () -> !panel), (fun top_widget bottom_widget -> panel := { top = top_widget; bottom = bottom_widget; actions = []; } ), (fun action -> panel := { !panel with actions = action :: !panel.actions; }) ;; (** Display the [table_contents] matrix as a GTK table *) let display_as_table table_contents (parent:GPack.box) = let table = GPack.table ~columns:(List.length (List.hd table_contents)) ~rows:(List.length table_contents) ~homogeneous:true ~packing:parent#pack () in Extlib.iteri (fun i row -> Extlib.iteri (fun j text -> table#attach ~left:j ~top:i ((GMisc.label ~justify:`LEFT ~text:text ()):>GObj.widget)) row) table_contents ; ;; (** Remove all sub-elements of a GUI object *) let clear_container w = List.iter (fun c -> c#destroy ()) w#children ;; (** The panel of Metrics has two parts: - The upper part contains the various choices of the user; - The bottom part displays the result. *) let init_panel () = let v = GPack.vbox () in (* Titles, buttons, and headers *) let up = GPack.hbox ~width:120 ~packing:(v#pack ~expand:true) () in (* Results *) let bottom = GPack.vbox ~width:120 ~packing:(v#pack ~expand:true) () in let choices = GEdit.combo_box_text ~active:0 ~strings:[] ~packing:(up#pack) () in let launch_button = GButton.button ~label:"Launch metrics" ~packing:(up#pack) () in ignore(launch_button#connect#clicked (fun () -> let actions = (get_panel ()).actions in let sopt = GEdit.text_combo_get_active choices in match sopt with | None -> () | Some s -> if List.mem_assoc s actions then let action = List.assoc s actions in clear_container bottom; action bottom; else () ) ); set_panel (Some choices) (Some bottom); v ;; let reset_panel _ = let metrics_panel = get_panel () in match metrics_panel.bottom with | None -> () | Some b -> clear_container b; ;; (** Returning a value to register in Frama-C's GUI *) let coerce_panel_to_ui panel_box _main_ui = "Metrics", panel_box#coerce, None ;; (** Add a new metrics to its dedicated panel. The text is added to the combox box while the action is added to the association lists of possible actions. *) let register_metrics name display_function = add_panel_action (name, display_function); let metrics_panel = get_panel () in GEdit.text_combo_add (Extlib.the metrics_panel.top) name; ;; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/metrics_cabs.ml�����������������������������������������������0000644�0001750�0001750�00000052165�12155630235�021235� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Implementation of cyclomatic complexity measures on CAbs' AST *) open Cabs open Metrics_base open Metrics_base.BasicMetrics open Metrics_parameters ;; class metricsCabsVisitor = object(self) inherit Cabsvisit.nopCabsVisitor (* Global metrics store for this Cabs AST *) val global_metrics = ref empty_metrics (* Local metrics in computation *) val local_metrics = ref empty_metrics (* Was last statement a case ? *) val was_case = ref false (* Local metrics are kept stored after computation in this map of maps. Its storing hierachy is as follows: filename -> function_name -> metrics *) val mutable metrics_map: (BasicMetrics.t Datatype.String.Map.t) Datatype.String.Map.t = Datatype.String.Map.empty val functions_no_source: (string, int) Hashtbl.t = Hashtbl.create 97 val functions_with_source: (string, int) Hashtbl.t = Hashtbl.create 97 val mutable standalone = true (* Getters/setters *) method functions_no_source = functions_no_source method functions_with_source = functions_with_source method set_standalone v = standalone <- v method get_metrics = !global_metrics method private update_metrics_map filename strmap = metrics_map <- Datatype.String.Map.add filename strmap metrics_map (* Utility methods to increase metrics counts *) method private incr_both_metrics f = apply_then_set f global_metrics; apply_then_set f local_metrics method add_to_functions_with_source (funcname:string) = Hashtbl.add functions_with_source funcname 0; Hashtbl.remove functions_no_source funcname; method private record_and_clear metrics = let filename = metrics.cfile_name and funcname = metrics.cfunc_name in (try let fun_tbl = Datatype.String.Map.find filename metrics_map in self#update_metrics_map filename (Datatype.String.Map.add funcname !local_metrics fun_tbl); with | Not_found -> let new_stringmap = Datatype.String.Map.add funcname !local_metrics Datatype.String.Map.empty in self#update_metrics_map filename new_stringmap; ); local_metrics := empty_metrics; method vdef def = match def with | FUNDEF (_, sname, _, _, _) -> begin let funcname = Metrics_base.extract_fundef_name sname in local_metrics := {!local_metrics with cfile_name = get_filename def; cfunc_name = funcname; cfuncs = 1; (* Only one function is indeed being defined here *)}; Metrics.debug ~level:1 "Definition of function %s encountered@." funcname; apply_then_set incr_funcs global_metrics; self#add_to_functions_with_source funcname; (* On return record the analysis of the function. *) Cil.ChangeDoChildrenPost ([def], fun _ -> begin if !local_metrics <> empty_metrics then self#record_and_clear !local_metrics; [def] end ); end | DECDEF _ | TYPEDEF _ | ONLYTYPEDEF _ | GLOBASM _ | PRAGMA _ | LINKAGE _ | CUSTOM _ | GLOBANNOT _ -> Cil.DoChildren; method vexpr expr = (match expr.expr_node with | NOTHING -> () | UNARY (unop, _) -> begin match unop with | PREINCR | POSINCR | PREDECR | POSDECR -> self#incr_both_metrics incr_assigns | MINUS | PLUS | NOT | BNOT -> () | MEMOF -> self#incr_both_metrics incr_ptrs | ADDROF -> () end | LABELADDR _ -> () | BINARY (bop, _, _) -> begin match bop with | ADD | SUB | MUL | DIV | MOD | BAND | BOR | XOR | SHL | SHR | EQ | NE | LT | GT | LE | GE -> () | AND | OR -> self#incr_both_metrics incr_dpoints | ASSIGN | ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN | DIV_ASSIGN | BOR_ASSIGN | XOR_ASSIGN | SHL_ASSIGN | SHR_ASSIGN | BAND_ASSIGN | MOD_ASSIGN -> self#incr_both_metrics incr_assigns; end | CAST _ -> () | CALL _ -> self#incr_both_metrics incr_calls; | QUESTION _ -> self#incr_both_metrics incr_dpoints; self#incr_both_metrics incr_ifs; | COMMA _ | CONSTANT _ | PAREN _ | VARIABLE _ | EXPR_SIZEOF _ | TYPE_SIZEOF _ | EXPR_ALIGNOF _ | TYPE_ALIGNOF _ | INDEX _ | MEMBEROF _ | MEMBEROFPTR _ | GNU_BODY _ | EXPR_PATTERN _ -> ()); Cil.DoChildren (* Allows to count only one control-flow branch per case lists *) method private set_case stmt = match stmt.stmt_node with | CASERANGE _ | CASE _ -> was_case := true; | DEFAULT _ | _ -> was_case := false method vstmt stmt = self#incr_both_metrics incr_slocs; (match stmt.stmt_node with | DEFAULT _ -> () (* The default case is not counted as a path choice point *) | CASERANGE _ | CASE _ -> if not !was_case then self#incr_both_metrics incr_dpoints; | IF _ -> self#incr_both_metrics incr_ifs; self#incr_both_metrics incr_dpoints; | NOP _ | COMPUTATION _ | BLOCK _ -> () (* Next 3 are all loop instructions *) | WHILE _ | DOWHILE _ | FOR _ -> self#incr_both_metrics incr_loops; self#incr_both_metrics incr_dpoints; | BREAK _ | CONTINUE _ -> () | RETURN _ -> self#incr_both_metrics incr_exits; | SWITCH _ -> () | LABEL _ -> () | GOTO _ | COMPGOTO _ -> self#incr_both_metrics incr_gotos; | DEFINITION _ | ASM _ | SEQUENCE _ | TRY_EXCEPT _ | TRY_FINALLY _ | CODE_ANNOT _ | CODE_SPEC _ -> ()); self#set_case stmt; Cil.DoChildren method private stats_of_filename filename = try Datatype.String.Map.find filename metrics_map with | Not_found -> Metrics.fatal "Metrics for file %s not_found@." filename method pp_file_metrics fmt filename = Format.fprintf fmt "@[<v 0>%a@]" (fun fmt filename -> let fun_tbl = self#stats_of_filename filename in Datatype.String.Map.iter (fun _fun_name fmetrics -> Format.fprintf fmt "@ %a" pp_base_metrics fmetrics) fun_tbl; ) filename method pp_detailed_text_metrics fmt () = Datatype.String.Map.iter (fun filename _func_tbl -> Format.fprintf fmt "%a" self#pp_file_metrics filename) metrics_map end ;; (** Halstead metrics computation *) module Halstead = struct (* We follow http://www.verifysoft.com/en_halstead_metrics.html for the classification of operands and operators operands = ids, typenames, typespecs, constants *) let update_val value key tbl = try let v = Hashtbl.find tbl key in Hashtbl.replace tbl key (v + value); with | Not_found -> Hashtbl.add tbl key value ;; let update_val_incr key tbl = update_val 1 key tbl;; type operand_tbl = { var_tbl : (string, int) Hashtbl.t; cst_tbl : (Cabs.constant, int) Hashtbl.t; } ;; type operator_tbl = { knownop_tbl : (string, int) Hashtbl.t; otherop_tbl : (string, int) Hashtbl.t; reserved_tbl : (string, int) Hashtbl.t; tspec_tbl : (Cabs.typeSpecifier, int) Hashtbl.t; } ;; let id_from_init iname = match (fst iname) with | s, _, _, _ -> s ;; class halsteadCabsVisitor = object(self) inherit Cabsvisit.nopCabsVisitor val operand_tbl = { var_tbl = Hashtbl.create 7; cst_tbl = Hashtbl.create 7; } val operator_tbl = { knownop_tbl = Hashtbl.create 7; otherop_tbl = Hashtbl.create 7; reserved_tbl = Hashtbl.create 7; tspec_tbl = Hashtbl.create 7; } method get_operator_tbl () = operator_tbl method get_operand_tbl () = operand_tbl method add_paren () = update_val_incr "(" operator_tbl.otherop_tbl; update_val_incr ")" operator_tbl.otherop_tbl; method vexpr e = match e.Cabs.expr_node with | UNARY _ -> let unop = fst (Cprint.get_operator e) in update_val_incr unop operator_tbl.knownop_tbl; Cil.DoChildren; | BINARY _ -> let binop = fst (Cprint.get_operator e) in update_val_incr binop operator_tbl.knownop_tbl; Cil.DoChildren; | QUESTION _ -> update_val_incr "?" operator_tbl.otherop_tbl; update_val_incr ":" operator_tbl.otherop_tbl; Cil.DoChildren; | COMMA elist -> let n = List.length elist in if (n > 1) then update_val (n - 1) "," operator_tbl.otherop_tbl; Cil.DoChildren; | CONSTANT c -> update_val_incr c operand_tbl.cst_tbl; Cil.DoChildren; | PAREN _ -> self#add_paren (); Cil.DoChildren; | VARIABLE s -> update_val_incr s operand_tbl.var_tbl; Cil.DoChildren; | EXPR_SIZEOF _ -> update_val_incr "sizeof" operator_tbl.reserved_tbl; Cil.DoChildren; | TYPE_SIZEOF _ -> update_val_incr "sizeof" operator_tbl.reserved_tbl; Cil.DoChildren; | INDEX _ -> update_val_incr "[]" operator_tbl.otherop_tbl; Cil.DoChildren; | _ -> Cil.DoChildren; method vstmt s = let reserved rstr = update_val_incr rstr operator_tbl.reserved_tbl; Cil.DoChildren; in match s.Cabs.stmt_node with | BLOCK _ -> update_val_incr "{" operator_tbl.otherop_tbl; update_val_incr "}" operator_tbl.otherop_tbl; Cil.DoChildren; | SEQUENCE _ -> print_string "seq\n"; update_val_incr ";" operator_tbl.otherop_tbl; Cil.DoChildren; | IF _ -> self#add_paren (); reserved "if"; | WHILE _ -> self#add_paren (); reserved "while"; | DOWHILE _ -> update_val_incr "do" operator_tbl.reserved_tbl; self#add_paren (); reserved "while"; | FOR _ -> self#add_paren (); update_val 2 ";" operator_tbl.otherop_tbl; reserved "for"; | BREAK _ -> reserved "break"; | CONTINUE _ -> reserved "continue"; | RETURN _ -> reserved "return"; | SWITCH _ -> self#add_paren (); reserved "switch"; | CASE _ -> reserved "case"; | CASERANGE _ -> update_val_incr "..." operator_tbl.otherop_tbl; update_val 2 ";" operator_tbl.otherop_tbl; reserved "case"; | DEFAULT _ -> reserved "default"; | LABEL _ -> update_val_incr ":" operator_tbl.otherop_tbl; Cil.DoChildren; | GOTO (s, _) -> let lname = Format.sprintf "label_%s" s in update_val_incr lname operand_tbl.var_tbl; reserved "goto"; | COMPGOTO _ -> update_val_incr "*" operator_tbl.otherop_tbl; reserved "goto"; | DEFINITION _ -> Cil.DoChildren; | ASM _ -> reserved "asm"; | TRY_EXCEPT _ -> update_val_incr "except" operator_tbl.reserved_tbl; reserved "try"; | TRY_FINALLY _ -> update_val_incr "finally" operator_tbl.reserved_tbl; reserved "try"; | _ -> Cil.DoChildren; method vtypespec tspec = update_val_incr tspec operator_tbl.tspec_tbl; Cil.DoChildren; method vspec spec = let reserved rstr = update_val_incr rstr operator_tbl.reserved_tbl; in let do_spec s = match s with | SpecTypedef -> reserved "typedef" | SpecInline -> reserved "inline" | SpecStorage AUTO -> reserved "auto" | SpecStorage STATIC -> reserved "static" | SpecStorage EXTERN -> reserved "extern" | SpecStorage REGISTER -> reserved "register" | SpecCV CV_CONST -> reserved "const" | SpecCV CV_VOLATILE -> reserved "volatile" | SpecCV CV_RESTRICT -> reserved "restrict" | _ -> () in List.iter do_spec spec; Cil.DoChildren; method vdecltype tdecl = match tdecl with | JUSTBASE -> Cil.SkipChildren; | PARENTYPE _ -> self#add_paren (); Cil.DoChildren; | ARRAY _ -> update_val_incr "array" operator_tbl.reserved_tbl; Cil.DoChildren; | PTR _ -> update_val_incr "*" operator_tbl.otherop_tbl; Cil.DoChildren; | PROTO _ -> Cil.SkipChildren; method vinitexpr ie = ( match ie with | COMPOUND_INIT l -> let n = List.length l in if n > 0 then update_val n "," operator_tbl.otherop_tbl; | _ -> ()); Cil.DoChildren method vblock b = if b.bstmts <> [] then ( let n = List.length b.bstmts in update_val n ";" operator_tbl.otherop_tbl); if b.battrs <> [] then update_val (List.length b.battrs) "," operator_tbl.otherop_tbl; Cil.DoChildren; method vdef d = match d with | FUNDEF (bl, (_, (fname, dtype, _, nloc)), b, loc1, loc2) -> Cil.ChangeDoChildrenPost( [FUNDEF(bl, ([], (fname, dtype, [], nloc)), b, loc1, loc2)], fun x -> x) | DECDEF (_, (_, name_list), _) -> let n = List.fold_left (fun acc n -> update_val_incr (id_from_init n) operand_tbl.var_tbl; acc + 1 ) (-1) name_list in begin assert(n >= 0); if (n > 0) then update_val n "," operator_tbl.otherop_tbl; Cil.DoChildren; end | _ -> Cil.DoChildren end ;; let compose _x1 y1 (x2, y2) = (1 + x2), (y1 + y2);; let fold x y = Hashtbl.fold compose x y;; let compute_operators operator_tbl = let x, y = fold operator_tbl.tspec_tbl ( fold operator_tbl.otherop_tbl ( fold operator_tbl.reserved_tbl ( fold operator_tbl.knownop_tbl (0,0)))) in (float_of_int x), (float_of_int y) ;; let compute_operands operand_tbl = let x, y = fold operand_tbl.cst_tbl ( fold operand_tbl.var_tbl (0,0)) in (float_of_int x), (float_of_int y) ;; type halstead_metrics = { distinct_operators : float; total_operators : float; distinct_operands : float; total_operands : float; program_length : float; program_volume : float; program_level : float; vocabulary_size : float; difficulty_level : float; effort_to_implement : float; time_to_implement : float; bugs_delivered : float; } let get_metrics cabs_visitor = let operator_tbl = cabs_visitor#get_operator_tbl () in let operand_tbl = cabs_visitor#get_operand_tbl () in let distinct_operators, total_operators = compute_operators operator_tbl and distinct_operands, total_operands = compute_operands operand_tbl in let program_length = total_operands +. total_operators in let vocabulary_size = distinct_operands +. distinct_operators in let log2 x = (Pervasives.log x) /. (Pervasives.log 2.0) in let program_volume = program_length *. (log2 vocabulary_size) in let difficulty_level = (distinct_operators /. 2.) *. (total_operands /. distinct_operands) in let program_level = 1. /. difficulty_level in let effort_to_implement = program_volume *. difficulty_level in let time_to_implement = effort_to_implement /. 18. in let bugs_delivered = (effort_to_implement ** (2./.3.)) /. 3000. in { distinct_operators = distinct_operators; total_operators = total_operators; distinct_operands = distinct_operands; total_operands = total_operands; program_length = program_length; program_volume = program_volume; program_level = program_level; vocabulary_size = vocabulary_size; difficulty_level = difficulty_level; effort_to_implement = effort_to_implement; time_to_implement = time_to_implement; bugs_delivered = bugs_delivered; } ;; let to_list hmetrics = [ [ "Total operators"; float_to_string hmetrics.total_operators; ]; [ "Distinct operators"; float_to_string hmetrics.distinct_operators; ]; [ "Total_operands"; float_to_string hmetrics.total_operands; ]; [ "Distinct operands"; float_to_string hmetrics.distinct_operands; ]; [ "Program length"; float_to_string hmetrics.program_length; ]; [ "Vocabulary size"; float_to_string hmetrics.vocabulary_size; ]; [ "Program volume"; float_to_string hmetrics.program_volume; ]; [ "Effort"; float_to_string hmetrics.effort_to_implement; ]; [ "Program level"; float_to_string hmetrics.program_level; ]; [ "Difficulty level"; float_to_string hmetrics.difficulty_level; ]; [ "Time to implement"; float_to_string hmetrics.time_to_implement; ]; [ "Bugs delivered"; float_to_string hmetrics.bugs_delivered; ]; ] ;; let pp_metrics ppf cabs_visitor = let metrics = get_metrics cabs_visitor in (* Compute the metrics from the informations gathered by the visitor. *) let minutes = (int_of_float metrics.time_to_implement) / 60 in let _hours, _minutes = minutes / 60, minutes mod 60 in let operator_tbl = cabs_visitor#get_operator_tbl () in let operand_tbl = cabs_visitor#get_operand_tbl () in let dummy_cst cst = { expr_loc = (Lexing.dummy_pos, Lexing.dummy_pos); expr_node = CONSTANT cst; } and simple_pp_htbl ppf htbl = Hashtbl.iter (fun k v -> Format.fprintf ppf "%s: %d@ " k v) htbl in (* Halstead metrics' bugs delivered statistics is said to be underapproximated for C. Hence the "lower bound" commentary on the output next to "bugs delivered". *) let title = "Halstead metrics" and stats = "Global statistics (Halstead)" and operator_sec = "Operators" and operand_sec = "Operands" in Format.fprintf ppf "@[<v 0>%a@ %a@ @ \ %a@ \ @[<v 2>%a@ %a%a%a%a@]@ \ @[<v 2>%a@ %a%a@]@ \ @]" (mk_hdr 1) title (fun ppf l -> List.iter (fun rowl -> Format.fprintf ppf "@[<hov>"; (match rowl with | title :: contents -> Format.fprintf ppf "%s:@ " title; List.iter (fun s -> Format.fprintf ppf "%s@ " s) contents; | [] -> ()); Format.fprintf ppf "@]@ "; ) l) (to_list metrics) (mk_hdr 1) stats (mk_hdr 2) operator_sec (* Operators table *) simple_pp_htbl operator_tbl.reserved_tbl simple_pp_htbl operator_tbl.otherop_tbl simple_pp_htbl operator_tbl.knownop_tbl (fun ppf htbl -> Hashtbl.iter (fun k v -> Format.fprintf ppf "%a: %d@ " Cprint.print_type_spec k v) htbl) operator_tbl.tspec_tbl (* Operands *) (mk_hdr 2) operand_sec simple_pp_htbl operand_tbl.var_tbl (fun ppf htbl -> Hashtbl.iter (fun k v -> Format.fprintf ppf "%a: %d@ " Cprint.print_expression (dummy_cst k) v) htbl) operand_tbl.cst_tbl; ;; let compute_metrics () = (* Run the visitor on all files *) let cabs_files = Ast.UntypedFiles.get () in let cabs_visitor = new halsteadCabsVisitor in List.iter (fun file -> ignore (Cabsvisit.visitCabsFile (cabs_visitor:>Cabsvisit.cabsVisitor) file)) cabs_files ; Metrics.result "%a" pp_metrics cabs_visitor; ;; let get_metrics () = let cabs_files = Ast.UntypedFiles.get () in let cabs_visitor = new halsteadCabsVisitor in List.iter (fun file -> ignore (Cabsvisit.visitCabsFile (cabs_visitor:>Cabsvisit.cabsVisitor) file)) cabs_files ; get_metrics cabs_visitor ;; end let compute_on_cabs () = try let cabs_files = Ast.UntypedFiles.get () in let cabs_visitor = new metricsCabsVisitor in List.iter (fun file -> Metrics.debug ~level:2 "Compute Cabs metrics for file %s@." (fst file); ignore (Cabsvisit.visitCabsFile (cabs_visitor:>Cabsvisit.cabsVisitor) file); ) cabs_files ; if Metrics_parameters.ByFunction.get () then Metrics.result "@[<v 0>Cabs:@ %a@]" cabs_visitor#pp_detailed_text_metrics (); Halstead.compute_metrics (); with | Ast.NoUntypedAst -> Metrics.warning "@[<v 0> Project has no untyped AST. Only metrics over normalized CIL \ AST are available. \ @]@." ;; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/metrics_parameters.mli����������������������������������������0000644�0001750�0001750�00000004556�12155630235�022642� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module Metrics: Plugin.S module Enabled: Plugin.WithOutput (** Activate metrics *) module ByFunction: Plugin.Bool (** Activate metrics by function *) module ValueCoverage: Plugin.WithOutput (** Give an estimation about value analysis code penetration. Only works on CIL AST. *) module AstType: 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 *) module SyntacticallyReachable: Plugin.String_set (** List of functions for which we compute the functions they may call *) (* Local Variables: compile-command: "make -C ../.." End: *) ��������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/register.ml���������������������������������������������������0000644�0001750�0001750�00000005551�12155630235�020420� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Metrics_parameters ;; let () = Enabled.set_output_dependencies [ Ast.self; AstType.self; OutputFile.self; SyntacticallyReachable.self; ] ;; let syntactic () = begin match AstType.get () with | "cil" -> Metrics_cilast.compute_on_cilast () (* Cabs metrics are experimental. unregistered, unjournalized *) | "cabs" -> Metrics_cabs.compute_on_cabs () | _ -> assert false (* the possible values are checked by the kernel*) end; 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 Enabled.get () then Enabled.output syntactic; if ValueCoverage.get () then ValueCoverage.output value; ;; (* Register main entry points *) let () = Db.Main.extend main (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/register_gui.ml�����������������������������������������������0000644�0001750�0001750�00000027047�12155630235�021270� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** This module defines abstraction for Metrics use *) let mk_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:true) () 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 module HalsteadMetricsGUI = struct let compute = Metrics_cabs.compute_on_cabs let name = "Halstead" let display_result (parent_win:GPack.box) = let padder = GBin.alignment ~padding:(5, 5, 15, 15) ~packing:parent_win#pack () in let box = GPack.vbox ~homogeneous:false () in padder#add (box:>GObj.widget); ignore(GMisc.label ~markup:(Printf.sprintf "<b>%s</b>" name) ~justify:`LEFT ~packing:box#pack ()); ignore(GMisc.separator `HORIZONTAL ~packing:box#pack ()); let metrics = Metrics_cabs.Halstead.get_metrics () in let table_contents = Metrics_cabs.Halstead.to_list metrics in Metrics_gui.display_as_table table_contents box let register _ = Metrics_gui.register_metrics name display_result end module CyclomaticMetricsGUI = struct open Metrics_base open Pretty_source open Visitor let name = "Cyclomatic" class cyclo_class (main_ui:Design.main_window_extension_points) = object(self) val mutable checked_fun = Kernel_function.dummy () method get_data = let checker = (new Metrics_cilast.slocVisitor) in ignore (visitFramacGlobal (checker :> frama_c_visitor) (Kernel_function.get_global checked_fun)); checker#get_metrics (* 2 becomes "2*checker#funcs" in the general case *) method do_value (main_ui:Design.main_window_extension_points) loc (total:int) (valeur:int) (percent:float) = match loc with | PVDecl (Some kf,_) -> begin (* Get the global of this function *) let fname = Kernel_function.get_name kf in (* create a small results window *) let dialog = GWindow.window ~title:(Format.sprintf "Value analysis statistics of %s" fname) ~modal:false ~position:`CENTER_ON_PARENT ~border_width:3 ~resizable:true () in dialog#set_transient_for main_ui#main_window#as_window; let padder = GBin.alignment ~padding:(5, 0, 15, 15) ~packing:dialog#add () in let vbox = GPack.vbox () in padder#add (vbox:>GObj.widget); ignore (dialog#event#connect#delete ~callback:(fun _ -> dialog#misc#hide (); true)); ignore(GMisc.label ~markup:(Printf.sprintf "<b>%s</b>" fname) ~justify:`LEFT ~packing:vbox#pack ()); ignore(GMisc.separator `HORIZONTAL ~packing:vbox#pack ()); let metrics_data = [["total stmts";(string_of_int total)]; ["stmts analyzed";(string_of_int valeur)]; ["percentage of stmts covered"; (string_of_float percent)] ] in Metrics_gui.display_as_table metrics_data vbox; let close_button = GButton.button ~stock:`OK ~packing:vbox#pack () in close_button#set_border_width 10; ignore (close_button#connect#clicked ~callback:dialog#misc#hide); dialog#show () end | _ -> prerr_endline "no function" method do_cyclo (main_ui:Design.main_window_extension_points) = let fname = Kernel_function.get_name checked_fun in (* create a small results window *) let dialog = GWindow.window ~title:(Format.sprintf "Measures for %s" fname) ~modal:false ~position:`CENTER_ON_PARENT ~border_width:3 ~resizable:true () in dialog#set_transient_for main_ui#main_window#as_window; let padder = GBin.alignment ~padding:(5, 0, 15, 15) ~packing:dialog#add () in let vbox = GPack.vbox () in padder#add (vbox:>GObj.widget); ignore (dialog#event#connect#delete ~callback:(fun _ -> dialog#misc#hide (); true)); ignore(GMisc.label ~markup:(Printf.sprintf "<b>%s</b>" fname) ~justify:`LEFT ~packing:vbox#pack ()); ignore(GMisc.separator `HORIZONTAL ~packing:vbox#pack ()); let metrics_data = BasicMetrics.to_list self#get_data in Metrics_gui.display_as_table metrics_data vbox; let close_button = GButton.button ~stock:`OK ~packing:vbox#pack () in close_button#set_border_width 10; ignore (close_button#connect#clicked ~callback:dialog#misc#hide); dialog#show () (* callback of menu_item "Cyclo" *) method display_localizable localizable () = begin match localizable with | PVDecl (Some kf,_) -> (* Process only the function selected *) (* Get the global of this function *) checked_fun <- kf; self#do_cyclo main_ui; | _ -> () end method cyclo_selector (popup_factory:GMenu.menu GMenu.factory) _main_ui ~button localizable = if button = 3 && Db.Value.is_computed () then match localizable with | PVDecl (Some kf, _) -> let callback1 () = Metrics_parameters.Metrics.debug "cyclo_selector - callback"; self#display_localizable localizable () in let callback2 () = (* function selected is kf *) let semantic = (Metrics_coverage.compute_semantic ()) in let l = (Metrics_coverage.compute_coverage_by_fun semantic) in (* Got a list of (kf,value,total,percent). Now let's scan this list *) try let (_,valeur,total,percent) = (List.find (fun (kf2,_,_,_) -> Kernel_function.equal kf kf2) l) in self#do_value main_ui localizable valeur total percent with Not_found -> () in begin ignore (popup_factory#add_item "Cyclomatic metrics" ~callback:callback1); ignore (popup_factory#add_item "Value metrics" ~callback:callback2) end | _ -> () initializer main_ui#register_source_selector self#cyclo_selector end let compute () = Metrics_cilast.compute_on_cilast () let display_result (parent_win:GPack.box) = let padder = GBin.alignment ~padding:(5, 5, 15, 15) ~packing:parent_win#pack () in let box = GPack.vbox ~homogeneous:false () in padder#add (box:>GObj.widget); ignore(GMisc.label ~markup:(Printf.sprintf "<b>%s</b>" name) ~justify:`LEFT ~packing:box#pack ()); ignore(GMisc.separator `HORIZONTAL ~packing:box#pack ()); let metrics = Metrics_cilast.get_metrics () in let table_contents = BasicMetrics.to_list metrics in Metrics_gui.display_as_table table_contents box let register main_ui = ignore (new cyclo_class main_ui); Metrics_gui.register_metrics name display_result end (** GUI hooks value coverage *) module ValueCoverageGUI = struct open Cil_datatype open Metrics_coverage open Gtk_helper let name = "Value coverage" let result = ref None let highlight = ref true (* TODO : Metrics data structure must be projectified ? *) let compute () = begin match !result with | None -> result := Some (fst (Metrics_coverage.compute ())) | Some _ -> () end; Extlib.the !result (* Functions are highlighted using different colors according to the following scheme: - Both semantically and syntactically reachable functions are green; - Only syntactically reachable are yellow; - Unreachable (neither semantically nor syntactically) functions are in red (bad!) *) let highlighter buffer loc ~start ~stop = if !highlight then begin match !result with | None -> () | Some metrics -> begin let pure_syntactic = Varinfo.Set.diff metrics.syntactic metrics.semantic in let hilit color = let tag = make_tag buffer "metrics" [`BACKGROUND color] in apply_tag buffer tag start stop in let syn_hilit () = hilit "yellow" and sem_hilit () = hilit "green" and unseen_hilit () = hilit "red" in match loc with | Pretty_source.PVDecl(_, vi) -> if Ast_info.is_function_type vi then begin if Varinfo.Set.mem vi pure_syntactic then syn_hilit () else if Varinfo.Set.mem vi metrics.semantic then sem_hilit () else unseen_hilit () end | _ -> () end end let display_result main_ui (parent_win:GPack.box) = let padder = GBin.alignment ~padding:(5, 5, 15, 15) ~packing:parent_win#pack () in let box = GPack.vbox ~homogeneous:false () in padder#add (box:>GObj.widget); ignore(GMisc.label ~markup:(Printf.sprintf "<b>%s</b>" name) ~justify:`LEFT ~packing:box#pack ()); ignore(GMisc.separator `HORIZONTAL ~packing:box#pack ()); let metrics = compute () in let pcent = Metrics_coverage.percent_coverage metrics in let progress_bar = GRange.progress_bar ~packing:box#pack () in progress_bar#set_fraction (pcent /. 100.0); ignore(GMisc.label ~markup:(Format.sprintf "%s%% functions reached" (Metrics_base.float_to_string pcent)) ~justify:`LEFT ~packing:box#pack ()); let _ = Gtk_helper.on_bool box "Highlight results" (fun () -> !highlight) (fun b -> highlight := b; main_ui#rehighlight ()) in main_ui#rehighlight () let register main_ui = Design.register_reset_extension (fun _ -> result := None); main_ui#register_source_highlighter highlighter; Metrics_gui.register_metrics name (display_result main_ui); end let register_final main_ui = let box = Metrics_gui.init_panel () in Design.register_reset_extension Metrics_gui.reset_panel; HalsteadMetricsGUI.register main_ui; CyclomaticMetricsGUI.register main_ui; ValueCoverageGUI.register main_ui; Metrics_gui.coerce_panel_to_ui box main_ui let gui (main_ui:Design.main_window_extension_points) = main_ui#register_panel register_final let () = Design.register_extension gui �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/css_html.ml���������������������������������������������������0000644�0001750�0001750�00000007333�12155630235�020410� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let css = "\ body {\ display:block;\ position: relative;\ left: 5%;\ width: 90%;\ font-family: Georgia, Times, serif;\ font-size: 10pt; /* base size */\ min-height: 30em;\ background: #ffffff;\ color: #444444;\ }\ \ h1 {\ font-family: Optima, Verdana, Arial, sans;\ font-size: 1.6em;\ font-weight: normal;\ color: black;\ margin: 0.4em 0em 0.4em 0em;\ padding: 0.4em 0em 0em 1em;\ border-bottom: thin solid #404040;\ }\ \ h2 {\ font-family: Optima, Verdana, Arial, sans;\ font-size: 1.2em;\ font-weight: normal;\ color: black;\ margin: 0.4em 0em 0.4em 0em;\ padding: 0.4em 0em 0em 1em;\ border-bottom: thin dotted #404040;\ }\ \ h3 {\ font-family: Optima, Verdana, Arial, sans;\ font-size: 1.2em;\ font-weight: normal;\ color: black;\ margin: 0.4em 0em 0.4em 0em;\ padding: 0.4em 0em 0em 1em;\ }\ \ td {\ text-align: center;\ border: thin solid black; \ }\ \ th { \ text-align: center;\ font-weight: normal;\ color: black;\ border: thin solid black; \ padding: 3pt;\ background-color: #bfb4b4;\ }\ \ td.entry { \ text-align: left;\ font-weight: normal;\ color: black;\ border: thin solid black; \ padding: 3pt;\ background-color: #e8e8e8 ;\ }\ td.stat { \ text-align: center;\ color: black;\ border: thin solid black; \ padding: 3pt;\ width: 20%; \ }\ \ td.result { \ text-align: center;\ color: black;\ border: thin solid black; \ padding: 3pt;\ background-color: #AFC7C7 ;\ }\ \ tr {}\ \ caption {\ caption-side: bottom;\ }\ \ table {\ border: medium solid black;\ width: 90%; \ }\ \ div.graph {\ text-align: center;\ }\ \ ul.horizontal {\ padding:0;\ margin:0;\ list-style-type:none;\ }\ \ li.horizontal {\ margin-left:1.5em;\ float:left; /*pour IE*/\ }\ \ span {\ font-weight: bold;\ }\ \ a.varinfo, span.vdecl a.varinfo_fun {\ text-decoration: none;\ }\ \ a.varinfo, a.varinfo_fun {\ color: #000;\ }\ \ h3.back {\ font-family: Optima, Verdana, Arial, sans;\ padding-top: 2em;\ }\ \ h3.back a {\ color:black;\ }\ " �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/metrics_coverage.ml�������������������������������������������0000644�0001750�0001750�00000030604�12155630235�022112� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 = object(self) inherit Visitor.frama_c_inplace (* 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 = Annotations.funspec ~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 = object(self) inherit coverageAuxVisitor 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 = let unseen = Varinfo.Set.diff syntactic semantic in object(self) inherit coverageAuxVisitor 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 %t)@]@ " vinit.vname vi.vname Cil.pp_thisloc ) | 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>%a@ " (Metrics_base.mk_hdr 2) "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 = object inherit Visitor.frama_c_inplace 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 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 in v#compute_and_print ;; let compute_syntactic kf = let vis = new callableFunctionsVisitor 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;@ " Printer.pp_varinfo vinfo) vinfoset) fvinfoset ) map; Format.fprintf fmt "@]" ;; type reachable_functions = { syntactic : Varinfo.Set.t; semantic : Varinfo.Set.t; } ;; let percent_coverage rfun = let nsyn = Varinfo.Set.cardinal rfun.syntactic and nsem = Varinfo.Set.cardinal rfun.semantic in let percent = (float_of_int nsem) /. (float_of_int nsyn) *. 100.0 in percent ;; let all_funs () = Globals.Functions.fold (fun kf acc -> let vi = Kernel_function.get_vi kf in if Metrics_base.consider_function vi then Varinfo.Set.add vi acc else acc) Varinfo.Set.empty let compute () = !Db.Value.compute (); let semantic = compute_semantic () in let main = fst (Globals.entry_point ()) in let syntactic, initializers = compute_syntactic main in { syntactic = syntactic; semantic = semantic; }, initializers ;; let pp_value_coverage () = assert (Db.Value.is_computed ()); let reachable, initializers = compute () in let all = all_funs () in let syntactic = reachable.syntactic and semantic = reachable.semantic in let unseen = Varinfo.Set.diff syntactic semantic in let unseen_num = Varinfo.Set.cardinal unseen in let nall = Varinfo.Set.cardinal all 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>\ %a@ \ Syntactically reachable functions = %d (out of %d)@ \ Semantically reached functions = %d@ \ Coverage estimation = %.1f%% @ " (Metrics_base.mk_hdr 1) "Value coverage statistics" nsyn nall 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 all = all_funs () in let card_syn = Varinfo.Set.cardinal syntactic in let title_reach = Pretty_utils.sfprintf "%a: %d" Kernel_function.pretty kf card_syn in let card_all = Varinfo.Set.cardinal all in let title_unreach = Pretty_utils.sfprintf "%a: %d" Kernel_function.pretty kf (card_all - card_syn) in Format.fprintf fmt "@[<v 0>%a@ %a@ %a@ %a@]" (Metrics_base.mk_hdr 2) (Format.sprintf "Functions syntactically reachable from %s" title_reach) pp_fun_set_by_file syntactic (Metrics_base.mk_hdr 2) (Format.sprintf "Functions syntactically unreachable from %s" title_unreach) pp_fun_set_by_file (Varinfo.Set.diff all 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>%a@ \ %d stmts in analyzed functions, %d stmts analyzed (%.1f%%)@ " (Metrics_base.mk_hdr 2) "Statements analyzed by Value" 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: *) ����������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/metrics_parameters.ml�����������������������������������������0000644�0001750�0001750�00000006340�12155630235�022462� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module Metrics = Plugin.Register (struct let name = "metrics" let shortname = "metrics" let help = "syntactic metrics" end) module Enabled = Metrics.WithOutput (struct let option_name = "-metrics" let help = "activate metrics computation" let output_by_default = true end) module ByFunction = Metrics.WithOutput (struct let option_name = "-metrics-by-function" let help = "also compute metrics on a per-function basis" let output_by_default = true end) 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 AstType = 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 () = AstType.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: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/metrics/metrics_base.mli����������������������������������������������0000644�0001750�0001750�00000014337�12155630235�021407� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Tag functions handling html tags for Format *) val html_tag_functions : Format.formatter_tag_functions;; (** mk_hdr [level] [ppf] [hdr_strg] produces a title from [hdr_strg] with an underline of the same length. The character of the underline is set according to [level]: - level 1 headers are underlined by '=' - level 2 headers by '-' - level 3 headers by '~' This function is supposed to follow reStructuredText's conventions. *) val mk_hdr : int -> Format.formatter -> string -> unit;; module BasicMetrics : sig (** Simple type of metrics. *) type t = { cfile_name : string ; (** Filename *) cfunc_name : string ; (** Function name if applicable, eg. not for global metrics *) cslocs: int ; (** Lines of code w.r.t. statements *) cifs: int ; (** If / cases of switch *) cloops: int ; (** Loops: for, while, do...while *) ccalls: int ; (** Function calls *) cgotos: int ; (** Gotos *) cassigns: int ; (** Assignments *) cexits: int ; (** Exit points: return *) cfuncs: int ; (** Functions defined: 1 in the case of a single function, possibly more for a file.*) cptrs: int ; (** Access to pointers *) cdecision_points: int ; (** Decision points of the program: ifs, switch cases, exception handlers, ... *) cglob_vars: int; (** Global variables *) } (** Helpers for metrics purposes for single increment steps *) val incr_funcs : t -> t ;; val incr_slocs : t -> t ;; val incr_ptrs : t -> t ;; val incr_ifs : t -> t ;; val incr_dpoints : t -> t ;; val incr_loops : t -> t ;; val incr_gotos : t -> t ;; val incr_exits : t -> t ;; val incr_assigns : t -> t ;; val incr_calls : t -> t ;; val incr_glob_vars : t -> t ;; (** Update a reference from a pure functional function. Used in particular in combination with helper functions above. *) val apply_then_set : (t -> t) -> t ref -> unit ;; (** Initial empty values for metrics computing. *) val empty_metrics: t;; (** Compute cyclomatic complexity from base_metrics record type. *) val cyclo: t -> int;; (** Matrix-like representation of the record in "Title: value" stytle *) val to_list : t -> string list list ;; (** Pretty printers for base metrics as text or html. *) val pp_base_metrics: Format.formatter -> t -> unit;; val pp_base_metrics_as_html_row: Format.formatter -> t -> unit;; end ;; (** Local varinfo map where the comparison function is the lexicographic one on their respectives names. *) module VInfoMap: sig include Map.S with type key = Cil_types.varinfo (* This should be removed whenever 3.12 will be the oldest OCaml version used and replaced by Map.cardinal. *) (** Cardinal of a VInfoMap *) val map_cardinal: 'a t -> int;; val to_varinfo_map: 'a t -> 'a Cil_datatype.Varinfo.Map.t end ;; val map_cardinal_varinfomap: 'a Cil_datatype.Varinfo.Map.t -> int;; (** Pretty print a varinfo set. *) val pretty_set : ((Cil_types.varinfo -> int -> unit) -> 'a -> 'b) -> Format.formatter -> 'a -> unit ;; (** Handling entry points informations *) val number_entry_points : ((Cil_types.varinfo -> int -> int -> int) -> 'a -> int -> 'b) -> 'a -> 'b ;; val pretty_entry_points : ((Cil_types.varinfo -> int -> unit) -> 'a -> unit) -> Format.formatter -> 'a -> unit ;; (** Get the filename where the definition of a varinfo occurs *) val file_of_vinfodef: Cil_types.varinfo -> string;; (** Get the filename containing the function definition *) val file_of_fundef: Cil_types.fundec -> string;; val extract_fundef_name: Cabs.single_name -> string;; val get_filename: Cabs.definition -> string;; (** Type of the generated report file. Automatically set according to the file extension. *) type output_type = | Html | Text ;; (** get_file_type [extension] sets the output type according to [extension]. Raises an error if [extension] is not among supported extensions or is empty. *) val get_file_type: string -> output_type;; (** consider_function [vinfo] returns false if the varinfo is not a function we are interested in. For example, builtins should not be part of the analysis and return false. Skip them using this auxiliary function. *) val consider_function: Cil_types.varinfo -> bool (** Convert float to string with the following convention: - if the float is an integer (ie, it has no digits after the decimal point), print it as such; - otherwise, print the first two digits after the decimal point. *) val float_to_string : float -> string ;; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/security_slicing/�����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020146� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/security_slicing/security_slicing_parameters.mli����������������������0000644�0001750�0001750�00000003661�12155630165�026462� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ************************************************************************* *) (** {2 Security parameters} *) (* ************************************************************************* *) open Plugin include S module Slicing: Bool (** Perform the security slicing pre-analysis. *) (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/security_slicing/configure��������������������������������������������0000755�0001750�0001750�00000276436�12155634042�022076� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 </dev/null exec 6>&1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME= PACKAGE_TARNAME= PACKAGE_VERSION= PACKAGE_STRING= PACKAGE_BUGREPORT= PACKAGE_URL= ac_unique_file="Makefile.in" ac_subst_vars='LTLIBOBJS LIBOBJS DYNAMIC_SECURITY_SLICING ENABLE_SECURITY_SLICING ENABLE_GUI FRAMAC_VERSION 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_security_slicing with_security_slicing_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= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures this package to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then cat <<\_ACEOF 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-security_slicing support for Security_slicing 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-security_slicing-static link security_slicing 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.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu 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 FRAMAC_VERSION=`frama-c -version | sed -n -e "s|^Version: *\(.*\)$|\1|p"` # 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 ${ac_cv_prog_ENABLE_GUI+:} false; 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 as_fn_executable_p "$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 ${ac_cv_file_Makefile_in+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "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" = xyes; then : default=yes;plugin_present=yes else plugin_present=no;default=no fi FORCE=no # Check whether --enable-security_slicing was given. if test "${enable_security_slicing+set}" = set; then : enableval=$enable_security_slicing; 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 $? "security_slicing is not available" "$LINENO" 5 fi FORCE_SECURITY_SLICING=$FORCE PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_SECURITY_SLICING ENABLE_SECURITY_SLICING=$ENABLE NAME_SECURITY_SLICING=security_slicing if test "$default" = "no" -a "$FORCE" = "no"; then INFO_SECURITY_SLICING=" (not available by default)" fi # Dynamic plug-ins configuration # Check whether --with-security_slicing-static was given. if test "${with_security_slicing_static+set}" = set; then : withval=$with_security_slicing_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_SECURITY_SLICING=$is_static if test "$is_static" != "yes"; then USE_NATIVE_DYNLINK="${USE_NATIVE_DYNLINK} security_slicing" DYNAMIC_SECURITY_SLICING=yes else DYNAMIC_SECURITY_SLICING=no fi echo "security_slicing... $ENABLE" # kept defined for write_plugin_config. A bit ugly, but not more than # usual autoconf stuff. # m4_undefine([PLUGIN_NAME]) if test "$ENABLE_SECURITY_SLICING" != "no"; then REQUIRE_SLICING=$REQUIRE_SLICING" "security_slicing REQUIRED_SECURITY_SLICING=$REQUIRED_SECURITY_SLICING" "slicing REQUIRE_VALUE_ANALYSIS=$REQUIRE_VALUE_ANALYSIS" "security_slicing REQUIRED_SECURITY_SLICING=$REQUIRED_SECURITY_SLICING" "value_analysis REQUIRE_PDG=$REQUIRE_PDG" "security_slicing REQUIRED_SECURITY_SLICING=$REQUIRED_SECURITY_SLICING" "pdg REQUIRE_GUI=$REQUIRE_GUI" "security_slicing REQUIRED_SECURITY_SLICING=$REQUIRED_SECURITY_SLICING" "gui # 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 if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\[/\\&/g s/\]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "./Makefile") 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= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' </dev/null 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 {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' <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 >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" eval set X " :F $CONFIG_FILES " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac 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 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/security_slicing/Makefile.in������������������������������������������0000644�0001750�0001750�00000005017�12155630165�022217� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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 PLUGIN_DIR ?=. PLUGIN_ENABLE:=@ENABLE_SECURITY_SLICING@ PLUGIN_DYNAMIC:=@DYNAMIC_SECURITY_SLICING@ PLUGIN_NAME:=Security_slicing PLUGIN_CMO:= security_slicing_parameters components PLUGIN_GUI_CMO:= register_gui PLUGIN_HAS_MLI:=yes PLUGIN_UNDOC:= analysis PLUGIN_DISTRIBUTED:=$(PLUGIN_ENABLE) PLUGIN_DISTRIB_EXTERNAL:= Makefile.in configure.ac configure PLUGIN_NO_TEST:=yes include $(FRAMAC_SHARE)/Makefile.dynamic # Regenerating the Makefile on need ifeq ("$(FRAMAC_INTERNAL)","yes") CONFIG_STATUS_DIR=$(FRAMAC_SRC) else CONFIG_STATUS_DIR=. endif $(Security_slicing_DIR)/Makefile: $(Security_slicing_DIR)/Makefile.in \ $(CONFIG_STATUS_DIR)/config.status cd $(CONFIG_STATUS_DIR) && ./config.status �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/security_slicing/components.ml����������������������������������������0000644�0001750�0001750�00000077056�12155630165�022705� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 open Db (* ************************************************************************* *) (** {2 Searching security annotations} *) (* ************************************************************************* *) (* (** The state of statement for which a security verification should occur. *) module Security_Annotations = Cil_computation.StmtSetRef (struct let name = "Components.Annotations" let dependencies = [ Ast.self ] end) let rec is_security_predicate p = match p.content with | 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 -> true | (* [state(lval) op term] *) Prel(_, { term_node = Tapp(f1, _, [ _ ]) }, { term_node = _ }) when f1.l_var_info.lv_name = Model.state_name -> assert false | _ -> false let has_security_requirement kf = List.exists (is_security_predicate $ Logic_const.pred_of_id_pred) (Kernel_function.get_spec kf).spec_requires (* Do not called twice. *) let search_security_requirements () = if Security_Annotations.is_empty () then begin Security_slicing_parameters.feedback ~level:3 "searching security annotations"; (* TODO: chercher dans les GlobalAnnotations *) let is_security_annotation 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 _ | AInvariant _ (* | ALoopBehavior _ *) (* [JS 2008/02/26] may contain a security predicate *) | AVariant _ | AAssigns _ -> 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); Globals.Functions.iter (fun kf -> if has_security_requirement kf then List.iter (fun (_, callsites) -> List.iter Security_Annotations.add callsites) (!Value.callers kf)); end *) (* ************************************************************************* *) (** {2 Computing security components} *) (* ************************************************************************* *) open PdgIndex let get_node_stmt node = Key.stmt (!Pdg.node_key node) module NodeKf = Datatype.Pair(PdgTypes.Node)(Kernel_function) (* type bwd_kind = Direct | Indirect type fwd_kind = Impact | Security type kind = | Backward of bwd_kind | Forward of fwd_kind (** Debugging purpose only *) let pretty_kind fmt = function | Backward Direct -> Format.fprintf fmt "backward direct" | Backward Indirect -> Format.fprintf fmt "backward indirect" | Forward Security -> Format.fprintf fmt "forward" | Forward Impact -> Format.fprintf fmt "impact" *) (* Never plugged in. To be tested. module Memo : sig val init: kind -> kernel_function -> unit val push_function: stmt -> kernel_function -> unit val pop_function: unit -> unit val memo: Pdg.t_node -> (unit -> (Pdg.t_node * kernel_function) list) -> (Pdg.t_node * kernel_function) list end = struct module Callstack = struct type t = { mutable stack: (stmt * kernel_function) list; mutable current_kf: kernel_function } let init kf callstack = callstack.stack <- []; callstack.current_kf <- kf let push stmt kf stack = stack.stack <- (stmt, stack.current_kf) :: stack.stack; stack.current_kf <- kf let pop stack = let kf = match stack.stack with [] -> assert false | (_, k) :: _ -> k in stack.current_kf <- kf 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 with Exit -> false let hash = Hashtbl.hash end (* *********************************************************************** *) (* state: kind -> callstack -> (node * kf) -> (node * kf) list *) module Nodekfs = Hashtbl.Make(NodeKf) (* (node * kf) -> (node * kf) list *) module Callstacks = struct include Hashtbl.Make(Callstack) (* callstack -> nodekfs *) let memo tbl c = try find tbl c with Not_found -> let t = Nodekfs.create 7 in replace tbl c t; t end module Memo = struct include Hashtbl let memo tbl k callstack = try 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 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; } (* *********************************************************************** *) let state = let spec = Cil.empty_funspec () in { kind = Backward Direct; callstack = { 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 } let update () = state.local_tbl <- Memo.memo state.memo_tbl state.kind state.callstack let init k kf = state.kind <- k; Callstack.init kf state.callstack; update () let push_function stmt kf = Callstack.push stmt kf state.callstack; update () let pop_function () = Callstack.pop state.callstack; update () let memo node f = let key = node, state.callstack.Callstack.current_kf in try Nodekfs.find state.local_tbl key with Not_found -> let value = f () in Nodekfs.replace state.local_tbl key value; value end *) (* used to enforce an invariant on [add] *) module Todolist : sig type todo = private { node: PdgTypes.Node.t; kf: kernel_function; pdg: Pdg.t; callstack_length: int; from_deep: bool } type t = todo list val mk_init: kernel_function -> Pdg.t -> PdgTypes.Node.t list -> todo list val add: PdgTypes.Node.t -> kernel_function -> Pdg.t -> int -> bool -> t -> t end = struct type todo = { node: PdgTypes.Node.t; 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 (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 let mk_init kf pdg = List.fold_left (fun acc n -> add n kf pdg 0 false acc) [] end module Component = struct (* not optimal implementation: no memoization (bts#006) *) module M = Map.Make(NodeKf) type fwd_kind = Impact | Security type kind = | Direct | Indirect_Backward | Forward of fwd_kind type value = { pdg: Pdg.t; mutable callstack_length: int; mutable direct: bool; mutable indirect_backward: bool; mutable forward: bool } type t = value M.t let is_direct v = v.direct let is_indirect_backward v = v.indirect_backward && not v.direct let is_forward v = not (v.direct || v.indirect_backward) (** Returns [found, new_already] with: - [found] is [true] iff [elt] was previously added for [kind] - [new_already] is [already] updated with [elt] and its (new) associated value. *) let check_and_add first elt kind pdg len (already: t) = 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;*) 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 in v.callstack_length <- min v.callstack_length len; v.direct <- dir; v.indirect_backward <- up; v.forward <- down; 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 in let v = { 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 else M.add elt v already let one_step_related_nodes kind pdg node = (* do not consider address dependencies now (except for impact analysis): just consider them during the last slicing pass (for semantic preservation of pointers) *) let direct node = !Pdg.direct_data_dpds pdg node in match kind with | 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 | Forward Impact -> !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 !Db.Value.use_spec_instead_of_definition kf then Lazy.force lazy_l else [] with Not_found -> [] let add_from_deep caller todo n = Todolist.add n caller (!Pdg.get caller) 0 true todo let forward_caller kf node todolist = 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 (PdgTypes.NodeSet.singleton node) (!Pdg.get caller) callsite in List.fold_left (add_from_deep caller) todolist nodes) todolist callsites) todolist (!Value.callers kf) let related_nodes_of_nodes kind result nodes = let initial_nodes = List.map (fun n -> n.Todolist.node, n.Todolist.kf) nodes in 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 = let nodes, _undef_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 = 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 _ -> [] 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 from_stmt = List.fold_left (fun s n -> PdgTypes.NodeSet.add n s) PdgTypes.NodeSet.empty 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 let initial_nodes kf stmt = Security_slicing_parameters.debug ~level:3 "computing initial nodes for %d" stmt.sid; 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 Not_found -> assert false else begin Security_slicing_parameters.debug ~level:3 "stmt %d is dead. skipping." stmt.sid; [] end in Todolist.mk_init kf pdg nodes let direct kf stmt = try let nodes = initial_nodes kf stmt in Security_slicing_parameters.debug "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 } in let res = 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 -> Security_slicing_parameters.warning "PDG is not manageable. skipping."; M.empty let backward kf stmt = try 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; related_nodes_of_nodes Indirect_Backward res nodes with Pdg.Top | Pdg.Bottom -> Security_slicing_parameters.warning "PDG is not manageable. skipping."; M.empty let whole kf stmt = 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 [] in Security_slicing_parameters.debug "computing forward component for stmt %d" stmt.sid; related_nodes_of_nodes (Forward Security) res from (* is exactly an impact analysis iff [fwd_kind = Impact] *) let forward fwd_kind kf stmt = let nodes = initial_nodes kf stmt in Security_slicing_parameters.debug "computing forward component for stmt %d" stmt.sid; 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 in Stmt.Set.elements set let get_component kind stmt = 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 | Forward _ -> whole, is_forward 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 in Stmt.Set.elements set (* let iter use_ctrl_dpds f kf stmt = let action = if use_ctrl_dpds then whole else direct in M.iter (fun elt _ -> f elt) (action kf stmt) *) end (* ************************************************************************ *) (* Dynamic registration *) (* ************************************************************************ *) let register name arg = Dynamic.register ~journalize:true ~plugin:"Security_slicing" name (Datatype.func Stmt.ty (Datatype.list Stmt.ty)) (Component.get_component arg) let get_direct_component = register "get_direct_component" Component.Direct let get_indirect_backward_component = register "get_indirect_backward_component" Component.Indirect_Backward let get_forward_component = register "get_forward_component" (Component.Forward Component.Security) let impact_analysis = Dynamic.register ~plugin:"Security_slicing" "impact_analysis" ~journalize:true (Datatype.func2 Kernel_function.ty Stmt.ty (Datatype.list Stmt.ty)) (Component.forward Component.Impact) (* ************************************************************************ *) (* type t = stmt *) (** Security component table: a security component is represented by the statement at which a security verification should occur. It is associated with the list of its statements. *) module Components : sig (*val add: t -> stmt -> unit val find: t -> stmt list val self: State.t val fold_fold: ('b -> t -> 'a -> 'b) -> ('a -> Cil_types.stmt -> 'a) -> 'b -> 'a -> 'b *) end = struct module S = State_builder.Hashtbl (Stmt.Hashtbl) (Datatype.Ref(Datatype.List(Stmt))) (struct let name = "Components" let size = 7 let dependencies = [ Ast.self; Db.Value.self ] end) let () = Cmdline.run_after_extended_stage (fun () -> State_dependency_graph.add_codependencies ~onto:S.self [ !Db.Pdg.self ]) (* let add c = let l = S.memo (fun _ -> ref []) c in fun s -> l := s :: !l let find s = !(S.find s) let self = S.self let fold_fold f g init_f init_g = S.fold (fun c l acc -> f acc c (List.fold_left g init_g !l)) init_f *) end (* module Nodes = State_builder.SetRef (struct include NodeKf.Datatype let compare = NodeKf.compare end) (struct let name = "Components.Nodes" let dependencies = [ Security_Annotations.self ] end) let use_ctrl_dependencies = ref false (** Set tables [Components] and [Stmts]. *) let compute, self = State_builder.apply_once "Components.compute" [ Security_Annotations.self ] (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 = 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) let () = Cmdline.run_after_extended_stage (fun () -> Project.State_builder.add_dependency self !Pdg.self; Project.State_builder.add_dependency Nodes.self self; Project.State_builder.add_dependency Components.self self) let get_component = Dynamic.register ~journalize:true "Security.get_component" (Datatype.func Kernel_type.stmt (Datatype.list Kernel_type.stmt)) (fun s -> compute (); Components.find s) (* ************************************************************************ *) (** {2 Security slicing} *) (* ************************************************************************ *) let slice ctrl = use_ctrl_dependencies := ctrl; Security_slicing_parameters.feedback ~level:2 "beginning slicing"; compute (); let name = "security slicing" in let slicing = !Slicing.Project.mk_project name in let select (n, kf) sel = Security_slicing_parameters.debug ~level:2 "selecting %a (of %s)" (!Pdg.pretty_node false) n (Kernel_function.get_name kf); !Slicing.Select.select_pdg_nodes sel (!Slicing.Mark.make ~data:true ~addr:true ~ctrl) [ n ] kf in let sel = Nodes.fold select Slicing.Select.empty_selects in Security_slicing_parameters.debug "adding selection"; !Slicing.Request.add_persistent_selection slicing sel; Security_slicing_parameters.debug "applying slicing request"; !Slicing.Request.apply_all_internal slicing; !Slicing.Slice.remove_uncalled slicing; let p = !Slicing.Project.extract name slicing in (* Project.copy ~only:(Options.get_selection_after_slicing ()) p;*) Security_slicing_parameters.feedback ~level:2 "slicing done"; p let slice = Dynamic.register "Security_slicing.slice" ~journalize:true (Datatype.func Datatype.bool Project.ty) slice *) (* Local Variables: compile-command: "make -C ../.." End: *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/security_slicing/Security_slicing.mli���������������������������������0000644�0001750�0001750�00000003375�12155630165�024201� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Security slicing. *) (** No function is directly exported: they are dynamically registered. *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/security_slicing/register_gui.mli�������������������������������������0000644�0001750�0001750�00000003434�12155630165�023346� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Extension of the GUI for the security plugin. *) (** No function is directly exported: this module simply extends the GUI. *) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/security_slicing/components.mli���������������������������������������0000644�0001750�0001750�00000003650�12155630165�023043� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Security slicing. *) open Cil_types val get_direct_component: stmt -> stmt list val get_indirect_backward_component: stmt -> stmt list val get_forward_component: stmt -> stmt list val impact_analysis: Kernel_function.t -> stmt -> stmt list (* val slice: bool -> Project.t *) (* Local Variables: compile-command: "make -C ../.." End: *) ����������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/security_slicing/register_gui.ml��������������������������������������0000644�0001750�0001750�00000007612�12155630165�023177� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Pretty_source open Gtk_helper open Cil_types module Make_HighlighterState(Info:sig val name: string end) = State_builder.List_ref (Cil_datatype.Stmt) (struct let name = Info.name let dependencies = [ Ast.self ] end) module ForwardHighlighterState = Make_HighlighterState(struct let name = "Security_gui.Forward" end) module IndirectBackwardHighlighterState = Make_HighlighterState(struct let name = "Security_gui.Indirectb" end) module DirectHighlighterState = Make_HighlighterState(struct let name = "Security_gui.Direct" end) let security_highlighter buffer loc ~start ~stop = match loc with | PStmt (_,s) -> let f = ForwardHighlighterState.get () in if List.exists (fun k -> k.sid=s.sid) f then begin let tag = make_tag buffer"forward" [`BACKGROUND "orange" ] in apply_tag buffer tag start stop end; let i = IndirectBackwardHighlighterState.get () in if List.exists (fun k -> k.sid=s.sid) i then begin let tag = make_tag buffer"indirect_backward" [`BACKGROUND "cyan" ] in apply_tag buffer tag start stop end; let d = DirectHighlighterState.get () in if List.exists (fun k -> k.sid=s.sid) d then begin let tag = make_tag buffer"direct" [`BACKGROUND "green" ] in apply_tag buffer tag start stop end | PVDecl _ | PTermLval _ | PLval _ | PGlobal _ | PIP _ -> () let security_selector (popup_factory:GMenu.menu GMenu.factory) main_ui ~button localizable = if button = 3 && Security_slicing_parameters.Slicing.get () then match localizable with | PStmt (_kf, ki) -> ignore (popup_factory#add_item "_Security component" ~callback: (fun () -> ForwardHighlighterState.set (Components.get_forward_component ki); IndirectBackwardHighlighterState.set (Components.get_indirect_backward_component ki); DirectHighlighterState.set (Components.get_direct_component ki); main_ui#rehighlight ())) | _ -> () let main main_ui = main_ui#register_source_selector security_selector; main_ui#register_source_highlighter security_highlighter let () = Design.register_extension main (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) ����������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/security_slicing/security_slicing_parameters.ml�����������������������0000644�0001750�0001750�00000003750�12155630165�026310� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module P = Plugin.Register (struct let name = "security-slicing" let shortname = "security-slicing" let help = "security slicing (experimental, undocumented)" end) include P module Slicing = False (struct let option_name = "-security-slicing" let help = "perfom the security slicing analysis" end) (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������frama-c-Fluorine-20130601/src/security_slicing/configure.ac�����������������������������������������0000644�0001750�0001750�00000004431�12155630165�022437� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## 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(security_slicing,PLUGIN_RELATIVE_PATH(plugin_file), [support for Security_slicing plug-in],yes,yes) if test "$ENABLE_SECURITY_SLICING" != "no"; then plugin_require(security_slicing,slicing) plugin_require(security_slicing,value_analysis) plugin_require(security_slicing,pdg) plugin_require(security_slicing,gui) check_plugin_dependencies fi write_plugin_config(Makefile) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/slicing_types/��������������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�017440� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/slicing_types/slicingInternals.ml�������������������������������������0000644�0001750�0001750�00000023414�12155630237�023312� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** {2 Internals types} * Internals type definitions should be hidden to the outside world, * but it is not really possible to have abstract types since Slicing has to * use Db.Slicing functions... *) open Cil_datatype (** {3 About the PDG} * As the PDG is not defined here anymore, look at * {{:../pdg/PdgTypes.html}PdgTypes} for more information about it. * *) (** {3 About options} *) (** associate a level to each function in order to control how it will be * specialized. This is only a hint used when the tool has to make a choice, * but it doesn't forbid to the user to do whatever he wants * (like building slices for a [DontSlice] function). *) type level_option = | DontSlice (** don't build slice for the function : ie. always call the source function. *) | DontSliceButComputeMarks (** don't slice the called functions, * but compute the marks for them *) | MinNbSlice (** try to use existing slices, create at most one *) | MaxNbSlice (** most precise slices (but merge slices with the same visibility, even if they don't have the same marks) *) (** {3 About function slice} *) (** Kinds of elementary marks. *) type mark = Cav of PdgTypes.Dpd.t | Spare let compare_mark m1 m2 = if m1 == m2 then 0 else match m1, m2 with | Spare, Spare -> 0 | Cav d1, Cav d2 -> PdgTypes.Dpd.compare d1 d2 | Cav _, Spare -> -1 | Spare, Cav _ -> 1 (** Each PDG element has 2 marks to deal with interprocedural propagation *) type pdg_mark = {m1 : mark ; m2 : mark } let 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 let r = compare_mark p1.m1 p2.m1 in if r = 0 then compare_mark p1.m2 p2.m2 else r (** Type for all the informations related to any function, * even if we don't have its definition. *) type fct_info = { fi_kf : Cil_types.kernel_function; fi_def : Cil_types.fundec option; fi_project : project; mutable fi_top : pdg_mark option; (** indicates if the function is maked top (=> src visible) *) mutable fi_level_option : level_option; (** level of specialisation for this function *) mutable fi_init_marks : ff_marks option; (** the marks that must be in every slices of that function *) mutable fi_slices : fct_slice list ; (** the list of the slices already computed for this function. *) mutable fi_next_ff_num : int; (** the number to assign to the next slice. *) mutable f_called_by : called_by; (** calls in slices that call source fct *) } and (** to represent where a function is called. *) called_by = (fct_slice * Cil_types.stmt) list and (** Function slice : created as soon as there is a criterion to compute it, even if the slice itself hasn't been computed yet. *) fct_slice = { ff_fct : fct_info ; ff_id : int ; mutable ff_marks : ff_marks; mutable ff_called_by : called_by } and (** [fct_id] is used to identify either a source function or a sliced one.*) fct_id = | FctSrc of fct_info (** source function *) | FctSliced of fct_slice (** sliced function *) and called_fct = | CallSrc of fct_info option (** call the source function (might be unknown if the call uses pointer) *) | CallSlice of fct_slice and (** information about a call in a slice which gives the function to call *) call_info = called_fct option and (** main part of a slice = mapping between the function elements * and information about them in the slice. *) marks_index = (pdg_mark, call_info) PdgIndex.FctIndex.t and ff_marks = PdgTypes.Pdg.t * marks_index and project = { name : string ; application : Project.t ; functions : fct_info Varinfo.Hashtbl.t; mutable actions : criterion list; } and (** Slicing criterion at the application level. When applied, they are translated into [fct_criterion] *) appli_criterion = | CaGlobalData of Locations.Zone.t (** select all that is necessary to compute the given location. *) | CaCall of fct_info (** select all that is necessary to call the given function. * Its application generates requests to add persistent selection * to all the function callers. *) | CaOther and (** Base criterion for the functions. These are the only one that can really generate function slices. All the other criterions are translated in more basic ones. Note that to build such a base criterion, the PDG has to be already computed. *) fct_base_criterion = pdg_mark PdgMarks.select and (** Used to identify a location (zone) at a given program point. * The boolean tell if the point is before (true) or after the statement *) loc_point = Cil_types.stmt * Locations.Zone.t * bool (** List of pdg nodes to be selected (see {!fct_user_crit})*) (*type nodes = pdg_node list*) and (** [node_or_dpds] tells how we want to select nodes, * or some of their dependencies (see {!fct_user_crit}). *) node_or_dpds = CwNode | CwAddrDpds | CwDataDpds | CwCtrlDpds and (** Tells which marks we want to put in the slice of a function *) fct_user_crit = (* | CuNodes of (pdg_node list * (node_or_dpds * pdg_mark) list) list *) | CuSelect of pdg_mark PdgMarks.select | CuTop of pdg_mark (** the function has probably no PDG, but we nonetheless give a mark to propagate *) and (** kinds of actions that can be apply to a function *) fct_crit = | CcUserMark of fct_user_crit (** add marks to a slice *) | CcChooseCall of Cil_types.stmt (** have to choose what function to call here. *) | CcChangeCall of Cil_types.stmt * called_fct (** call the [called_fct] for the given call [Cil_types.stmt] *) | CcMissingOutputs of Cil_types.stmt * (pdg_mark PdgMarks.select) * bool (** this call is affected to a function that doesn't compute enough * outputs : we will have to choose between adding outputs to that slice, * or call another one. The boolean tells if the modifications would * change the visibility of some outputs. *) | CcMissingInputs of Cil_types.stmt * (pdg_mark PdgMarks.select) * bool (** the function calls a slice that has been modified : * and doesn't compute not enough inputs. * We will have to choose between adding marks to this function, * and call another slice. * The boolean tells if the modifications would * change the visibility of some inputs. *) | CcPropagate of (pdg_mark PdgMarks.select) (** simply propagate the given marks *) | CcExamineCalls of pdg_mark PdgMarks.info_called_outputs and (** Slicing criterion for a function. *) fct_criterion = { cf_fct : fct_id ; (** Identification of the {b RESULT} of this filter. * When it a a slice, it might be an existing slice that will be modified, * or a new one will be created during application. * When it is the source function, it means what the criterion has to be * applied on each existing slice, and stored into the inititial marks of * the function. *) cf_info : fct_crit } and (** A slicing criterion is either an application level criterion, * or a function level one. *) criterion = CrAppli of appli_criterion | CrFct of fct_criterion (** {2 Internals values} *) (** {3 For the journalization of these internals types} *) let dummy_pdg_mark = {m1 = Spare ; m2 = Spare } (** The whole project. *) let dummy_project = { name = ""; application = Project_skeleton.dummy; functions = Varinfo.Hashtbl.create 0; actions = [] } let dummy_fct_info = { fi_kf = Kernel_function.dummy () ; fi_def = None; fi_project = dummy_project; fi_top = None; fi_level_option = DontSlice; fi_init_marks = None; fi_slices = [] ; fi_next_ff_num =0; f_called_by = []; } let dummy_marks_index = PdgIndex.FctIndex.create 0 let dummy_ff_marks = (PdgTypes.Pdg.top (Kernel_function.dummy ()), dummy_marks_index) let dummy_fct_slice = { ff_fct = dummy_fct_info ; ff_id = 0 ; ff_marks = dummy_ff_marks ; ff_called_by = [] } let dummy_fct_user_crit = CuTop dummy_pdg_mark (* Local Variables: compile-command: "make -C ../.." End: *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/slicing_types/slicingTypes.ml�����������������������������������������0000644�0001750�0001750�00000016274�12155630237�022465� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Slicing module types. *) exception Slicing_Internal_Error of string exception ChangeCallErr of string exception PtrCallExpr exception CantRemoveCalledFf exception WrongSlicingLevel (** raised when someone tries to build more than one slice for the entry point. * *) exception OnlyOneEntryPointSlice (** raised when one triesy to select something in a function where we are not * able to compute the Pdg. *) exception NoPdg (** {2 Public types} * These types are the only one that should be used by the API functions. * Public type definitions should be hidden to the outside world, * but it is not really possible to have abstract types since Slicing has to * use Db.Slicing functions... So, it is up to the user of this module to use * only this public part. *) (** contains global things that has been computed so far for the slicing project. This includes : - the slices of the functions, - and the queue of actions to be applied. *) type sl_project = SlicingInternals.project (** Type of the selections * (we store the varinfo because we cannot use the kernel_function in this file) * *) type sl_select = Cil_types.varinfo * SlicingInternals.fct_user_crit module Fct_user_crit = Datatype.Make (struct include Datatype.Undefined (* TODO: unmarshal *) type t = SlicingInternals.fct_user_crit let reprs = [ SlicingInternals.dummy_fct_user_crit ] let name = "SlicingTypes.Fct_user_crit" let mem_project = Datatype.never_any_project let varname _ = "user_criteria" end) (** Function slice *) type sl_fct_slice = SlicingInternals.fct_slice (** Marks : used to put 'colors' in the result *) type sl_mark = SlicingInternals.pdg_mark (** {3 For the journalization of values of these types} *) let pp_sl_project p_caller fmt p = let pp fmt = Format.fprintf fmt "@[<hv 2>!Db.Slicing.Project.from_unique_name@;%S@]" p.SlicingInternals.name in Type.par p_caller Type.Call fmt pp module Sl_project = Datatype.Make (struct include Datatype.Undefined (* TODO: unmarshal *) type t = sl_project let reprs = [ SlicingInternals.dummy_project ] let name = "SlicingTypes.Sl_project" let internal_pretty_code = pp_sl_project let varname s = "sl_project_" ^ s.SlicingInternals.name let mem_project f s = f s.SlicingInternals.application end) module Sl_select = Datatype.Make (struct include Datatype.Undefined (* TODO: unmarshal *) type t = sl_select let reprs = List.map (fun v -> v, SlicingInternals.dummy_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) let pp_sl_fct_slice p_caller fmt ff = let pp fmt = Format.fprintf fmt "@[<hv 2>!Db.Slicing.Slice.from_num_id@;%a@;%a@;%d@]" (Sl_project.internal_pretty_code Type.Call) ff.SlicingInternals.ff_fct.SlicingInternals.fi_project (Kernel_function.internal_pretty_code Type.Call) ff.SlicingInternals.ff_fct.SlicingInternals.fi_kf ff.SlicingInternals.ff_id in Type.par p_caller Type.Call fmt pp module Sl_fct_slice = Datatype.Make (struct include Datatype.Undefined (* TODO: unmarshal *) open SlicingInternals type t = fct_slice let name = "SlicingTypes.Sl_fct_slice" let reprs = [ dummy_fct_slice ] let internal_pretty_code = pp_sl_fct_slice let mem_project f x = f x.ff_fct.fi_project.application end) let dyn_sl_fct_slice = Sl_fct_slice.ty let pp_sl_mark p fmt m = let pp = match m.SlicingInternals.m1, m.SlicingInternals.m2 with | SlicingInternals.Spare, _ -> None | _, SlicingInternals.Spare -> None | SlicingInternals.Cav mark1, SlicingInternals.Cav mark2 -> if (PdgTypes.Dpd.is_bottom mark2) then (* 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)) else None in let pp = match pp with | Some pp -> pp | None -> 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 fun fmt -> Format.fprintf fmt "@[<hv 2>SlicingInternals.create_sl_mark@;~m1:%a@;~m2:%a@]" pp m.SlicingInternals.m1 pp m.SlicingInternals.m2 in Type.par p Type.Call fmt pp module Sl_mark = Datatype.Make_with_collections (struct type t = SlicingInternals.pdg_mark let name = "SlicingTypes.Sl_mark" let structural_descr = Structural_descr.Unknown let reprs = [ SlicingInternals.dummy_pdg_mark ] let compare = SlicingInternals.compare_pdg_mark let equal : t -> t -> bool = ( = ) let hash = Hashtbl.hash let copy = Datatype.undefined let rehash = Datatype.undefined let internal_pretty_code = pp_sl_mark let pretty = Datatype.from_pretty_code let mem_project = Datatype.never_any_project let varname = Datatype.undefined end) let dyn_sl_mark = Sl_mark.ty (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/���������������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�017274� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/value_types.ml�������������������������������������������0000644�0001750�0001750�00000004470�12155630237�022177� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 type call_site = kernel_function * kinstr module Callsite = Datatype.Pair_with_collections(Kernel_function)(Cil_datatype.Kinstr) (struct let module_name = "Value_callbacks.Callpoint" end) type callstack = call_site list module Callstack = Datatype.With_collections (Datatype.List(Callsite)) (struct let module_name = "Value_types.Callstack" end) type 'a callback_result = | Normal of 'a | NormalStore of 'a * int | Reuse of int type cacheable = | Cacheable | NoCache | NoCacheCallers type call_result = { c_values: (Cvalue.V_Offsetmap.t option * Cvalue.Model.t) list; c_clobbered: Base.SetLattice.t; c_cacheable: cacheable; } (* Local Variables: compile-command: "make -C ../.." End: *) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/function_Froms.ml����������������������������������������0000644�0001750�0001750�00000012260�12155630237�022626� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Locations type froms = { deps_return : Lmap_bitwise.From_Model.LOffset.t; deps_table : Lmap_bitwise.From_Model.t } let top = { deps_return = Lmap_bitwise.From_Model.LOffset.degenerate Zone.top; deps_table = Lmap_bitwise.From_Model.top; } let join x y = { deps_return = Lmap_bitwise.From_Model.LOffset.join x.deps_return y.deps_return ; deps_table = Lmap_bitwise.From_Model.join x.deps_table y.deps_table } let outputs { deps_table = t } = Lmap_bitwise.From_Model.fold (fun z _ acc -> Locations.Zone.join z acc) t Locations.Zone.bottom let inputs ?(include_self=false) t = let aux b offm acc = Lmap_bitwise.From_Model.LOffset.fold (fun itvs (self, z) acc -> let acc = Locations.Zone.join z acc in match include_self, self, b with | true, true, Some b -> Locations.Zone.join acc (Zone.inject b itvs) | _ -> acc ) offm acc in try let return = aux None t.deps_return Locations.Zone.bottom in let aux_table b = aux (Some b) in Lmap_bitwise.From_Model.fold_base aux_table t.deps_table return with Lmap_bitwise.From_Model.Cannot_fold -> Locations.Zone.top let pretty fmt { deps_return = r ; deps_table = t } = Format.fprintf fmt "%a@\n\\result %a@\n" Lmap_bitwise.From_Model.pretty t Lmap_bitwise.From_Model.LOffset.pretty r (** same as pretty, but uses the type of the function to output more precise informations. @raise Error if the given type is not a function type *) let pretty_with_type typ fmt { deps_return = r; deps_table = t } = let (rt_typ,_,_,_) = Cil.splitFunctionType typ in if Lmap_bitwise.From_Model.is_bottom t then Format.fprintf fmt "@[<v>@[@;<2 0>@[NON TERMINATING - NO EFFECTS@]@]@]" else if Cil.isVoidType rt_typ then begin if Lmap_bitwise.From_Model.is_empty t then Format.fprintf fmt "@[<v>@[@;<2 0>@[NO EFFECTS@]@]@]" else Format.fprintf fmt "@[<v>@[@;<2 0>@[%a@]@]@]" Lmap_bitwise.From_Model.pretty t end else if Lmap_bitwise.From_Model.LOffset.is_empty r then Format.fprintf fmt "@[<v>@[@;<2 0>@[%a@]\\result FROM \\nothing@]@]" Lmap_bitwise.From_Model.pretty t else Format.fprintf fmt "@[<v>@[@;<2 0>@[%a@]\\result%a@]@]" Lmap_bitwise.From_Model.pretty t (Lmap_bitwise.From_Model.LOffset.pretty_with_type (Some rt_typ)) r let hash { deps_return = dr ; deps_table = dt } = Lmap_bitwise.From_Model.hash dt + 197*Lmap_bitwise.From_Model.LOffset.hash dr let equal { deps_return = dr ; deps_table = dt } { deps_return = dr' ; deps_table = dt' } = Lmap_bitwise.From_Model.equal dt dt' && Lmap_bitwise.From_Model.LOffset.equal dr dr' include Datatype.Make (struct type t = froms let reprs = List.fold_left (fun acc o -> List.fold_left (fun acc m -> { deps_return = o; deps_table = m } :: acc) acc Lmap_bitwise.From_Model.reprs) [] Lmap_bitwise.From_Model.LOffset.reprs let structural_descr = Structural_descr.t_record [| Lmap_bitwise.From_Model.LOffset.packed_descr; Lmap_bitwise.From_Model.packed_descr |] let name = "Function_Froms" let hash = hash let compare = Datatype.undefined let equal = equal let pretty = pretty let internal_pretty_code = Datatype.undefined let rehash = Datatype.identity let copy = Datatype.undefined let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/lmap_sig.mli���������������������������������������������0000644�0001750�0001750�00000012653�12155630237�021605� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Signature for maps from bases to memory maps. The memory maps are intended to be those of the [Offsetmap] module. *) open Locations type v (** type of the values associated to the locations *) type offsetmap (** type of the maps associated to a base *) type widen_hint_y (** widening hints associated to values *) module LBase : sig type t val iter : (Base.base -> offsetmap -> unit) -> t -> unit end type tt = private Bottom | Top | Map of LBase.t include Datatype.S_with_collections with type t = tt type widen_hint = bool * Base.Set.t * (Base.t -> widen_hint_y) val add_base : Base.t -> offsetmap -> t -> t val pretty_without_null : Format.formatter -> t -> unit val pretty_filter: Format.formatter -> t -> Zone.t -> (Base.t -> bool) -> unit val pretty_diff: Format.formatter -> t -> t -> unit val add_binding: with_alarms:CilE.warn_mode -> exact:bool -> t -> location -> v -> t val find: conflate_bottom:bool -> with_alarms:CilE.warn_mode -> t -> location -> v val join : t -> t -> t val is_included : t -> t -> bool val top: t val is_top: t -> bool (** Empty map. Casual users do not need this.*) val empty_map : t val is_empty_map : t -> bool (** Every location is associated to [VALUE.bottom] in [bottom]. This state can be reached only in dead code. *) val bottom : t val is_reachable : t -> bool val widen : widen_hint-> t -> t -> (bool * t) val filter_base : (Base.t -> bool) -> t -> t (** @raise Not_found if the varid is not present in the map. *) val find_base : Base.t -> t -> offsetmap val find_base_or_default : Base.t -> t -> offsetmap (** Removes the base if it is present. Does nothing otherwise. *) val remove_base : Base.t -> t -> t val reduce_previous_binding : with_alarms:CilE.warn_mode -> t -> location -> v -> t val reduce_binding : with_alarms:CilE.warn_mode -> t -> location -> v -> t (** [paste_offsetmap ~from:offmap ~dst_loc ~start ~size ~exact m] copies [size] bits starting at [start] in [offmap], and pastes them at [dst_loc] in [m]. The copy is exact if and only if [dst_loc] is exact, and [exact is true] *) val paste_offsetmap : with_alarms:CilE.warn_mode -> from:offsetmap -> dst_loc:Location_Bits.t -> start:Integer.t -> size:Integer.t -> exact:bool -> t -> t (** [copy_offsetmap alarms loc m] returns the superposition of the bits pointed to by [loc] within [m]. [loc.size] must not be top. Return [None] if all pointed adresses are invalid in [m]. *) val copy_offsetmap : with_alarms:CilE.warn_mode -> location -> t -> offsetmap option (** [fold_base f m] calls [f] on all bases bound to non top offsetmaps in the non bottom map [m]. @raise Error_Bottom if [m] is bottom. *) val fold_base : (Base.t -> 'a -> 'a) -> t -> 'a -> 'a (** [fold_base_offsetmap f m] calls [f] on all bases bound to non top offsetmaps in the non bottom map [m]. @raise Error_Bottom if [m] is bottom.*) val fold_base_offsetmap : (Base.t -> offsetmap -> 'a -> 'a) -> t -> 'a -> 'a val add_new_base: Base.t -> size:Integer.t -> v -> size_v:Integer.t -> t -> t exception Error_Bottom (** Cached iterators *) val cached_fold : f:(Base.t -> offsetmap -> 'a) -> cache:string * int -> temporary:bool -> joiner:('a -> 'a -> 'a) -> empty:'a -> t -> 'a val cached_map : f:(Base.t -> offsetmap -> offsetmap) -> cache:string * int -> temporary:bool -> t -> t (** Prefixes. To be used by advanced users only *) type subtree val comp_prefixes: t -> t -> unit val find_prefix : t -> Hptmap.prefix -> subtree option val hash_subtree : subtree -> int val equal_subtree : subtree -> subtree -> bool exception Found_prefix of Hptmap.prefix * subtree * subtree (** Clear the caches local to this module. Beware that they are not project-aware, and that you must call them at every project switch. *) val clear_caches: unit -> unit (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/inout_type.mli�������������������������������������������0000644�0001750�0001750�00000004450�12155630237�022205� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) type tt = { over_inputs: Locations.Zone.t; over_inputs_if_termination: Locations.Zone.t; under_outputs_if_termination: Locations.Zone.t; over_outputs: Locations.Zone.t; over_outputs_if_termination: Locations.Zone.t; } include Datatype.S with type t = tt val pretty_operational_inputs: t Pretty_utils.formatter (** Pretty-print the fields [over_inputs_if_termination], [over_inputs] and [under_outputs_if_termination] *) val pretty_outputs: t Pretty_utils.formatter (** Pretty-print the fields [over_outputs] and [over_outputs_if_termination]. *) val map: (Locations.Zone.t -> Locations.Zone.t) -> t -> t val bottom: tt val join: tt -> tt -> tt (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/lmap_bitwise.mli�����������������������������������������0000644�0001750�0001750�00000012007�12155630237�022462� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Functors making map indexed by zone. @plugin development guide *) open Abstract_interp open Lattice_Interval_Set open Locations exception Bitwise_cannot_copy module type Location_map_bitwise = sig type y include Datatype.S module LOffset : sig include Datatype.S val map: ((bool * y) -> (bool * y)) -> t -> t val fold : (Int_Intervals.t -> bool * y -> 'a -> 'a) -> t -> 'a -> 'a val fold_fuse_same : (Int_Intervals.t -> bool * y -> 'a -> 'a) -> t -> 'a -> 'a val join: t -> t -> t val pretty_with_type: Cil_types.typ option-> Format.formatter -> t -> unit val collapse : t -> y val empty : t val degenerate: y -> t val is_empty: t->bool val add_iset : exact:bool -> Int_Intervals.t -> y -> t -> t end val empty : t val bottom: t val is_empty : t -> bool val is_bottom : t -> bool val top: t val join : t -> t -> t val is_included : t -> t -> bool val add_binding : exact:bool -> t -> Zone.t -> y -> t val map_and_merge : (y -> y) -> t -> t -> t (** [map_and_merge f m1 m2] maps [f] on values in [m1] and [add_exact] all elements of the mapped [m1] to [m2] *) val filter_base : (Base.t -> bool) -> t -> t val find : t -> Zone.t -> y val find_base: t -> Zone.t -> LOffset.t exception Cannot_fold val uninitialize: Cil_types.varinfo list -> t -> t (** binds the given variables to bottom, keeps the other unchanged. *) val fold : (Zone.t -> bool * y -> 'a -> 'a) -> t -> 'a -> 'a (** [fold f m] folds a function [f] on bindings in [m]. Each binding associates to a zone a boolean representing the possibility that the zone was not modified, and a value of type y. May raise [Cannot_fold]. *) val fold_base : (Base.t -> LOffset.t -> 'a -> 'a) -> t -> 'a -> 'a val fold_fuse_same : (Zone.t -> bool * y -> 'a -> 'a) -> t -> 'a -> 'a (** Same behavior as [fold], except if two disjoint ranges [r1] and [r2] of a given base are mapped to the same value and boolean. In this case, [fold] will call its argument [f] on [r1], then on [r2]. [fold_fuse_same] will call it directly on [r1 U r2], where U is the join on sets of intervals. May raise [Cannot_fold]. *) val map2 : ((bool * y) option -> (bool * y) option -> bool * y) -> t -> t -> t (** like for [fold], the boolean in [bool * y] indicates if it is possible that the zone was not modified *) val copy_paste : with_alarms:CilE.warn_mode -> f:(bool * y -> bool * y) -> location -> location -> t -> t (** This function takes a function [f] to be applied to each bit of the read slice. Otherwise, it has the same specification as [copy_paste] for [Location_map.copy_paste]. It may raise [Bitwise_cannot_copy]. Precondition : the two locations must have the same size *) (** Clear the caches local to this module. Beware that they are not project-aware, and that you must call them at every project switch. *) val clear_caches: unit -> unit end (** Lattice with default values on a range or on an entire base. *) module type With_default = sig include Abstract_interp.Lattice val default : Base.t -> Int.t -> Int.t -> t val defaultall : Base.t -> t end module Make_bitwise(V : With_default) : Location_map_bitwise with type y = V.t module From_Model : Location_map_bitwise with type y = Locations.Zone.t (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/tr_offset.ml���������������������������������������������0000644�0001750�0001750�00000014201�12155630237�021623� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp open CilE type t = Set of Ival.O.t | Interval of Int.t * Int.t * Int.t | Imprecise of Int.t * Int.t exception Unbounded let empty = Set (Ival.O.empty) (* Returns [still_exact_flag, (alarm, reduce_ival)] *) let reduce_ival_by_bound ival size validity = let pred_size = Int.pred size in match validity with | Base.Invalid -> true, (true, Set Ival.O.empty) | Base.Known (bound_min, bound_max) | Base.Unknown (bound_min, _, bound_max) | Base.Periodic (bound_min, bound_max, _) -> let max_in_bound = Int.sub bound_max pred_size in let is_in_bound mn mx r modu = let out, new_mn = match mn with | Some mn when (Int.ge mn bound_min) -> false, mn | _ -> true, Int.round_up_to_r ~r ~modu ~min:bound_min in let out, new_mx = match mx with | Some mx when (Int.le mx max_in_bound) -> let out = match validity with | Base.Unknown (_,Some valid_max, _) when Int.gt mx (Int.sub valid_max pred_size) -> true | Base.Unknown (_, None, _) -> true | _ -> out in out, mx | _ -> true, Int.round_down_to_r ~r ~modu ~max:max_in_bound in let itv_or_set = if Int.le new_mn new_mx then begin if Int.lt modu size then Imprecise(new_mn, Int.add new_mx pred_size) else Interval(new_mn, new_mx, modu) end else empty in out, itv_or_set in let out, reduced_bounds as result = begin match ival with | Ival.Top (mn,mx,r,m) -> is_in_bound mn mx r m | Ival.Float _ -> is_in_bound None None Integer.zero Integer.one | Ival.Set s -> let out, set = Array.fold_right (fun offset (out_acc, reduced_acc) -> let sOffset = Some offset in let out, reduced = is_in_bound sOffset sOffset Integer.zero Integer.one in out || out_acc, if reduced != empty then Ival.O.add offset reduced_acc else reduced_acc) s (false, Ival.O.empty) in (out, Set set) end in match validity with | Base.Periodic(_, _, p) -> assert (Int.is_zero bound_min); let reduced_bounds = match reduced_bounds with | Imprecise (mn, mx) -> if Int.equal (Int.pos_div mn p) (Int.pos_div mx p) then Imprecise (Int.pos_rem mn p, Int.pos_rem mx p) else Imprecise (bound_min, Int.pred p) | Set s -> let treat_offset offset acc = let new_offset = Int.pos_rem offset p in if Int.gt (Int.add new_offset size) p then raise Unbounded else (* Format.printf "old offset: %a mx: %a period: %a new: %a@." Int.pretty offset Int.pretty bound_max Int.pretty p Int.pretty new_offset; *) Ival.O.add new_offset acc in begin try Set (Ival.O.fold treat_offset s Ival.O.empty) with Unbounded -> Imprecise (bound_min, Int.pred p) end | Interval(lb, _ub, mo) -> if Int.is_zero (Int.pos_rem mo p) then Set (Ival.O.singleton (Int.pos_rem lb p)) else begin (* Format.printf "Interval %a %a %a / %a@." Int.pretty lb Int.pretty _ub Int.pretty mo Int.pretty p; *) Imprecise (bound_min, Int.pred p) end in false, (out, reduced_bounds) | _ -> true, result let filter_by_bound_for_reading ~with_alarms ival size validity = let _, (out, filtered_by_bound) = reduce_ival_by_bound ival size validity in if out then warn_mem_read with_alarms; filtered_by_bound let filter_by_bound_for_writing ~with_alarms ~exact ival size validity = let still_exact, (out, filtered_by_bound) = reduce_ival_by_bound ival size validity in if out then warn_mem_write with_alarms; (exact && still_exact), filtered_by_bound (* Local Variables: compile-command: "make -C ../.." End: *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/lmap.ml��������������������������������������������������0000644�0001750�0001750�00000062752�12155630237�020577� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp open Locations open CilE module Make_LOffset (V: Lattice_With_Isotropy.S) (Offsetmap: module type of Offsetmap_sig with type v = V.t and type widen_hint = V.widen_hint) (Default_offsetmap: sig val default_offsetmap : Base.t -> Offsetmap.t end) = struct type v = V.t type offsetmap = Offsetmap.t type widen_hint_y = V.widen_hint open Default_offsetmap module LBase = struct module Comp = struct let f _base offsetmap = Offsetmap.cardinal_zero_or_one offsetmap let compose a b = a && b let e = true let default = true end module Initial_Values = struct let v = [ [] ] end include Hptmap.Make (Base) (Offsetmap) (Comp) (Initial_Values) (struct let l = [ Ast.self ] end) let () = Ast.add_monotonic_state self let add k v m = if Offsetmap.equal v (default_offsetmap k) then remove k m else add k v m let find_or_default varid map = try find varid map with Not_found -> default_offsetmap varid end let clear_caches = LBase.clear_caches exception Found_prefix = LBase.Found_prefix type tt = | Bottom | Top | Map of LBase.t let equal m1 m2 = match m1, m2 with | Bottom, Bottom -> true | Top, Top -> true | Map m1, Map m2 -> m1 == m2 | _ -> false let comp_prefixes m1 m2 = match m1, m2 with | Map m1, Map m2 -> LBase.comp_prefixes m1 m2 | _ -> () type subtree = LBase.subtree let find_prefix m p = match m with Map m -> LBase.find_prefix m p | Top | Bottom -> None let equal_subtree = LBase.equal_subtree let hash_subtree = LBase.hash_subtree let compare = if LBase.compare == Datatype.undefined then Datatype.undefined else fun m1 m2 -> match m1, m2 with | Bottom, Bottom | Top, Top -> 0 | Map m1, Map m2 -> LBase.compare m1 m2 | Bottom, (Top | Map _) | Top, Map _ -> -1 | Map _, (Top | Bottom) | Top, Bottom -> 1 let empty_map = Map LBase.empty let hash = function | Bottom -> 457 | Top -> 458 | Map m -> LBase.hash m let pretty fmt m = Format.fprintf fmt "@["; (match m with Bottom -> Format.fprintf fmt "NOT ACCESSIBLE" | Map m -> LBase.iter (fun base offs -> let typ = Base.typeof base in Format.fprintf fmt "@[%a@[%a@]@\n@]" Base.pretty base (Offsetmap.pretty_typ typ) offs) m | Top -> Format.fprintf fmt "NO INFORMATION"); Format.fprintf fmt "@]" include Datatype.Make_with_collections (struct type t = tt let structural_descr = Structural_descr.Structure (Structural_descr.Sum [| [| LBase.packed_descr |] |]) let name = Offsetmap.name ^ " lmap" let reprs = Bottom :: Top :: List.map (fun b -> Map b) LBase.reprs let equal = equal let compare = compare let hash = hash let pretty = pretty let internal_pretty_code = Datatype.undefined let rehash = Datatype.identity let copy = Datatype.undefined let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) let () = Type.set_ml_name ty None let top = Top let bottom = Bottom let is_top x = equal top x exception Error_Bottom let add_base base offsetmap acc = match acc with | Map acc -> Map (LBase.add base offsetmap acc) | Bottom -> raise Error_Bottom | Top -> Top let is_empty_map = function Bottom -> assert false | Top -> assert false | Map m -> LBase.is_empty m let filter_base f m = match m with Top -> Top | Bottom -> assert false | Map m -> Map (LBase.fold (fun k v acc -> if f k then LBase.add k v acc else acc) m LBase.empty) let find_base (vi:LBase.key) (m:t) = match m with | Bottom -> raise Not_found | Map m -> LBase.find vi m | Top -> Offsetmap.empty let remove_base (vi:LBase.key) (m:t) = match m with | Bottom -> m | Map m -> Map (LBase.remove vi m) | Top -> assert false let is_reachable t = match t with Bottom -> false | Top | Map _ -> true let pretty_without_null fmt m = Format.fprintf fmt "@["; (match m with Bottom -> Format.fprintf fmt "NOT ACCESSIBLE" | Top -> Format.fprintf fmt "NO INFORMATION" | Map m -> LBase.iter (fun base offs -> if not (Base.is_null base) then Format.fprintf fmt "@[%a@[%a@]@\n@]" Base.pretty base (Offsetmap.pretty_typ (Base.typeof base)) offs) m); Format.fprintf fmt "@]" let all_bottom m = let f v _ = if not (V.equal V.bottom v) then raise Exit in try Offsetmap.iter_on_values f m; true with Exit -> false (* Display bases in [filter]. *) let pretty_filter fmt mm filter refilter = Format.fprintf fmt "@["; (match mm with | Bottom -> Format.fprintf fmt "NON TERMINATING FUNCTION" | Top -> Format.fprintf fmt "NO INFORMATION" | Map m -> let filter_it base _itvs () = if refilter base then let offsm = LBase.find_or_default base m in if not (all_bottom offsm) then Format.fprintf fmt "@[%a@[%a@]@\n@]" Base.pretty base (Offsetmap.pretty_typ (Base.typeof base)) offsm in try Zone.fold_topset_ok filter_it filter () with Zone.Error_Top -> Format.fprintf fmt "Cannot filter: dumping raw memory (including unchanged variables)@\n%a@\n" pretty mm ); Format.fprintf fmt "@]" let add_binding_offsetmap ~reducing ~with_alarms ~exact varid offsets size v map = let validity = Base.validity varid in if ((not reducing) && (Base.is_read_only varid) || validity = Base.Invalid) then raise Offsetmap.Result_is_bottom; match size with | Int_Base.Top -> let offsm = LBase.find_or_default varid map in let orig = Origin.current Origin.K_Arith in let new_offsm = Offsetmap.update_imprecise_everywhere ~validity orig v offsm in if offsm == new_offsm then map else LBase.add varid new_offsm map | Int_Base.Value size -> assert (Int.gt size Int.zero); let offsetmap_orig = LBase.find_or_default varid map in (*Format.printf "add_binding_offsetmap varid:%a offset:%a@\n" Base.pretty varid Ival.pretty offsets;*) let new_offsetmap = Offsetmap.update ~with_alarms ~validity ~exact ~offsets ~size v offsetmap_orig in if offsetmap_orig == new_offsetmap then map else LBase.add varid new_offsetmap map let add_new_base base ~size v ~size_v state = match state with | Bottom -> state | Top -> state | Map mem -> Map (LBase.add base (Offsetmap.create ~size v ~size_v) mem) let add_binding ~reducing ~with_alarms ~exact initial_mem {loc=loc ; size=size } v = (*Format.printf "add_binding: loc:%a@\n" Location_Bits.pretty loc;*) if V.equal v V.bottom then Bottom else match initial_mem with | Top -> initial_mem | Bottom -> assert false | Map mem -> let result = (match loc with | Location_Bits.Top (Base.SetLattice.Top, orig) -> CilE.do_warn with_alarms.imprecision_tracing (fun _ -> Kernel.warning ~current:true ~once:true "writing at a completely unknown address @[%a@]@\n\ Aborting." Origin.pretty_as_reason orig ); warn_mem_write with_alarms; (* Format.printf "dumping memory : %a@\n" pretty initial_mem;*) top (* the map where every location maps to top *) | Location_Bits.Top (Base.SetLattice.Set set, origin) -> warn_mem_write with_alarms; let treat_base varid acc = if (not reducing) && (Base.is_read_only varid) then acc else match Base.validity varid with | Base.Invalid -> acc | Base.Unknown _ | Base.Known _ | Base.Periodic _ -> let offsm = LBase.find_or_default varid mem in let validity = Base.validity varid in let offsetmap = Offsetmap.update_imprecise_everywhere ~validity origin v offsm in LBase.add varid offsetmap acc in let result = Map (Base.Hptset.fold treat_base set (treat_base Base.null mem)) in (* Format.printf "debugging add_binding topset, loc =%a, result=%a@." Location_Bits.pretty loc pretty result; *) result | Location_Bits.Map loc_map -> (* Format.printf "add_binding size:%a@\n" Int_Base.pretty size;*) let had_non_bottom = ref false in let result = Location_Bits.M.fold (fun varid offsets map -> try let r = add_binding_offsetmap ~reducing ~with_alarms ~exact varid offsets size v map in had_non_bottom := true; r with Offsetmap.Result_is_bottom -> CilE.warn_mem_write with_alarms; map) loc_map mem in if !had_non_bottom then Map result else begin (do_warn with_alarms.imprecision_tracing (* another field would be appropriate here TODO *) (fun _ -> Kernel.warning ~current:true ~once:true "all target addresses were invalid. This path is \ assumed to be dead.")); bottom end) in result let find_base_or_default base mem = match mem with Map mem -> LBase.find_or_default base mem | Top -> Offsetmap.empty | Bottom -> assert false let find ~conflate_bottom ~with_alarms mem { loc = loc ; size = size } = let result = match mem with | Bottom -> V.bottom | Top | Map _ -> let handle_imprecise_base base acc = let validity = Base.validity base in CilE.warn_mem_read with_alarms; let offsetmap = find_base_or_default base mem in let new_v = Offsetmap.find_imprecise_everywhere ~validity offsetmap in V.join new_v acc in begin match loc with | Location_Bits.Top (topparam,_orig) -> begin try Base.SetLattice.fold handle_imprecise_base topparam (handle_imprecise_base Base.null V.bottom) with Base.SetLattice.Error_Top -> V.top end | Location_Bits.Map loc_map -> begin match size with | Int_Base.Top -> begin try Location_Bits.M.fold (fun base _offsetmap acc -> handle_imprecise_base base acc) loc_map V.bottom with Base.SetLattice.Error_Top -> V.top end | Int_Base.Value size -> Location_Bits.M.fold (fun base offsets acc -> let validity = Base.validity base in let offsetmap = find_base_or_default base mem in (*Format.printf "offsetmap(%a):%a@\noffsets:%a@\nsize:%a@\n" Base.pretty base (Offsetmap.pretty None) offsetmap Ival.pretty offsets Int.pretty size;*) let new_v = Offsetmap.find ~conflate_bottom ~validity ~with_alarms ~offsets ~size offsetmap in (* Format.printf "find got:%a@\n" V.pretty new_v; *) V.join new_v acc) loc_map V.bottom end end in result let reduce_previous_binding ~with_alarms initial_mem l v = assert (if not (Locations.cardinal_zero_or_one l) then begin Format.printf "Internal error 835; debug info:@\n%a@." Locations.pretty l; false end else true); add_binding ~reducing:true ~exact:true ~with_alarms initial_mem l v (* XXXXXXXXX bug with uninitialized values ? *) let reduce_binding ~with_alarms initial_mem l v = let v_old = find ~conflate_bottom:true ~with_alarms initial_mem l in if V.equal v v_old then initial_mem else let vv = V.narrow v_old v in (* Format.printf "narrow %a %a %a@." V.pretty v_old V.pretty v V.pretty vv; *) if V.equal vv v_old then initial_mem else reduce_previous_binding ~with_alarms initial_mem l vv (* let reduce_previous_binding ~with_alarms initial_mem l v = let s1 = reduce_previous_binding ~with_alarms initial_mem l v in let s2 = reduce_binding ~with_alarms initial_mem l v in if not (equal s1 s2) then Format.printf "DIFF@\n%a@\n@\n%a@\n@\n%a@." V.pretty v pretty s1 pretty s2; s1 *) let add_binding = add_binding ~reducing:false let join_internal = let decide_none base v1 = (Offsetmap.join v1 (default_offsetmap base)) in let decide_some v1 v2 = (Offsetmap.join v1 v2) in let symetric_merge = LBase.symetric_merge ~cache:("lmap",65536) ~decide_none ~decide_some in fun m1 m2 -> Map (symetric_merge m1 m2) let join mm1 mm2 = match mm1, mm2 with | Bottom,m | m,Bottom -> m | Top, _ | _, Top -> Top | Map m1, Map m2 -> if m1 == m2 then mm1 else join_internal m1 m2 let pretty_diff_aux fmt m1 m2 = let print base m1 m2 = match m1, m2 with | None, None -> () | Some m, None -> let typ = Base.typeof base in Format.fprintf fmt "@[L %a@[%a@]@]@ " Base.pretty base (Offsetmap.pretty_typ typ) m | None, Some m -> let typ = Base.typeof base in Format.fprintf fmt "@[R %a@[%a@]@]@ " Base.pretty base (Offsetmap.pretty_typ typ) m | Some m1, Some m2 -> if not (Offsetmap.equal m1 m2) then let typ = Base.typeof base in let pp = Offsetmap.pretty_typ typ in Format.fprintf fmt "@[%a @[<v>L@[%a@]@,R@[%a@]@]@]@ " Base.pretty base pp m1 pp m2 in let decide b m1 m2 = print b m1 m2; Offsetmap.empty in let aux = LBase.generic_merge ~cache:("",0) ~decide in Format.fprintf fmt "@[<v>"; ignore (aux m1 m2); Format.fprintf fmt "@]" let pretty_diff fmt mm1 mm2 = match mm1, mm2 with | Bottom, _ -> Format.fprintf fmt "BOT / Not BOT" | _, Bottom -> Format.fprintf fmt "Not BOT / BOT" | Top, _ -> Format.fprintf fmt "TOP / Not TOP" | _, Top -> Format.fprintf fmt "Not TOP / TOP" | Map m1, Map m2 -> if m1 == m2 then Format.fprintf fmt "Equal" else pretty_diff_aux fmt m1 m2 let is_included = let decide_fst base v1 = Offsetmap.is_included_exn v1 (default_offsetmap base) in let decide_snd base v2 = Offsetmap.is_included_exn (default_offsetmap base) v2 in let decide_both = Offsetmap.is_included_exn in let generic_is_included = LBase.generic_is_included Abstract_interp.Is_not_included ~cache:("lmap", 16384) ~decide_fst ~decide_snd ~decide_both in fun (m1:t) (m2:t) -> match m1,m2 with Bottom,_ -> true | _,Bottom -> false | _, Top -> true | Top, _ -> false | Map m1,Map m2 -> try generic_is_included m1 m2; true with Is_not_included -> false (* Precondition : m1 <= m2 *) type widen_hint = bool * Base.Set.t * (Base.t -> V.widen_hint) let widen (widen_other_keys, wh_key_set, wh_hints) r1 r2 = let result = match r1,r2 with | Top, _ | _, Top -> assert false | Bottom,Bottom -> false, Bottom | _,Bottom -> assert false (* thanks to precondition *) | Bottom, m -> false, m | Map m1,Map m2 -> let m_done, m_remain = (* [m_done] = widened state on keys of [wh_key_set]. if a widening is performed for one of them, [m_remain] will be empty. *) Base.Set.fold (fun key (m_done, m_remain) -> let offs2 = LBase.find_or_default key m2 in let offs1 = LBase.find_or_default key m1 in let fixed = Offsetmap.is_included offs2 offs1 in (* Format.printf "key=%a, fixed=%b@." Base.pretty key fixed; *) if fixed then (m_done, LBase.remove key m_remain) else let new_off = Offsetmap.widen (wh_hints key) offs1 offs2 in LBase.add key new_off m_done, LBase.empty) wh_key_set (m2, m2) in let fixed_for_all_wh_key = not (LBase.is_empty m_remain) in (* Format.printf "widening (widen_other_keys=%b, fixed_for_all_wh_key %b)@." widen_other_keys fixed_for_all_wh_key; *) if widen_other_keys then let other_keys_widened = Map (LBase.fold (fun base offs2 acc -> (* Format.printf "widening also on key %a@." Base.pretty base; *) let offs1 = LBase.find_or_default base m1 in let new_off = Offsetmap.widen (wh_hints base) offs1 offs2 in if offs2 != new_off then LBase.add base new_off acc else acc ) m_remain m_done) in true, other_keys_widened else fixed_for_all_wh_key, Map m_done in result let paste_offsetmap ~with_alarms ~from ~dst_loc ~start ~size ~exact m = match m with | Bottom | Top -> m | Map m' -> let loc_dst = make_loc dst_loc (Int_Base.inject size) in assert (Int.lt Int.zero size); let loc_dst' = Locations.valid_part ~for_writing:true loc_dst in if not (Location.equal loc_dst loc_dst') then CilE.warn_mem_write with_alarms; let loc_dst = loc_dst' in let exact = exact && cardinal_zero_or_one loc_dst in (* TODO: do we want to alter exact here? *) let had_non_bottom = ref false in let treat_dst base_dst i_dst acc = if Base.is_read_only base_dst then (CilE.warn_mem_write with_alarms; acc) else let validity = Base.validity base_dst in let offsetmap_dst = LBase.find_or_default base_dst m' in try let new_offsetmap = Offsetmap.paste_slice ~with_alarms ~validity ~exact (from, start) ~size ~offsets:i_dst offsetmap_dst in had_non_bottom := true; if offsetmap_dst != new_offsetmap then LBase.add base_dst new_offsetmap acc else acc with Offsetmap.Result_is_bottom -> CilE.warn_mem_write with_alarms; acc in match dst_loc with | Location_Bits.Map _ -> let result = Location_Bits.fold_i treat_dst dst_loc m' in if !had_non_bottom then Map result else begin Kernel.warning ~once:true ~current:true "all target addresses were invalid. This path is assumed to \ be dead."; bottom end | Location_Bits.Top (top, orig) -> if not (Base.SetLattice.equal top Base.SetLattice.top) then Kernel.result ~current:true ~once:true "writing somewhere in @[%a@]@[%a@]." Base.SetLattice.pretty top Origin.pretty_as_reason orig; let src_end = Int.pred (Int.add start size) in let validity = Base.Known (start, src_end) in let v = Offsetmap.find ~with_alarms:CilE.warn_none_mode ~validity ~conflate_bottom:false ~offsets:(Ival.inject_singleton start) ~size from in add_binding ~with_alarms ~exact:false m loc_dst v let copy_offsetmap ~with_alarms src_loc mm = match mm with | Bottom -> None | Top -> Some Offsetmap.empty | Map m -> try let size = Int_Base.project src_loc.size in try begin let treat_src k_src i_src (acc : Offsetmap.t option) = let validity = Base.validity k_src in let offsetmap_src = LBase.find_or_default k_src m in if Offsetmap.is_empty offsetmap_src then ( CilE.warn_mem_read with_alarms; acc) else let copy = Offsetmap.copy_slice ~with_alarms ~validity ~offsets:i_src ~size offsetmap_src in (* TODO. copy_ival seems to return an empty offsetmap only if i_src is degenerate. This needs further checking *) assert (not (Offsetmap.is_empty copy)); match acc with | None -> Some copy | Some acc -> Some ((Offsetmap.join copy acc)) in Location_Bits.fold_i treat_src src_loc.loc None end with | Location_Bits.Error_Top (* from Location_Bits.fold *) -> let v = find ~conflate_bottom:false ~with_alarms mm src_loc in Some (Offsetmap.create ~size ~size_v:size v) with | Int_Base.Error_Top (* from Int_Base.project *) -> Some Offsetmap.empty let fold_base f m acc = match m with | Bottom -> raise Error_Bottom | Top -> assert false | Map m -> LBase.fold (fun k _ acc -> f k acc) m acc let fold_base_offsetmap f m acc = match m with | Top -> assert false | Bottom -> raise Error_Bottom | Map m -> LBase.fold (fun k off acc -> f k off acc) m acc let cached_fold ~f ~cache ~temporary ~joiner ~empty = let cached_f = LBase.cached_fold ~f ~cache ~temporary ~joiner ~empty in function | Top -> assert false | Bottom -> raise Error_Bottom | Map mm -> (cached_f mm) let cached_map ~f ~cache ~temporary = let cached_f = LBase.cached_map ~f ~cache ~temporary in function Bottom -> Bottom | Top -> assert false | Map mm -> Map (cached_f mm) end (* Local Variables: compile-command: "make -C ../.." End: *) ����������������������frama-c-Fluorine-20130601/src/memory_state/locations.mli��������������������������������������������0000644�0001750�0001750�00000027017�12155630237�022005� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Memory locations. @plugin development guide *) open Cil_types open Abstract_interp open Lattice_Interval_Set (** Association between varids and offsets in byte. @plugin development guide *) module Location_Bytes : sig (* TODOBY: write an mli for MapLattice, and name the result. Use it there, and simplify *) module M : sig type key = Base.t type t val iter : (Base.t -> Ival.t -> unit) -> t -> unit val find : key -> t -> Ival.t val fold : (Base.t -> Ival.t -> 'a -> 'a) -> t -> 'a -> 'a end type z = | Top of Base.SetLattice.t * Origin.t | Map of M.t (** Those locations have a lattice structure, including standard operations such as [join], [narrow], etc. *) include Lattice with type t = z and type widen_hint = Base.SetLattice.widen_hint * (Base.t -> Ival.widen_hint) val singleton_zero : t (** the set containing only the value for to the C expression [0] *) val singleton_one : t (** the set containing only the value [1] *) val zero_or_one : t val is_zero : t -> bool val is_bottom : t -> bool val top_int : t val top_float : t val top_single_precision_float : t val inject : Base.t -> Ival.t -> t val inject_ival : Ival.t -> t val inject_float : Ival.F.t -> t (** Non directly lattice-related operations *) val add_or_bottom : Base.t -> Ival.t -> M.t -> M.t val diff : t -> t -> t (** Over-approximation of difference. [arg2] needs to be exact or an under_approximation. *) val diff_if_one : t -> t -> t (** Over-approximation of difference. [arg2] can be an over-approximation. *) val shift : Ival.t -> t -> t (** Topifying of values, in case of imprecise accesses *) val topify_arith_origin : t -> t val topify_misaligned_read_origin : t -> t val topify_merge_origin : t -> t val topify_leaf_origin : t -> t val under_topify : t -> t val topify_with_origin: Origin.t -> t -> t val topify_with_origin_kind: Origin.kind -> t -> t val inject_top_origin : Origin.t -> Base.SetLattice.O.t -> t (** [inject_top_origin origin p] creates a top with origin [origin] and additional information [param] *) val top_with_origin: Origin.t -> t (** Completely imprecise value. Use only as last resort. *) val fold_bases : (Base.t -> 'a -> 'a) -> t -> 'a -> 'a (** Fold on all the bases of the location, including [Top bases]. @raise Error_Top in the case [Top Top]. *) val fold_i : (Base.t -> Ival.t -> 'a -> 'a) -> t -> 'a -> 'a (** Fold with offsets. @raise Error_Top in the cases [Top Top], [Top bases]. *) val cached_fold: cache:string * int -> temporary:bool -> f:(Base.t -> Ival.t -> 'a) -> projection:(Base.t -> Ival.t) -> joiner:('a -> 'a -> 'a) -> empty:'a -> t -> 'a (** Cached version of [fold_i], for advanced users *) (** Number of locations *) val cardinal_zero_or_one : t -> bool val cardinal_less_than : t -> int -> int val find_lonely_binding : t -> Base.t * Ival.t val find_lonely_key : t -> Base.t * Ival.t val fold_enum : split_non_enumerable:int -> (t -> 'a -> 'a) -> t -> 'a -> 'a val splitting_cardinal_less_than : split_non_enumerable:int -> t -> int -> int (** Destructuring *) val find_or_bottom : Base.t -> M.t -> Ival.t val split : Base.t -> t -> Ival.t * t val get_bases : t -> Base.SetLattice.t (** Returns the bases the location may point too. Never fail, but may return [Base.SetLattice.Top]. *) (** Local variables inside locations *) val contains_addresses_of_locals : (M.key -> bool) -> t -> bool (** [contains_addresses_of_locals is_local loc] returns [true] if [loc] contains the adress of a variable for which [is_local] returns [true] *) val remove_escaping_locals : (M.key -> bool) -> t -> Base.SetLattice.t * t (** TODO: merge with above function [remove_escaping_locals is_local v] removes from [v] information associated with bases for which [is_local] returns [true]. *) val contains_addresses_of_any_locals : t -> bool (** [contains_addresses_of_any_locals loc] returns [true] iff [loc] contains the adress of a local variable or of a formal variable. *) (** Other *) val iter_on_strings : skip:Base.t option -> (Base.t -> string -> int -> int -> unit) -> t -> unit val partially_overlaps : size:Int.t -> t -> t -> bool (** Is there a possibly-non empty intersection between the two supplied locations, assuming they have size [size] *) val is_relationable: t -> bool val may_reach : Base.t -> t -> bool (** [may_reach base loc] is true if [base] might be accessed from [loc]. *) (**/**) val clear_caches: unit -> unit end (** Association between varids and offsets in bits. @plugin development guide *) module Location_Bits : module type of Location_Bytes (** Association between varids and ranges of bits. @plugin development guide *) module Zone : sig type map_t type tt = Top of Base.SetLattice.t * Origin.t | Map of map_t include Datatype.S with type t = tt val top : t val bottom : t val is_bottom: t -> bool val inject : Base.t -> Int_Intervals.t -> t val join : t -> t -> t (** Over-approximation of union. *) val link : t -> t -> t (** Under_approximation of union. *) val narrow : t -> t -> t (** Over-approximation of intersection. *) val meet : t -> t -> t (** Under-approximation of intersection. *) val diff : t -> t -> t (** Over-approximation of difference. [arg2] needs to be exact or an under-approximation. *) val diff_if_one : t -> t -> t (** Over-approximation of difference. [arg2] can be an over-approximation. *) exception Error_Bottom exception Error_Top val map_i : (Base.t -> Int_Intervals.t -> t) -> t -> t val find_lonely_key : t -> Base.t * Int_Intervals.t val find_or_bottom : Base.t -> map_t -> Int_Intervals.t val mem_base : Base.t -> t -> bool (** [mem_base b m] returns [true] if [b] is associated to something or topified in [t], and [false] otherwise. @since Carbon-20101201 *) val intersects : t -> t -> bool (** Assuming that [z1] and [z2] only contain valid bases, [valid_intersects z1 z2] returns true iff [z1] and [z2] have a valid intersection. *) val valid_intersects : t -> t -> bool type widen_hint val widen : widen_hint -> t -> t -> t val is_included : t -> t -> bool val is_included_exn : t -> t -> unit val cardinal_zero_or_one : t -> bool val cardinal_less_than : t -> int -> int (** {3 Folding} *) val filter_base : (Base.t -> bool) -> t -> t (** [filter_base] can't raise Error_Top since it filters bases of [Top bases]. Note: the filter may give an over-approximation (in the case [Top Top]). *) val fold_bases : (Base.t -> 'a -> 'a) -> t -> 'a -> 'a (** [fold_bases] folds also bases of [Top bases]. @raise Error_Top in the case [Top Top]. *) val fold_i : (Base.t -> Int_Intervals.t -> 'a -> 'a) -> t -> 'a -> 'a (** [fold_i f l acc] folds [l] by base. @raise Error_Top in the cases [Top Top], [Top bases]. *) val fold_topset_ok : (Base.t -> Int_Intervals.t -> 'a -> 'a) -> t -> 'a -> 'a (** [fold_i f l acc] folds [l] by base. @raise Error_Top in the case [Top Top]. *) val cached_fold : cache:string * int -> temporary:bool -> f:(Base.t -> Lattice_Interval_Set.Int_Intervals.t -> 'b) -> projection:(Base.t -> Lattice_Interval_Set.Int_Intervals.t) -> joiner:('b -> 'b -> 'b) -> empty:'b -> t -> 'b (** {3 Lmap_bitwise utilities} *) (** The functions default and default_all are intended to be called by the functor Lmap_bitwise. *) val default : Base.t -> Int.t -> Int.t -> t val defaultall : Base.t -> t (**/**) val clear_caches: unit -> unit end (** {2 Locations} *) (** A {!Location_Bits.t} and a size in bits. @plugin development guide *) type location = private { loc : Location_Bits.t; size : Int_Base.t; } (** @plugin development guide *) module Location: Datatype.S with type t = location val loc_bottom : location val make_loc : Location_Bits.t -> Int_Base.t -> location val loc_equal : location -> location -> bool val loc_size : location -> Int_Base.t val is_valid : for_writing:bool -> location -> bool (** Is the given location entirely valid, as the destination of a write operation if [for_writing] is true, as the destination of a read otherwise. *) val is_valid_or_function : location -> bool (** Is the location entirely valid for reading, or is it a valid function pointer. *) val valid_part : for_writing:bool -> location -> location (** Overapproximation of the valid part of the given location. Beware that [is_valid (valid_part loc)] does not necessarily hold, as garbled mix are not reduced by [valid_part]. *) val invalid_part : location -> location (** Overapproximation of the invalid part of a location *) (* Currently, this is the identity function *) val cardinal_zero_or_one : location -> bool (** Is the location bottom or a singleton? *) val valid_cardinal_zero_or_one : for_writing:bool -> location -> bool (** Is the valid part of the location bottom or a singleton? *) val filter_base: (Base.t -> bool) -> location -> location val filter_loc : location -> Zone.t -> location val pretty : Format.formatter -> location -> unit val pretty_english : prefix:bool -> Format.formatter -> location -> unit (** {2 Conversion functions} *) val loc_to_loc_without_size : location -> Location_Bytes.t val loc_bytes_to_loc_bits : Location_Bytes.t -> Location_Bits.t val loc_bits_to_loc_bytes : Location_Bits.t -> Location_Bytes.t val enumerate_bits : location -> Zone.t val enumerate_valid_bits : for_writing:bool -> location -> Zone.t (** @plugin development guide *) val zone_of_varinfo : varinfo -> Zone.t (** @since Carbon-20101201 *) val loc_of_varinfo : varinfo -> location val loc_of_base : Base.t -> location val loc_of_typoffset : Base.t -> typ -> offset -> location (* Local Variables: compile-command: "make -C ../.." End: *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/inout_type.ml��������������������������������������������0000644�0001750�0001750�00000012330�12155630237�022030� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) type tt = { over_inputs: Locations.Zone.t; over_inputs_if_termination: Locations.Zone.t; under_outputs_if_termination: Locations.Zone.t; over_outputs: Locations.Zone.t; over_outputs_if_termination: Locations.Zone.t; } let pretty_operational_inputs_aux fmt x = Format.fprintf fmt "@[<v 2>Operational inputs:@ @[<hov>%a@]@]@ " Locations.Zone.pretty (x.over_inputs); Format.fprintf fmt "@[<v 2>Operational inputs on termination:@ @[<hov>%a@]@]@ " Locations.Zone.pretty (x.over_inputs_if_termination); Format.fprintf fmt "@[<v 2>Sure outputs:@ @[<hov>%a@]@]@ " Locations.Zone.pretty (x.under_outputs_if_termination); ;; let pretty_outputs_aux fmt x = Format.fprintf fmt "@[<v 2>Over outputs:@ @[<hov>%a@]@]@ " Locations.Zone.pretty (x.over_outputs); Format.fprintf fmt "@[<v 2>Over outputs on termination:@ @[<hov>%a@]@]@ " Locations.Zone.pretty (x.over_outputs_if_termination); ;; let wrap_vbox f fmt x = Format.fprintf fmt "@[<v>"; f fmt x; Format.fprintf fmt "@]" let pretty_operational_inputs = wrap_vbox pretty_operational_inputs_aux let pretty_outputs = wrap_vbox pretty_outputs_aux open Locations include Datatype.Make (struct include Datatype.Serializable_undefined type t = tt let pretty fmt x = Format.fprintf fmt "@[<v>"; pretty_operational_inputs_aux fmt x; pretty_outputs_aux fmt x; Format.fprintf fmt "@]" let structural_descr = let z = Locations.Zone.packed_descr in Structural_descr.t_record [| z; z; z; z; z |] let reprs = List.map (fun z -> { over_inputs_if_termination = z; under_outputs_if_termination = z; over_inputs = z; over_outputs = z; over_outputs_if_termination = z; }) Locations.Zone.reprs let name = "Full.tt" let hash { over_inputs_if_termination = a; under_outputs_if_termination = b; over_inputs = c; over_outputs = d; over_outputs_if_termination = e; } = Zone.hash a + 17 * Zone.hash b + 587 * Zone.hash c + 1077 * Zone.hash d + 13119 * Zone.hash e let equal { over_inputs_if_termination = a; under_outputs_if_termination = b; over_inputs = c; over_outputs = d; over_outputs_if_termination = e; } { over_inputs_if_termination = a'; under_outputs_if_termination = b'; over_inputs = c'; over_outputs = d'; over_outputs_if_termination = e'; } = Zone.equal a a' && Zone.equal b b' && Zone.equal c c' && Zone.equal d d' && Zone.equal e e' let mem_project = Datatype.never_any_project end) let map f v = { over_inputs_if_termination = f v.over_inputs_if_termination; under_outputs_if_termination = f v.under_outputs_if_termination; over_inputs = f v.over_inputs; over_outputs = f v.over_outputs; over_outputs_if_termination = f v.over_outputs_if_termination; } let bottom = { over_inputs = Zone.bottom; over_inputs_if_termination = Zone.bottom; under_outputs_if_termination = Zone.top; over_outputs = Zone.bottom; over_outputs_if_termination = Zone.bottom; } let join c1 c2 = { over_inputs = Zone.join c1.over_inputs c2.over_inputs; over_inputs_if_termination = Zone.join c1.over_inputs_if_termination c2.over_inputs_if_termination; over_outputs = Zone.join c1.over_outputs c2.over_outputs; over_outputs_if_termination = Zone.join c1.over_outputs_if_termination c2.over_outputs_if_termination; under_outputs_if_termination = Zone.meet c1.under_outputs_if_termination c2.under_outputs_if_termination; } (* Local Variables: compile-command: "make -C ../.." End: *) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/offsetmap.ml���������������������������������������������0000644�0001750�0001750�00000175376�12155630237�021641� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp (* This module uses Bigints everywhere. Set up some notations *) let pretty_int = Int.pretty let ( =~ ) = Integer.equal let ( <>~ ) x y = not (Integer.equal x y) let ( <~ ) = Integer.lt let ( >~ ) = Integer.gt let ( <=~ ) = Integer.le let ( >=~ ) = Integer.ge let ( +~ ) = Integer.add let ( -~ ) = Integer.sub (*let ( *~ ) = Integer.mul*) let ( /~ ) = Integer.pos_div let ( %~ ) = Integer.pos_rem let succ = Integer.succ let pred = Integer.pred module Make (V : Lattice_With_Isotropy.S) = struct open Format exception Result_is_bottom type v = V.t type widen_hint = V.widen_hint type tt = | Empty (* min, the lower bound of the key interval, is always zero because trees are relative. max * offset_left * subtree_left * offset_right * subtree_right * rem * modu * value * tag *) | Node of Integer.t * Integer.t * tt * Integer.t * tt * Rel.t * Integer.t * V.t * int let equal (t1:tt) (t2:tt) = t1 == t2 let compare t1 t2 = match t1, t2 with | Empty, Empty -> 0 | Empty, Node _ -> -1 | Node _, Empty -> 1 | Node (_, _, _, _, _, _, _, _, h1), Node (_, _, _, _, _, _, _, _, h2) -> Datatype.Int.compare h1 h2 (** Pretty printing *) let pretty_offset_aux s curr_off ppf tree = if tree == Empty then Format.fprintf ppf "@[empty at %a@]" pretty_int curr_off else let rec pretty_offset s curr_off ppf tree = match tree with | Empty -> () | Node (max, offl, subl, offr, subr, rem, modu, v, _) -> pretty_offset "" (curr_off +~ offl) ppf subl; Format.fprintf ppf "@[%s[%a..%a] -> (%a, %a, %a);@]@ " s pretty_int curr_off pretty_int (max +~ curr_off) Rel.pretty rem pretty_int modu V.pretty v; pretty_offset "" (curr_off +~ offr) ppf subr; in pretty_offset s curr_off ppf tree ;; let _pretty_offset fmt (off, t) = Format.fprintf fmt "@[<v><off: %a>@ %a@]" pretty_int off (pretty_offset_aux "r" off) t; ;; let pretty fmt t = Format.fprintf fmt "@[<v>%a@]" (pretty_offset_aux "r" Integer.zero) t; ;; include (struct (* This function is almost injective. Can we do better, eg. by mapping Empty to 0 and skipping this value for all nodes? And it is worth it? *) let hash = function | Empty -> 311 | Node(_,_,_,_,_,_,_,_,tag) -> tag let rehash_ref = ref (fun _ -> assert false) module D = Datatype.Make (struct type t = tt let name = V.name ^ " newoffsetmap" let reprs = [ Empty ] open Structural_descr let r = Recursive.create () let structural_descr = let p_bint = Datatype.Big_int.packed_descr in Structure (Sum [| [| p_bint; p_bint; recursive_pack r; p_bint; recursive_pack r; p_bint; p_bint; V.packed_descr; p_int |] |]) let () = Recursive.update r structural_descr let equal = equal let hash = hash let compare = compare let rehash x = !rehash_ref x let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = pretty let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) include D (* Basic operations on nodes *) let empty = Empty;; let is_empty t = t == Empty let equal_internal t1 t2 = match t1, t2 with | Empty, Empty -> true | Node _, Empty | Empty, Node _ -> false | Node (max1, offl1, subl1, offr1, subr1, rem1, modu1, v1, _), Node (max2, offl2, subl2, offr2, subr2, rem2, modu2, v2, _) -> subl1 == subl2 && subr1 == subr2 && offl1 =~ offl2 && offr1 =~ offr2 && V.equal v1 v2 && max1 =~ max2 && Rel.equal rem1 rem2 && modu1 =~ modu2 let hash_internal t = match t with Empty -> 97 | Node (max, offl, subl, offr, subr, rem, modu, v, _) -> let h = Integer.hash max in let h = 31 * h + Integer.hash offl in let h = 31 * h + hash subl in let h = 31 * h + Integer.hash offr in let h = 31 * h + hash subr in let h = 31 * h + Rel.hash rem in let h = 31 * h + Integer.hash modu in let h = 31 * h + V.hash v in h module NewoHashconsTbl = State_builder.Hashconsing_tbl (struct include D let hash_internal = hash_internal let equal_internal = equal_internal let initial_values = [] end) (struct let name = name let dependencies = [ Ast.self ] let size = 137 end) let () = Ast.add_monotonic_state NewoHashconsTbl.self let counter = ref 0 let singleton_tag t = match t with Empty -> min_int | Node(_, _, _, _, _, _, _, _, tag) -> tag land min_int let nNode cur offl subl offr subr f g v = let current_counter = !counter in let tag = if V.cardinal_zero_or_one v then (singleton_tag subl) land (singleton_tag subr) else 0 in let tag = tag lor current_counter in let tentative_new_node = Node(cur, offl, subl, offr, subr, f, g, v,tag) in let hashed_node = NewoHashconsTbl.merge tentative_new_node in if hashed_node != tentative_new_node then begin if current_counter = max_int then Kernel.fatal "Internal maximum exeeded"; counter := Pervasives.succ current_counter; end; hashed_node let rehash_node x = match x with | Empty -> empty | Node _ -> NewoHashconsTbl.merge x let () = rehash_ref := rehash_node end : sig include Datatype.S with type t = tt val empty : t val hash: t -> int val nNode : Integer.t -> Integer.t -> t -> Integer.t -> t -> Rel.t -> Integer.t -> V.t -> t val is_empty : t -> bool val singleton_tag : t -> int end) module Cacheable = struct type t = Integer.t * tt let hash (i, t: t) = Integer.hash i + 37 * hash t let equal (i1, t1: t) (i2, t2: t) = t1 == t2 && i1 =~ i2 let sentinel = Integer.minus_one, empty end let clear_caches = ref [] let equal_vv (rem1, modu1, v1) (rem2, modu2, v2) = rem1 =~ rem2 && modu1 =~ modu2 && V.equal v1 v2 ;; let get_vv node curr_off = match node with | Empty -> assert false | Node (_, _, _, _, _, remrel, modu, v, _) -> let rem = (Rel.add_abs curr_off remrel) %~ modu in rem, modu, v ;; let _get_v = function | Empty -> assert false | Node (_, _, _, _, _, _, _, v, _) -> v ;; let get_max = function | Empty -> assert false | Node (max, _, _, _, _, _, _, _, _) -> max ;; let get_modu = function | Empty -> assert false | Node (_, _, _, _, _, _, modu, _, _) -> modu ;; let is_above min1 max1 min2 max2 = if min1 =~ Integer.zero then true else if min2 =~ Integer.zero then false else let signature_interval min max = Integer.logxor (pred min) max in signature_interval min1 max1 >~ signature_interval min2 max2 ;; type zipper = | End | Right of Integer.t * t * zipper | Left of Integer.t * t * zipper;; (** Zippers : Offset of a node * Node * continuation of the zipper *) exception End_reached;; exception Empty_tree;; let _pr_zipper ppf z = printf "[Zipper]---@."; let rec aux ppf = function | End -> printf "@ E@." | Right (o, Node(max, _, _, _, _subr, _, _, _, _),z ) -> fprintf ppf "@[<h 2> [%a,%a] R@\n%a@]" pretty_int o pretty_int (o +~ max) aux z | Left (o, Node(max, _, _, _, _subr, _, _, _, _),z ) -> fprintf ppf "@[<h 2> [%a,%a] L@\n%a@]" pretty_int o pretty_int (o +~ max) aux z | Right (_, Empty, _) | Left (_, Empty, _) -> assert false in aux ppf z; printf "[/Zipper]---@.@."; ;; (** Returns an absolute position and an associated new tree *) let rec rezip zipper curr_off node = match zipper with | End -> curr_off, node | Right (offset, Node(max, offl, subl, _offr, _subr, rem, modu, v, _), z) -> rezip z offset (nNode max offl subl (curr_off -~ offset) node rem modu v) | Left (offset, Node(max, _offl, _subl, offr, subr, rem, modu, v, _), z) -> rezip z offset (nNode max (curr_off -~ offset) node offr subr rem modu v) | Right (_, Empty, _) | Left (_, Empty, _) -> assert false ;; (** Returns an absolute position, a node and a zipper *) let rec leftmost_child curr_off zipper node = match node with | Empty -> raise Empty_tree | Node (_, _, Empty, _, _, _, _, _, _) -> curr_off, node, zipper | Node (_, offl, subl, _, _, _, _, _, _) -> let new_offset = curr_off +~ offl in leftmost_child new_offset (Left (curr_off, node, zipper)) subl ;; (** Returns an absolute position, a node and a zipper *) let rec rightmost_child curr_off zipper node = match node with | Empty -> raise Empty_tree | Node (_, _, _, _, Empty, _, _, _, _) -> curr_off, node, zipper | Node (_, _offl, _subl, offr, subr, _, _, _, _) -> let new_offset = curr_off +~ offr in rightmost_child new_offset (Right (curr_off, node, zipper)) subr ;; (** Move to the right of the current node. Uses a zipper for that. *) let move_right curr_off node zipper = match node with | Node (_, _, _, offr, ((Node _ ) as subr), _, _, _, _) -> let new_offset = curr_off +~ offr in leftmost_child new_offset (Right (curr_off, node, zipper)) subr | Node (_, _, _, _, Empty, _, _, _, _) -> begin let rec unzip_until_left zipper = match zipper with | End -> raise End_reached | Right (_, _, z) -> unzip_until_left z | Left (offset, tree, z) -> offset, tree, z in unzip_until_left zipper end | Empty -> assert false ;; type imp_zipper = { mutable offset: Integer.t; mutable node: t; mutable zipper: zipper; };; let imp_move_right imp_z = let o, n, z = move_right imp_z.offset imp_z.node imp_z.zipper in imp_z.offset <- o; imp_z.node <- n; imp_z.zipper <- z; ;; (** Folding and iterating from the leftmost node to the rightmost one If t = n0 fold f t i = f n2 (f n0 (f n1 i)) / \ iter f t = f n1; fn0; f n2; n1 n2 *) let fold_offset f o t = let o, n, z = leftmost_child o End t in let rec aux_fold o t z pre = match t with | Empty -> pre | Node (max, _, _, _, _, r, m, v, _) -> let abs_max = max +~ o in let now = f (o, abs_max) (v, m, r) pre in try let no, nt, nz = move_right o t z in aux_fold no nt nz now with End_reached -> now in aux_fold o n z ;; let fold f t = fold_offset f Integer.zero t ;; let iter_offset f o t = let o, n, z = leftmost_child o End t in let rec aux_iter o t z = match t with | Empty -> () | Node (max, _, _, _, _, r, m, v, _) -> begin let abs_max = max +~ o in f (o, abs_max) (v, m, r); try let no, nt, nz = move_right o t z in aux_iter no nt nz with End_reached -> () end in aux_iter o n z ;; let iter f t = iter_offset f Integer.zero t ;; let rec iter_on_values f t = match t with | Empty -> () | Node (_, _, left, _, right, _, modu, v, _) -> iter_on_values f left; f v modu; iter_on_values f right ;; let rec fold_on_values f t acc = match t with | Empty -> acc | Node (_, _, left, _, right, _, modu, v, _) -> fold_on_values f right (f v modu ((fold_on_values f left acc))) ;; (** Smart constructor for nodes: it glues the node being allocated to potential candidates if needed (i.e. leftmost node of right subtree and rightmost node of left subtree), *) let make_node curr_off max offl subl offr subr rem modu v = let rem, modu = if V.is_isotropic v then Integer.zero, Integer.one else rem, modu in let curr_vv = (rem, modu, v) in let max, offr, subr = try let offset, nr, zr = leftmost_child (curr_off +~ offr) End subr in match nr with | Node (nmax, _, nsubl , noffr, nsubr, nrelrem, nmodu, nv, _) -> assert (is_empty nsubl); let nrem = (Rel.add_abs offset nrelrem) %~ nmodu in if equal_vv (nrem, nmodu, nv) curr_vv && (V.cardinal_zero_or_one v || (offset %~ modu =~ rem)) then begin let curr_offr, new_subr = rezip zr (offset +~ noffr) nsubr in let new_max = succ (max +~ nmax) in let new_offr = curr_offr -~ curr_off in new_max, new_offr, new_subr end else max, offr, subr | Empty -> assert false with Empty_tree -> max, offr, subr in let curr_off, max, offl, subl, offr = try let offset, nl, zl = rightmost_child (curr_off +~ offl) End subl in match nl with | Node (nmax, noffl, nsubl , _, noffr, nrelrem, nmodu, nv, _) -> assert (is_empty noffr); let nrem = (Rel.add_abs offset nrelrem) %~ nmodu in if equal_vv (nrem, nmodu, nv) curr_vv && (curr_off %~ modu =~ rem) then ( let new_curr_offl, new_subl = rezip zl (offset +~ noffl) nsubl in let succ_nmax = succ nmax in let lmax = max +~ succ_nmax in let new_offl = new_curr_offl -~ offset in let new_offr = offr +~ succ_nmax in let new_coff = curr_off -~ succ_nmax in (*assert (new_coff =~ offset);*) new_coff, lmax, new_offl, new_subl, new_offr) else curr_off, max, offl, subl, offr |Empty -> assert false with Empty_tree -> curr_off, max, offl, subl, offr in let remrel = Rel.pos_rem (Rel.sub_abs rem curr_off) modu in curr_off, nNode max offl subl offr subr remrel modu v ;; (** Smart add node: Adds a node to the current tree and merges (new) consecutive intervals containing the same values The node is [min..max] rem, modu, v and the tree to which it is added is rooted at offset curr_off Hypothesis: the tree is in canonical form w.r.t having no mergeable intervals. *) let add_node min max rem modu v curr_off tree = let rec aux_add curr_off tree = match tree with | Empty -> let sz = max -~ min in make_node min sz Integer.zero empty (succ sz) empty rem modu v | Node (nmax, noffl, nsubl, noffr, nsubr, nremrel, nmodu, nv, _) -> let nrem = (Rel.add_abs curr_off nremrel) %~ nmodu in let abs_min = curr_off and abs_max = nmax +~ curr_off in if max <~ abs_min then begin if is_above min max abs_min abs_max then let new_offr = abs_min -~ min in (*Format.printf "add to the left above@."; *) make_node min (max -~ min) Integer.zero empty new_offr tree rem modu v else begin (* Format.printf "L@ co:%a@ t:%a@ [%a...%a]@.@." pretty_int curr_off (pretty_offset curr_off) tree pretty_int min pretty_int max ; *) let new_curr_offl, new_node = aux_add (curr_off +~ noffl) nsubl in let new_offl = new_curr_offl -~ curr_off in make_node curr_off nmax new_offl new_node noffr nsubr nrem nmodu nv end end else begin if is_above min max abs_min abs_max then begin let new_offl = abs_min -~ min in let new_max = max -~ min in make_node min new_max new_offl tree (succ new_max) empty rem modu v end else begin (* Format.printf "add to the right Not ABOVE@."; *) let new_curr_offr, new_node = aux_add (curr_off +~ noffr) nsubr in let new_offr = new_curr_offr -~ abs_min in make_node abs_min nmax noffl nsubl new_offr new_node nrem nmodu nv end end in aux_add curr_off tree ;; let add_node_from_root ~min ~max ~rem ~modu ~v t = snd (add_node min max rem modu v Integer.zero t) let add_basic_node ~min ~max ~v m = if V.is_isotropic v then add_node_from_root ~min ~max ~rem:Integer.zero ~modu:Integer.one ~v m else let size = Integer.length min max in let v = V.anisotropic_cast ~size v in let rem = min %~ size in add_node_from_root ~min ~max ~rem ~modu:size ~v m (** Checks that [tree] is sanely built *) let rec _check curr_off tree = match tree with | Empty -> () | Node (max, offl, subl, offr, subr, rem, modu, _v, _) -> assert (Rel.check ~rem ~modu); assert (not (is_empty subl) || Integer.is_zero offl); assert (not (is_empty subr) || offr =~ succ max); let abs_min = curr_off and abs_max = curr_off +~ max in let aux offset tree = match tree with | Empty -> () | Node (nmax, _, _, _, _, _, _, _, _) -> let nabs_min = curr_off +~ offset in let nabs_max = nmax +~ nabs_min in assert (is_above abs_min abs_max nabs_min nabs_max) in aux offl subl; aux offr subr; _check (curr_off +~ offl) subl; _check (curr_off +~ offr) subr; ;; (** Inclusion functions *) (* Auxiliary fonction for inclusion: test the inclusion of the values *) let is_similar inclv (r1 : Integer.t) (m1: Integer.t) v1 r2 m2 v2 = if (r1 =~ r2 && m1 =~ m2) || V.is_isotropic v1 || V.is_isotropic v2 then inclv v1 v2 else false (* Auxiliary fonction for inclusion *) let is_included_node_exn inclv (amin1 : Integer.t) (amax1 : Integer.t) r1 m1 v1 amin2 amax2 r2 m2 v2 mabs_min mabs_max = if V.is_isotropic v1 || V.is_isotropic v2 then inclv v1 v2 else let max_test = if amax1 <~ amax2 then (succ mabs_max) %~ m1 =~ r1 else true in let ok_min = amin1 =~ amin2 || mabs_min %~ m1 =~ r1 and ok_max = amax1 =~ amax2 || max_test in if r1 =~ r2 && m1 =~ m2 && ok_min && ok_max then inclv v1 v2 else false (* Functional for inclusion test. *) let is_included_aux cache inclv (o1, t1) (o2, t2) = match t1, t2 with | Empty, _ -> true (* BYTODO *) | _, Empty -> true (* BYTODO *) | Node (max1, offl1, subl1, offr1, subr1, r1rel, m1, v1, _), Node (max2, offl2, subl2, offr2, subr2, r2rel, m2, v2, _) -> let amin1 = o1 in let amax1 = max1 +~ o1 in let amin2 = o2 in let amax2 = max2 +~ o2 in let ol1 = o1 +~ offl1 in let ol2 = o2 +~ offl2 in let or1 = o1 +~ offr1 in let or2 = o2 +~ offr2 in let r1 = (Rel.add_abs o1 r1rel) %~ m1 in let r2 = (Rel.add_abs o2 r2rel) %~ m2 in if amax1 <~ amin2 then cache (o1, t1) (ol2, subl2) && cache (or1, subr1) (o2, t2) else if amin1 >~ amax2 then cache (o1, t1) (or2, subr2) && cache (ol1, subl1) (o2, t2) else begin (* this node of t2 covers part of the interval of t1 we are focused on *) if amin1 =~ amin2 then let mabs_min = amin1 in begin (if amax1 =~ amax2 then begin is_similar inclv r1 m1 v1 r2 m2 v2 && cache (or1, subr1) (or2, subr2) end else if amax1 >~ amax2 then begin is_included_node_exn inclv amin1 amax1 r1 m1 v1 amin2 amax2 r2 m2 v2 mabs_min amax2 && cache (o1, t1) (or2, subr2) end else begin assert (amax1 <~ amax2); is_included_node_exn inclv amin1 amax1 r1 m1 v1 amin2 amax2 r2 m2 v2 mabs_min amax1 && cache (or1, subr1) (o2, t2) end ) && cache (ol1, subl1) (ol2, subl2) end else let treat_current_right_nodes mabs_min = if amax1 =~ amax2 then begin is_included_node_exn inclv amin1 amax1 r1 m1 v1 amin2 amax2 r2 m2 v2 mabs_min amax1 && cache (or1, subr1) (or2, subr2) end else if amax1 >~ amax2 then begin is_included_node_exn inclv amin1 amax1 r1 m1 v1 amin2 amax2 r2 m2 v2 mabs_min amax2 && cache (o1, t1) (or2, subr2) end else begin assert (amax1 <~ amax2); is_included_node_exn inclv amin1 amax1 r1 m1 v1 amin2 amax2 r2 m2 v2 mabs_min amax1 && cache (or1, subr1) (o2, t2) end; in if amin1 >~ amin2 then begin treat_current_right_nodes amin2 && cache (ol1, subl1) (o2, t2) end else begin assert (amin1 <~ amin2); treat_current_right_nodes amin1 && cache (o1, t1) (ol2, subl2) end end ;; module IsIncludedCache = Binary_cache.Make_Binary(Cacheable)(Cacheable) let () = clear_caches := IsIncludedCache.clear :: !clear_caches;; let is_included t1 t2 = let rec aux t1 t2 = if Cacheable.equal t1 t2 then true else is_included_aux (IsIncludedCache.merge aux) V.is_included t1 t2 in aux (Integer.zero, t1) (Integer.zero, t2) ;; let is_included_exn t1 t2 = if not (is_included t1 t2) then raise Is_not_included ;; (** Joins two trees with no overlapping intervals. *) let rec union t1_curr_off t1 t2_curr_off t2 = (* Format.printf "Union t1:%a t2:%a@." (pretty_offset t1_curr_off) t1 (pretty_offset t2_curr_off) t2; *) match t1, t2 with | Empty, Empty -> assert (t1_curr_off =~ t2_curr_off); t1_curr_off, empty | Empty, Node _ -> t2_curr_off, t2 | Node _, Empty -> t1_curr_off, t1 | Node (lmax, loffl, lsubl, loffr, lsubr, lremrel, lmodu, lv, _), Node (rmax, roffl, rsubl, roffr, rsubr, rremrel, rmodu, rv, _) -> let labs_min = t1_curr_off and labs_max = lmax +~ t1_curr_off and rabs_min = t2_curr_off and rabs_max = rmax +~ t2_curr_off in let lrem = (Rel.add_abs t1_curr_off lremrel) %~ lmodu in let rrem = (Rel.add_abs t2_curr_off rremrel) %~ rmodu in if is_above labs_min labs_max rabs_min rabs_max then (* t2 is on the right of t1 *) let new_curr_offr, new_subr = union (t1_curr_off +~ loffr) lsubr t2_curr_off t2 in make_node t1_curr_off lmax loffl lsubl (new_curr_offr -~ t1_curr_off) new_subr lrem lmodu lv else begin (* t1 is on the left of t2 *) (* assert (is_above rabs_min rabs_max labs_min labs_max); *) let new_curr_offl, new_subl = union t1_curr_off t1 (t2_curr_off +~ roffl) rsubl in make_node t2_curr_off rmax (new_curr_offl -~ t2_curr_off) new_subl roffr rsubr rrem rmodu rv end ;; (** Merge two trees that span the same range. This function is a functional: [cache] must be used for recursive calls on subtrees. [f_aux] is the function that merges the intervals point-wise. *) let merge cache f_aux (o1, t1) (o2, t2) = match t1, t2 with | Empty, Empty -> assert false | Node _, Empty -> assert false | Empty, Node _ -> assert false | Node (max1, offl1, subl1, offr1, subr1, rem1rel, modu1, v1, _), Node (max2, offl2, subl2, offr2, subr2, rem2rel, modu2, v2, _) -> let abs_min1 = o1 and abs_max1 = max1 +~ o1 and abs_min2 = o2 and abs_max2 = max2 +~ o2 in let rem1 = (Rel.add_abs o1 rem1rel) %~ modu1 in let rem2 = (Rel.add_abs o2 rem2rel) %~ modu2 in if abs_min2 >~ abs_max1 then if is_above abs_min1 abs_max1 abs_min2 abs_max2 then (* t2 is on the right of t1 *) let off, t = cache (o1 +~ offr1, subr1) (o2, t2) in make_node o1 max1 offl1 subl1 (off -~ o1) t rem1 modu1 v1 else(* t1 is on the left of t2 *) begin (* Format.printf "t2:[%a %a] %a @.t1:[%a %a] %a@." pretty_int abs_min2 pretty_int abs_max2 (pretty_debug_offset o2) t2 pretty_int abs_min1 pretty_int abs_max1 (pretty_debug_offset o1) t1; *) (* assert (is_above abs_min2 abs_max2 abs_min1 abs_max1); *) let off, t = cache (o1, t1) (o2 +~ offl2, subl2) in make_node o2 max2 (off -~ o2) t offr2 subr2 rem2 modu2 v2 end else if abs_min1 >~ abs_max2 then if is_above abs_min1 abs_max1 abs_min2 abs_max2 then (* t2 is on the left of t1 *) let off, t = cache (o1 +~ offl1, subl1) (o2, t2) in make_node o1 max1 (off -~ o1) t offr1 subl1 rem1 modu1 v1 else begin assert (is_above abs_min2 abs_max2 abs_min1 abs_max1); (* t1 is on the right of t2 *) let off, t = cache (o1, t1) (o2 +~ offr2, subr2) in make_node o2 max2 offl2 subl2 (off -~ o2) t rem2 modu2 v2 end else (* here n1 \inter n2 <> \emptyset: -compute the intersection interval: middle_abs_min, middle_abs_max - add the rest of the nodes to their left/right subtree depending on the size of the node - add the new node in the merged left subtree and plug the merged right tree in *) let (curr_offl, left_t), middle_abs_min = let abs_offl1 = o1 +~ offl1 and abs_offl2 = o2 +~ offl2 in if abs_min1 =~ abs_min2 then cache (abs_offl1, subl1) (abs_offl2, subl2), abs_min1 else if abs_min1 <~ abs_min2 then let new_offl1, new_subl1 = add_node abs_min1 (pred abs_min2) rem1 modu1 v1 abs_offl1 subl1 in cache (new_offl1, new_subl1) (abs_offl2, subl2), abs_min2 else begin assert (abs_min1 >~ abs_min2); let new_offl2, new_subl2 = add_node abs_min2 (pred abs_min1) rem2 modu2 v2 abs_offl2 subl2 in cache (abs_offl1, subl1) (new_offl2, new_subl2), abs_min1 end in let (curr_offr, right_t), middle_abs_max = let abs_offr1 = o1 +~ offr1 and abs_offr2 = o2 +~ offr2 in if abs_max1 =~ abs_max2 then cache (abs_offr1, subr1) (abs_offr2, subr2), abs_max1 else if abs_max1 <~ abs_max2 then let new_offr2, new_subr2 = add_node (succ abs_max1) abs_max2 rem2 modu2 v2 abs_offr2 subr2 in cache (abs_offr1, subr1) (new_offr2, new_subr2), abs_max1 else begin assert (abs_max1 >~ abs_max2); let min = (succ abs_max2) in let new_offr1, new_subr1 = add_node min abs_max1 rem1 modu1 v1 abs_offr1 subr1 in cache (new_offr1, new_subr1) (abs_offr2, subr2), abs_max2 end in let rem, modu, v = f_aux middle_abs_min middle_abs_max rem1 modu1 v1 rem2 modu2 v2 in let curr_offl, left_t = add_node middle_abs_min middle_abs_max rem modu v curr_offl left_t in union curr_offl left_t curr_offr right_t ;; let extract_bits ~start ~stop ~modu v = assert (start <=~ stop && stop <=~ modu); let start,stop = if Cil.theMachine.Cil.theMachine.Cil_types.little_endian then start,stop else let mmodu = pred modu in mmodu -~ stop, mmodu -~ start in V.extract_bits ~start ~stop ~size:modu v ;; let merge_bits ~conflate_bottom ~offset ~length ~value ~total_length acc = assert (length +~ offset <=~ Integer.of_int total_length); if Cil.theMachine.Cil.theMachine.Cil_types.little_endian then V.little_endian_merge_bits ~conflate_bottom ~offset ~value ~total_length acc else V.big_endian_merge_bits ~conflate_bottom ~offset ~value ~total_length ~length acc ;; (* [offset] is the offset where the read has begun (ie the global read start). [size] is the total size we want to read from [offset]. [curr_off] and [(rem, modu, v)] refer to the current node to be read. [acc] is the current state of accumulated reads. *) let extract_bits_and_stitch ~topify ~conflate_bottom ~offset ~size curr_off (rem, modu, v) max acc = let inform = ref false in let r = let abs_max = curr_off +~ max in (* last bit to be read, be it in the current node or one of its successors *) let max_bit = pred (offset +~ size) in let extract_single_step min acc = assert (not (V.is_isotropic v)); let interval_offset = min -~ offset in let merge_offset = if interval_offset >=~ Integer.zero then interval_offset else Integer.zero in let start = (min -~ rem) %~ modu in let modu_end = if rem =~ Integer.zero then pred modu else pred rem in (* where do we stop reading ? either at the end of the current slice (round_up_to_r min) or at the end of the interval (abs_max) *) let read_end = Integer.min (Integer.min (Integer.round_up_to_r ~min ~r:modu_end ~modu) abs_max) max_bit in let stop = (read_end -~ rem) %~ modu in (* Format.printf "Single step: merge offset %a length %a \ start %a stop %a total length %a offset %a max bit %a\ @\n current offset %a Rem %a modu %a V %a@." pretty_int merge_offset pretty_int (Integer.length start stop) pretty_int start pretty_int stop pretty_int size pretty_int offset pretty_int max_bit pretty_int curr_off pretty_int rem pretty_int modu V.pretty v ; *) let this_inform, read_bits = extract_bits ~topify ~start ~stop ~modu v in inform := !inform || this_inform; let result = merge_bits ~topify ~conflate_bottom ~offset:merge_offset ~length:(Integer.length start stop) ~value:read_bits ~total_length:(Integer.to_int size) acc in read_end, result in let start = Integer.max offset curr_off and stop = Integer.min max_bit abs_max in if V.is_isotropic v then let interval_offset = rem -~ start (* ? *) in let merge_offset = if interval_offset <~ Integer.zero then Integer.zero else interval_offset in merge_bits ~topify ~conflate_bottom ~offset:merge_offset ~length:(Integer.length start stop) ~value:v ~total_length:(Integer.to_int size) acc else let start_point = ref start in let acc = ref acc in while !start_point <=~ stop do let read_end, result = extract_single_step !start_point !acc in acc := result; start_point := succ read_end; done; !acc; in (* Format.printf "extract_bits_and_stitch istart@ %Ld@ size %Ld\ coff %Ld abs_max %Ld val %a@\n acc %a res %a@." offset size curr_off (curr_off +~ (get_max node)) V.pretty (get_v node) V.pretty acc V.pretty r; *) !inform, r ;; (** Auxiliary function to join 2 trees with merge. The merge on two values is done by [merge_v]. Since this function can be [V.widen], the left/right order of arguments must be preserved. *) let f_aux_merge merge_v abs_min abs_max rem1 modu1 v1 rem2 modu2 v2 = (* Format.printf "f_aux_merge: [%a, %a]@.(%a %a %a)@.(%a %a %a)@." pretty_int abs_min pretty_int abs_max pretty_int rem1 pretty_int modu1 V.pretty v1 pretty_int rem2 pretty_int modu2 V.pretty v2 ; *) let joined size v1 v2 = V.anisotropic_cast size (merge_v v1 v2) in if (rem1 =~ rem2 && modu1 =~ modu2) || V.is_isotropic v2 then rem1, modu1, joined modu1 v1 v2 else if V.is_isotropic v1 then rem2, modu2, joined modu2 v1 v2 else let topify = Origin.K_Merge in let conflate_bottom = false in let offset = abs_min in let size = Integer.length abs_min abs_max in let rem = abs_min %~ size in let _, v1' = if modu1 =~ size && ((rem1 %~ size) =~ rem) then false, v1 else extract_bits_and_stitch ~topify ~conflate_bottom ~offset ~size offset (rem1, modu1, v1) abs_max V.singleton_zero in let _, v2' = if modu2 =~ size && ((rem2 %~ size) =~ rem) then false, v2 else extract_bits_and_stitch ~topify ~conflate_bottom ~offset ~size offset (rem2, modu2, v2) abs_max V.singleton_zero in (* Format.printf "1: (%a, %a, %a);@.2: (%a, %a, %a);@.[%a--%a] -> %a/%a@." pretty_int rem1 pretty_int modu1 V.pretty v1 pretty_int rem2 pretty_int modu2 V.pretty v2 pretty_int abs_min pretty_int abs_max V.pretty v1' V.pretty v2'; *) rem, size, merge_v v1' v2' ;; let f_join = f_aux_merge V.join;; module JoinCache = Binary_cache.Make_Symetric(Cacheable)(Cacheable) let () = clear_caches := JoinCache.clear :: !clear_caches;; (** Joining two trees that cover the same range *) let join t1 t2 = let rec aux_cache t1 t2 = if Cacheable.equal t1 t2 then t1 else JoinCache.merge (merge aux_cache f_join) t1 t2 in snd (aux_cache (Integer.zero, t1) (Integer.zero, t2)) ;; let f_widen wh = f_aux_merge (V.widen wh);; let widen wh t1 t2 = let rec aux t1 t2 = if Cacheable.equal t1 t2 then t1 else merge aux (f_widen wh) t1 t2 in snd (aux (Integer.zero, t1) (Integer.zero, t2)) ;; (* Given an integer i, find the interval the ith bit belongs to (thus its node) Returns: the zipper to navigate from the root to the node found, and the node itself *) exception Bit_Not_found (* TODO: not clear it does not leak outside *) let find_bit_offset i zipper offset tree = let rec aux_find tree curr_off z = match tree with | Empty -> raise Bit_Not_found | Node (max, offl, subl, offr, subr, _, _modu, _v, _) -> let abs_max = curr_off +~ max in if (i >=~ curr_off) && (i <=~ abs_max) then (z, curr_off, tree) else if i <~ curr_off then aux_find subl (curr_off +~ offl) (Left(curr_off, tree, z)) else begin assert (i >~ abs_max); aux_find subr (curr_off +~ offr) (Right(curr_off, tree, z)) end in aux_find tree offset zipper ;; let find_bit i tree = find_bit_offset i End Integer.zero tree ;; (* First and last bits are included in the interval. The returned value is at the very least isotropic, possibly topified. *) let find_imprecise (first_bit, last_bit) tree = let rec aux tree_offset tree = match tree with | Empty -> V.bottom | Node (max, offl, subl, offr, subr, _rrel, _m, v, _) -> let abs_max = max +~ tree_offset in let subl_value = if first_bit <~ tree_offset then let subl_abs_offset = tree_offset +~ offl in aux subl_abs_offset subl else V.bottom in let subr_value = if last_bit >~ abs_max then let subr_abs_offset = tree_offset +~ offr in aux subr_abs_offset subr else V.bottom in let current_node_value = if last_bit <~ tree_offset || first_bit >~ abs_max then V.bottom else if V.is_isotropic v then v else V.topify_misaligned_read_origin v in V.join subl_value (V.join subr_value current_node_value) in aux Integer.zero tree (* Searches for all intervals of the rangemap contained in the the interval [start, offset + size - 1]. Assumes the rangemap is rooted at offset 0. *) let find_itv ~topify ~with_alarms ~conflate_bottom ~start ~size tree period_read_ahead = ignore(with_alarms); (* FIXME *) let z, cur_off, root = find_bit start tree in match root with | Empty -> (* Bit_Not_found has been raised by find_bit in this case *) assert false | Node (max, _, _, _, _subr, rrel, m, v, _) -> let r = (Rel.add_abs cur_off rrel) %~ m in let isize = pred (start +~ size) in let nsize = cur_off +~ max in let isotropic = V.is_isotropic v in if isize <=~ nsize && (isotropic || (m =~ size && start %~ m =~ r)) then begin let read_ahead = if isotropic || (Integer.is_zero (period_read_ahead %~ m)) then Some nsize else None in false, read_ahead, v end else let inform = ref false in let acc = ref V.singleton_zero in let impz = { node = root; offset = cur_off; zipper = z; } in while impz.offset <=~ isize do let this_inform, v = extract_bits_and_stitch ~topify ~conflate_bottom ~offset:start ~size impz.offset (get_vv impz.node impz.offset) (get_max impz.node) !acc in inform := !inform || this_inform; acc := v; if impz.offset +~ (get_max impz.node) >=~ isize then impz.offset <- succ isize (* end the loop *) else (* Nominal behavior: do next binding *) imp_move_right impz done; !inform, None, !acc ;; (* Finds the value associated to some offsets represented as an ival. *) let find ~with_alarms ~validity ~conflate_bottom ~offsets ~size tree = let inform = ref false in let filtered_by_bound = try Tr_offset.filter_by_bound_for_reading ~with_alarms offsets size validity with Tr_offset.Unbounded -> raise Not_found (* return top *) in let r = try match filtered_by_bound with | Tr_offset.Interval(mn, mx, m) -> let r = mn %~ m in let mn = ref mn in let acc = ref V.bottom in let pred_size = pred size in while !mn <=~ mx do let this_inform, read_ahead, v = find_itv ~topify:Origin.K_Misalign_read ~conflate_bottom ~with_alarms ~start:!mn ~size tree m in inform := !inform || this_inform; acc := V.join v !acc; let naive_next = !mn +~ m in mn := match read_ahead with None -> naive_next | Some read_ahead -> let max = read_ahead -~ pred_size in let aligned_b = Integer.round_down_to_r ~max ~r ~modu:m in Integer.max naive_next aligned_b done; !acc | Tr_offset.Set s -> Ival.O.fold (fun offset acc -> let this_inform, _, new_value = find_itv ~topify:Origin.K_Misalign_read ~conflate_bottom ~with_alarms ~start:offset ~size tree Integer.zero in inform := !inform || this_inform; let result = V.join acc new_value in if V.equal result V.top then raise Not_found; result) s V.bottom | Tr_offset.Imprecise(mn, mx) -> find_imprecise (mn, mx) tree with Bit_Not_found -> V.top in if !inform then begin let w = with_alarms.CilE.imprecision_tracing in Extlib.may (fun _ -> Kernel.warning ~current:true ~once:true "extracting bits of a pointer") w.CilE.a_log; w.CilE.a_call () end; r ;; (* Keep the part of the tree under a given limit offset. *) let rec keep_below offset curr_off tree = match tree with | Empty -> offset, empty | Node (max, offl, subl, offr, subr, rrel, m, v, _) -> let new_offl = offl +~ curr_off in if offset <~ curr_off then keep_below offset new_offl subl else if offset =~ curr_off then new_offl, subl else let sup = curr_off +~ max in if offset >~ sup then let new_offr, new_subr = keep_below offset (curr_off +~ offr) subr in curr_off, nNode max offl subl (new_offr -~ curr_off) new_subr rrel m v else let new_max = pred (offset -~ curr_off) in add_node curr_off (new_max +~ curr_off) ((Rel.add_abs curr_off rrel) %~ m) m v (curr_off +~ offl ) subl ;; let rec keep_above offset curr_off tree = match tree with | Empty -> (succ offset), empty | Node (max, offl, subl, offr, subr, rrel, m, v, _) -> let new_offr = offr +~ curr_off in let abs_max = curr_off +~ max in if offset >~ abs_max then (* This node should be forgotten, let's look at the right subtree *) keep_above offset new_offr subr else if offset =~ abs_max then (* we are at the limit, the right subtree is the answer *) new_offr, subr else if offset <~ curr_off then (* we want to keep this node and part of its left subtree *) let new_offl, new_subl = keep_above offset (curr_off +~ offl) subl in curr_off, nNode max (new_offl -~ curr_off) new_subl offr subr rrel m v else (* the cut happens somewhere in this node it should be cut accordingly and reinjected into its right subtree *) let new_reml = (Rel.add_abs curr_off rrel) %~ m in add_node (succ offset) abs_max new_reml m v new_offr subr ;; let update_itv_with_rem ~exact ~offset ~abs_max ~size ~rem curr_off v tree = let off1, t1 = keep_above abs_max curr_off tree in let off2, t2 = keep_below offset curr_off tree in let rabs = (Rel.add_abs offset rem) %~ size in if exact then let off_add, t_add = add_node offset abs_max rabs size v off1 t1 in union off2 t2 off_add t_add else let v_is_isotropic = V.is_isotropic v in let z, o, t = find_bit_offset offset End curr_off tree in let left_tree = ref t2 in let left_offset = ref off2 in let impz = { node = t; offset = o; zipper = z; } in while impz.offset <=~ abs_max do match impz.node with | Empty -> assert false | Node (max, _offl, _subl, _offr, _subr, rrel, m_node, v_node, _) -> let rabs_node = (Rel.add_abs impz.offset rrel) %~ m_node in let new_r, new_m, new_v = if V.is_isotropic v_node || v_is_isotropic || (rabs =~ rabs_node && m_node =~ size) then let new_r, new_m = if v_is_isotropic then rabs_node, m_node else rabs, size in let cast_v = V.anisotropic_cast ~size:new_m (V.join v_node v) in new_r, new_m, cast_v else let new_value = V.topify_merge_origin (V.join v_node v) in let new_rem = Integer.zero and new_modu = Integer.one in new_rem, new_modu, new_value in let node_abs_max = impz.offset +~ max in let end_reached, write_max = if node_abs_max >=~ abs_max then true, abs_max else false, node_abs_max in let new_left_offset, new_left_tree = add_node (Integer.max impz.offset offset) write_max new_r new_m new_v !left_offset !left_tree in left_tree := new_left_tree; left_offset := new_left_offset; if not end_reached then imp_move_right impz else impz.offset <- succ abs_max done; union !left_offset !left_tree off1 t1 ;; let update_itv = update_itv_with_rem ~rem:Rel.zero;; (* This function does a weak update of the entire [offsm], by adding the topification of [v]. The parameter [validity] is respected, and so is the current size of [offsm]: each interval already present in [offsm] and valid is overwritten. Interval already present but not valid are bound to [V.bottom]. *) let update_imprecise_everywhere ~validity o v offsm = if is_empty offsm then ( assert (validity = Base.Invalid); raise Result_is_bottom ); let v = V.topify_with_origin o v in let clip_min, clip_max = match validity with | Base.Invalid -> assert false (* offsetmap should be empty *) | Base.Known (min, max) | Base.Unknown (min, _, max) -> (fun min' -> Integer.max min min'), (fun max' -> Integer.min max max') | Base.Periodic (_, _, p) -> let min = Integer.zero and max = pred p in (fun min' -> Integer.max min min'), (fun max' -> Integer.min max max') in fold (fun (min, max) (bound_v, _, _) acc -> let new_v = V.join (V.topify_with_origin o bound_v) v in let new_min = clip_min min and new_max = clip_max max in let acc = if min <~ new_min (* Before validity *) then add_basic_node ~min ~max:(pred min) ~v:V.bottom acc else acc in let acc = add_basic_node ~min:new_min ~max:new_max ~v:new_v acc in let acc = if new_max <~ max (* After validity *) then add_basic_node ~min:(succ new_max) ~max ~v:V.bottom acc else acc in acc ) offsm empty ;; (** Update a set of intervals in a given rangemap all offsets starting from mn ending in mx must be updated with value v, every period *) let update_itvs ~exact ~mn ~mx ~period ~size v tree = assert(mx >=~ mn); let r = mn %~ period in let rec aux_update mn mx curr_off tree = match tree with | Empty -> curr_off, empty | Node (max, offl, subl, offr, subr, r_node, m_node, v_node, _) -> let abs_offl = offl +~ curr_off in let abs_offr = offr +~ curr_off in let new_offl, new_subl, undone_left = let last_read_max_offset = curr_off -~ size in if pred (mn +~ size) <~ curr_off then let new_mx = Integer.round_down_to_r ~max:last_read_max_offset ~r ~modu:period in let new_mx, undone = if new_mx >=~ mx then mx, None else new_mx, Some (new_mx +~ period) in let o, t = aux_update mn new_mx abs_offl subl in o, t, undone else abs_offl, subl, Some mn and new_offr, new_subr, undone_right = let abs_max = curr_off +~ max in let first_read_min_offset = succ abs_max in if mx >~ abs_max then let new_mn = Integer.round_up_to_r ~min:first_read_min_offset ~r ~modu:period in let new_mn, undone = if new_mn <=~ mn then mn, None else new_mn, Some (new_mn -~ period) in let o, t = aux_update new_mn mx abs_offr subr in o, t, undone else abs_offr, subr, Some mx in let o, t = add_node curr_off (curr_off +~ max) ((Rel.add_abs curr_off r_node) %~ m_node) m_node v_node new_offl new_subl in let curr_off, tree = union o t new_offr new_subr in match undone_left, undone_right with | Some min, Some max -> begin let update = update_itv ~exact in if size =~ period then let abs_max = pred (size +~ max) in update ~offset:min ~abs_max ~size curr_off v tree else let offset = ref min in let o = ref curr_off in let t = ref tree in while !offset <=~ max do let abs_max = pred (size +~ !offset) in let o', t' = update ~offset:!offset ~abs_max ~size !o v !t in o := o'; t := t'; offset := !offset +~ period; done; !o, !t; end | Some _, None | None, Some _ | None, None -> curr_off, tree in snd (aux_update mn mx Integer.zero tree) ;; (* Same speficication as above, except that if too many writes are required, the result is automatically approximated *) let update_itvs_or_approx ~exact ~mn ~mx ~period ~size v m = let number = succ ((mx -~ mn) /~ period) in let plevel = !Lattice_Interval_Set.plevel in if number <=~ (Integer.of_int plevel) && (period >=~ size) then update_itvs ~exact ~mn ~mx ~period ~size v m else begin if size <~ period then (* We are going to write the locations that are between [size+1] and [period] unnecessarily, warn the user *) Kernel.result ~current:true ~once:true "more than %d(%a) locations to update in array. Approximating." !Lattice_Interval_Set.plevel pretty_int number; let abs_max = pred (mx +~ size) in snd (update_itv ~exact:false ~offset:mn ~abs_max ~size Integer.zero v m) end let update ~with_alarms ~validity ~exact ~offsets ~size v t = let v = V.anisotropic_cast ~size v in try let exact, reduced = Tr_offset.filter_by_bound_for_writing ~with_alarms ~exact offsets size validity in match reduced with | Tr_offset.Imprecise (mn, mx) -> let v = V.topify_misaligned_read_origin v in snd (update_itv ~exact:false ~offset:mn ~abs_max:mx ~size:Integer.one Integer.zero v t) (* TODO: check *) | Tr_offset.Interval(mn, mx, m) -> update_itvs_or_approx exact mn mx m size v t | Tr_offset.Set s when not (Ival.O.is_empty s) -> Ival.O.fold (fun offset acc -> let update = update_itv ~exact in let _, r = update ~offset ~size ~abs_max:(pred (offset +~ size)) Integer.zero v acc in r ) s t | Tr_offset.Set _ -> if exact then raise Result_is_bottom else t with Tr_offset.Unbounded -> (let w = with_alarms.CilE.imprecision_tracing in Extlib.may(fun _ -> Kernel.warning ~once:true ~current:true "Writing at unbounded offset: approximating") w.CilE.a_log; w.CilE.a_call()); update_imprecise_everywhere ~validity (Origin.current Origin.K_Arith) v t let copy_single offset tree size period_read_ahead = let z, cur_off, root = find_bit offset tree in let cur_copy_offset = ref offset (* diffrent from cur_off, as we may be in the middle of the node *) in let impz = { node = root; offset = cur_off; zipper = z; } in let acc = ref empty in let iend = pred (offset +~ size) in let read_ahead = (* See if we can read everything in this node with some read-ahead *) let max, modu = get_max root, get_modu root in let next_end = cur_off +~ max in if offset >=~ cur_off && iend <~ cur_off +~ max && Integer.is_zero (period_read_ahead %~ modu) then Some next_end else None in while (match impz.node with | Empty -> assert false | Node (max, _, _, _, _subr, rrel, m, v, _) -> let next_end = impz.offset +~ max in let nend = Integer.min iend next_end in let new_rel_end = nend -~ offset in let nbeg = !cur_copy_offset -~ offset in let abs_rem = (Rel.add_abs nbeg (Rel.sub rrel (Rel.sub_abs !cur_copy_offset impz.offset))) %~ m in let o, t = add_node nbeg new_rel_end abs_rem m v Integer.zero !acc in assert (o =~ Integer.zero); acc := t; let cond = iend >~ next_end in if cond then begin imp_move_right impz; cur_copy_offset := impz.offset; end; cond) do (); done; read_ahead, !acc ;; let copy_slice ~with_alarms ~validity ~offsets ~size tree = let filtered_by_bound = try Tr_offset.filter_by_bound_for_reading ~with_alarms offsets size validity with Tr_offset.Unbounded -> raise Not_found (* return top *) in let init = add_basic_node ~min:Integer.zero ~max:(pred size) ~v:V.bottom empty in let join acc t = if is_empty acc then t else join acc t in let result = match filtered_by_bound with | Tr_offset.Interval(mn, mx, m) -> let r = mn %~ m in let mn = ref mn in let acc_tree = ref init in let pred_size = pred size in while !mn <=~ mx do let read_ahead, new_tree = copy_single !mn tree size m in acc_tree := join !acc_tree new_tree; let naive_next = !mn +~ m in mn := match read_ahead with | None -> naive_next | Some read_ahead -> let max = read_ahead -~ pred_size in let aligned_b = Integer.round_down_to_r ~max ~r ~modu:m in Integer.max naive_next aligned_b done; !acc_tree | Tr_offset.Set s -> Ival.O.fold (fun offset acc_tree -> let _, t = copy_single offset tree size Integer.zero in join acc_tree t ) s init | Tr_offset.Imprecise(mn, mx) -> let v = find_imprecise (mn, mx) tree in add_basic_node ~min:Integer.zero ~max:(pred size) ~v empty in result ;; let fold_between ~entire (imin, imax) f t acc = let rec aux curr_off t acc = match t with | Empty -> acc | Node (max, offl, subl, offr, subr, rem, modu, v, _) -> let abs_max = max +~ curr_off in let acc = if imin <~ curr_off then ( aux (offl +~ curr_off) subl acc) else acc in let acc = if imax <~ curr_off || imin >~ abs_max then acc else if entire then (* Call f on the entire binding *) f (curr_off, abs_max) (v, modu, rem) acc else (* Cut the interval to [imin..imax] *) let lmin = Integer.max imin curr_off in let lmax = Integer.min imax abs_max in let lrem = Rel.pos_rem (Rel.sub rem (Rel.sub_abs lmin curr_off)) modu in f (lmin, lmax) (v, modu, lrem) acc in if imax >~ abs_max then aux (offr +~ curr_off) subr acc else acc in aux Integer.zero t acc ;; let paste_slice_itv ~exact from start stop start_dest to_ = let update = update_itv_with_rem ~exact in let offset = start_dest -~ start in let treat_interval (imin, imax) (v, modu, rem) acc = let dmin, dmax = imin +~ offset, imax +~ offset in snd (update ~offset:dmin ~abs_max:dmax ~rem:rem ~size:modu Integer.zero v acc) in fold_between ~entire:false (start, stop) treat_interval from to_ ;; let paste_slice ~with_alarms ~validity ~exact (src, start_src) ~size ~offsets dst = try let plevel = !Lattice_Interval_Set.plevel in let stop_src = Int.pred (Int.add start_src size) in ignore (Ival.cardinal_less_than offsets plevel); (* TODO: this should be improved if offsets if of the form [a..b]c%d with d >= size. In this case, the write do not overlap, and could be done in one run in the offsetmap itself *) let aux start_to (acc, success) = let stop_to = Int.pred (Int.add start_to size) in match validity with | Base.Invalid -> CilE.warn_mem_write with_alarms; acc, success | Base.Periodic (b, e, _) | Base.Known (b,e) | Base.Unknown (b,_,e) when Int.lt start_to b || Int.gt stop_to e -> CilE.warn_mem_write with_alarms; acc, success | Base.Known _ | Base.Unknown _ -> paste_slice_itv ~exact src start_src stop_src start_to acc, true | Base.Periodic (b, _e, period) -> assert (Int.equal b Int.zero) (* assumed in module Base *); let start_to = Int.rem start_to period in let stop_to = Int.pred (Int.add start_to size) in if Int.gt stop_to period then Kernel.not_yet_implemented "Paste of overly long \ values in periodic offsetmaps" (* TODO *); paste_slice_itv ~exact:false src start_src stop_src start_to acc, true in let res, success = Ival.fold aux offsets (dst, false) in if success then res else raise Result_is_bottom with Not_less_than -> Kernel.result ~current:true ~once:true "too many locations to update in array. Approximating."; (* Value to paste, since we cannot be precise *) let validity_src = Base.Known (start_src, Int.pred (start_src +~ size)) in let v = find ~with_alarms:CilE.warn_none_mode ~validity:validity_src ~conflate_bottom:false ~offsets:(Ival.inject_singleton start_src) ~size src in update ~with_alarms ~validity ~exact ~offsets ~size v dst let pretty_typ typ fmt m = let inset_utf8 = Unicode.inset_string () in let is_first = ref true in let pretty_binding fmt (bk, ek) (v, modu, rel_offs) = if not (V.equal v V.bottom) then begin (* TODOBY: temporary *) if !is_first then is_first:=false else Format.fprintf fmt "@\n"; Format.fprintf fmt "@[" ; (* Print left-member and return misalign condition *) let force_misalign, _printed_type = match typ with | None -> Format.fprintf fmt "[rbits %a to %a]" pretty_int bk pretty_int ek ; (* misalign condition: *) (not (Rel.is_zero rel_offs) || (ek -~ bk <>~ pred modu)) && not (V.is_isotropic v), None | Some typ -> (* returns misalign condition. *) Bit_utils.pretty_bits typ ~use_align:(not (V.is_isotropic v)) ~align:rel_offs ~rh_size:modu ~start:bk ~stop:ek fmt in Format.fprintf fmt " %s@ @[<hv 1>%a@]" inset_utf8 V.pretty v ; if force_misalign then if Rel.is_zero rel_offs && (Int.length bk ek) %~ modu =~ Integer.zero then (if Int.length bk ek >~ modu then Format.fprintf fmt " repeated %%%a " pretty_int modu) else ( let b_bits = Rel.pos_rem (Rel.sub Rel.zero rel_offs) modu in let e_bits = Rel.add_abs (ek -~ bk) b_bits in Format.fprintf fmt "%s%%%a, bits %a to %a " (if e_bits >~ modu then " repeated " else "") pretty_int modu Rel.pretty b_bits pretty_int e_bits ); Format.fprintf fmt "@]"; end in if is_empty m then Format.fprintf fmt "@[[?] %s ANYTHING@]" inset_utf8 else Format.fprintf fmt "@[%a@]" (fun fmt -> iter (pretty_binding fmt)) m let create_isotropic ~size v = assert (V.is_isotropic v); add_basic_node ~min:Integer.zero ~max:(pred size) ~v empty let create ~size v ~size_v = add_node_from_root ~min:Integer.zero ~max:(pred size) ~rem:Integer.zero ~modu:size_v ~v empty let cardinal_zero_or_one offsetmap = (singleton_tag offsetmap) <> 0 let from_string s = let s = s ^ "\000" in let r = ref empty in let char_width = 8 in let l = String.length s in for i = 0 to l-1 do let b = i * char_width in let e = b + char_width - 1 in r := add_basic_node ~min:(Integer.of_int b) ~max:(Integer.of_int e) ~v:(V.of_char s.[i]) !r done; !r let from_wstring s = let s = s @ [0L] in let pwchar_width = Integer.of_int (Cil.bitsSizeOf Cil.theMachine.Cil.wcharType - 1) in let addw (b,acc) wchar = let e = b +~ pwchar_width in succ e, add_basic_node ~min:b ~max:e ~v:(V.of_int64 wchar) acc in snd (List.fold_left addw (Integer.zero,empty) s) let from_cstring = function | Base.CSWstring w -> from_wstring w | Base.CSString s -> from_string s let add (min, max) (v, modu, rem) m = snd (update_itv_with_rem ~exact:true ~offset:min ~abs_max:max ~rem ~size:modu Integer.zero v m) let find_imprecise_everywhere ~validity m = match validity with | Base.Known (min, max) | Base.Unknown (min, _, max) -> find_imprecise (min, max) m | Base.Periodic (_min, _max, p) -> find_imprecise (Int.zero, pred p) m | Base.Invalid -> V.bottom let clear_caches () = List.iter (fun f -> f ()) !clear_caches end (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/offsetmap_bitwise.mli������������������������������������0000644�0001750�0001750�00000006755�12155630237�023532� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Undocumented. Do not use this module if you don't know what you are doing. *) (* [JS 2011/10/03] To the authors/users of this module: please document it. *) open Abstract_interp open Lattice_Interval_Set type itv = Int.t * Int.t module Make(V: Abstract_interp.Lattice) : sig include Datatype.S_no_copy val degenerate : V.t -> t val pretty_with_type : Cil_types.typ option -> Format.formatter -> t -> unit val empty : t val is_empty : t -> bool val find : (Int.t -> Int.t -> V.t) -> itv -> t -> V.t val add : itv -> V.t -> t -> t val add_approximate : itv -> V.t -> t -> t val collapse : t -> V.t val find_iset : (Int.t -> Int.t -> V.t) -> V.t -> Int_Intervals.t -> t -> V.t val add_iset : exact:bool -> Int_Intervals.t -> V.t -> t -> t val join : t -> t -> t val joindefault : t -> t val is_included_exn : t -> t -> unit val is_included : t -> t -> bool val map_and_merge : (V.t -> V.t) -> t -> t -> t val map : (bool * V.t -> bool * V.t) -> t -> t val map2 : ((bool * V.t) option -> (bool * V.t) option -> bool * V.t) -> t -> t -> t val fold : (Int_Intervals.t -> bool * V.t -> 'a -> 'a) -> t -> 'a -> 'a val fold_fuse_same: (Int_Intervals.t -> bool * V.t -> 'a -> 'a) -> t -> 'a -> 'a (** Same behavior as [fold], except if two disjoint intervals [r1] and [r2] are mapped to the same value and boolean. In this case, [fold] will call its argument [f] on [r1], then on [r2]. [fold_fuse_same] will call it directly on [r1 U r2], where U is the join on sets of intervals. *) val copy_paste : f:((bool*V.t -> bool*V.t) * (Int.t -> Int.t -> V.t)) option -> t -> Int.t -> Int.t -> Int.t -> t -> t val copy_merge : t -> Int.t -> Int.t -> Int.t -> t -> t val copy : f:((bool*V.t -> bool*V.t) * (Int.t -> Int.t -> V.t)) option -> t -> Int.t -> Int.t -> t end (* Local Variables: compile-command: "make -C ../.." End: *) �������������������frama-c-Fluorine-20130601/src/memory_state/tr_offset.mli��������������������������������������������0000644�0001750�0001750�00000004636�12155630237�022007� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Reduction of a location (expressed as an Ival.t plus a size) by a base validity. Only the locations in the trailed result are valid. *) type t = | Set of Ival.O.t (** Limited number of locations *) | Interval of (** min *) Integer.t * (** max *) Integer.t * (** modu *)Integer.t | Imprecise of (** min *) Integer.t * (** max *) Integer.t (** This case only happens with infinite or periodic validities *) exception Unbounded val filter_by_bound_for_reading : with_alarms:CilE.warn_mode -> Ival.t -> Integer.t -> Base.validity -> t val filter_by_bound_for_writing : with_alarms:CilE.warn_mode -> exact:bool -> Ival.t -> Integer.t -> Base.validity -> bool * t (* Local Variables: compile-command: "make -C ../.." End: *) ��������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/offsetmap.mli��������������������������������������������0000644�0001750�0001750�00000003507�12155630237�021774� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Maps from intervals to values. The documentation of the returned maps is in module {!Offsetmap_sig}. *) module Make (V : Lattice_With_Isotropy.S) : module type of Offsetmap_sig with type v = V.t and type widen_hint = V.widen_hint �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/int_Interv_Map.ml����������������������������������������0000644�0001750�0001750�00000016607�12155630237�022562� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Undocumented. Do not use this module if you don't know what you are doing. *) open Abstract_interp module Make(Value: Rangemap.Value) = struct include Rangemap.Make(Int_Interv)(Value) let check (bi,ei) = assert (Int.le bi ei) let add x = check x; add x let find x = check x; find x exception No_binding_above let find_above i m = let o (b2, _e2) = Int.le i b2 in lowest_binding_above o m let pretty pretty_v fmt m = Pretty_utils.pp_iter ~pre:"@[<hv 1>{" ~suf:"}@]" ~sep:" ;@ " (fun pp map -> iter (fun bi_ei v -> pp (bi_ei, v)) map) (fun fmt ((bi, ei), v) -> Format.fprintf fmt "[%a..%a] -> %a" Int.pretty bi Int.pretty ei pretty_v v) fmt m let enlarge_to_right ~extend_right same_values ei new_vv acc = if extend_right then (* look for an interval starting just after i *) let s_ei = Int.succ ei in match concerned_intervals Int_Interv.fuzzy_order (s_ei,s_ei) acc with [] -> acc,ei | [(ba,ea) as a,vva] -> assert (Int.equal ba s_ei); if same_values vva new_vv then (remove a acc),ea else acc,ei | _ -> assert false else acc,ei let handle_rightmost_itv ~extend_right same_values ei new_vv ((_,ei1),vv1) acc = if Int.gt ei1 ei then (* Part of the previous binding remains on the right-hand-side *) if extend_right && same_values vv1 new_vv then (* same value -> merge keys *) acc,ei1 else add (Int.succ ei, ei1) vv1 acc,ei else enlarge_to_right ~extend_right same_values ei new_vv acc let enlarge_to_left ~extend_left same_values bi new_vv acc = if extend_left then (* look for an interval ending just before i *) let p_bi = Int.pred bi in match concerned_intervals Int_Interv.fuzzy_order (p_bi,p_bi) acc with [] -> acc,bi | [(ba,ea) as a,vva] -> assert (Int.equal ea p_bi); if same_values vva new_vv then (remove a acc),ba else acc,bi | _ -> assert false else acc, bi let handle_leftmost_itv ~extend_left same_values bi new_vv ((bi1,_),vv1) acc = if Int.lt bi1 bi then (* Part of the previous binding remains on the left-hand-side *) if extend_left && same_values vv1 new_vv then (* same value -> merge keys *) acc,bi1 else add (bi1, Int.pred bi) vv1 acc,bi else enlarge_to_left ~extend_left same_values bi new_vv acc let cleanup_overwritten_bindings ?(extend_left=true) ?(extend_right=true) same_values (bi,ei as i) new_vv m = (* if not (extend_right && extend_left) then Format.printf "left:%b right:%b@\n" extend_left extend_right; *) let concerned_intervals = concerned_intervals Int_Interv.fuzzy_order i m in let result = match concerned_intervals with | [] -> let acc,new_bi = enlarge_to_left ~extend_left same_values bi new_vv m in let acc,new_ei = enlarge_to_right ~extend_right same_values ei new_vv acc in Some(new_bi, new_ei, acc) | [((bi1, ei1) as i1, vv1) as binding1] -> let cond_start = Int.le bi1 bi in let cond_end = Int.ge ei1 ei in let cond_same = same_values vv1 new_vv in if (cond_start && cond_end && cond_same && extend_right && extend_left) then None (* nothing to do, the new interval is included in the previous one and the old and new values are the same*) else begin let result1 = remove i1 m in let result2,new_bi = handle_leftmost_itv same_values ~extend_left bi new_vv binding1 result1 in let result3,new_ei = handle_rightmost_itv ~extend_right same_values ei new_vv binding1 result2 in Some(new_bi, new_ei, result3) end | ((_bi1, _ei1), _vv1 as binding1)::tail -> let result1 = List.fold_right (fun (i1,_) acc -> remove i1 acc) concerned_intervals m in (* part of the last interval might remain on the right *) let result2,new_ei = handle_rightmost_itv ~extend_right same_values ei new_vv binding1 result1 in let rec f l acc = match l with | [] -> assert false (* at least 2 elements in [concerned_intervals] *) | [(_bi1, _ei1), _vv1 as binding1] -> (* part of the first interval might remain on the left *) handle_leftmost_itv ~extend_left same_values bi new_vv binding1 acc | ((_bi1, _ei1), _vv1)::tail -> (* the middle intervals are completely covered : ignore former values *) f tail acc in let result3,new_bi = f tail result2 in Some(new_bi, new_ei, result3) in (* if not (extend_right && extend_left) then (match result with None -> Format.printf "Cleanup...NONE@\n" | Some (new_bi,new_ei,_) -> Format.printf "Cleanup...new_bi:%a new_ei:%a@\n" Int.pretty new_bi Int.pretty new_ei);*) result let remove_itv _fuzzy_order (start,stop as ss) to_ = let concerned_intervals = concerned_intervals Int_Interv.fuzzy_order ss to_ in List.fold_left (fun acc (bi,ei as i,vv) -> let r = remove i acc in let r = if Int.lt bi start then add (bi,Int.pred start) vv r else r in let r = if Int.gt ei stop then add (Int.succ stop,ei) vv r else r in r) to_ concerned_intervals let shift offs m = mapii (fun k v -> Int_Interv.shift offs k, v) m end (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/lmap_bitwise.ml������������������������������������������0000644�0001750�0001750�00000051210�12155630237�022310� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp open Lattice_Interval_Set open Locations exception Bitwise_cannot_copy module type Location_map_bitwise = sig type y include Datatype.S module LOffset: sig include Datatype.S val map: ((bool * y) -> (bool * y)) -> t -> t val fold : (Int_Intervals.t -> bool * y -> 'a -> 'a) -> t -> 'a -> 'a val fold_fuse_same : (Int_Intervals.t -> bool * y -> 'a -> 'a) -> t -> 'a -> 'a val join: t -> t -> t val pretty_with_type: Cil_types.typ option -> Format.formatter -> t -> unit val collapse : t -> y val empty : t val degenerate: y -> t val is_empty: t->bool val add_iset : exact:bool -> Int_Intervals.t -> y -> t -> t end val empty : t val bottom: t val is_empty : t -> bool val is_bottom : t -> bool val top : t val join : t -> t -> t val is_included : t -> t -> bool val add_binding : exact:bool -> t -> Zone.t -> y -> t val map_and_merge : (y -> y) -> t -> t -> t val filter_base : (Base.t -> bool) -> t -> t val find : t -> Zone.t -> y val find_base: t -> Zone.t -> LOffset.t exception Cannot_fold val uninitialize: Cil_types.varinfo list -> t -> t val fold : (Zone.t -> bool * y -> 'a -> 'a) -> t -> 'a -> 'a val fold_base : (Base.t -> LOffset.t -> 'a -> 'a) -> t -> 'a -> 'a val fold_fuse_same : (Zone.t -> bool * y -> 'a -> 'a) -> t -> 'a -> 'a val map2 : ((bool * y) option -> (bool * y) option -> bool * y) -> t -> t -> t val copy_paste : with_alarms:CilE.warn_mode -> f:(bool * y -> bool * y) -> location -> location -> t -> t val clear_caches: unit -> unit end module type With_default = sig include Lattice val default : Base.t -> Int.t -> Int.t -> t val defaultall : Base.t -> t end module Make_bitwise (V:With_default) = struct module LOffset = struct include Offsetmap_bitwise.Make(V) let real_copy = copy let copy = Datatype.undefined end module LBase = struct include Hptmap.Make(Base)(LOffset)(Hptmap.Comp_unused)(struct let v = [[]] end)(struct let l = [ Ast.self ] end) let () = Ast.add_monotonic_state self let find_or_default base m = try find base m with Not_found -> LOffset.empty end let clear_caches = LBase.clear_caches type tt = Top | Map of LBase.t | Bottom type y = V.t let empty = Map LBase.empty let bottom = Bottom exception Cannot_fold let hash = function | Top -> 0 | Bottom -> 17 | Map x -> LBase.hash x let equal a b = match a,b with | Top,Top -> true | Map m1, Map m2 -> LBase.equal m1 m2 | Bottom, Bottom -> true | (Top | Bottom | Map _), _ -> false let is_empty x = equal empty x let is_bottom x = x = Bottom let top = Top let pretty fmt m = match m with | Top -> Format.fprintf fmt "@[<v>FROMTOP@]" | Bottom -> Format.fprintf fmt "@[<v>UNREACHABLE_B@]" | Map m -> Format.fprintf fmt "@[<v>"; (LBase.iter (fun base offs -> Format.fprintf fmt "%a@[<v>%a@]@," Base.pretty base (LOffset.pretty_with_type (Base.typeof base)) offs ) m); Format.fprintf fmt "@]" include Datatype.Make (struct type t = tt let reprs = Top :: List.map (fun b -> Map b) LBase.reprs let structural_descr = Structural_descr.Structure (Structural_descr.Sum [| [| LBase.packed_descr |] |]) let name = LOffset.name ^ " lmap_bitwise" let hash = hash let equal = equal let compare = Datatype.undefined let pretty = pretty let internal_pretty_code = Datatype.undefined let rehash = Datatype.identity let copy = Datatype.undefined let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) let fold f m acc = match m with | Top | Bottom -> acc | Map m -> LBase.fold (fun k offsetmap acc -> LOffset.fold (fun itvs v acc -> let z = Zone.inject k itvs in f z v acc) offsetmap acc) m acc let fold_base f m acc= match m with | Bottom | Top -> raise Cannot_fold | Map m -> LBase.fold f m acc let fold_fuse_same f m acc = let f' b offs acc = LOffset.fold_fuse_same (fun itvs v acc -> f (Zone.inject b itvs) v acc) offs acc in fold_base f' m acc let add_binding ~exact m (loc:Zone.t) v = match loc, m with | Zone.Top (Base.SetLattice.Top, _),_|_,Top -> Top | Zone.Top (Base.SetLattice.Set s, _), Map m -> let result = let treat_base base acc = let offsetmap_orig = try LBase.find base m with Not_found -> LOffset.empty in let new_offsetmap = LOffset.add_iset ~exact Int_Intervals.top v offsetmap_orig in LBase.add base new_offsetmap acc in Base.Hptset.fold treat_base s (treat_base Base.null m) in Map result | Zone.Map _, Map m -> let result = let treat_offset varid offs m = let offsetmap_orig = try LBase.find varid m with Not_found -> LOffset.empty in let new_offsetmap = LOffset.add_iset ~exact offs v offsetmap_orig in LBase.add varid new_offsetmap m in Zone.fold_i treat_offset loc m in Map result | _, Bottom -> assert false let join m1 m2 = let result = match m1, m2 with | Top, _ | _, Top -> Top | Bottom, m | m, Bottom -> m | Map m1, Map m2 -> let treat_base varid offsmap1 acc = let offsmap = try let offsmap2 = LBase.find varid m2 in LOffset.join offsmap1 offsmap2 with Not_found -> LOffset.joindefault offsmap1 in LBase.add varid offsmap acc in let all_m1 = LBase.fold treat_base m1 LBase.empty in let result = LBase.fold (fun varid offsmap2 acc -> try ignore (LBase.find varid m1); acc with Not_found -> LBase.add varid (LOffset.joindefault offsmap2) acc) m2 all_m1 in Map result in (*Format.printf "JoinBitWise: m1=%a@\nm2=%a@\nRESULT=%a@\n" pretty m1 pretty m2 pretty result;*) result let map2 f m1 m2 = match m1, m2 with | Top, _ | _, Top -> Top | Map m1, Map m2 -> let treat_base varid offsmap1 acc = let offsmap_result = try let offsmap2 = LBase.find varid m2 in LOffset.map2 f offsmap1 offsmap2 with Not_found -> LOffset.map (fun x -> f (Some x) None) offsmap1 in LBase.add varid offsmap_result acc in let all_m1 = LBase.fold treat_base m1 LBase.empty in let result = LBase.fold (fun varid offsmap2 acc -> try ignore (LBase.find varid m1); acc with Not_found -> let offsetmap = LOffset.map (fun x -> f None (Some x)) offsmap2 in LBase.add varid offsetmap acc) m2 all_m1 in Map result | Bottom, Bottom -> Bottom | Bottom, Map m -> Map (LBase.fold (fun base offs acc -> let offs = LOffset.map (fun x -> f None (Some x)) offs in LBase.add base offs acc) m LBase.empty) | Map m, Bottom -> Map (LBase.fold (fun base offs acc -> let offs = LOffset.map (fun x -> f (Some x) None) offs in LBase.add base offs acc) m LBase.empty) let is_included m1 m2 = match m1, m2 with | _, Top -> true | Top ,_ -> false | Bottom, _ -> true | _, Bottom -> false | Map m1, Map m2 -> let treat_offset1 varid offs1 = let offs2 = try LBase.find varid m2 with Not_found -> LOffset.empty in LOffset.is_included_exn offs1 offs2 in let treat_offset2 varid offs2 = try ignore (LBase.find varid m1); () with Not_found -> LOffset.is_included_exn LOffset.empty offs2 in try LBase.iter treat_offset1 m1; LBase.iter treat_offset2 m2; true with Is_not_included -> false (* let join x y = let r1 = join x y in let r2 = map2 (fun x y -> match x,y with | Some (bx, x), Some (by, y) -> bx || by, V.join x y | Some (_, x), None | None, Some (_, x) -> true, x | None, None -> assert false) x y in if not (is_included r1 r2 && is_included r2 r1) then begin Format.printf "Warning: Joining '%a' and '%a' to '%a' /// '%a'@." pretty x pretty y pretty r1 pretty r2; end; r1 *) let map_and_merge f (m_1:t) (m_2:t) = match m_1,m_2 with | Top,_ | _, Top -> Top | Bottom, Bottom -> Bottom | Bottom, Map _ -> m_2 | Map m, Bottom -> Map (LBase.fold (fun b m acc -> let m = LOffset.map (fun (b, v) -> b, f v) m in LBase.add b m acc ) m LBase.empty) | Map m1, Map m2 -> let result = LBase.fold (fun k1 v1 acc -> (* Format.printf "HERE :%a %a@\n" Base.pretty k1 (LOffset.pretty) v1; *) let new_v = try let v2 = LBase.find k1 m2 in LOffset.map_and_merge f v1 v2 with Not_found -> let result = LOffset.map (fun (d,v) -> d,f v) v1 in result in (* Format.printf "RESULT:%a %a@\n" Base.pretty k1 (LOffset.pretty) new_v; *) LBase.add k1 new_v acc) m1 m2 in let result = Map result in (* Format.printf "map_and_merge %a and %a RESULT:%a @." pretty m_1 pretty m_2 pretty result; *) result let filter_base f m = match m with | Top -> Top | Bottom -> Bottom | Map m -> let result = LBase.fold (fun k v acc -> if f k then LBase.add k v acc else acc) m LBase.empty in Map result let uninitialize locals m = match m with | Top -> Top | Bottom -> Bottom | Map m -> let result = List.fold_left (fun acc v -> let base = Base.create_varinfo v in let (i1,i2) = match Base.validity base with | Base.Invalid -> assert false (* map should be empty *) | Base.Periodic(i1, _, p) -> assert (Int.is_zero i1); i1, Int.pred p | Base.Unknown (i1,_,i2) | Base.Known(i1,i2) -> (i1,i2) in if Int.lt i2 i1 then assert false (* not supposed to happen for a local *) else let offset = LOffset.add (i1,i2) V.bottom LOffset.empty in LBase.add base offset acc) m locals in Map result let find_base m loc = match loc, m with | Zone.Top _, _ | _, (Top | Bottom) -> LOffset.empty | Zone.Map _, Map m -> let treat_offset varid offs acc = let default = V.default varid in let offsetmap = try LBase.find varid m with Not_found -> LOffset.empty in LOffset.add_iset ~exact:true offs (LOffset.find_iset default (V.defaultall varid) offs offsetmap) acc in Zone.fold_i treat_offset loc LOffset.empty let find m loc = match loc, m with | Zone.Top _, _ | _, Top -> V.top | _, Bottom -> V.bottom | Zone.Map _, Map m -> let treat_offset varid offs acc = let default = V.default varid in let offsetmap = try LBase.find varid m with Not_found -> LOffset.empty in V.join (LOffset.find_iset default (V.defaultall varid) offs offsetmap) acc in Zone.fold_i treat_offset loc V.bottom let copy_offsetmap ~f src_loc m = let result = begin begin try let size = Int_Base.project src_loc.size in begin let treat_src k_src i_src (acc : LOffset.t option) = let validity = Base.validity k_src in try let offsetmap_src = LBase.find_or_default k_src m in (* Format.printf "copy_offsetmap/treat_src k_src:%a i_src:%a@\n" Base.pretty k_src Ival.pretty i_src;*) ignore (Ival.cardinal_less_than i_src 100); Ival.fold (fun start acc -> let stop = Int.pred (Int.add start size) in match validity with | Base.Periodic _ -> raise Bitwise_cannot_copy | Base.Invalid -> acc | (Base.Known (b,e) | Base.Unknown (b,_,e)) when Int.lt start b || Int.gt stop e -> acc | Base.Known _ | Base.Unknown _ -> let default = V.default k_src in let copy = LOffset.real_copy ~f:(Some (f, default)) offsetmap_src start stop in let r = match acc with | None -> Some copy | Some acc -> let r = LOffset.join copy acc in if LOffset.is_empty r then raise Not_found; Some r in r) i_src acc with | Not_found (* from [LOffset.is_empty] *) -> (*CilE.warn_once "reading top in @[%a@]. Look above for origin." Location_Bits.pretty src_loc.loc;*) Some LOffset.empty | Not_less_than (* from [Ival.cardinal_less_than] *)-> (*ignore (CilE.warn_once "approximating lval assignment");*) raise Bitwise_cannot_copy in try Extlib.the (Location_Bits.fold_i treat_src src_loc.loc None) with Location_Bits.Error_Top -> (*CilE.warn_once "reading unknown location(2)@ @[%a@]" Location_Bits.pretty src_loc.loc;*) LOffset.empty end with | Location_Bits.Error_Top (* from Location_Bits.fold *) | Not_less_than (* from Ival.cardinal_less_than *) | Int_Base.Error_Top (* from Int_Base.project *) | Ival.Error_Top (* from Ival.fold *) -> LOffset.empty end end in (* Format.printf "copy_offsetmap: m:%a src:%a result:%a@\n" pretty m Locations.pretty src_loc pretty result;*) result let paste_offsetmap ~with_alarms map_to_copy dst_loc start size m = let dst_is_exact = Locations.valid_cardinal_zero_or_one ~for_writing:true (Locations.make_loc dst_loc (Int_Base.inject size)) in let stop = Int.pred (Int.add start size) in let had_non_bottom = ref false in let plevel = !Lattice_Interval_Set.plevel in let treat_dst k_dst i_dst (acc_lmap : LBase.t) = if Base.is_read_only k_dst then acc_lmap else let validity = Base.validity k_dst in let offsetmap_dst = LBase.find_or_default k_dst m in let new_offsetmap = try ignore (Ival.cardinal_less_than i_dst plevel); Ival.fold (fun start_to acc -> let stop_to = Int.pred (Int.add start_to size) in match validity with | Base.Periodic _ -> raise Bitwise_cannot_copy | Base.Known (b,e) | Base.Unknown (b,_,e) when Int.lt start_to b || Int.gt stop_to e -> CilE.warn_mem_write with_alarms; acc | Base.Invalid -> CilE.warn_mem_write with_alarms; acc | Base.Known _ | Base.Unknown _ -> had_non_bottom := true; (match validity with | Base.Unknown (_, None, _) -> CilE.warn_mem_write with_alarms | Base.Unknown (_, Some k, _) when Int.gt stop_to k -> CilE.warn_mem_write with_alarms | _ -> ()); (if dst_is_exact then LOffset.copy_paste ~f:None else LOffset.copy_merge) map_to_copy start stop start_to acc) i_dst offsetmap_dst with Not_less_than -> raise Bitwise_cannot_copy in LBase.add k_dst new_offsetmap acc_lmap in try let result = Location_Bits.fold_i treat_dst dst_loc m in if !had_non_bottom then result else begin Kernel.warning ~once:true ~current:true "all target addresses were invalid. This path is assumed to be dead."; assert false end with Location_Bits.Error_Top -> (* from Location_Bits.fold_i *) raise Bitwise_cannot_copy let copy_paste_map ~f src_loc dst_loc mm = assert (Int_Base.equal src_loc.size dst_loc.size ); (* temporary fix *) if not (Locations.is_valid ~for_writing:false src_loc && Locations.is_valid ~for_writing:true dst_loc) then raise Bitwise_cannot_copy; try let size = Int_Base.project src_loc.size in let result = copy_offsetmap ~f src_loc mm in paste_offsetmap result dst_loc.loc Int.zero size mm with | Int_Base.Error_Top (* from Int_Base.project *) -> raise Bitwise_cannot_copy let copy_paste ~with_alarms ~f src_loc dst_loc mm = let res = match mm with | Top -> Top | Bottom -> Bottom | Map mm -> Map (copy_paste_map ~with_alarms ~f src_loc dst_loc mm) in (* Format.printf "Lmap.copy_paste orig: %a from src:%a to dst:%a result:%a@\n" pretty mm Locations.pretty src_loc Locations.pretty dst_loc pretty res;*) res end module From_Model = struct include Make_bitwise(Locations.Zone) end (* Local Variables: compile-command: "make -C ../.." End: *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/function_Froms.mli���������������������������������������0000644�0001750�0001750�00000004772�12155630237�023010� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Information computed by the From plugin for each function. *) type froms = { deps_return : Lmap_bitwise.From_Model.LOffset.t (** Dependencies for the returned value *); deps_table : Lmap_bitwise.From_Model.t (** Dependencies on all the zones modified by the function *); } include Datatype.S with type t = froms val join: froms -> froms -> froms val top: froms val pretty_with_type: Cil_types.typ -> froms Pretty_utils.formatter (** Extract the left part of a from result, ie. the zones that are written *) val outputs: froms -> Locations.Zone.t (** Extract the right part of a from result, ie. the zones on which the written zones depend. If [include_self] is true, and the from is of the form [x FROM y (and SELF)], [x] is added to the result; default value is [false]. *) val inputs: ?include_self:bool -> froms -> Locations.Zone.t (* Local Variables: compile-command: "make -C ../.." End: *) ������frama-c-Fluorine-20130601/src/memory_state/widen_type.ml��������������������������������������������0000644�0001750�0001750�00000013040�12155630237�021777� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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_datatype module Widen_hint_bases = Base.Map.Make(Ival.Widen_Hints) module Widen_hint_stmts = Stmt.Map.Make(Widen_hint_bases) module Bases_stmts = Stmt.Map.Make(Base.Set) include Datatype.Pair (Bases_stmts) (Datatype.Make (struct include Datatype.Serializable_undefined type t = Ival.Widen_Hints.t * Ival.Widen_Hints.t * Widen_hint_bases.t * Widen_hint_stmts.t let name = "widen types" let structural_descr = Structural_descr.t_tuple [| Ival.Widen_Hints.packed_descr; Ival.Widen_Hints.packed_descr; Widen_hint_bases.packed_descr; Widen_hint_stmts.packed_descr |] let reprs = List.map (fun wh -> wh, wh, Base.Map.empty, Stmt.Map.empty) Ival.Widen_Hints.reprs let mem_project = Datatype.never_any_project end)) (* map from Base.t to Ival.Widen_Hints.t *) type var_key = Default | All | VarKey of Cvalue.V.M.key let hints_from_key (forced_hints, default_hints, var_map) var_key = let widen_hints = let hints = try Ival.Widen_Hints.union (Base.Map.find var_key var_map) default_hints with Not_found -> default_hints in Ival.Widen_Hints.union forced_hints hints in (* Format.printf "WIDEN_HInt widen a var_key %a -> %a @\n" Base.pretty var_key Ival.Widen_Hints.pretty widen_hints; *) Base.Hptset.empty, fun _ -> widen_hints let hints_from_keys stmt_key (stmt_map1, (forced_hints, default_hints, var_map, stmt_map)) = let var_map = try Stmt.Map.find stmt_key stmt_map with Not_found -> var_map in let var_set = try Stmt.Map.find stmt_key stmt_map1 with Not_found -> Base.Set.empty in var_set, hints_from_key (forced_hints, default_hints, var_map) let add_var_hints stmt var_hints (stmt_map1, map2) = let new_hints = let previous_hints = try Stmt.Map.find stmt stmt_map1 with Not_found -> Base.Set.empty in Base.Set.union var_hints previous_hints in Stmt.Map.add stmt new_hints stmt_map1, map2 let add_num_hints stmt_key var_key hints (stmt_map1, (forced_hints, default_hints, var_map, stmt_map)) = let add_merge var_key hints var_map = let new_hints = let previous_hints = try Base.Map.find var_key var_map with Not_found -> Ival.Widen_Hints.empty in Ival.Widen_Hints.union hints previous_hints in Base.Map.add var_key new_hints var_map in let map2 = match (stmt_key, var_key) with | (None, VarKey (var_key)) -> (* add a set of [hints] for a [var_key] *) let new_hints = let previous_hints = try Base.Map.find var_key var_map with Not_found -> Ival.Widen_Hints.empty in Ival.Widen_Hints.union hints previous_hints in forced_hints, default_hints, add_merge var_key new_hints var_map, stmt_map | (Some(stmt_key), VarKey (var_key)) -> (* add a set of [hints] for a [stmt_key, var_key] *) let new_var_map = let previous_var_map = try Stmt.Map.find stmt_key stmt_map with Not_found -> Base.Map.empty in add_merge var_key hints previous_var_map in forced_hints, default_hints, var_map, Stmt.Map.add stmt_key new_var_map stmt_map | (_, All) -> (* add a set of [hints] for all var_keys *) Ival.Widen_Hints.union hints forced_hints, default_hints, var_map, stmt_map | (_, Default) -> (* add a set of default [hint] *) forced_hints, Ival.Widen_Hints.union hints default_hints, var_map, stmt_map in stmt_map1, map2 (* an [empty] set of hints *) let empty = Stmt.Map.empty, (Ival.Widen_Hints.empty, Ival.Widen_Hints.empty, Base.Map.empty, Stmt.Map.empty) (* a [default] set of hints *) let default = add_num_hints None Default Ival.Widen_Hints.default_widen_hints empty (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/lmap.mli�������������������������������������������������0000644�0001750�0001750�00000004212�12155630237�020733� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Maps from bases to memory maps. The memory maps are those of the [Offsetmap] module. @plugin development guide *) module Make_LOffset (V:Lattice_With_Isotropy.S) (Offsetmap: module type of Offsetmap_sig with type v = V.t and type widen_hint = V.widen_hint) (Default_offsetmap: sig val default_offsetmap : Base.t -> Offsetmap.t end): module type of Lmap_sig with type v = V.t and type widen_hint_y = V.widen_hint and type offsetmap = Offsetmap.t (* Local Variables: compile-command: "make -C ../.." End: *) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/cvalue.mli�����������������������������������������������0000644�0001750�0001750�00000016451�12155630237�021271� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Representation of Value's abstract memory. *) open Abstract_interp open Locations (** Values. *) module V : sig (** Values are essentially bytes-indexed locations, the NULL base representing basic integers or float. Operations that are not related to locations (ie that are not present in [Location_Bytes]) are defined below. *) include module type of Location_Bytes (* Too many aliases, and OCaml module system is not able to keep track of all of them. Use some shortcuts *) with type z = Location_Bytes.z and type M.t = Location_Bytes.M.t include Lattice_With_Isotropy.S with type t := t and type widen_hint := widen_hint and module Top_Param := Base.SetLattice exception Not_based_on_null val project_ival : t -> Ival.t val min_and_max_float : t -> Ival.F.t * Ival.F.t val is_imprecise : t -> bool val is_topint : t -> bool val is_bottom : t -> bool val is_isotropic : t -> bool val contains_zero : t -> bool val contains_non_zero : t -> bool val of_char : char -> t val of_int64: int64 -> t val subdiv_float_interval : size:int -> t -> t * t val compare_min_float : t -> t -> int val compare_max_float : t -> t -> int val compare_min_int : t -> t -> int val compare_max_int : t -> t -> int val filter_le : t -> cond_expr:t -> t val filter_ge : t -> cond_expr:t -> t val filter_lt : t -> cond_expr:t -> t val filter_gt : t -> cond_expr:t -> t val filter_le_float : bool -> typ_loc:Cil_types.typ -> t -> cond_expr:t -> t val filter_ge_float : bool -> typ_loc:Cil_types.typ -> t -> cond_expr:t -> t val filter_lt_float : bool -> typ_loc:Cil_types.typ -> t -> cond_expr:t -> t val filter_gt_float : bool -> typ_loc:Cil_types.typ -> t -> cond_expr:t -> t val eval_comp: signed:bool -> Cil_types.binop -> t -> t -> t (** Can only be called on the 6 comparison operators *) val inject_int : Int.t -> t val interp_boolean : contains_zero:bool -> contains_non_zero:bool -> t val cast: size:Int.t -> signed:bool -> t -> t * bool val cast_float: rounding_mode:Ival.Float_abstract.rounding_mode -> t -> bool * bool * t val cast_double: t -> bool * bool * t val cast_float_to_int : signed:bool -> size:int -> t -> bool (** addresses *) * bool (** top *) * bool (** overflow *) * t val cast_float_to_int_inverse : single_precision:bool -> t -> t val cast_int_to_float : Ival.Float_abstract.rounding_mode -> t -> t * bool val add_untyped : Int_Base.t -> t -> t -> t val mul: with_alarms:CilE.warn_mode -> t -> t -> t val div : with_alarms:CilE.warn_mode -> t -> t -> t val c_rem : with_alarms:CilE.warn_mode -> t -> t -> t val shift_right : with_alarms:CilE.warn_mode -> size:(bool*int) option -> t -> t -> t val shift_left : with_alarms:CilE.warn_mode -> size:(bool*int) option -> t -> t -> t val bitwise_and : signed:bool -> size:int -> t -> t -> t val bitwise_xor: with_alarms:CilE.warn_mode -> t -> t -> t val bitwise_or : size:int -> t -> t -> t val all_values : size:Int.t -> t -> bool val create_all_values : modu:Int.t -> signed:bool -> size:int -> t val has_sign_problems : t -> bool end (** Values with 'undefined' and 'escaping addresses' flags. *) module V_Or_Uninitialized : sig type un_t = | C_uninit_esc of V.t | C_uninit_noesc of V.t | C_init_esc of V.t | C_init_noesc of V.t include Lattice_With_Isotropy.S with type t = un_t and type widen_hint = Locations.Location_Bytes.widen_hint val uninitialized : un_t val initialized : V.t -> un_t val change_initialized : bool -> un_t -> un_t val get_v : un_t -> V.t val get_flags : un_t -> int val unspecify_escaping_locals : exact:bool -> (V.M.key -> bool) -> un_t -> Base.SetLattice.t * un_t val is_initialized : int -> bool val is_noesc : int -> bool val cardinal_zero_or_one_or_isotropic: t -> bool end (** Memory slices. Tey are. maps from intervals to values with flags. All sizes and intervals are in bits. *) module V_Offsetmap: module type of Offsetmap_sig with type v = V_Or_Uninitialized.t and type widen_hint = V_Or_Uninitialized.widen_hint (** Values bound by default to a variable. *) module Default_offsetmap: sig val create_initialized_var : Cil_types.varinfo -> Base.validity -> V_Offsetmap.t -> Base.t val default_offsetmap : Base.t -> V_Offsetmap.t end (** Memories. They are maps from bases to memory slices *) module Model: sig (** Functions inherited from [Lmap_sig] interface *) include module type of Lmap_sig with type v = V_Or_Uninitialized.t and type offsetmap = V_Offsetmap.t and type widen_hint_y = V_Or_Uninitialized.widen_hint val find_unspecified : with_alarms:CilE.warn_mode -> t -> location -> V_Or_Uninitialized.t val find : conflate_bottom:bool -> with_alarms:CilE.warn_mode -> t -> location -> V.t val find_and_reduce_indeterminate : with_alarms:CilE.warn_mode -> t -> location -> t * V.t val add_binding : with_alarms:CilE.warn_mode -> exact:bool -> t -> location -> V.t -> t val add_binding_unspecified : t -> location -> V_Or_Uninitialized.t -> t val add_binding_not_initialized : t -> location -> t val add_new_base : Base.t -> size:Int.t -> V.t -> size_v:Int.t -> t -> t val reduce_by_initialized_defined_loc : (V_Or_Uninitialized.t -> V_Or_Uninitialized.t) -> Locations.Location_Bits.t -> Int.t -> t -> t val reduce_previous_binding : with_alarms:CilE.warn_mode -> t -> location -> V.t -> t val reduce_binding : with_alarms:CilE.warn_mode -> t -> location -> V.t -> t val uninitialize_blocks_locals : Cil_types.block list -> t -> t val uninitialize_formals_locals : Cil_types.fundec -> t -> t end (* Local Variables: compile-command: "make -C ../.." End: *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/locations.ml���������������������������������������������0000644�0001750�0001750�00000047126�12155630237�021637� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp open Lattice_Interval_Set module Initial_Values = struct let v = [ [Base.null,Ival.singleton_zero]; [Base.null,Ival.singleton_one]; [Base.null,Ival.zero_or_one]; [Base.null,Ival.top]; [Base.null,Ival.top_float]; [Base.null,Ival.top_single_precision_float]; [] ] end module MapLattice = Map_Lattice.Make (Base)(Base.SetLattice)(Ival)(Initial_Values)(struct let zone = false end) module HT = Hashtbl module Location_Bytes = struct include MapLattice type z = tt = | Top of Base.SetLattice.t * Origin.t | Map of M.t let inject_ival i = inject Base.null i let inject_float f = inject_ival (Ival.inject_float (Ival.Float_abstract.inject_singleton f)) let top_float = inject_ival Ival.top_float let top_single_precision_float = inject_ival Ival.top_single_precision_float let singleton_zero = inject_ival Ival.singleton_zero let singleton_one = inject_ival Ival.singleton_one let zero_or_one = inject_ival Ival.zero_or_one (* true iff [v] is exactly 0 *) let is_zero v = equal v singleton_zero (* [shift offset l] is the location [l] shifted by [offset] *) let shift offset l = try map_offsets (Ival.add_int offset) l with Error_Top -> l let top_with_origin origin = Top(Base.SetLattice.top, origin) let topify_with_origin o v = match v with | Top (s,a) -> Top (s, Origin.join a o) | v when is_zero v -> v | Map m -> if is_bottom v then v else inject_top_origin o (get_bases m) let topify_with_origin_kind ok v = let o = Origin.current ok in topify_with_origin o v let get_bases m = match m with | Top(top_param,_) -> top_param | Map m -> Base.SetLattice.inject (get_bases m) let is_relationable m = try let b,_ = find_lonely_binding m in match Base.validity b with | Base.Periodic _ -> false | Base.Known _ | Base.Unknown _ | Base.Invalid -> true with Not_found -> false let iter_on_strings = let z = "\000" in fun ~skip f l -> match l with | Top _ -> assert false | Map m -> M.iter (fun base offs -> match skip with Some base_to_skip when Base.equal base base_to_skip -> () | _ -> match base with Base.String (_, strid) -> let str = match Base.get_string strid with | Base.CSString s -> s | Base.CSWstring _ -> failwith "Unimplemented: wide strings" in let strz = str ^ z in let len = String.length str in let range = Ival.inject_range (Some Int.zero) (Some (Int.of_int len)) in let roffs = Ival.narrow range offs in Ival.fold (fun i () -> f base strz (Int.to_int i) len) roffs () | _ -> ()) m let under_topify v = match v with | Top _ -> v | Map _ -> if is_included singleton_zero v then singleton_zero else bottom let topify_merge_origin v = topify_with_origin_kind Origin.K_Merge v let topify_misaligned_read_origin v = topify_with_origin_kind Origin.K_Misalign_read v let topify_arith_origin v = topify_with_origin_kind Origin.K_Arith v let topify_leaf_origin v = topify_with_origin_kind Origin.K_Leaf v let may_reach base loc = if Base.is_null base then true else match loc with | Top (toparam,_) -> Base.SetLattice.is_included (Base.SetLattice.inject_singleton base) toparam | Map m -> try ignore (M.find base m); true with Not_found -> false let contains_addresses_of_locals is_local = let f base _offsets = is_local base in let projection _base = Ival.top in let cached_f = cached_fold ~cache:("loc_top_locals", 653) ~temporary:true ~f ~projection ~joiner:(||) ~empty:false in fun loc -> try cached_f loc with Error_Top -> assert (match loc with | Top (Base.SetLattice.Top,_) -> true | Top (Base.SetLattice.Set _top_param,_orig) -> false | Map _ -> false); true (** TODO: merge with above function *) let remove_escaping_locals is_local v = match v with | Top (Base.SetLattice.Top as t,_) -> t, v | Top (Base.SetLattice.Set garble, orig) -> let locals, nonlocals = Base.Hptset.partition is_local garble in (Base.SetLattice.inject locals), inject_top_origin orig nonlocals | Map m -> let locals, clean_map = M.fold (fun base _ (locals, m as acc) -> if is_local base then (Base.Hptset.add base locals), (M.remove base m) else acc) m (Base.Hptset.empty, m) in (Base.SetLattice.inject locals), Map clean_map let contains_addresses_of_any_locals = let f base _offsets = Base.is_any_formal_or_local base in let projection _base = Ival.top in let cached_f = cached_fold ~cache:("loc_top_any_locals", 777) ~temporary:false ~f ~projection ~joiner:(||) ~empty:false in fun loc -> try cached_f loc with Error_Top -> assert (match loc with | Top (Base.SetLattice.Top,_) -> true | Top (Base.SetLattice.Set _top_param,_orig) -> false | Map _ -> false); true exception Found_overlap let partially_overlaps_table = Datatype.Int.Hashtbl.create 7 let () = Project.register_after_set_current_hook ~user_only:false (fun _ -> Datatype.Int.Hashtbl.clear partially_overlaps_table) let partially_overlaps ~size mm1 mm2 = match mm1, mm2 with | Top (_,_), Top (_,_) -> true | Top _, (Map _ as m) | (Map _ as m), Top _ -> not (equal m bottom) | Map m1, Map m2 -> let size_int = Int.to_int size in try let map_partially_overlaps = try Datatype.Int.Hashtbl.find partially_overlaps_table size_int with Not_found -> let f = M.generic_symetric_existential_predicate Found_overlap (fun _s _t -> true) ~decide_one:(fun _ _ -> ()) ~decide_both: (fun x y -> if Ival.partially_overlaps size x y then raise Found_overlap) in Datatype.Int.Hashtbl.add partially_overlaps_table size_int f; f in map_partially_overlaps m1 m2; false with Found_overlap -> true end module Location_Bits = Location_Bytes module Zone = struct module Initial_Values = struct let v = [ [] ] end include Map_Lattice.Make (Base) (Base.SetLattice) (Int_Intervals) (Initial_Values) (struct let zone = true end) let default base bi ei = inject base (Int_Intervals.inject [bi,ei]) let defaultall base = inject base Int_Intervals.top let pretty fmt m = match m with | Top (Base.SetLattice.Top,a) -> Format.fprintf fmt "ANYTHING(origin:%a)" Origin.pretty a | Top (s,a) -> Format.fprintf fmt "Unknown(%a, origin:%a)" Base.SetLattice.pretty s Origin.pretty a | Map _ when equal m bottom -> Format.fprintf fmt "\\nothing" | Map off -> let print_binding fmt (k, v) = Format.fprintf fmt "@[<h>%a%a@]" Base.pretty k (Int_Intervals.pretty_typ (Base.typeof k)) v in Pretty_utils.pp_iter ~pre:"" ~suf:"" ~sep:";@,@ " (fun f -> M.iter (fun k v -> f (k, v))) print_binding fmt off let valid_intersects m1 m2 = let result = match m1,m2 with | Map _, Map _ -> intersects m1 m2 | Top (toparam, _), m | m, Top (toparam, _) -> (equal m bottom) || let f base () = if Base.SetLattice.is_included (Base.SetLattice.inject_singleton base) toparam then raise Hptmap.Found_inter in try fold_bases f m (); false with Hptmap.Found_inter | Error_Top -> true in result let mem_base b = function | Top (top_param, _) -> Base.SetLattice.mem b top_param | Map m -> M.mem b m end type location = { loc : Location_Bits.t; size : Int_Base.t } let is_valid_aux is_valid_offset {loc=loc;size=size} = try let size = Int_Base.project size in let is_valid_offset = is_valid_offset size in match loc with | Location_Bits.Top _ -> false | Location_Bits.Map m -> Location_Bits.M.iter is_valid_offset m; true with | Int_Base.Error_Top | Base.Not_valid_offset -> false let is_valid ~for_writing = is_valid_aux (Base.is_valid_offset ~for_writing) let is_valid_or_function = is_valid_aux (fun size base offs -> if Base.is_function base then (if Ival.is_zero offs then () else raise Base.Not_valid_offset) else Base.is_valid_offset ~for_writing:false size base offs) exception Found_two (* Reduce [offsets] so that reading [size] from [offsets] fits within the validity of [base] *) let reduce_offset_by_validity ~for_writing base offsets size = if for_writing && Base.is_read_only base then Ival.bottom else match Base.validity base, size with | Base.Invalid, _ -> Ival.bottom | _, Int_Base.Top -> offsets | ( Base.Known (minv,maxv) | Base.Unknown (minv,_,maxv) | Base.Periodic (minv, maxv, _)), Int_Base.Value size -> let maxv = Int.succ (Int.sub maxv size) in let range = Ival.inject_range (Some minv) (Some maxv) in Ival.narrow range offsets let valid_cardinal_zero_or_one ~for_writing {loc=loc;size=size} = Location_Bits.equal Location_Bits.bottom loc || let found_one = let already = ref false in function () -> if !already then raise Found_two; already := true in try match loc with | Location_Bits.Top _ -> false | Location_Bits.Map m -> Location_Bits.M.iter (fun base offsets -> let valid_offsets = reduce_offset_by_validity ~for_writing base offsets size in if Ival.cardinal_zero_or_one valid_offsets then begin if not (Ival.is_bottom valid_offsets) then found_one () end else raise Found_two ) m; true with | Int_Base.Error_Top | Found_two -> false let loc_bytes_to_loc_bits x = match x with | Location_Bytes.Map _ -> Location_Bytes.map_offsets (Ival.scale (Bit_utils.sizeofchar())) x | Location_Bytes.Top _ -> x let loc_bits_to_loc_bytes x = match x with | Location_Bits.Map _ -> Location_Bits.map_offsets (Ival.scale_div ~pos:true (Bit_utils.sizeofchar())) x | Location_Bits.Top _ -> x let loc_to_loc_without_size {loc = loc} = loc_bits_to_loc_bytes loc let loc_size { size = size } = size let make_loc loc_bits size = if (match size with | Int_Base.Value v -> Int.gt v Int.zero | _ -> true) then { loc = loc_bits; size = size } else { loc = loc_bits; size = Int_Base.top } let filter_base f loc = { loc with loc = Location_Bits.filter_base f loc.loc } let int_base_size_of_varinfo v = try let s = bitsSizeOf v.vtype in let s = Int.of_int s in Int_Base.inject s with Cil.SizeOfError _ -> Kernel.debug ~once:true "Variable %a has no size" Printer.pp_varinfo v; Int_Base.top let loc_of_varinfo v = let base = Base.find v in make_loc (Location_Bits.inject base Ival.zero) (int_base_size_of_varinfo v) let loc_of_base v = make_loc (Location_Bits.inject v Ival.zero) (Base.bits_sizeof v) let loc_of_typoffset v typ offset = try let offs, size = bitsOffset typ offset in let size = if size = 0 then Int_Base.top else Int_Base.inject (Int.of_int size) in make_loc (Location_Bits.inject v (Ival.of_int offs)) size with SizeOfError _ -> make_loc (Location_Bits.inject v Ival.top) Int_Base.top let loc_bottom = make_loc Location_Bits.bottom Int_Base.top let cardinal_zero_or_one { loc = loc ; size = size } = Location_Bits.cardinal_zero_or_one loc && Int_Base.cardinal_zero_or_one size let loc_equal { loc = loc1 ; size = size1 } { loc = loc2 ; size = size2 } = Int_Base.equal size1 size2 && Location_Bits.equal loc1 loc2 let loc_hash { loc = loc; size = size } = Int_Base.hash size + 317 * Location_Bits.hash loc let loc_compare { loc = loc1 ; size = size1 } { loc = loc2 ; size = size2 } = let c1 = Int_Base.compare size1 size2 in if c1 <> 0 then c1 else Location_Bits.compare loc1 loc2 let pretty fmt { loc = loc ; size = size } = Format.fprintf fmt "%a (size:%a)" Location_Bits.pretty loc Int_Base.pretty size let pretty_loc = pretty let pretty_english ~prefix fmt { loc = m ; size = size } = match m with | Location_Bits.Top (Base.SetLattice.Top,a) -> Format.fprintf fmt "somewhere unknown (origin:%a)" Origin.pretty a | Location_Bits.Top (s,a) -> Format.fprintf fmt "somewhere in %a (origin:%a)" Base.SetLattice.pretty s Origin.pretty a | Location_Bits.Map _ when Location_Bits.is_bottom m -> Format.fprintf fmt "nowhere" | Location_Bits.Map off -> let print_binding fmt (k, v) = ( match Ival.is_zero v, Base.validity k, size with true, Base.Known (_,s1), Int_Base.Value s2 when Int.equal (Int.succ s1) s2 -> Format.fprintf fmt "@[<h>%a@]" Base.pretty k | _ -> Format.fprintf fmt "@[<h>%a with offsets %a@]" Base.pretty k Ival.pretty v) in Pretty_utils.pp_iter ~pre:(if prefix then format_of_string "in " else "") ~suf:"" ~sep:";@,@ " (fun f -> Location_Bits.M.iter (fun k v -> f (k, v))) print_binding fmt off (* Iterator to use in the case [Top (Base.SetLattice.Set _, _)] with the same signature as in the case [Map] *) let fold_topset f = Base.Hptset.fold (fun base acc -> f base Ival.top acc) let enumerate_valid_bits ~for_writing {loc = loc_bits; size = size}= let compute_offset base offs acc = let valid_offset = reduce_offset_by_validity ~for_writing base offs size in if Ival.is_bottom valid_offset then acc else let valid_itvs = Int_Intervals.from_ival_size valid_offset size in Zone.M.add base valid_itvs acc in match loc_bits with | Location_Bits.Top (Base.SetLattice.Top, _) -> Zone.top | Location_Bits.Top (Base.SetLattice.Set s, _) -> Zone.inject_map (fold_topset compute_offset s Zone.M.empty) | Location_Bits.Map m -> Zone.inject_map (Location_Bits.M.fold compute_offset m Zone.M.empty) (** [valid_part l] is an over-approximation of the valid part of the location [l] *) let valid_part ~for_writing {loc = loc; size = size } = let compute_loc base offs acc = let valid_offset = reduce_offset_by_validity ~for_writing base offs size in if Ival.is_bottom valid_offset then acc else Location_Bits.M.add base valid_offset acc in let locbits = match loc with | Location_Bits.Top (Base.SetLattice.Top, _) -> loc | Location_Bits.Top (Base.SetLattice.Set s, _) -> (* We do not reduce garbled mixes. This makes them disappear after one memory access. *) if false then Location_Bits.inject_map (fold_topset compute_loc s Location_Bits.M.empty) else loc | Location_Bits.Map m -> Location_Bits.inject_map (Location_Bits.M.fold compute_loc m Location_Bits.M.empty) in make_loc locbits size let enumerate_bits ({loc = loc_bits; size = size} as _arg)= let compute_offset base offs acc = let valid_offset = Int_Intervals.from_ival_size offs size in Zone.M.add base valid_offset acc in match loc_bits with | Location_Bits.Top (Base.SetLattice.Top, _) -> Zone.top | Location_Bits.Top (Base.SetLattice.Set s, _) -> Zone.inject_map (fold_topset compute_offset s Zone.M.empty) | Location_Bits.Map m -> Zone.inject_map (Location_Bits.M.fold compute_offset m Zone.M.empty) let zone_of_varinfo var = enumerate_bits (loc_of_varinfo var) (** [invalid_part l] is an over-approximation of the invalid part of the location [l] *) let invalid_part l = l (* TODO (but rarely useful) *) let filter_loc ({loc = loc; size = size } as initial) zone = try let result = Location_Bits.fold_i (fun base ival acc -> let result_ival = match zone,size with | Zone.Top _, _ | _, Int_Base.Top -> ival | Zone.Map zone_m,Int_Base.Value size -> Int_Intervals.fold (fun (bi,ei) acc -> let width = Int.length bi ei in if Int.lt width size then acc else Ival.inject_range (Some bi) (Some (Int.length size ei))) (Zone.find_or_bottom base zone_m) Ival.bottom in Location_Bits.join acc (Location_Bits.inject base result_ival)) loc Location_Bits.bottom in make_loc result size with Location_Bits.Error_Top -> initial module Location = Datatype.Make (struct include Datatype.Serializable_undefined type t = location let structural_descr = Structural_descr.t_record [| Location_Bits.packed_descr; Int_Base.packed_descr |] let reprs = List.fold_left (fun acc l -> List.fold_left (fun acc n -> { loc = l; size = n } :: acc) acc Int_Base.reprs) [] Location_Bits.reprs let name = "Locations.Location" let mem_project = Datatype.never_any_project let equal = loc_equal let compare = loc_compare let hash = loc_hash let pretty = pretty_loc end) (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/offsetmap_bitwise.ml�������������������������������������0000644�0001750�0001750�00000064650�12155630237�023357� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp open Lattice_Interval_Set type itv = Int.t * Int.t module Make(V: Abstract_interp.Lattice) = struct open Abstract_interp module V_bool = struct include Datatype.Pair_with_collections(Datatype.Bool)(V) (struct let module_name = Format.sprintf "Offsetmap_bitwise(%s).Make.V_bool" V.name end) let hash (b,v) = let h = V.hash v in if b then h else 100000 + h let fast_equal (b1, v1: t) (b2, v2: t) = b1 = b2 && v1 == v2 end module M = Int_Interv_Map.Make(V_bool) type tt = Map of M.t | Degenerate of V.t let hash x = match x with | Degenerate v -> 571 + V.hash v | Map map -> M.hash map let empty = Map M.empty let degenerate v = Degenerate v let equal_map mm1 mm2 = try M.equal mm1 mm2 with Int_Interv.Cannot_compare_intervals -> false let equal m1 m2 = match m1, m2 with Degenerate v1, Degenerate v2 -> V.equal v1 v2 | Map mm1, Map mm2 -> equal_map mm1 mm2 | Map _, Degenerate _ | Degenerate _, Map _ -> false let compare = if V.compare == Datatype.undefined || M.compare == Datatype.undefined then ( Kernel.debug "Missing comparison function for %s offsetmap_bitwise \ (%b, %b)"V.name (V.compare == Datatype.undefined) (M.compare == Datatype.undefined); Datatype.undefined) else fun m1 m2 -> if m1 == m2 then 0 else match m1, m2 with | Map m1, Map m2 -> M.compare m1 m2 | Degenerate v1, Degenerate v2 -> V.compare v1 v2 | Map _, Degenerate _ -> -1 | Degenerate _, Map _ -> 1 module MapIntervals = Map.Make(struct type t = Int_Intervals.t let compare = Int_Intervals.compare_itvs end) (* Print a map by fusing together intervals that map to the same value *) let fold_fuse_same_aux f m acc = let h = V_bool.Hashtbl.create 17 in (* Map the various values in m to the intervals they appear in*) let sort_by_content itv v () = let cur = try V_bool.Hashtbl.find h v with Not_found -> Int_Intervals.bottom in let itvs = Int_Intervals.inject [itv] in let new_ = Int_Intervals.join itvs cur in V_bool.Hashtbl.replace h v new_ in M.fold sort_by_content m (); (* Now sort the contents of h by increasing intervals *) let m = V_bool.Hashtbl.fold (fun v itvs acc -> MapIntervals.add itvs v acc) h MapIntervals.empty in (* Call f on those intervals *) MapIntervals.fold (fun itvs v acc -> f itvs v acc) m acc let fold_fuse_same f offsm acc = match offsm with | Degenerate v -> f Int_Intervals.top (true,v) acc | Map offsm -> fold_fuse_same_aux f offsm acc let range_covers_whole_type typ itvs = match typ with | None -> false | Some typ -> match Int_Intervals.project_singleton itvs with | Some (b, e) -> (try let s = Cil.bitsSizeOf typ in Int.equal b Int.zero && Int.equal e (Int.of_int (pred s)) with Cil.SizeOfError _ -> false) | None -> false let pretty_with_type typ fmt m = match m with | Degenerate v -> Format.fprintf fmt "@[[..] FROM @[%a@]@]" V.pretty v | Map m -> let pp_itv = Int_Intervals.pretty_typ typ in let first = ref true in let pretty_binding fmt itvs (default,v) () = if !first then first := false else Format.fprintf fmt "@," ; Format.fprintf fmt "@[<hv>@[%a@]%(%)@[FROM @[%a%s@]@]@]" pp_itv itvs (if range_covers_whole_type typ itvs then (" ": (unit,Format.formatter,unit) format) else "@ ") V.pretty v (if default then " (and SELF)" else "") in Format.fprintf fmt "@[<v>"; fold_fuse_same_aux (pretty_binding fmt) m (); Format.fprintf fmt "@]" let pretty = pretty_with_type None include Datatype.Make (struct type t = tt let name = V.name ^ " offsetmap_bitwise" let structural_descr = Structural_descr.Structure (Structural_descr.Sum [| [| M.packed_descr |]; [| V.packed_descr |] |]) let reprs = List.fold_left (fun acc m -> Map m :: acc) (List.map (fun v -> Degenerate v) V.reprs) M.reprs let equal = equal let hash = hash let compare = compare let pretty = pretty let internal_pretty_code = Datatype.undefined let rehash = Datatype.identity let copy = Datatype.undefined let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) let () = Type.set_ml_name ty None let is_empty m = match m with Map m -> M.is_empty m | Degenerate _ -> false let find default ((bi,ei) as i) m = match m with Degenerate v -> v | Map m -> let concerned_intervals = M.concerned_intervals Int_Interv.fuzzy_order i m in let treat_mid_interval (_bk,ek) (bl,_el) acc = (* Format.printf "treat_mid_itv: ek:%a bl:%a@\n" Int.pretty ek Int.pretty bl; *) let s_ek = Int.succ ek in if Int.lt s_ek bl then V.join (default s_ek (Int.pred bl)) acc else acc in (*let concerned_intervals = List.rev concerned_intervals in*) match concerned_intervals with [] -> default bi ei | ((_bk,ek),_)::_ -> let implicit_right = if Int.gt ei ek then default (Int.succ ek) ei else V.bottom in let rec implicit_mid_and_left list acc = match list with | [(bl,_el),_] -> if Int.lt bi bl then V.join acc (default bi (Int.pred bl)) else acc | (k,_)::(((l,_)::_) as tail) -> treat_mid_interval k l (implicit_mid_and_left tail acc) | [] -> assert false in let implicit = implicit_mid_and_left concerned_intervals implicit_right in (* now add the explicit values *) List.fold_left (function acc -> function ((bi,ei),(d,v)) -> let valu = V.join v acc in if d then (V.join valu (default bi ei)) else valu ) implicit concerned_intervals let same_values ((bx:bool),x) (by,y) = (bx = by) && (V.equal x y ) let add_map_internal i v map = (* FIXME (?) Fails to stick the writing binding with neighbors if applicable *) match M.cleanup_overwritten_bindings same_values i v map with | None -> map | Some(new_bi, new_ei, cleaned_m) -> (* Add the new binding *) let result = M.add (new_bi,new_ei) v cleaned_m in result let merge_map m1 m2 = M.fold (fun k v acc -> add_map_internal k v acc) m1 m2 (* low-level add to manipulate the pairs (default,value) *) let add_internal ((_bi,_ei) as i) (_bv, tv as v) m = match m with | Degenerate v1 -> Degenerate (V.join tv v1) | Map map -> Map (add_map_internal i v map) (** exact add *) let add i v m = add_internal i (false,v) m (** approximate add, for when the target location is ambiguous *) let add_approximate (b, e as i) v m = match m with | Degenerate v1 -> Degenerate (V.join v v1) | Map map -> let concerned_intervals = M.concerned_intervals Int_Interv.fuzzy_order i map in let treat_interval (acc, right_bound) ((b1, e1), (d1, v1)) = let acc, restricted_e1 = if Int.lt e1 right_bound then begin (* there is a hole *) let i_hole = (Int.succ e1, right_bound) in add_internal i_hole (true, v) acc, e1 end else acc, Int.min e1 e in let restricted_b1 = Int.max b1 b in let restricted_i1 = restricted_b1, restricted_e1 in add_internal restricted_i1 (d1,V.join v1 v) acc, Int.pred restricted_b1 in let acc, right_bound = List.fold_left treat_interval (m, e) concerned_intervals in let result = if Int.le b right_bound then begin (* there is a hole *) let i_hole = (b, right_bound) in add_internal i_hole (true, v) acc end else acc in (* Format.printf "bitwise add_approximate@\ninterval:%a..%a value:%a@\nstate%a@\nresult: %a@." Int.pretty b Int.pretty e V.pretty v pretty m pretty result;*) result (* let new_v = List.fold_left (fun vacc (_,(_,v)) -> (V.join vacc v)) v concerned_intervals in let d = try Int_Interv.check_coverage i concerned_intervals; List.fold_left (fun acc ((_,_),(d,_)) -> acc || d) false concerned_intervals with Is_not_included -> true in add_internal i (d, new_v) m *) let collapse m = match m with | Degenerate v -> v | Map map -> M.fold (fun _ (_,v) acc -> V.join acc v) map V.bottom let find_iset default alldefault is m = let result = if Int_Intervals.is_top is then V.join alldefault (collapse m) else let s = Int_Intervals.project_set is in if s = [] then V.bottom else begin match m with | Degenerate v -> List.fold_left (fun acc i -> V.join acc (default (fst i) (snd i))) v s | Map _ -> let f acc i = V.join acc (find default i m) in List.fold_left f V.bottom s end in (* Format.printf "find_iset %a %a@\nresult:%a@." Int_Intervals.pretty is pretty m V.pretty result; *) result let add_iset ~exact is v m = if Int_Intervals.is_top is then begin (* Format.printf "add_iset degenerate: value: %a@\nmap: %a@." V.pretty v pretty m; *) Degenerate (V.join v (collapse m)) end else begin let s = Int_Intervals.project_set is in match m with | Degenerate v1 -> Degenerate (V.join v v1) | Map _ -> let result = List.fold_left (fun acc i -> (if exact then add else add_approximate) i v acc) m s in result end let joindefault_internal = M.map (fun v -> true, (snd v)) let fold f m acc = match m with | Degenerate v -> f Int_Intervals.top (true,v) acc | Map m -> M.fold (fun i v acc -> f (Int_Intervals.inject [i]) v acc) m acc let map_map f m = M.fold (fun i v acc -> add_map_internal i (f v) acc) (* [pc] add_internal could be replaced by a more efficient function that assumes there are no bindings above i *) m M.empty let map f m = match m with | Degenerate v -> Degenerate (snd (f (true,v))) | Map m -> Map (map_map f m) (* let check_contiguity m = let id = map (fun x -> x) m in assert (equal id m) let check_map_contiguity m = let id = map_map (fun x -> x) m in assert (equal_map id m) *) let joindefault m = match m with Degenerate _ -> m | Map m -> Map (joindefault_internal m) let map2 (f : (bool * V.t) option -> (bool * V.t) option -> bool * V.t) mm1 mm2 = (* check_contiguity(mm2); check_contiguity(mm1); *) let result = match mm1, mm2 with | Degenerate(v), m | m, Degenerate(v) -> Degenerate (snd (f (Some (true, v)) (Some (true, collapse m)))) | Map(m1), Map(m2) -> (*Format.printf "map2: m1:@\n%a@\nm2:@\n%a@\n" pretty mm1 pretty mm2;*) let compute_remains_m1_and_merge m1 acc = let remains = map_map (fun vv -> f (Some vv) None) m1 in merge_map remains acc in let compute_remains_m2_and_merge m2 acc = (* check_map_contiguity(acc); *) let remains = map_map (fun vv -> f None (Some vv)) m2 in (* check_map_contiguity(remains); *) let result = merge_map remains acc in (* check_map_contiguity(result);*) result in let rec out_out (b1,_e1 as i1) v1 m1 (b2, _e2 as i2) v2 m2 acc = (*Format.printf "out_out: b1=%a e1=%a b2=%a e2=%a@\n" Int.pretty b1 Int.pretty e1 Int.pretty b2 Int.pretty e2; *) (* check_map_contiguity(acc);*) let result = if Int.lt b1 b2 then in_out i1 v1 m1 i2 v2 m2 acc else if Int.gt b1 b2 then out_in i1 v1 m1 i2 v2 m2 acc else (* b1 = b2 *) in_in i1 v1 m1 i2 v2 m2 acc in (* check_map_contiguity(result);*) result and in_out (b1,e1 as i1) v1 m1 (b2, _e2 as i2) v2 m2 acc = (*Format.printf "in_out: b1=%a e1=%a b2=%a e2=%a@\n" Int.pretty b1 Int.pretty e1 Int.pretty b2 Int.pretty e2; *) (* check_map_contiguity(acc);*) assert (Int.gt b2 b1); let result = let pb2 = Int.pred b2 in let new_v = f (Some v1) None in if Int.lt pb2 e1 then begin (* -> in_in *) let new_acc = add_map_internal (b1,pb2) new_v acc in in_in (b2,e1) v1 m1 i2 v2 m2 new_acc end else begin let new_acc = add_map_internal i1 new_v acc in try let (new_i1, new_v1) = M.lowest_binding m1 in let new_m1 = M.remove new_i1 m1 in if Int.lt e1 pb2 then (* -> out_out *) out_out new_i1 new_v1 new_m1 i2 v2 m2 new_acc else (* pb2 = e1 *) (* -> in_or_out_in *) in_or_out_in new_i1 new_v1 new_m1 i2 v2 m2 new_acc with M.Empty_rangemap -> compute_remains_m2_and_merge (add_map_internal i2 v2 m2) new_acc end in (* check_map_contiguity(result);*) result and out_in (b1,_e1 as i1) v1 m1 (b2, e2 as i2) v2 m2 acc = (* Format.printf "out_in: b1=%a e1=%a b2=%a e2=%a@\n" Int.pretty b1 Int.pretty e1 Int.pretty b2 Int.pretty e2; *) (* check_map_contiguity(acc);*) assert (Int.lt b2 b1); let result = let pb1 = Int.pred b1 in let new_v = f None (Some v2) in if Int.lt pb1 e2 then begin (* -> in_in *) let new_acc = add_map_internal (b2,pb1) new_v acc in in_in i1 v1 m1 (b1,e2) v2 m2 new_acc end else begin let new_acc = add_map_internal i2 new_v acc in try let (new_i2, new_v2) = M.lowest_binding m2 in let new_m2 = M.remove new_i2 m2 in if Int.lt e2 pb1 then (* -> out_out *) out_out i1 v1 m1 new_i2 new_v2 new_m2 new_acc else (* pb1 = e2 *) (* -> in_in_or_out *) in_in_or_out i1 v1 m1 new_i2 new_v2 new_m2 new_acc with M.Empty_rangemap -> compute_remains_m1_and_merge (add_map_internal i1 v1 m1) new_acc end in (* check_map_contiguity(result);*) result and in_in_or_out (b1,_e1 as i1) v1 m1 (b2,_e2 as i2) v2 m2 acc = (*Format.printf "in_in_or_out: b1=%a e1=%a b2=%a e2=%a@\n" Int.pretty b1 Int.pretty e1 Int.pretty b2 Int.pretty e2;*) (if Int.equal b1 b2 then in_in else (assert (Int.lt b1 b2);in_out)) i1 v1 m1 i2 v2 m2 acc and in_or_out_in (b1,_e1 as i1) v1 m1 (b2,_e2 as i2) v2 m2 acc = (*Format.printf "in_or_out_in: b1=%a e1=%a b2=%a e2=%a@\n" Int.pretty b1 Int.pretty e1 Int.pretty b2 Int.pretty e2;*) (if Int.equal b1 b2 then in_in else (assert (Int.gt b1 b2);out_in)) i1 v1 m1 i2 v2 m2 acc and in_in_e1_first (_b1, e1 as i1) _v1 m1 (_b2, e2) v2 m2 acc new_v12 = (*Format.printf "in_in_e1_first: b1=%a e1=%a b2=%a e2=%a@\n" Int.pretty b1 Int.pretty e1 Int.pretty b2 Int.pretty e2; *) assert (Int.lt e1 e2); let new_acc = add_map_internal i1 new_v12 acc in let new_i2 = (Int.succ e1,e2) in try let (new_i1, new_v1) = M.lowest_binding m1 in let new_m1 = M.remove new_i1 m1 in in_or_out_in new_i1 new_v1 new_m1 new_i2 v2 m2 new_acc with M.Empty_rangemap -> compute_remains_m2_and_merge (add_map_internal new_i2 v2 m2) new_acc and in_in_e2_first (_b1, e1) v1 m1 (_b2, e2 as i2) _v2 m2 acc new_v12= (*Format.printf "in_in_e2_first: b1=%a e1=%a b2=%a e2=%a@\n" Int.pretty b1 Int.pretty e1 Int.pretty b2 Int.pretty e2; *) assert (Int.lt e2 e1); let new_acc = add_map_internal i2 new_v12 acc in let new_i1 = (Int.succ e2,e1) in try let (new_i2, new_v2) = M.lowest_binding m2 in let new_m2 = M.remove new_i2 m2 in in_in_or_out new_i1 v1 m1 new_i2 new_v2 new_m2 new_acc with M.Empty_rangemap -> compute_remains_m1_and_merge (add_map_internal new_i1 v1 m1) new_acc and in_in_same_end (_b1, e1 as i1) _v1 m1 (_b2, e2) _v2 m2 acc new_v12= (*Format.printf "in_in_same_end: b1=%a e1=%a b2=%a e2=%a@\n" Int.pretty b1 Int.pretty e1 Int.pretty b2 Int.pretty e2; *) assert (Int.equal e1 e2); let acc = add_map_internal i1 new_v12 acc in try let (new_i1, new_v1) = M.lowest_binding m1 in let new_m1 = M.remove new_i1 m1 in try let (new_i2, new_v2) = M.lowest_binding m2 in let new_m2 = M.remove new_i2 m2 in out_out new_i1 new_v1 new_m1 new_i2 new_v2 new_m2 acc with M.Empty_rangemap -> compute_remains_m1_and_merge m1 acc with M.Empty_rangemap -> compute_remains_m2_and_merge m2 acc and in_in (b1, e1 as i1) v1 m1 (b2, e2 as i2) v2 m2 acc = (*Format.printf "in_in: b1=%a e1=%a b2=%a e2=%a@\n" Int.pretty b1 Int.pretty e1 Int.pretty b2 Int.pretty e2; *) assert (Int.equal b1 b2); let new_v12 = f (Some v1) (Some v2) in (if Int.gt e1 e2 then in_in_e2_first else if Int.lt e1 e2 then in_in_e1_first else in_in_same_end) i1 v1 m1 i2 v2 m2 acc new_v12 in try let i1, v1 = M.lowest_binding m1 in try let i2, v2 = M.lowest_binding m2 in let new_m1 = M.remove i1 m1 in let new_m2 = M.remove i2 m2 in Map (out_out i1 v1 new_m1 i2 v2 new_m2 M.empty) with M.Empty_rangemap -> mm1 with M.Empty_rangemap -> mm2 in (* check_contiguity(result);*) result let check_inter offs1 offs2 = let check bi ei = let concerned_intervals = M.concerned_intervals Int_Interv.fuzzy_order (bi,ei) offs2 in List.iter (fun (_,(b,_v)) -> if not b then raise Is_not_included) concerned_intervals in let f (bi,ei) _ acc = match acc with None -> (* (* now we do something about -**..bi *) if Int.neq bi Int.min_int then check Int.min_int (Int.pred bi);*) Some ei | Some ek -> let pbi = Int.pred bi in if Int.lt ek pbi then check (Int.succ ek) pbi; Some ei in match M.fold f offs1 None with | None -> () | Some _ek -> (* if Int.lt ek Int.max_int then check (Int.succ ek) Int.max_int *) () let is_included_exn offs1 offs2 = if offs1 != offs2 then match offs1, offs2 with | Map offs1, Map offs2 -> let treat_itv (_bi, _ei as i) (di,vi) = let concerned_intervals = M.concerned_intervals Int_Interv.fuzzy_order i offs2 in Int_Interv.check_coverage i concerned_intervals; List.iter (fun ((_bj, _ej),(dj,vj)) -> if di && (not dj) then raise Is_not_included; if not (V.is_included vi vj) then raise Is_not_included) concerned_intervals in M.iter treat_itv offs1 ; check_inter offs1 offs2 | Degenerate _v1, Map _offs2 -> raise Is_not_included | _, Degenerate v2 -> if not (V.is_included (collapse offs1) v2) then raise Is_not_included let is_included m1 m2 = try is_included_exn m1 m2; true with Is_not_included -> false let join mm1 mm2 = (* check_contiguity(mm1); check_contiguity(mm2); *) if mm1 == mm2 then mm1 else let result = map2 (fun v1 v2 -> match v1,v2 with | None, None -> assert false | Some v , None | None, Some v -> true, snd v | Some v1, Some v2 -> (fst v1 || fst v2), (V.join (snd v1) (snd v2))) mm1 mm2 in (* check_contiguity(result);*) result (* map [f] on [offs] and merge with [acc] *) let map_and_merge f offs acc = (* check_contiguity(acc); check_contiguity(offs);*) let generic_f v1 v2 = match v1,v2 with | None, None -> assert false | Some (d,v), None -> d,f v | None, Some vv -> vv | Some (d1,v1), Some (d2,v2) -> d1&&d2, if d1 then V.join (f v1) v2 else f v1 in (* Format.printf "@[Offsetmap.map_and_merge offs:%a and acc:%a@]@." (pretty) offs (pretty) acc; *) let result = map2 generic_f offs acc in (* check_contiguity(result);*) result (* this code was copied from the non-bitwise lattice, it could be shared if it was placed in M. TODO PC 2007/02 *) let copy_paste_map ~f from start stop start_to _to = let result = let ss = start,stop in let to_ss = start_to, Int.sub (Int.add stop start_to) start in (* First removing the bindings of the destination interval *) let _to = M.remove_itv Int_Interv.fuzzy_order to_ss _to in let concerned_itv = M.concerned_intervals Int_Interv.fuzzy_order ss from in let offset = Int.sub start_to start in let current = ref start in let f, treat_empty_space = match f with Some (f, default) -> f, (fun acc i -> let src_b = !current in if Int.le i src_b then acc else let src_e = Int.pred i in let dest_itv = Int.add (!current) offset, Int.add src_e offset in (* Format.printf "treat_empty ib=%a ie=%a@." Int.pretty src_b Int.pretty src_e;*) add_map_internal dest_itv (f (true, default src_b src_e)) acc) | None -> (fun x -> x), (fun acc _i -> acc) in let treat_interval ((b,_) as i,v) acc = let acc = treat_empty_space acc b in let new_vv = f v in let src_b, src_e = Int_Interv.clip_itv ss i in let dest_i = Int.add src_b offset, Int.add src_e offset in current := Int.succ src_e; (*Format.printf "treat_itv: ib=%a ie=%a v=%a dib=%a die=%a@." Int.pretty (fst i) Int.pretty (snd i) V.pretty v Int.pretty (fst dest_i) Int.pretty (snd dest_i);*) add_map_internal dest_i new_vv acc in let acc = List.fold_right treat_interval concerned_itv _to in treat_empty_space acc (Int.succ stop) in (* Format.printf "Offsetmap_bitwise.copy_paste from:%a start:%a stop:%a start_to:%a to:%a result:%a@\n" (pretty) (Map from) Int.pretty start Int.pretty stop Int.pretty start_to (pretty) (Map _to) (pretty) (Map result); *) result let copy_paste ~f from start stop start_to _to = match from, _to with Map from, Map _to -> Map (copy_paste_map ~f from start stop start_to _to) | _, _ -> let collapse_from = collapse from in let value_from = ( match f with Some (f,_default) -> (snd (f (true,collapse_from))) | None -> collapse_from ) in Degenerate (V.join value_from (collapse _to)) let copy_merge from start stop start_to _to = let old_value = copy_paste ~f:None _to start_to (Int.sub (Int.add start_to stop) start) start empty in let merged_value = join old_value from in copy_paste ~f:None merged_value start stop start_to _to let copy ~f from start stop = copy_paste ~f from start stop Int.zero empty end (* Local Variables: compile-command: "make -C ../.." End: *) ����������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/value_types.mli������������������������������������������0000644�0001750�0001750�00000006154�12155630237�022351� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Declarations that are useful for plugins written on top of the results of Value. *) open Cil_types (* TODO: These types are already defined in Value_util. *) type call_site = kernel_function * kinstr type callstack = call_site list (** Value callstacks, as used e.g. in Db.Value hooks *) module Callsite: Datatype.S_with_collections with type t = call_site module Callstack: Datatype.S_with_collections with type t = callstack type 'a callback_result = | Normal of 'a | NormalStore of 'a * int | Reuse of int type cacheable = | Cacheable (** Functions whose result can be safely cached *) | NoCache (** Functions whose result should not be cached, but for which the caller can still be cached. Typically, functions printing something during the analysis. *) | NoCacheCallers (** Functions for which neither the call, neither the callers, can be cached *) (** Results of a a call to a function *) type call_result = { c_values: (** Memory states after the call *) (Cvalue.V_Offsetmap.t option (** the value returned (ie. what is after the 'return' C keyword). *) * Cvalue.Model.t (** the memory state after the function has been executed *)) list; c_clobbered: Base.SetLattice.t (** An over-approximation of the bases in which addresses of local variables might have been written *); c_cacheable: cacheable (** Is it possible to cache the result of this call? *); } (* Local Variables: compile-command: "make -C ../.." End: *) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/widen_type.mli�������������������������������������������0000644�0001750�0001750�00000004531�12155630237�022155� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Widening hints for the Value Analysis datastructures. *) include Datatype.S (** Key for the first map : from Base.t to Ival.Widen_Hints.t *) type var_key = Default | All | VarKey of Base.t (** an [empty] set of hints *) val empty : t (** a [default] set of hints *) val default : t (** add a set of hints for a [stmt, var], [Default] or [All] (stmts, keys) *) val add_num_hints: Cil_types.stmt option -> var_key -> Ival.Widen_Hints.t -> t -> t (** add a set of Base for a [stmt] *) val add_var_hints : Cil_types.stmt -> Base.Set.t -> t -> t (** widen hints from a [Cil_types.stmt, Base] *) val hints_from_keys : Cil_types.stmt -> t -> Base.Set.t * (Base.t -> Locations.Location_Bytes.widen_hint) (* Local Variables: compile-command: "make -C ../.." End: *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/int_Interv.mli�������������������������������������������0000644�0001750�0001750�00000004062�12155630237�022126� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Intervals of integers. *) exception Cannot_compare_intervals include Datatype.S with type t = Integer.t * Integer.t (** Locates (b2, e2) with respect to (b1, e1). Therefore the meaning of "Above" and "Below" may look as if it is reversed, beware. *) val fuzzy_order: t -> t -> Rangemap.fuzzy_order val shift: Integer.t -> t -> t val check_coverage: t -> (t * 'a) list -> unit val clip_itv: t -> t -> t (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/offsetmap_sig.mli����������������������������������������0000644�0001750�0001750�00000016622�12155630237�022640� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Signature for {!Offsetmap} module, that implement efficient maps from intervals to arbitrary values. *) (* This module is declared as a pure mli to avoid duplicating the interface of [Offsetmap] in the .ml and in the .mli files. *) open Abstract_interp type v (** Type of the values stored in the offsetmap *) type widen_hint include Datatype.S (** Datatype for the offsetmaps *) (** {2 Pretty-printing} *) val pretty : Format.formatter -> t -> unit val pretty_typ: Cil_types.typ option -> Format.formatter -> t -> unit (** {2 Creating basic offsetmaps} *) val create: size:Int.t -> v -> size_v:Int.t -> t (** [create ~size v ~size_v] creates an offsetmap of size [size] in which the intervals [k*size_v .. (k+1)*size_v-1] with [0<= k <= size/size_v] are all mapped to [v]. *) val create_isotropic: size:Int.t -> v -> t (** Same as {!create}, but for values that are isotropic. In this case, [size_v] is automatically computed. *) val from_cstring : Base.cstring -> t (** {2 Empty offsetmap} *) val empty : t val is_empty: t -> bool (** {2 Iterators} *) val iter: ((Int.t * Int.t) -> (v * Int.t * Rel.t) -> unit) -> t -> unit (** [iter f m] calls [f] on all the intervals bound in [m], in increasing order. The arguments of [f (min, max) (v, size, offset)] are as follow: - [(start, stop)] are the bounds of the interval, inclusive. - [v] is the value bound to the interval, and [size] its size; if [size] is less than [stop-start+1], [v] repeats itself until [stop]. - [offset] is the offset at which [v] starts in the interval; it ranges over [0..size-1]. If [offset] is [0], [v] starts at the beginning of the interval. Otherwise, it starts at [offset-size]. *) val fold: ((Int.t * Int.t) -> (v * Int.t * Rel.t) -> 'a -> 'a) -> t -> 'a -> 'a (** Same as [iter], but with an accumulator. *) val fold_between: entire:bool -> Int.t * Int.t -> ((Int.t * Int.t) -> (v * Int.t * Rel.t) -> 'a -> 'a) -> t -> 'a -> 'a (** [fold_between ~entire (start, stop) m acc] is similar to [fold f m acc], except that only the intervals that intersect [start..stop] (inclusive) are presented. If [entire] is true, intersecting intervals are presented whole (ie. they may be bigger than [start..stop]). If [entire] is [false], only the intersection with [ib..ie] is presented. *) val iter_on_values: (v -> Int.t -> unit) -> t -> unit (** [iter_on_values f m] iterates on the entire contents of [m], but [f] receives only the value bound to each interval and the size of this value. Interval bounds and the offset of the value are not computed. *) val fold_on_values: (v -> Int.t -> 'a -> 'a) -> t -> 'a -> 'a (** Same as [iter_on_values] but with an accumulator *) (** {2 Join and inclusion testing} *) val join : t -> t -> t val is_included : t -> t -> bool (** [is_included m1 m2] tests whether [m1] is included in [m2]. *) val is_included_exn : t -> t -> unit (** [is_included_exn m1 m2] raises {!Abstract_interp.Is_not_included} if [m1] is not included in [m2], and does nothing otherwise. *) val widen : widen_hint -> t -> t -> t (** [widen wh m1 m2] performs a widening step on [m2], assuming that [m1] was the previous state. The relation [is_included m1 m2] must hold *) (** {2 Searching values} *) val find : with_alarms:CilE.warn_mode -> validity:Base.validity -> conflate_bottom:bool -> offsets:Ival.t -> size:Integer.t -> t -> v (** Find the value bound to a set of intervals, expressed as an ival, in the given rangemap. *) val find_imprecise: Int.t * Int.t -> t -> v (** [find_imprecise (ib, ie) m] returns the join of the values bound between [ib] and [ie] (inclusively) in [m]. *) (* TODOBY add validity *) val find_imprecise_everywhere: validity:Base.validity -> t -> v (** Returns the join of all the values bound in the offsetmap. *) val copy_slice: with_alarms:CilE.warn_mode -> validity:Base.validity -> offsets:Ival.t -> size:Integer.t -> t -> t (** [copy_slice ~with_alarms ~validity ~offsets ~size m] copies and merges the slices of [m] starting at offsets [offsets] and of size [size]. Offsets invalid according to [validity] are removed. *) (* TODOBY: clarify and document return convention *) (** {2 Adding values} *) val add : (Int.t * Int.t) -> (v * Int.t * Rel.t) -> t -> t (** [add_with_offset (min, max) (v, size, offset) m] maps the interval [min..max] (inclusive) to the value [v] in [m]. [v] is assumed as having size [size]. If [stop-start+1] is greater than [size], [v] repeats itself until the entire interval is filled. [offset] is the offset at which [v] starts in the interval, interpreted as for {!iter}. Offsetmaps cannot contain holes, so [m] must already bind at least the intervals [0..start-1]. *) exception Result_is_bottom val update : with_alarms:CilE.warn_mode -> validity:Base.validity -> exact:bool -> offsets:Ival.t -> size:Int.t -> v -> t -> t (** Can raise [Result_is_bottom] *) val update_imprecise_everywhere: validity:Base.validity -> Origin.t -> v -> t -> t (** [update_everywhere ~validity o v m] computes the offsetmap resulting from imprecisely writing [v] potentially anywhere where [m] is valid according to [validity]. If a value becomes too imprecise, [o] is used as origin. *) val paste_slice: with_alarms:CilE.warn_mode -> validity:Base.validity -> exact:bool -> (t * Int.t) (** Source *)-> size:Int.t -> offsets:Ival.t -> t -> t (** {2 Misc} *) val cardinal_zero_or_one: t -> bool (** Returns [true] if and only if all the interval bound in the offsetmap are mapped to values with cardinal at most 1. *) (** Clear the caches local to this module. Beware that they are not project-aware, and that you must call them at every project switch. *) val clear_caches: unit -> unit (* Local Variables: compile-command: "make -C ../.." End: *) ��������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/cvalue.ml������������������������������������������������0000644�0001750�0001750�00000106237�12155630237�021122� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp open Locations open CilE module V = struct include Location_Bytes exception Not_based_on_null let project_ival m = try let k, v = find_lonely_key m in if not (Base.is_null k) then raise Not_based_on_null else v with Not_found -> raise Not_based_on_null let min_and_max_float f = try let i = project_ival f in Ival.min_and_max_float i with Not_based_on_null -> assert false (* [JS 2013/01/09] unused right now *) let _force_float kind v = try let i = project_ival v in let f, fi = Ival.force_float kind i in f, inject_ival (fi) with Not_based_on_null -> true, topify_arith_origin v let is_imprecise v = match v with | Top _ -> true | _ -> false let is_topint v = equal top_int v let is_bottom v = equal bottom v let is_isotropic v = match v with | Top _ -> true | Map _ -> is_topint v || is_bottom v || is_zero v let contains_zero loc = try let is_valid_offset base offset = match base with Base.Null -> if Ival.contains_zero offset then raise Base.Not_valid_offset | _ -> let bits_offset = Ival.scale (Bit_utils.sizeofchar()) offset in Base.is_valid_offset ~for_writing:false Int.zero base bits_offset in match loc with | Location_Bytes.Top _ -> true | Location_Bytes.Map m -> Location_Bytes.M.iter is_valid_offset m; false with | Base.Not_valid_offset -> true let contains_non_zero v = not ((equal v bottom) || (is_zero v)) let of_char c = inject_ival (Ival.of_int (Char.code c)) let of_int64 i = inject_ival (Ival.of_int64 i) let subdiv_float_interval ~size v = try let v_ival = project_ival v in let ival1, ival2 = Ival.subdiv_float_interval ~size v_ival in inject_ival ival1, inject_ival ival2 with Not_based_on_null -> assert false let compare_bound ival_compare_bound l1 l2 = if l1 == l2 then 0 else if is_bottom l2 then 1 else if is_bottom l1 then -1 else try let f1 = project_ival l1 in let f2 = project_ival l2 in ival_compare_bound f1 f2 with Not_based_on_null -> assert false let compare_min_float = compare_bound Ival.compare_min_float let compare_max_float = compare_bound Ival.compare_max_float let compare_min_int = compare_bound Ival.compare_min_int let compare_max_int = compare_bound Ival.compare_max_int let filter_comparison ival_filter e1 ~cond_expr = let r = match e1 with | Top _ -> e1 | Map m1 -> try let k,v2 = find_lonely_key cond_expr in let v1 = find_or_bottom k m1 in let r = Map (add_or_bottom k (ival_filter v1 v2) m1) in if (not (Base.equal k Base.null)) && (ival_filter == Ival.filter_ge || ival_filter == Ival.filter_gt) then diff_if_one r singleton_zero else r with Not_found -> e1 in (* Format.printf "filter_comparison %a %a -> %a@." pretty e1 pretty cond_expr pretty r; *) r let filter_comparison_float float_filter e1 ~cond_expr = try let v1 = project_ival e1 in let v2 = project_ival cond_expr in inject_ival (float_filter v1 v2) with Not_based_on_null -> e1 let filter_le e1 ~cond_expr = filter_comparison Ival.filter_le e1 ~cond_expr let filter_ge e1 ~cond_expr = filter_comparison Ival.filter_ge e1 ~cond_expr let filter_lt e1 ~cond_expr = filter_comparison Ival.filter_lt e1 ~cond_expr let filter_gt e1 ~cond_expr = filter_comparison Ival.filter_gt e1 ~cond_expr let filter_le_float allmodes ~typ_loc e1 ~cond_expr = filter_comparison_float (Ival.filter_le_float allmodes ~typ_loc) e1 ~cond_expr let filter_ge_float allmodes ~typ_loc e1 ~cond_expr = filter_comparison_float (Ival.filter_ge_float allmodes ~typ_loc) e1 ~cond_expr let filter_lt_float allmodes ~typ_loc e1 ~cond_expr = filter_comparison_float (Ival.filter_lt_float allmodes ~typ_loc) e1 ~cond_expr let filter_gt_float allmodes ~typ_loc e1 ~cond_expr = filter_comparison_float (Ival.filter_gt_float allmodes ~typ_loc) e1 ~cond_expr let pretty fmt v = (*Format.printf "@[HERE@.@]";*) let pretty_org fmt org = if not (Origin.is_top org) then Format.fprintf fmt "@ @[(origin: %a)@]" Origin.pretty org in match v with | Top (Base.SetLattice.Top, a) -> Format.fprintf fmt "{{ ANYTHING%a }}" pretty_org a | Top (t, a) -> Format.fprintf fmt "{{ garbled mix of &%a%a }}" Base.SetLattice.pretty t pretty_org a | Map m -> try Ival.pretty fmt (project_ival v) with | Not_based_on_null -> let print_binding fmt k v = if Ival.equal Ival.singleton_zero v then Format.fprintf fmt "@[%a@]" Base.pretty_addr k else Format.fprintf fmt "@[%a +@ %a@]" Base.pretty_addr k Ival.pretty v in Pretty_utils.pp_iter ~pre:"@[<hov 3>{{ " ~suf:" }}@]" ~sep:" ;@ " (fun pp map -> M.iter (fun k v -> pp (k, v)) map) (fun fmt (k, v) -> print_binding fmt k v) fmt m let inject_int (v:Int.t) = inject_ival (Ival.inject_singleton v) let interp_boolean ~contains_zero ~contains_non_zero = match contains_zero, contains_non_zero with | true, true -> zero_or_one | true, false -> singleton_zero | false, true -> singleton_one | false, false -> bottom let add v1 v2 = try Location_Bytes.shift (project_ival v1) v2 with Not_based_on_null -> try Location_Bytes.shift (project_ival v2) v1 with Not_based_on_null -> join (topify_arith_origin v1) (topify_arith_origin v2) (* compute [e1+factor*e2] using C semantic for +, i.e. [ptr+v] is [add_untyped sizeof_in_octets( *ptr) ptr v] *) let add_untyped factor e1 e2 = try if Int_Base.equal factor (Int_Base.minus_one) then (* Either e1 and e2 have the same base, and it's a substraction of pointers, or e2 is really an integer *) let b1, o1 = Location_Bytes.find_lonely_key e1 in let b2, o2 = Location_Bytes.find_lonely_key e2 in if Base.compare b1 b2 <> 0 then raise Not_found; inject_ival (Ival.sub o1 o2) else begin if not (Int_Base.equal factor (Int_Base.one)) then raise Not_found; (* cannot multiply a pointer *) add e1 e2 end with Not_found -> (* we end up here if the only way left to make this addition is to convert e2 to an integer *) try let right = Ival.scale_int64base factor (project_ival e2) in Location_Bytes.shift right e1 with Not_based_on_null -> (* from [project_ival] *) join (topify_arith_origin e1) (topify_arith_origin e2) let compare_min_max min max = match min, max with | None,_ -> -1 | _,None -> -1 | Some min, Some max -> Int.compare min max let compare_max_min max min = match max, min with | None,_ -> 1 | _,None -> 1 | Some max, Some min -> Int.compare max min let do_le min1 max1 min2 max2 = if compare_max_min max1 min2 <= 0 then singleton_one else if compare_min_max min1 max2 > 0 then singleton_zero else zero_or_one let do_ge min1 max1 min2 max2 = do_le min2 max2 min1 max1 let do_lt min1 max1 min2 max2 = if compare_max_min max1 min2 < 0 then singleton_one else if compare_min_max min1 max2 >= 0 then singleton_zero else zero_or_one let do_gt min1 max1 min2 max2 = do_lt min2 max2 min1 max1 let _comparisons _info ~signed f e1 e2 = let r = try let k1,v1 = find_lonely_key e1 in let k2,v2 = find_lonely_key e2 in if not (Base.equal k1 k2) then begin if (not signed) then begin let e1_zero = equal e1 singleton_zero in let e2_zero = equal e2 singleton_zero in if (e1_zero && (f == do_le || f == do_lt)) || (e2_zero && (f == do_ge || f == do_gt)) then singleton_one else if (e2_zero && (f == do_le || f == do_lt)) || (e1_zero && (f == do_ge || f == do_gt)) then singleton_zero else zero_or_one end else zero_or_one end else Ival.compare_C f v1 v2 with Not_found -> zero_or_one in (* Format.printf "comparisons %a %a %a@." pretty e1 pretty e2 pretty r; *) r let asym_rel ~signed op e1 e2 = let open Cil_types in try let k1,v1 = find_lonely_key e1 in let k2,v2 = find_lonely_key e2 in if Base.equal k1 k2 then begin let f = match op with | Ge -> do_ge | Le -> do_le | Gt -> do_gt | Lt -> do_lt | _ -> assert false in Ival.compare_C f v1 v2 end else begin if signed then zero_or_one else begin let e1_zero = equal e1 singleton_zero in let e2_zero = equal e2 singleton_zero in if (e1_zero && (op = Le || op = Lt)) || (e2_zero && (op = Ge || op = Gt)) then singleton_one else if (e2_zero && (op = Le || op = Lt)) || (e1_zero && (op = Ge || op = Gt)) then singleton_zero else zero_or_one end end with Not_found -> zero_or_one let check_equal positive e1 e2 = let one,zero = if positive then Ival.singleton_one, Ival.singleton_zero else Ival.singleton_zero, Ival.singleton_one in inject_ival (if (equal e1 e2) && (cardinal_zero_or_one e1) then one else if intersects e1 e2 then Ival.zero_or_one else zero) let eval_comp ~signed op v1 v2 = let open Cil_types in match op with | Eq -> check_equal true v1 v2 | Ne -> check_equal false v1 v2 | Le | Ge | Lt | Gt -> asym_rel ~signed op v1 v2 | _ -> assert false let cast_float ~rounding_mode v = try let i = project_ival v in let b, i = Ival.cast_float ~rounding_mode i in false, b, inject_ival i with Not_based_on_null -> if is_bottom v then false, false, bottom else true, true, topify_arith_origin v let cast_double v = try let i = project_ival v in let b, i = Ival.cast_double i in false, b, inject_ival i with Not_based_on_null -> if is_bottom v then false, false, bottom else true, true, topify_arith_origin v let cast ~size ~signed expr = try let i = project_ival expr in inject_ival (Ival.cast ~size ~signed ~value:i), true with | Not_based_on_null -> if Int.ge size (Int.of_int (Bit_utils.sizeofpointer ())) || is_bottom expr || is_imprecise expr then expr, true else topify_arith_origin expr, false let import_function ~topify ~with_alarms info f e1 e2 = try let v1 = project_ival e1 in let v2 = project_ival e2 in inject_ival (f v1 v2) with Not_based_on_null -> if is_bottom e1 || is_bottom e2 then bottom else begin (do_warn with_alarms.imprecision_tracing (fun _ -> match e1,e2 with | Map _, Map _ -> Kernel.warning ~once:true ~current:true "Operation %a %s %a incurs a loss of precision" pretty e1 info pretty e2 | _ -> ())); join (topify_with_origin_kind topify e1) (topify_with_origin_kind topify e2) end let arithmetic_function = import_function ~topify:Origin.K_Arith let cast_float_to_int ~signed ~size v = try let v1 = project_ival v in let alarm_use_as_float, alarm_overflow, r = Ival.cast_float_to_int ~signed ~size v1 in false, alarm_use_as_float, alarm_overflow, inject_ival r with Not_based_on_null -> true, true, true, topify_arith_origin v let cast_float_to_int_inverse ~single_precision i = try let v1 = project_ival i in let r = Ival.cast_float_to_int_inverse ~single_precision v1 in inject_ival r with Not_based_on_null -> assert false let cast_int_to_float rounding_mode v = try let i = project_ival v in let ok, r = Ival.cast_int_to_float rounding_mode i in inject_ival r, ok with Not_based_on_null -> v, false let div ~with_alarms e1 e2 = if equal e2 singleton_one then e1 else begin if (with_alarms.others.a_log <> None) && contains_zero e2 then CilE.warn_div with_alarms; arithmetic_function ~with_alarms "/" Ival.div e1 e2 end let c_rem ~with_alarms e1 e2 = if (with_alarms.others.a_log <> None) && contains_zero e2 then warn_div with_alarms; arithmetic_function ~with_alarms "%" Ival.c_rem e1 e2 let mul ~with_alarms e1 e2 = arithmetic_function ~with_alarms "*" Ival.mul e1 e2 (** Warn about overflow iff [size] is not [None]. Beware when calling this function *) let shift_left ~topify ~with_alarms ~size e1 e2 = let default e1 e2 = begin try let size = Extlib.opt_map (function (_, y) -> Int.of_int y) size in import_function ~topify ~with_alarms "<<" (Ival.shift_left ~size) e1 e2 with Not_found -> join (topify_with_origin_kind topify e1) (topify_with_origin_kind topify e2) end in match size with | None -> default e1 e2 | Some ((warn_negative, size)) -> let size_int = Int.of_int size in let valid_range_rhs = inject_ival (Ival.inject_range (Some Int.zero) (Some (Int.pred size_int))) in if (with_alarms.others.a_log <> None) then begin if not (is_included e2 valid_range_rhs) then warn_shift with_alarms size; end; let e2 = narrow e2 valid_range_rhs in let e1 = if warn_negative then begin let valid_range_lhs = inject_ival (Ival.inject_range (Some Int.zero) None) in if not (is_included e1 valid_range_lhs) then warn_shift_left_positive with_alarms; narrow e1 valid_range_lhs end else e1 in default e1 e2 let bitwise_xor ~with_alarms v1 v2 = arithmetic_function ~with_alarms "^" Ival.bitwise_xor v1 v2 let shift_right ~with_alarms ~size e1 e2 = let default () = begin try let size = Extlib.opt_map (function (_,s) -> Int.of_int s) size in arithmetic_function ~with_alarms ">>" (Ival.shift_right ~size) e1 e2 with Not_found -> join (topify_arith_origin e1) (topify_arith_origin e2) end in match size with | None -> default () | Some (_,size) -> let size_int = Int.of_int size in let valid_range = inject_ival (Ival.inject_range (Some Int.zero) (Some (Int.pred size_int))) in if not (intersects e2 valid_range) then begin warn_shift with_alarms size; if with_alarms.others.a_log <> None then Kernel.warning ~once:true ~current:true "invalid shift of %a-bit value by %a. \ This path is assumed to be dead." Int.pretty size_int pretty e2; bottom end else begin if (with_alarms.others.a_log <> None) && not (is_included e2 valid_range) then warn_shift with_alarms size; default () end let bitwise_and ~signed ~size e1 e2 = let bitwise_and_pointer_ival p ival = let _min, _max = match Ival.min_and_max ival with Some min, Some max when Int.ge min Int.zero -> min, max | _ -> raise Not_based_on_null in let treat_base _base _offsets _acc = Location_Bytes.topify_arith_origin p (* TODO *) in Location_Bytes.fold_i treat_base p Location_Bytes.bottom in try let v1 = project_ival e1 in try let v2 = project_ival e2 in let result = Ival.bitwise_and ~signed ~size v1 v2 in inject_ival result with Not_based_on_null | Location_Bytes.Error_Top -> bitwise_and_pointer_ival e2 v1 with Not_based_on_null | Location_Bytes.Error_Top -> try let v2 = project_ival e2 in bitwise_and_pointer_ival e1 v2 with Not_based_on_null | Location_Bytes.Error_Top -> join (topify_arith_origin e1) (topify_arith_origin e2) let bitwise_or ~topify ~size e1 e2 = try let v1 = project_ival e1 in let v2 = project_ival e2 in let result = Ival.bitwise_or ~size v1 v2 in inject_ival result with Not_based_on_null -> join (topify_with_origin_kind topify e1) (topify_with_origin_kind topify e2) let extract_bits ~topify ~start ~stop ~size v = try let i = project_ival v in false, inject_ival (Ival.extract_bits ~start ~stop ~size i) with | Not_based_on_null -> if is_imprecise v then false, v else true, topify_with_origin_kind topify v let big_endian_merge_bits ~topify ~conflate_bottom ~total_length ~length ~value ~offset acc = if is_bottom acc || is_bottom value then begin if conflate_bottom then bottom else join (topify_with_origin_kind topify acc) (topify_with_origin_kind topify value) end else let total_length_i = Int.of_int total_length in assert (Int.le (Int.add length offset) total_length_i); let result = bitwise_or ~topify ~size:total_length (shift_left ~topify ~with_alarms:warn_none_mode ~size:(Some (false,total_length)) value (inject_ival (Ival.inject_singleton (Int.sub (Int.sub total_length_i offset) length)))) acc in (* Format.printf "big_endian_merge_bits : total_length:%d length:%a value:%a offset:%a acc:%a GOT:%a@." total_length Int.pretty length pretty value Int.pretty offset pretty acc pretty result; *) result let little_endian_merge_bits ~topify ~conflate_bottom ~total_length ~value ~offset acc = if is_bottom acc || is_bottom value then begin if conflate_bottom then bottom else join (topify_with_origin_kind topify acc) (topify_with_origin_kind topify value) end else let result = bitwise_or ~topify ~size:total_length (shift_left ~topify ~with_alarms:warn_none_mode ~size:(Some (false, total_length)) value (inject_ival (Ival.inject_singleton offset))) acc in (*Format.printf "le merge_bits : total_length:%d value:%a offset:%a acc:%a GOT:%a@." total_length pretty value Int.pretty offset pretty acc pretty result;*) result let all_values ~size v = try let i = project_ival v in Ival.all_values ~size i with Not_based_on_null -> false let anisotropic_cast ~size v = if all_values ~size v then top_int else v let create_all_values ~modu ~signed ~size = inject_ival (Ival.create_all_values ~modu ~signed ~size) let bitwise_or = bitwise_or ~topify:Origin.K_Arith let shift_left = shift_left ~topify:Origin.K_Arith let has_sign_problems v = not (is_included top_int v) && not (is_included v top_float) end module V_Or_Uninitialized = struct type un_t = | C_uninit_esc of V.t | C_uninit_noesc of V.t | C_init_esc of V.t | C_init_noesc of V.t type tt = un_t let mask_init = 2 let mask_noesc = 1 let is_initialized flags = (flags land mask_init) <> 0 let is_noesc flags = (flags land mask_noesc) <> 0 let get_v = function | C_uninit_esc v | C_uninit_noesc v | C_init_esc v | C_init_noesc v -> v let get_flags : tt -> int = fun v -> Obj.tag (Obj.repr v) let create : int -> V.t -> tt = fun flags v -> match flags with | 0 -> C_uninit_esc v | 1 -> C_uninit_noesc v | 2 -> C_init_esc v | 3 -> C_init_noesc v | _ -> assert false (* let (==>) = (fun x y -> (not x) || y) *) type widen_hint = V.widen_hint let widen wh t1 t2 = create (get_flags t2) (V.widen wh (get_v t1) (get_v t2)) let equal t1 t2 = (get_flags t1) = (get_flags t2) && V.equal (get_v t1) (get_v t2) exception Error_Bottom exception Error_Top let join t1 t2 = (* { initialized = t1.initialized && t2.initialized; no_escaping_adr = t1.no_escaping_adr && t2.no_escaping_adr; v = V.join t1.v t2.v } *) create ((get_flags t1) land (get_flags t2)) (V.join (get_v t1) (get_v t2)) let narrow t1 t2 = (* {initialized = t1.initialized || t2.initialized; no_escaping_adr = t1.no_escaping_adr || t2.no_escaping_adr; v = V.narrow t1.v t2.v } *) create ((get_flags t1) lor (get_flags t2)) (V.narrow (get_v t1) (get_v t2)) let link t1 t2 = create ((get_flags t1) land (get_flags t2)) (V.link (get_v t1) (get_v t2)) let meet t1 t2 = create ((get_flags t1) lor (get_flags t2)) (V.meet (get_v t1) (get_v t2)) let bottom = C_init_noesc V.bottom let top = C_uninit_esc V.top let is_bottom = equal bottom let uninitialized = C_uninit_noesc V.bottom let initialized v = C_init_noesc v let remove_indeterminateness v = match v with C_init_noesc _ -> v | (C_uninit_noesc v | C_uninit_esc v | C_init_esc v) -> C_init_noesc v let escaping_addr = C_init_esc V.bottom let is_included t1 t2 = (* (t2.initialized ==> t1.initialized) && (t2.no_escaping_adr ==> t1.no_escaping_adr) && V.is_included t1.v t2.v *) let flags1 = get_flags t1 in let flags2 = get_flags t2 in (lnot flags2) lor flags1 = -1 && V.is_included (get_v t1) (get_v t2) let is_included_exn t1 t2 = if not (is_included t1 t2) then raise Abstract_interp.Is_not_included let intersects _t1 _t2 = assert false (* ((not t2.initialized) && (not t1.initialized)) || ((not t2.no_escaping_adr) && (not t1.no_escaping_adr)) || V.intersects t1.v t2.v *) let pretty fmt t = let flags = get_flags t in let no_escaping_adr = is_noesc flags in let initialized = is_initialized flags in let v = get_v t in if initialized && no_escaping_adr then V.pretty fmt v else if equal t uninitialized then Format.fprintf fmt "UNINITIALIZED" else if equal t escaping_addr then Format.fprintf fmt "ESCAPINGADDR" else if initialized && not no_escaping_adr then Format.fprintf fmt "%a or ESCAPINGADDR" V.pretty v else if (not initialized) && no_escaping_adr then Format.fprintf fmt "%a or UNINITIALIZED" V.pretty v else Format.fprintf fmt "%a or UNINITIALIZED or ESCAPINGADDR" V.pretty v let cardinal_zero_or_one t = match t with C_init_noesc v -> V.cardinal_zero_or_one v | C_init_esc v | C_uninit_noesc v -> V.is_bottom v | C_uninit_esc _ -> false let cardinal_less_than t b = match t with C_init_noesc v -> V.cardinal_less_than v b | _ -> raise Abstract_interp.Not_less_than let hash t = (get_flags t) * 4513 + (V.hash (get_v t)) include Datatype.Make (struct type t = tt (* = | C_uninit_esc of V.t | C_uninit_noesc of V.t | C_init_esc of V.t | C_init_noesc of V.t *) let name = "Cvalue.V_Or_Uninitialized" let structural_descr = let v = V.packed_descr in Structural_descr.Structure (Structural_descr.Sum [| [| v |]; [| v |]; [| v |]; [| v |] |]) let reprs = List.fold_left (fun acc v -> List.fold_left (fun acc v -> List.fold_left (fun acc v -> C_uninit_noesc v :: acc) (C_uninit_esc v :: acc) V.reprs) (C_init_noesc v :: acc) V.reprs) (List.map (fun v -> C_init_esc v) V.reprs) V.reprs let hash = hash let equal = equal let compare = Datatype.undefined let copy = Datatype.undefined let rehash = Datatype.identity let pretty = pretty let internal_pretty_code = Datatype.undefined let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) module Top_Param = Base.SetLattice let is_isotropic t = V.is_isotropic (get_v t) let cardinal_zero_or_one_or_isotropic t = cardinal_zero_or_one t || is_isotropic t let cast ~size ~signed t = let v, ok = V.cast ~size ~signed (get_v t) in create (get_flags t) v, ok let extract_bits ~topify ~start ~stop ~size t = let inform_extract_pointer_bits, v = V.extract_bits ~topify ~start ~stop ~size (get_v t) in inform_extract_pointer_bits, create (get_flags t) v let little_endian_merge_bits ~topify ~conflate_bottom ~total_length ~value ~offset t = create ((get_flags t) land (get_flags value)) (V.little_endian_merge_bits ~topify ~conflate_bottom ~total_length ~value:(get_v value) ~offset (get_v t)) let big_endian_merge_bits ~topify ~conflate_bottom ~total_length ~length ~value ~offset t = create ((get_flags t) land (get_flags value)) (V.big_endian_merge_bits ~topify ~conflate_bottom ~total_length ~length ~value:(get_v value) ~offset (get_v t)) let topify_merge_origin t = create (get_flags t) (V.topify_merge_origin (get_v t)) let topify_arith_origin t = create (get_flags t) (V.topify_arith_origin (get_v t)) let topify_misaligned_read_origin t = create (get_flags t) (V.topify_misaligned_read_origin (get_v t)) let topify_with_origin o t = create (get_flags t) (V.topify_with_origin o (get_v t)) let topify_with_origin_kind ok t = create (get_flags t) (V.topify_with_origin_kind ok (get_v t)) let anisotropic_cast ~size t = create (get_flags t) (V.anisotropic_cast ~size (get_v t)) let inject_top_origin o t = C_init_noesc (V.inject_top_origin o t) let under_topify t = create (get_flags t) (V.under_topify (get_v t)) let of_char c = C_init_noesc (V.of_char c) let of_int64 c = C_init_noesc (V.of_int64 c) let singleton_zero = C_init_noesc (V.singleton_zero) let unspecify_escaping_locals ~exact is_local t = let flags = get_flags t in let flags = flags land mask_init (* clear noesc flag *) in let v = get_v t in let locals, v' = V.remove_escaping_locals is_local v in let v = if exact then v' else V.join v v' in locals, create flags v let change_initialized init v = match init, v with | true, C_uninit_esc v -> C_init_esc v | true, C_uninit_noesc v -> C_init_noesc v | true, _ -> v | false, C_init_esc v -> C_uninit_esc v | false, C_init_noesc v -> C_uninit_noesc v | false, _ -> v let project_with_alarms ~with_alarms ~conflate_bottom loc v = let v_v = get_v v in let bottom = V.is_bottom v_v in let flags = get_flags v in (* distasteful FIXME *) if conflate_bottom then begin if not (is_initialized flags) then warn_uninitialized with_alarms; if not (is_noesc flags) then warn_escapingaddr with_alarms; end; if with_alarms.unspecified.a_log <> None && bottom && not (is_initialized flags && is_noesc flags ) then begin do_warn with_alarms.unspecified (fun _ -> Kernel.warning ~current:true ~once:true "completely indeterminate value %a." (Locations.pretty_english ~prefix:true) loc) end; v_v end module V_Offsetmap = Offsetmap.Make(V_Or_Uninitialized) module Default_offsetmap = struct module InitializedVars = Cil_state_builder.Varinfo_hashtbl (V_Offsetmap) (struct let name = "Cvalue.Default_offsetmap.InitializedVars" let dependencies = [ Ast.self ] let size = 117 end) let () = Ast.add_monotonic_state InitializedVars.self let create_initialized_var varinfo validity initinfo = InitializedVars.add varinfo initinfo; Base.create_initialized varinfo validity let default_offsetmap base = match base with | Base.Initialized_Var (v,_) -> (try InitializedVars.find v with Not_found -> V_Offsetmap.empty) | Base.Var _ -> begin match Base.validity base with | Base.Invalid -> V_Offsetmap.empty | Base.Known (mn, mx) | Base.Unknown (mn, _, mx) -> assert (Int.ge mx mn && Int.equal mn Int.zero); V_Offsetmap.create_isotropic ~size:(Int.succ mx) V_Or_Uninitialized.uninitialized | Base.Periodic (mn, mx, p) -> assert (Int.is_zero mn && Int.gt mx p); V_Offsetmap.create_isotropic ~size:p V_Or_Uninitialized.bottom end | Base.Null -> V_Offsetmap.empty | Base.String (_,e) -> V_Offsetmap.from_cstring (Base.get_string e) end module Model = struct include Lmap.Make_LOffset(V_Or_Uninitialized)(V_Offsetmap)(Default_offsetmap) let find_orig = find let find_unspecified = find_orig ~conflate_bottom:false let find ~conflate_bottom ~with_alarms state loc = let v = find_orig ~conflate_bottom ~with_alarms state loc in V_Or_Uninitialized.project_with_alarms ~with_alarms ~conflate_bottom loc v let reduce_by_initialized_defined_loc f loc_bits size state = try let base, offset = Locations.Location_Bits.find_lonely_key loc_bits in let ll = Ival.project_int offset in let lh = Int.pred (Int.add ll size) in let offsm = find_base base state in let aux (offl, offh) (v, modu, shift) acc = let v' = f v in if v' != v then begin if V_Or_Uninitialized.is_bottom v' then raise Exit; let il = Int.max offl ll and ih = Int.min offh lh in let abs_shift = Integer.pos_rem (Rel.add_abs offl shift) modu in (* il and ih are the bounds of the interval to reduce. We change the initialized flags in the following cases: - either we overwrite entire values, or the partly overwritten value is at the beginning or at the end of the subrange - or we do not lose information on misaligned or partial values: the result is a singleton *) if V_Or_Uninitialized.cardinal_zero_or_one_or_isotropic v' || ((Int.equal offl il || Int.equal (Int.pos_rem ll modu) abs_shift) && (Int.equal offh ih || Int.equal (Int.pos_rem (Int.succ lh) modu) abs_shift)) then let diff = Rel.sub_abs il offl in let shift_il = Rel.pos_rem (Rel.sub shift diff) modu in V_Offsetmap.add (il, ih) (v', modu, shift_il) acc else acc end else acc in let noffsm = V_Offsetmap.fold_between ~entire:true (ll, lh) aux offsm offsm in add_base base noffsm state with | Exit -> bottom | Not_found (* from find_lonely_key *) | Ival.Not_Singleton_Int (* from Ival.project_int *) -> state let find_and_reduce_indeterminate ~with_alarms state loc = let conflate_bottom = true in let v = find_orig ~conflate_bottom ~with_alarms state loc in let v_v = V_Or_Uninitialized.project_with_alarms ~with_alarms ~conflate_bottom loc v in let loc_bits = loc.loc in let state = match v with | V_Or_Uninitialized.C_uninit_esc _ | V_Or_Uninitialized.C_uninit_noesc _ | V_Or_Uninitialized.C_init_esc _ when Locations.cardinal_zero_or_one loc -> let size = try Int_Base.project loc.size with _ -> assert false (* TODO: list exceptions *) in reduce_by_initialized_defined_loc V_Or_Uninitialized.remove_indeterminateness loc_bits size state | _ -> state in state, v_v let add_binding_not_initialized acc loc = add_binding ~with_alarms:warn_none_mode ~exact:true acc loc (V_Or_Uninitialized.uninitialized) let add_binding_unspecified acc loc v = add_binding ~with_alarms:warn_none_mode ~exact:true acc loc v let add_binding ~with_alarms ~exact acc loc value = add_binding ~with_alarms ~exact acc loc (V_Or_Uninitialized.initialized value) let reduce_binding ~with_alarms acc loc value = reduce_binding ~with_alarms acc loc (V_Or_Uninitialized.initialized value) let reduce_previous_binding ~with_alarms acc loc value = reduce_previous_binding ~with_alarms acc loc (V_Or_Uninitialized.initialized value) let add_new_base base ~size v ~size_v state = let v = V_Or_Uninitialized.initialized v in add_new_base base ~size v ~size_v state let uninitialize_blocks_locals blocks state = List.fold_left (fun acc block -> List.fold_left (fun acc vi -> let base = Base.create_varinfo vi in remove_base base acc) acc block.Cil_types.blocals) state blocks let uninitialize_formals_locals fundec state = let locals = List.map Base.create_varinfo fundec.Cil_types.slocals in let formals = List.map Base.create_varinfo fundec.Cil_types.sformals in let cleanup acc v = remove_base v acc in let result = List.fold_left cleanup state locals in List.fold_left cleanup result formals end (* Local Variables: compile-command: "make -C ../.." End: *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/memory_state/int_Interv.ml��������������������������������������������0000644�0001750�0001750�00000007437�12155630237�021766� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Abstract_interp let fuzzy_order (b1, e1) (b2, e2) = if Int.lt e1 b2 then Rangemap.Above else if Int.lt e2 b1 then Rangemap.Below else Rangemap.Match exception Cannot_compare_intervals include Datatype.Make (struct (* better to not use Datatype.Pair since we customize [compare] *) type t = Int.t * Int.t let structural_descr = Structural_descr.t_tuple [| Int.packed_descr; Int.packed_descr |] let name = "Int_Interv" let reprs = List.fold_left (fun acc n1 -> List.fold_left (fun acc n2 -> (n1, n2) :: acc) acc Int.reprs) [] Int.reprs let compare x y = match fuzzy_order x y with | Rangemap.Above -> -1 | Rangemap.Below -> 1 | Rangemap.Match -> if Int.equal (fst x) (fst y) && Int.equal (snd x) (snd y) then 0 else begin (*Format.printf "Comparaison d'intervalles non comparables [%a..%a] et [%a..%a]@\n@\n" Int.pretty (fst x) Int.pretty (snd x) Int.pretty (fst y) Int.pretty (snd y);*) raise Cannot_compare_intervals end let hash (x, y) = Int.hash x + 7 * Int.hash y let equal (a,b) (c,d) = Int.equal a c && Int.equal b d let rehash = Datatype.identity let copy = Datatype.undefined let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let mem_project = Datatype.never_any_project let varname = Datatype.undefined end) let shift s (b,e) = Int.add b s, Int.add e s let check_coverage (bi,ei) concerned = ( match concerned with [] -> raise Is_not_included | ((_bj,ej),_) :: _ -> if Int.gt ei ej then raise Is_not_included); let rec check_joint concerned = match concerned with [] -> assert false | [(bj,_ej),_] -> if Int.lt bi bj then raise Is_not_included | ((bj,_ej),_) :: ((((_bk,ek),_)::_) as tail) -> if not (Int.equal bj (Int.succ ek)) then raise Is_not_included; check_joint tail in check_joint concerned let clip_itv (refb1,refe1) (b2,e2) = assert (Int.le b2 refe1 && Int.ge e2 refb1); (* the 2 is a concerned_interval of the ref *) let min = Int.max refb1 b2 in let max = Int.min refe1 e2 in min,max (* Local Variables: compile-command: "make -C ../.." End: *) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/scope/����������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�015675� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/scope/dpds_gui.ml�����������������������������������������������������0000644�0001750�0001750�00000046210�12155630237�020034� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Pretty_source open Cil_types open Cil_datatype let update_column = ref (fun _ -> ()) let add_tag buffer (name, tag_prop) start stop = let tag = Gtk_helper.make_tag buffer ~name tag_prop in Gtk_helper.apply_tag buffer tag start stop let scope_start_tag = ("startscope", [`UNDERLINE `DOUBLE]) let zones_used_tag = ("zones", [`BACKGROUND "#FFeeCC"]) let show_def_direct_tag = ("show_def", [`BACKGROUND "#FFca63"]) let show_def_indirect_tag = ("show_def_indirect", [`BACKGROUND "#FFdb74"]) let scope_b_tag = ("b_scope", [`BACKGROUND "#CCFFff"]) let scope_fb_tag = ("fb_scope", [`BACKGROUND "#CCFFee"]) let scope_f_tag = ("f_scope", [`BACKGROUND "#CCFFbb"]) let scope_p_tag = ("p_scope", [`BACKGROUND "#FFFFab"]) let scope_p_warn_tag = ("p_warn_scope", [`BACKGROUND "#D5FFAb"]) let empty_tag = ("", []) let add_msg (main_ui:Design.main_window_extension_points) txt = main_ui#annot_window#buffer#insert (txt ^ "\n") let pretty_zone fmt z = Format.fprintf fmt "@[<h 1>%a@]" Locations.Zone.pretty z let ask_for_lval (main_ui:Design.main_window_extension_points) kf stmt = let txt = GToolbox.input_string ~title:"Input lvalue expression" "" in match txt with None | Some "" -> None | Some txt -> 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 Some (txt, lval) with e -> main_ui#error "[ask for lval] '%s' invalid expression: %s@." txt (Printexc.to_string e); None let get_kf_stmt_opt localizable = match (Pretty_source.kf_of_localizable localizable, Pretty_source.ki_of_localizable localizable) with Some kf, Kstmt st -> Some(kf,st) | Some _, Kglobal | None, _ -> None let get_annot_opt localizable = match localizable with | Pretty_source.PIP(Property.IPCodeAnnot(_,_,annot)) -> Some annot | _ -> None (** [kf_stmt_opt] is used if we want to ask the lval to the user in a popup *) let get_lval_opt main_ui kf_stmt_opt localizable = match localizable with | Pretty_source.PLval (Some _kf, (Kstmt _stmt), lv) -> let lv_txt = Pretty_utils.sfprintf "%a" Printer.pp_lval lv in Some (lv_txt, lv) | _ -> ( match kf_stmt_opt with None -> None | Some (kf, stmt) -> match (ask_for_lval main_ui kf stmt) with None -> None | Some (lv_txt, lv) -> Some (lv_txt, lv)) module Kf_containing_highlighted_stmt = Kernel_function.Make_Table (Datatype.String.Set) (struct let name = "Dpds_gui.Kf_containing_highlighted_stmt" let size = 7 let dependencies = [ (*Dependencies are managed manually by Make_StmtSetState*) ] end) let default_icon_name = "gtk-apply" let default_icon = Datatype.String.Set.singleton default_icon_name module Make_StmtSetState (Info:sig val name: string end) = struct include State_builder.Ref (Stmt.Set) (struct let name = Info.name let dependencies = [ Db.Value.self ] 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) default_icon) s; !update_column `Contents end module Make_StmtMapState (Info:sig val name: string end) = struct module D = Datatype include State_builder.Ref (Stmt.Map.Make(Datatype.String.Set)) (struct let name = Info.name let dependencies = [ Db.Value.self ] let default () = Stmt.Map.empty end) let set s = set s; Kf_containing_highlighted_stmt.clear (); Stmt.Map.iter (fun stmt s -> let kf = Kernel_function.find_englobing_kf stmt in let prev = try Kf_containing_highlighted_stmt.find kf with Not_found -> D.String.Set.empty in let union = D.String.Set.union prev s in Kf_containing_highlighted_stmt.replace kf union) s; !update_column `Contents end module type DpdCmdSig = sig type t_in val help : string val get_info : (Kernel_function.t * Cil_types.stmt) option -> string val compute : Kernel_function.t -> Cil_types.stmt -> t_in -> string val tag_stmt : Cil_types.stmt -> (string * GText.tag_property list) val clear: unit -> unit end module DataScope : (DpdCmdSig with type t_in = lval) = struct type t_in = lval module Fscope = Make_StmtSetState (struct let name = "Dpds_gui.Highlighter.Fscope" end) module FBscope = Make_StmtSetState (struct let name = "Dpds_gui.Highlighter.FBscope" end) module Bscope = Make_StmtSetState (struct let name = "Dpds_gui.Highlighter.Bscope" end) let clear () = Fscope.clear(); FBscope.clear(); Bscope.clear() let help = ("[data_scope] " ^"highlight the statements where the value of D is the same " ^"than at its value at L.\n\t" ^"For more information, please look at the Scope plugin documentation.") let get_info _kf_stmt_opt = if Stmt.Set.is_empty (Fscope.get ()) && Stmt.Set.is_empty (FBscope.get ()) && Stmt.Set.is_empty (Bscope.get ()) then "" else "[scope] selected" let compute kf stmt lval = let f, (fb, b) = !Db.Scope.get_data_scope_at_stmt kf stmt lval in Fscope.set f; FBscope.set fb; Bscope.set b; "[scope] computed" let tag_stmt stmt = if Stmt.Set.mem stmt (Fscope.get()) then scope_f_tag else if Stmt.Set.mem stmt (FBscope.get()) then scope_fb_tag else if Stmt.Set.mem stmt (Bscope.get()) then scope_b_tag else empty_tag end module Pscope (* : (DpdCmdSig with type t_in = code_annotation) *) = struct type t_in = code_annotation module Pscope = Make_StmtSetState (struct let name = "Dpds_gui.Highlighter.Pscope" end) module Pscope_warn = State_builder.List_ref (Code_annotation) (struct let name = "Dpds_gui.Highlighter.Pscope_warn" let dependencies = [ Db.Value.self ] end) let clear () = Pscope.clear(); Pscope_warn.clear() let help = ("[prop_scope] " ^"highlight the statements where the value of the assertion is also ok\n\t" ^"For more information, please look at the Scope plugin documentation.") let get_info _kf_stmt_opt = if Stmt.Set.is_empty (Pscope.get ()) then "" else "[prop_scope] selected" let compute kf stmt annot = let s1, s2 = !Db.Scope.get_prop_scope_at_stmt kf stmt annot in Pscope.set s1; Pscope_warn.set s2; "[prop_scope] computed" let tag_stmt stmt = (*if Stmt.Set.mem stmt (Pscope_warn.get()) then scope_p_warn_tag else*) if Stmt.Set.mem stmt (Pscope.get()) then scope_p_tag else empty_tag let tag_annot annot = let tag = List.exists (fun a -> a.annot_id = annot.annot_id) (Pscope_warn.get()) in if tag then scope_p_warn_tag else empty_tag end module ShowDef : (DpdCmdSig with type t_in = lval) = struct type t_in = lval module ShowDefState = Make_StmtMapState (struct let name = "Dpds_gui.Highlighter.ShowDef" end) let clear () = ShowDefState.clear() let help = ("[show_def] " ^"highlight the statements that define the value of D at L,\n\t" ^"and print a message if a part of D might be undefined.\n\t" ^"Notice that 'undefined' only means here " ^"not defined on some path from the beginning of the function.") let get_info _kf_stmt_opt = if Stmt.Map.is_empty (ShowDefState.get()) then "" else "[show_def] selected" let indirect_icon = Datatype.String.Set.singleton "gtk-jump-to" let conv m = let aux stmt (direct, indirect) acc = let empty = Datatype.String.Set.empty in let direct = if direct then default_icon else empty in let indirect = if indirect then indirect_icon else empty in let s = Datatype.String.Set.union direct indirect in if Datatype.String.Set.is_empty s then acc else Stmt.Map.add stmt s acc in Stmt.Map.fold aux m Stmt.Map.empty let compute kf stmt lv = let r = !Db.Scope.get_defs_with_type kf stmt lv in Datascope.R.feedback "Defs computed"; match r with | None -> clear (); "[Show Defs] nothing found. The information about some functions \ may be missing." | Some (defs, undef) -> let msg = match undef with | None -> "" | Some undef -> Pretty_utils.sfprintf "[Show Defs] notice that %a %s" pretty_zone undef "may not be defined by this function at this point" in ShowDefState.set (conv defs); msg let tag_stmt stmt = try let s = Stmt.Map.find stmt (ShowDefState.get()) in if Datatype.String.Set.mem default_icon_name s then show_def_direct_tag else show_def_indirect_tag with Not_found -> empty_tag end module Zones : (DpdCmdSig with type t_in = lval) = struct type t_in = lval module ZonesState = struct include State_builder.Option_ref (Datatype.Pair (Stmt.Hashtbl.Make(Locations.Zone)) (Stmt.Set)) (struct let name = "Dpds_gui.Highlighter.ZonesState" let dependencies = [ Db.Value.self ] 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) default_icon) (snd s); !update_column `Contents end let clear () = ZonesState.clear () let help = ("[zones] computes, for each point Li of the function, " ^"the data Di needed to know the value of D at L.\n" ^"\tAfter this computation, the result Di will be printed in the " ^" information window each time a statement Li is selected.") let get_info kf_stmt_opt = try let zones, _ = ZonesState.get () in match kf_stmt_opt with | None -> "[zones] no information for this point" | Some (_kf, stmt) -> let z = !Db.Scope.get_zones zones stmt in let txt = Pretty_utils.sfprintf "[zones] needed before stmt %d = %a" stmt.sid pretty_zone z in txt with Not_found -> "" let compute kf stmt lval = let used_stmts, zones = !Db.Scope.build_zones kf stmt lval in ZonesState.set (zones, used_stmts); "[zones] computed" let tag_stmt stmt = let is_used = try let _zones, used = ZonesState.get () in Stmt.Set.mem stmt used with Not_found -> false in if is_used then zones_used_tag else empty_tag end let help (main_ui:Design.main_window_extension_points) = let add txt = add_msg main_ui txt in add ("General : " ^"each of these commands starts from a data D at a program point L.\n\t" ^"The program point is the one that is before the selected statement,\n\t" ^"and the data is the one that is selected if any, " ^"or it can be given via a popup.\n" ^"\tIf the text given in the popup is empty, or 'Cancel' is chosen, " ^"the selection of the command is reseted."); add (ShowDef.help); add (Zones.help); add (DataScope.help); add (Pscope.help); add ("All : call the 3 commands on the same D and L."); add ("Reset : reset the internal state for all the previous commands.") module DpdsState = State_builder.Option_ref (Stmt) (struct let name = "Dpds_gui.Highlighter.DpdsState" let dependencies = [ Db.Value.self ] end) let reset () = DpdsState.clear (); ShowDef.clear (); Zones.clear (); DataScope.clear (); Pscope.clear (); Kf_containing_highlighted_stmt.clear (); !update_column `Contents let callbacks ?(defs=false) ?(zones=false) ?(scope=false) ?(pscope=false) main_ui (kf, stmt, localizable) = let compute f arg = let msg = f kf stmt arg in if msg <> "" then add_msg main_ui msg in let set_txt x = let txt = Pretty_utils.sfprintf "[dependencies] for %s before stmt %d in %a" x stmt.sid Kernel_function.pretty kf in DpdsState.set stmt; add_msg main_ui txt in let _ = if pscope then begin reset (); match get_annot_opt localizable with | Some ({annot_content = (AAssert _)} as annot) -> begin set_txt ("annotation "^(string_of_int annot.annot_id)); compute Pscope.compute annot end | _ -> () end else begin Pscope.clear (); match get_lval_opt main_ui (Some(kf, stmt)) localizable with | None -> reset () | Some (lval_txt, lval) -> begin set_txt lval_txt; if defs then compute ShowDef.compute lval else ShowDef.clear (); if zones then compute Zones.compute lval else Zones.clear (); if scope then compute DataScope.compute lval else DataScope.clear () end end in main_ui#rehighlight () let highlighter (buffer:GSourceView2.source_buffer) localizable ~start ~stop = try let start_s = DpdsState.get () in let put_tag tag = match tag with ("",[]) -> () | _ -> add_tag buffer tag start stop in match localizable with | PStmt (_,stmt) -> if start_s.sid = stmt.sid then put_tag scope_start_tag; put_tag (Pscope.tag_stmt stmt); put_tag (DataScope.tag_stmt stmt); put_tag (Zones.tag_stmt stmt ); put_tag (ShowDef.tag_stmt stmt) | PIP (Property.IPCodeAnnot (_, _, annot)) -> put_tag (Pscope.tag_annot annot) | 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. * If [~use_values], check if the value analysis has been computed. *) let add_item (main_ui:Design.main_window_extension_points) ~use_values (factory:GMenu.menu GMenu.factory) name arg_opt callback = 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 *) 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) ~button localizable = if button = 3 then begin let submenu = popup_factory#add_submenu "Dependencies" in let submenu_factory = new GMenu.factory submenu in add_item main_ui ~use_values:false submenu_factory "Help" (Some()) (fun _ -> help main_ui) ; ignore (submenu_factory#add_separator ()); let kf_stmt_opt = get_kf_stmt_opt localizable in let arg = match kf_stmt_opt with None -> None | Some (kf, stmt) -> Some (kf, stmt, localizable) in let add_zones_item name cb = add_item main_ui ~use_values:true submenu_factory name arg (fun arg -> main_ui#protect ~cancelable:true (fun () -> cb main_ui arg)) in add_zones_item "Show defs" (callbacks ~defs:true); add_zones_item "Zones" (callbacks ~zones:true); add_zones_item "DataScope" (callbacks ~scope:true); add_zones_item "PropScope" (callbacks ~pscope:true); ignore (submenu_factory#add_separator ()); add_zones_item "Show All" (callbacks ~defs:true ~zones:true ~scope:true); add_item main_ui ~use_values:false submenu_factory "Reset All" (Some()) (fun _ -> reset () ; main_ui#rehighlight ()) end let filetree_decorate main_ui = main_ui#file_tree#append_pixbuf_column ~title:"Scope" (fun globs -> let icons = function | GFun ({svar = v }, _) -> (try Kf_containing_highlighted_stmt.find (Globals.Functions.get v) with Not_found -> Datatype.String.Set.empty) | _ -> Datatype.String.Set.empty in let ids = if Kf_containing_highlighted_stmt.length () <> 0 then let icons = List.fold_left (fun acc glob -> Datatype.String.Set.union (icons glob) acc) Datatype.String.Set.empty globs in if Datatype.String.Set.is_empty icons then Datatype.String.Set.singleton "" else icons else Datatype.String.Set.singleton "" in let icons = if Datatype.String.Set.mem default_icon_name ids then [default_icon_name] else Datatype.String.Set.elements (Datatype.String.Set.remove default_icon_name ids) in List.map (fun icon -> `STOCK_ID icon) icons ) (fun _ -> Kf_containing_highlighted_stmt.length () <>0) let main main_ui = main_ui#register_source_selector selector; main_ui#register_source_highlighter highlighter; update_column := (filetree_decorate main_ui) let () = Design.register_extension main ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/scope/Scope.mli�������������������������������������������������������0000644�0001750�0001750�00000003271�12155630237�017460� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Scope analysis. *) (** No function is directly exported: they are registered in !Db.Scope. *) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/scope/defs.ml���������������������������������������������������������0000644�0001750�0001750�00000024506�12155630237�017163� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** 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 module Interproc = Datascope.R.True(struct let option_name = "-scope-defs-interproc" let help = "interprocedural defs computation" end) module NSet = PdgTypes.Node.Set let add_list_to_set l s = List.fold_left (fun r n -> NSet.add n r) s l let _pp_list_node_underout prefix fmt = Pretty_utils.pp_list ~pre:(prefix ^^ " @[") ~suf:"@]@." ~sep:"@ " (fun fmt (n, undef) -> match undef with | None -> PdgTypes.Node.pretty fmt n | Some undef -> Format.fprintf fmt "%a {underout %a}" PdgTypes.Node.pretty n Locations.Zone.pretty undef) fmt let _pp_set prefix fmt = Pretty_utils.pp_iter ~pre:(prefix ^^ " @[") ~suf:"@]@." ~sep:"@ " NSet.iter PdgTypes.Node.pretty fmt (** The nodes [nodes] define the searched location [z]. If those nodes are calls to functions, go inside those calls, and find which nodes are relevant. *) let rec add_callee_nodes z acc nodes = let new_nodes, acc = NSet.fold (fun node acc2 -> 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 = match out_key with | PdgIndex.Signature.OutLoc out -> (* [out] might be an over-approximation of the location we are searching for. We refine the search if needed. *) let z = Locations.Zone.narrow out z in fst (!Db.Pdg.find_location_nodes_at_end callee_pdg z) | PdgIndex.Signature.OutRet -> (* probably never occurs *) fst (!Db.Pdg.find_output_nodes callee_pdg out_key) in let outputs = List.map fst outputs in add_list_to_set outputs new_nodes, add_list_to_set outputs acc) callees acc2 | _ -> acc2) nodes (NSet.empty, acc) in if NSet.is_empty new_nodes then acc else add_callee_nodes z acc new_nodes (** [kf] doesn't define all the data that we are looking for: the [undef] zone must have been defined in its caller, let's find it. [z] is the initial zone that we are looking for, so that we do not look for more than it. *) (* BYTODO: maybe [undef] could be used instead of [z] altogether *) let rec add_caller_nodes z kf acc (undef, nodes) = let join_undef u u' = match u, u' with | _, None -> u | None, Some _ -> u' | Some z, Some z' -> Some (Locations.Zone.join z z') in let add_one_call_nodes pdg (acc_undef, acc) stmt = let acc_undef, acc = match undef with | None -> acc_undef, acc | Some undef -> let nodes_for_undef, undef' = !Db.Pdg.find_location_nodes_at_stmt pdg stmt ~before:true undef in let acc_undef = join_undef acc_undef undef' in let acc = add_list_to_set (List.map fst nodes_for_undef) acc in acc_undef, acc in let add_call_input_nodes node (acc_undef, acc) = 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 -> let n = !Db.Pdg.find_call_input_node pdg stmt n_param in acc_undef, NSet.add n acc | PdgIndex.Signature.InImpl z' -> let z = Locations.Zone.narrow z z' in let nodes, undef'= !Db.Pdg.find_location_nodes_at_stmt pdg stmt ~before:true z in let acc_undef = join_undef acc_undef undef' in acc_undef, add_list_to_set (List.map fst nodes) acc end | _ -> acc_undef, acc in NSet.fold add_call_input_nodes nodes (acc_undef, acc) in let add_one_caller_nodes acc (kf, stmts) = let pdg = !Db.Pdg.get kf in let acc_undef, caller_nodes = List.fold_left (add_one_call_nodes pdg) (None, NSet.empty) stmts in add_caller_nodes z kf (NSet.union caller_nodes acc) (acc_undef, caller_nodes) in List.fold_left add_one_caller_nodes acc (!Db.Value.callers kf) let compute_aux kf stmt lval = debug1 "[Defs.compute] for %a at sid:%d in '%a'@." Printer.pp_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 = add_list_to_set (List.map fst nodes) NSet.empty in let nodes = if Interproc.get () then begin let caller_nodes = add_caller_nodes zone kf nodes (undef, nodes) in add_callee_nodes zone caller_nodes caller_nodes end else nodes in Some (nodes, undef) with Db.Pdg.Bottom | Db.Pdg.Top | Not_found -> None let compute kf stmt lval = let extract (nodes, undef) = let add_node node defs = 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 = NSet.fold add_node nodes Stmt.Set.empty in (defs, undef) in Extlib.opt_map extract (compute_aux kf stmt lval) (* Variation of the function above. For each PDG node that has been found, we find whether it directly modifies [lval] through an affectation (statements [Set] or [Call (lv, _)], or if the change is indirect through the body of a call. *) let compute_with_def_type kf stmt lval = let extract (nodes, undef) = let add_node node acc = let change stmt (direct, indirect) = let (prev_d, pred_i) = try Stmt.Map.find stmt acc with Not_found -> (false, false) in let after = (direct || prev_d, indirect || pred_i) in Stmt.Map.add stmt after acc in match !Db.Pdg.node_key node with | PdgIndex.Key.Stmt s -> change s (true, false) | PdgIndex.Key.CallStmt _ -> assert false | PdgIndex.Key.SigCallKey (s, sign) -> (match sign with | PdgIndex.Signature.Out (PdgIndex.Signature.OutRet) -> change s (true, false) (* defined by affectation in 'v = ()' *) | PdgIndex.Signature.In _ -> change s (true, false) (* defined by formal v in 'f(v)' *) | PdgIndex.Signature.Out (PdgIndex.Signature.OutLoc _) -> begin match s.skind with | Instr (Call (_, { enode = Lval (Var vi, NoOffset)}, _, _)) when let kf = Globals.Functions.get vi in !Db.Value.use_spec_instead_of_definition kf -> (* defined through a call, but function has no body *) change s (true, false) | _ -> (* defined within call to a function with a body*) change s (false, true) end ) | PdgIndex.Key.SigKey _ -> acc | s -> Format.printf "## %a@." PdgIndex.Key.pretty s; acc in let stmts = NSet.fold add_node nodes Stmt.Map.empty in (stmts, undef) in Extlib.opt_map extract (compute_aux kf stmt lval) (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) module D = Datatype.Option (Datatype.Pair(Stmt.Set)(Datatype.Option(Locations.Zone))) module DT = Datatype.Option (Datatype.Pair (Stmt.Map.Make(Datatype.Pair(Datatype.Bool)(Datatype.Bool))) (Datatype.Option(Locations.Zone))) let () = Db.register (* kernel_function -> stmt -> lval -> (Cil_datatype.Stmt.Set.t * Locations.Zone.t option) option *) (Db.Journalize ("Scope.get_defs", Datatype.func3 Kernel_function.ty Stmt.ty Lval.ty (D.ty))) Db.Scope.get_defs compute; Db.register (* kernel_function -> stmt -> lval -> ((bool, bool) Cil_datatype.Stmt.Map.t * Locations.Zone.t option) option *) (Db.Journalize ("Scope.get_defs_with_type", Datatype.func3 Kernel_function.ty Stmt.ty Lval.ty (DT.ty))) Db.Scope.get_defs_with_type compute_with_def_type; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/scope/defs.mli��������������������������������������������������������0000644�0001750�0001750�00000003252�12155630237�017327� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* This file is empty on purpose. Plugins register callbacks in src/kernel/db.ml. *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/scope/datascope.ml����������������������������������������������������0000644�0001750�0001750�00000051571�12155630237�020207� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** The aim here is to select the statements where a data D * has the same value then a given starting program point L. *) open Cil_types (*open Cil_datatype*) module R = Plugin.Register (struct let name = "scope" let shortname = "scope" let help = "data dependencies higher level functions" end) (** {2 Computing a mapping between zones and modifying statements} We first go through all the function statements in other to build a mapping between each zone and the statements that are modifying it. **) (** Statement identifier *) module StmtDefault = struct include Cil_datatype.Stmt let default = Cil.dummyStmt end (** set of values to store for each data *) module StmtSetLattice = struct include Abstract_interp.Make_Lattice_Set(StmtDefault) 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 s = inject_singleton s let to_list ~keep_default set = fold (fun n l -> if (n = StmtDefault.default) && not keep_default then l else n::l) set [] 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 (StmtSetLattice) (* Clear the (non-project compliant) internal caches each time the ast changes, which includes every time we switch project. *) let () = Ast.add_hook_on_update LM.clear_caches type t = LM.t let empty = LM.empty let find = LM.find let add_zone ~exact lmap zone sid = let new_val = StmtSetLattice.single sid in let lmap = LM.add_binding exact lmap zone new_val in lmap let test_and_merge old_lmap new_lmap = let new_lmap = LM.join old_lmap new_lmap in if LM.is_included new_lmap old_lmap then None else Some new_lmap let pretty fmt lmap = Format.fprintf fmt "Lmap = %a@\n" LM.pretty lmap end 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.enumerate_valid_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. * Something to do only for calls and assignments. * *) 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 in let process_froms lmap froms = let from_table = froms.Function_Froms.deps_table in try Lmap_bitwise.From_Model.fold (fun out _ lmap -> register lmap out) from_table lmap with Lmap_bitwise.From_Model.Cannot_fold -> (R.debug ~level:1 "register_modified_zones : top on stmt(%d) : %a@." stmt.sid Printer.pp_stmt stmt; register lmap Locations.Zone.top) in match inst with | Set (lval, _, _) -> 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, _, zone = get_lval_zones ~for_writing:true stmt lval in register lmap zone in try let froms = !Db.From.Callwise.find (Kstmt stmt) in process_froms lmap froms with Not_found -> (* don't have callwise (-calldeps option) *) let _funcexp_dpds, called_functions = !Db.Value.expr_to_kernel_function ~with_alarms:CilE.warn_none_mode (Kstmt stmt) ~deps:(Some Locations.Zone.bottom) funcexp in Kernel_function.Hptset.fold (fun kf lmap -> process_froms lmap (!Db.From.get kf)) called_functions lmap end | _ -> lmap (** compute the mapping for the function * @raise Kernel_function.No_Definition if [kf] has no definition *) let compute 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_reachable_stmt s then match s.skind with | Instr i -> register_modified_zones lmap s i | _ -> lmap else lmap in let f_datas = List.fold_left do_stmt InitSid.empty f.sallstmts in R.debug ~level:2 "data init stmts : %a" InitSid.pretty f_datas; f.sallstmts, f_datas (* TODO : store it ! *) (** {2 Computing Scopes} *) module State = struct type t = Start | NotSeen | Modif | SameVal let pretty fmt b = Format.fprintf fmt "%s" (match b with | Start -> "Start" | NotSeen -> "NotSeen" | Modif -> "Modif" | SameVal -> "SameVal") let merge b1 b2 = let b = match b1, b2 with | Start, _ | _, Start -> Start | NotSeen, b | b, NotSeen -> b | Modif, _ | _, Modif -> Modif | SameVal, SameVal -> SameVal in b let equal (b1 : t) b2 = (b1 = b2) let test_and_merge ~old new_ = let result = merge new_ old in if equal result old then None else Some result let transfer modif m = if modif then Modif else if m = Start then SameVal else m end (** Place to store the dataflow analyses results *) module GenStates (S : sig type t val pretty : Format.formatter -> t -> unit end) = struct type key = stmt type data = S.t type t = data Cil_datatype.Stmt.Hashtbl.t let states:t = Cil_datatype.Stmt.Hashtbl.create 50 let clear () = Cil_datatype.Stmt.Hashtbl.clear states let mem = Cil_datatype.Stmt.Hashtbl.mem states let find = Cil_datatype.Stmt.Hashtbl.find states let replace = Cil_datatype.Stmt.Hashtbl.replace states let add = Cil_datatype.Stmt.Hashtbl.add states let iter f = Cil_datatype.Stmt.Hashtbl.iter f states let fold f = Cil_datatype.Stmt.Hashtbl.fold f states let length () = Cil_datatype.Stmt.Hashtbl.length states let pretty fmt infos = Cil_datatype.Stmt.Hashtbl.iter (fun k v -> Format.fprintf fmt "Stmt:%d\n%a\n======" k.sid S.pretty v) infos end module States = GenStates (State) module BackwardScope (X : sig val modified : stmt -> bool end ) = struct let name = "scope(back)" let debug = ref false module StmtStartData = States type t = StmtStartData.data let pretty = State.pretty let combineStmtStartData _stmt ~old new_ = State.test_and_merge ~old new_ let combineSuccessors s1 s2 = State.merge s1 s2 let doStmt _stmt = Dataflow.Default let doInstr stmt _instr m_after = Dataflow.Done (State.transfer (X.modified stmt) m_after) let filterStmt _stmt _next = true let funcExitData = State.NotSeen let stmt_can_reach _ _ = true end let backward_data_scope allstmts modif_stmts s = States.clear (); 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.Backwards(Computer) in Compute.compute stmts module ForwardScope (X : sig val modified : stmt -> bool end ) = struct let name = "scope(forward)" let debug = ref false module StmtStartData = States type t = StmtStartData.data let pretty = State.pretty let copy (s:t) = s (* BY: the two functions below treat State.Start as a special value, and do not propagate it. See tests/scope/no-effect.i for an example where it is useful in [combinePredecessors]. It is not clear if this a limitation of the dataflow API, or if it could be simulated using the transfer function. *) let computeFirstPredecessor _stmt state = if state = State.Start then State.SameVal else state let combinePredecessors _stmt ~old new_ = let new_ = if new_ = State.Start then State.SameVal else new_ in State.test_and_merge ~old new_ let doStmt _stmt _state = Dataflow.SDefault let doInstr stmt _ m_before = Dataflow.Done (State.transfer (X.modified stmt) m_before) let stmt_can_reach _ _ = true let filterStmt _stmt = true let doGuard _ _ _ = Dataflow.GDefault, Dataflow.GDefault let doEdge _ _ d = d end let forward_data_scope modif_stmts s = States.clear (); let modified s = StmtSetLattice.mem s modif_stmts in let module Computer = ForwardScope (struct let modified = modified end) in let module Compute = Dataflow.Forwards(Computer) in States.replace s State.Start; Compute.compute [s] (* XXX *) let add_s s acc = (* we add only 'simple' statements *) match s.skind with | Instr _ | Return _ | Continue _ | Break _ | Goto _ -> Cil_datatype.Stmt.Set.add s acc | Block _ | Switch _ | If _ | UnspecifiedSequence _ | Loop _ | TryExcept _ | TryFinally _ -> acc (** Do backward and then forward propagations and compute the 3 statement sets : * - forward only, * - forward and backward, * - backward only. *) let find_scope allstmts modif_stmts s = let add fw s' x acc = match x with | State.Start -> if fw then add_s s' acc else let x = List.fold_left (fun x s -> State.merge x (States.find s)) State.NotSeen s.succs 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 let bw = States.fold (add false) Cil_datatype.Stmt.Set.empty in let _ = forward_data_scope modif_stmts s in let fw = States.fold (add true) Cil_datatype.Stmt.Set.empty in let fb = Cil_datatype.Stmt.Set.inter bw fw in let fw = Cil_datatype.Stmt.Set.diff fw fb in let bw = Cil_datatype.Stmt.Set.diff bw fb in fw, fb, bw (** Try to find the statement set where [data] has the same value than * before [stmt]. * @raise Kernel_function.No_Definition if [kf] has no definition *) let get_data_scope_at_stmt kf stmt lval = 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 let modif_stmts = InitSid.find info zone in let (f_scope, fb_scope, b_scope) = find_scope allstmts modif_stmts stmt in R.debug "@[<hv 4>get_data_scope_at_stmt %a at %d @\n\ modified by = %a@\n\ f = %a@\nfb = %a@\nb = %a@]" (* stmt at *) Locations.Zone.pretty zone stmt.sid (* modified by *) (Pretty_utils.pp_list ~sep:",@ " Cil_datatype.Stmt.pretty_sid) (StmtSetLattice.to_list ~keep_default:false modif_stmts) (* scope *) Cil_datatype.Stmt.Set.pretty f_scope Cil_datatype.Stmt.Set.pretty fb_scope Cil_datatype.Stmt.Set.pretty b_scope; (f_scope, (fb_scope, b_scope)) exception ToDo let get_annot_zone kf stmt annot = let add_zone z info = let s = info.Db.Properties.Interp.To_zone.ki in let before = info.Db.Properties.Interp.To_zone.before in let zone = info.Db.Properties.Interp.To_zone.zone in R.debug ~level:2 "[forward_prop_scope] need %a %s stmt %d@." Locations.Zone.pretty zone (if before then "before" else "after") s.sid; if before && stmt.sid = s.sid then Locations.Zone.join zone z else (* TODO *) raise ToDo in let (info, _), _ = !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 R.debug "[get_annot_zone] need %a" Locations.Zone.pretty zone ; zone (** add [annot] to [acc] if it is not already in. [acc] is supposed to be sorted according to [annot_id]. @return true if it has been added. *) let rec add_annot annot acc = match acc with | [] -> [ annot ], true | a :: tl -> if annot.annot_id < a.annot_id then annot::acc, true else if annot.annot_id = a.annot_id then acc, false else let tl, added = add_annot annot tl in a::tl, added (** Check if some assertions before [s] are identical to [pred]. * Add them to acc if any *) let check_stmt_annots pred stmt acc = let check _ annot acc = match annot.annot_content with | AAssert (_, p) -> if Logic_utils.is_same_predicate p.content pred.content then let acc, added =add_annot annot acc in if added then R.debug "annot at stmt %d could be removed: %a" stmt.sid Printer.pp_code_annotation annot; acc else acc | _ -> acc in Annotations.fold_code_annot check stmt acc (** Return the set of stmts (scope) where [annot] has the same value * than in [stmt] * and add to [to_be_removed] the annotations that are identical to [annot] * in the statements that are both the scope and that are dominated by stmt. * *) 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 kf Printer.pp_code_annotation annot; let sets = (Cil_datatype.Stmt.Set.empty, to_be_removed) in try let zone = get_annot_zone kf stmt annot in let _allstmts, info = compute kf in let modif_stmts = InitSid.find info zone in let _ = forward_data_scope modif_stmts stmt in let pred = match annot.annot_content with | AAssert (_, p) -> p | _ -> R.abort "only 'assert' are handled here" in let add s x ((acc_scope, acc_to_be_rm) as acc) = match x with | State.Start -> (add_s s acc_scope, acc_to_be_rm) | State.SameVal -> 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 sets with ToDo -> R.warning "[get_annot_zone] don't know how to compute zone: skip this annotation"; sets (** Collect the annotations that can be removed because they are redondant. *) class check_annot_visitor = object(self) inherit Visitor.frama_c_inplace val mutable to_be_removed = [] method get_to_be_removed () = to_be_removed method vcode_annot annot = let kf = Extlib.the self#current_kf in let stmt = Cil.get_original_stmt self#behavior (Extlib.the self#current_stmt) in let _ = match annot.annot_content with | AAssert (_, _) -> R.debug ~level:2 "[check] annot %d at stmt %d in %a : %a@." annot.annot_id stmt.sid Kernel_function.pretty kf Printer.pp_code_annotation annot; let _, added = add_annot annot to_be_removed in (* just check if [annot] is in [to_be_removed] : * don't add it... *) if added then (* annot is not already removed *) let _scope, rem = get_prop_scope_at_stmt kf stmt ~to_be_removed annot in to_be_removed <- rem | _ -> () in Cil.SkipChildren method vglob_aux g = match g with | GFun (_, _loc) when !Db.Value.is_called (Extlib.the self#current_kf) -> Cil.DoChildren | _ -> Cil.SkipChildren method vexpr _ = Cil.SkipChildren end (* class check_annot_visitor *) let f_check_asserts () = let visitor = new check_annot_visitor in ignore (Visitor.visitFramacFile (visitor:>Visitor.frama_c_visitor) (Ast.get ())); visitor#get_to_be_removed () let check_asserts () = R.feedback "check if there are some redondant assertions..."; let to_be_removed = f_check_asserts () in let n = List.length to_be_removed in R.result "[check_asserts] %d assertion(s) could be removed@." n; to_be_removed (* erasing optional arguments *) let get_prop_scope_at_stmt kf stmt annot = get_prop_scope_at_stmt kf stmt annot (** Visitor to remove the annotations collected by [check_asserts]. * In fact, it changes them to [assert true;] * *) class rm_annot_visitor to_be_removed = object inherit Visitor.frama_c_inplace method vcode_annot annot = let _, not_in = add_annot annot to_be_removed in if not_in then (* not to be removed *) Cil.SkipChildren else (* is to be removed *) match annot.annot_content with | AAssert (_, p) -> R.debug ~level:2 "[rm_asserts] removing redundant %a@." Printer.pp_code_annotation annot; let p = { p with content = Ptrue } in let aassert = AAssert ([], p) in let annot = { annot with annot_content = aassert } in Cil.ChangeTo annot | _ -> Cil.SkipChildren end (** Remove the annotations collected by [check_asserts]. *) let rm_asserts () = let to_be_removed = f_check_asserts () in let n = List.length to_be_removed in (if n > 0 then R.feedback "[rm_asserts] removing %d assertion(s)@." n); let visitor = new rm_annot_visitor to_be_removed in Visitor.visitFramacFileSameGlobals visitor (Ast.get ()) (* let code_annotation_type = ??? TODO *) (** Register external functions into Db. *) let () = Db.register (* kernel_function -> stmt -> lval -> Cil_datatype.Stmt.Set.t * (Cil_datatype.Stmt.Set.t * Cil_datatype.Stmt.Set.t) *) (Db.Journalize ("Scope.get_data_scope_at_stmt", Datatype.func3 Kernel_function.ty Cil_datatype.Stmt.ty Cil_datatype.Lval.ty (Datatype.pair Cil_datatype.Stmt.Set.ty (Datatype.pair Cil_datatype.Stmt.Set.ty Cil_datatype.Stmt.Set.ty)))) Db.Scope.get_data_scope_at_stmt get_data_scope_at_stmt; Db.register (* (kernel_function -> stmt -> code_annotation -> Cil_datatype.Stmt.Set.t * code_annotation list *) Db.Journalization_not_required (* TODO *) (* (Db.Journalize("Scope.get_prop_scope_at_stmt", Datatype.func Kernel_type.kernel_function (Datatype.func Kernel_type.stmt (Datatype.func code_annotation_type (Datatype.couple Kernel_type.stmt_set (Datatype.list code_annotation_type)))))) *) Db.Scope.get_prop_scope_at_stmt get_prop_scope_at_stmt; Db.register (* unit -> code_annotation list *) Db.Journalization_not_required (* TODO *) (* (Db.Journalize("Scope.check_asserts", Datatype.func Datatype.unit (Datatype.list code_annotation_type))) *) Db.Scope.check_asserts check_asserts; Db.register (Db.Journalize ("Scope.rm_asserts", Datatype.func Datatype.unit Datatype.unit)) Db.Scope.rm_asserts rm_asserts (* Local Variables: compile-command: "make -C ../.." End: *) ���������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/scope/zones.ml��������������������������������������������������������0000644�0001750�0001750�00000033330�12155630237�017373� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module R = Datascope.R let debug1 fmt = R.debug ~level:1 fmt let debug2 fmt = R.debug ~level:2 fmt open Cil_datatype open Cil_types module Data = struct type t = Locations.Zone.t let bottom = Locations.Zone.bottom let equal = Locations.Zone.equal let intersects = Locations.Zone.valid_intersects let merge = Locations.Zone.join (* over-approx *) 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 stmt exp end module Ctx = struct 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 Stmt.Hashtbl.replace ctx k d (* let mem = Stmt.Hashtbl.mem : useless because Ctx has to be initialized to bot *) let _pretty fmt infos = Stmt.Hashtbl.iter (fun k d -> Format.fprintf fmt "Stmt:%d -> %a@\n" k.sid Data.pretty d) infos end let compute_new_data old_zone l_zone l_dpds exact r_dpds = if (Data.intersects old_zone l_zone) then let zone = if exact then Data.diff old_zone l_zone else old_zone in let zone = Data.merge zone l_dpds in let zone = Data.merge zone r_dpds in (true, zone) else (false, old_zone) (* the call result can be processed like a normal assignment *) let process_call_res data stmt lvaloption froms = let data = match lvaloption with | None -> false, data | 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 ~for_writing:true stmt lval in compute_new_data data l_zone l_dpds exact r_dpds in data (* we need [data_after] zone after the call, so we need to add the dpds * of each output that intersects this zone. * Moreover, we need to add the part of [data_after] that has not been * modified for sure. *) let process_froms data_after froms = let from_table = froms.Function_Froms.deps_table in let process_out_call out (default, out_dpds) (to_prop, used, new_data) = let exact = not default in (* be careful to compare out with data_after and not new_data *) if (Data.intersects data_after out) then let to_prop = if exact then Data.diff to_prop out else to_prop in let new_data = Data.merge new_data out_dpds in (to_prop, true, new_data) else (to_prop, used, new_data) in let to_prop = (* part of data_after that we need to compute before call : * = data_after minus all exact outputs. * Don't use [data_after - (merge out)] to avoid approximation in merge *) data_after in let new_data = Data.bottom in (* add out_dpds when out intersects data_after*) let used = false in (* is the call needed ? *) let to_prop, used, new_data = try Lmap_bitwise.From_Model.fold process_out_call from_table (to_prop, used, new_data) with Lmap_bitwise.From_Model.Cannot_fold -> process_out_call Locations.Zone.top (false, Locations.Zone.top) (to_prop, used, new_data) in let data = Data.merge to_prop new_data in (used, data) let process_call_args data called_kf stmt args = let param_list = Kernel_function.get_formals called_kf in let asgn_arg_to_param data param arg = let param_zone = Locations.zone_of_varinfo param in let arg_dpds = Data.exp_zone stmt arg in let exact = true in (* param is always a variable so asgn is exact *) let _used, data = compute_new_data data param_zone Data.bottom exact arg_dpds in (* can ignore 'used' because if we need param, we already know that the * call is needed *) data in let rec do_param_arg data param_list args = match param_list, args with | [], [] -> data | p :: param_list, a :: args -> let data = asgn_arg_to_param data p a in do_param_arg data param_list args | [], _ -> (* call to a variadic function *) (* warning already sent during 'from' computation. *) (* TODO : merge the remaining args in data ?... *) data | _, [] -> R.abort "call to a function with to few arguments" in do_param_arg data param_list args let process_one_call data stmt lvaloption froms = let res_used, data = process_call_res data stmt lvaloption froms in let out_used, data = process_froms data froms in let used = res_used || out_used in used, data let process_call data_after stmt lvaloption funcexp args = let funcexp_dpds, called_functions = !Db.Value.expr_to_kernel_function ~with_alarms:CilE.warn_none_mode (Kstmt stmt) ~deps:(Some Data.bottom) funcexp in let used, data = try let froms = !Db.From.Callwise.find (Kstmt stmt) in process_one_call data_after stmt lvaloption froms with Not_found -> (* don't have callwise (-calldeps option) *) let do_call kf acc = (* notice that we use the same old data for each possible call *) (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 *) List.fold_left (fun (acc_u,acc_d) (u,d) -> (acc_u || u), Data.merge acc_d d) (false, Data.bottom) 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 data in let data = Data.merge funcexp_dpds data in used, data else begin assert (R.verify (Data.equal data data_after) "if statement not used, data doesn't change !"); used, data end module Computer (Param:sig val states : Ctx.t end) = struct let name = "Zones" let debug = ref false let used_stmts = ref [] let add_used_stmt stmt = used_stmts := stmt :: !used_stmts let get_and_reset_used_stmts () = let stmts = !used_stmts in used_stmts := [] ; stmts type t = Data.t let pretty = Data.pretty module StmtStartData = struct type data = t 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_ = let result = Data.merge old new_ in if Data.equal result old then None else Some result let combineSuccessors = Data.merge let doStmt _stmt = Dataflow.Default let doInstr stmt instr data = match instr with | Set (lval, exp, _) -> 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 Dataflow.Done data | Call (lvaloption,funcexp,args,_) -> let used, data = process_call data stmt lvaloption funcexp args in let _ = if used then add_used_stmt stmt in Dataflow.Done data | _ -> Dataflow.Default let filterStmt _stmt _next = true let funcExitData = Data.bottom let stmt_can_reach _ _ = true end let compute_ctrl_info pdg ctrl_part used_stmts = let module CtrlComputer = Computer (struct let states = ctrl_part end) 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 = 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 -> debug2 "[zones] node %a is stmt %d@." PdgTypes.Node.pretty ctrl_node stmt.sid; 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 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 = debug1 "[zones] add ctrl of stmt %d@." stmt.sid; if Stmt.Hashtbl.mem seen stmt then new_stmts else begin Stmt.Hashtbl.add seen stmt (); match !Db.Pdg.find_simple_stmt_nodes pdg stmt with | [] -> [] | n::_ -> add_node_ctrl_nodes new_stmts n end in let rec add_stmts_ctrl stmts all_used_stmts = let all_used_stmts = stmts @ all_used_stmts in let new_stmts = List.fold_left add_stmt_ctrl [] stmts in let preds = List.fold_left (fun acc s -> s.preds @ acc) [] new_stmts in if preds <> [] then CtrlCompute.compute preds; let used_stmts = CtrlComputer.get_and_reset_used_stmts () in if used_stmts = [] then all_used_stmts else add_stmts_ctrl used_stmts all_used_stmts in add_stmts_ctrl used_stmts [] let compute kf stmt lval = let f = Kernel_function.get_definition kf in let dpds, _exact, zone = Datascope.get_lval_zones ~for_writing:false stmt lval in let zone = Data.merge dpds zone in 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 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.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, * because in fact, it means nothing to separate them. * So let's put everything in the same object *) let used_stmts = DataComputer.get_and_reset_used_stmts () in let all_used_stmts = if used_stmts = [] then [] else compute_ctrl_info (!Db.Pdg.get kf) ctrl_part used_stmts in let all_used_stmts = List.fold_left (fun e acc -> Stmt.Set.add acc e) Stmt.Set.empty all_used_stmts in all_used_stmts, data_part let get stmt_zones stmt = 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.sid Data.pretty d in (* Sort output so that it does not depend on the OCaml hash function. Can be removed when OCaml 4.01 is mandatory *) let sorted = Stmt.Hashtbl.fold Stmt.Map.add stmt_zones Stmt.Map.empty in Stmt.Map.iter pp sorted (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) let () = Db.register (* kernel_function -> stmt -> lval -> StmtSet.t * t_zones *) Db.Journalization_not_required (* TODO *) (* (Db.Journalize("Scope.build_zones", Datatype.func Kernel_type.kernel_function (Datatype.func Kernel_type.stmt (Datatype.func Kernel_type.lval (Datatype.couple Kernel_type.stmt_set zones_ty))))) *) Db.Scope.build_zones compute; Db.register (* t_zones -> Cil_types.stmt -> Locations.Zone.t *) Db.Journalization_not_required (* TODO *) (*(Db.Journalize("Scope.get_zones", Datatype.func zones_ty (Datatype.func Kernel_type.stmt data_ty)))*) Db.Scope.get_zones get; Db.register (* (Format.formatter -> t_zones -> unit) *) Db.Journalization_not_required (* TODO *) (*(Db.Journalize("Scope.pretty_zones", Datatype.func Datatype.formatter (Datatype.func zones_ty Datatype.unit)))*) Db.Scope.pretty_zones pretty; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/scope/zones.mli�������������������������������������������������������0000644�0001750�0001750�00000003252�12155630237�017544� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* This file is empty on purpose. Plugins register callbacks in src/kernel/db.ml. *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/report/���������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016102� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/report/dump.mli�������������������������������������������������������0000644�0001750�0001750�00000003202�12155630227�017547� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/report/configure������������������������������������������������������0000755�0001750�0001750�00000274256�12155634042�020030� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 </dev/null exec 6>&1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME= PACKAGE_TARNAME= PACKAGE_VERSION= PACKAGE_STRING= PACKAGE_BUGREPORT= PACKAGE_URL= ac_unique_file="Makefile.in" ac_subst_vars='LTLIBOBJS LIBOBJS DYNAMIC_REPORT ENABLE_REPORT ENABLE_GUI FRAMAC_VERSION 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= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures this package to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then cat <<\_ACEOF 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.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu 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 FRAMAC_VERSION=`frama-c -version | sed -n -e "s|^Version: *\(.*\)$|\1|p"` # 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 ${ac_cv_prog_ENABLE_GUI+:} false; 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 as_fn_executable_p "$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 ${ac_cv_file_Makefile_in+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "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" = xyes; 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 if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\[/\\&/g s/\]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "./Makefile") 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= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' </dev/null 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 {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' <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 >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" eval set X " :F $CONFIG_FILES " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac 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 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/report/Report.mli�����������������������������������������������������0000644�0001750�0001750�00000003241�12155630227�020060� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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: they are registered in {!Db.Report}. *) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/report/Makefile.in����������������������������������������������������0000644�0001750�0001750�00000005237�12155630227�020156� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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:= report_parameters 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 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/report/scan.ml��������������������������������������������������������0000644�0001750�0001750�00000011717�12155630227�017367� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 -> let vi = Kernel_function.get_vi kf in if not (Cil.is_unused_builtin vi) then report (fun () -> inspector#function_section kf) inspector#property !ips) !functions ; inspector#finished ; end end (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������frama-c-Fluorine-20130601/src/report/register.ml����������������������������������������������������0000644�0001750�0001750�00000005013�12155630227�020257� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Plug-in Implementation --- *) (* -------------------------------------------------------------------------- *) let print () = Report_parameters.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 print, _ = State_builder.apply_once "Report.print_once" [ Report_parameters.Enabled.self; (* reprint if we explicitly ask for *) Report_parameters.PrintProperties.self; Property_status.self ] print let main () = if Report_parameters.Enabled.get () then print () let () = Db.Report.print := print; Db.Main.extend main; (* Local Variables: compile-command: "make -C ../.." End: *) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/report/report_parameters.mli������������������������������������������0000644�0001750�0001750�00000003244�12155630227�022346� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.S module Enabled : Plugin.Bool module PrintProperties: Plugin.Bool ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/report/scan.mli�������������������������������������������������������0000644�0001750�0001750�00000004416�12155630227�017536� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/report/dump.ml��������������������������������������������������������0000644�0001750�0001750�00000020440�12155630227�017401� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 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_maybe_unreachable = 0 ; (* possible unreachable *) val mutable st_unreachable = 0 ; (* confirmed unreachable *) 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 ip st = match ip, st with (* Special display for unreachable *) | Property.IPReachable _, Invalid_under_hyp _ -> st_maybe_unreachable <- succ st_maybe_unreachable; "Possibly unreachable" | Property.IPReachable _, Invalid _ -> st_unreachable <- succ st_unreachable; "Unreachable" (* All other cases, including some unreachable *) | _, (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 ~kloc: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 ~kloc:true) p) ps ) (Scan.partial_pending ps) method property ip st = begin Format.fprintf out "%a @[%a@]@\n" pp_status (self#category ip st) (Description.pp_localized ~kf:`Never ~ki:true ~kloc:true) ip ; if Report_parameters.PrintProperties.get () then Format.fprintf out "%s@[%a@]@\n" tab Property.pretty 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 = 1 then Format.fprintf out " %4d Alarm emitted@\n" st_alarm ; if st_alarm > 1 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_maybe_unreachable > 0 then Format.fprintf out " %4d Unconfirmed unreachable@\n" st_maybe_unreachable ; if st_unreachable > 0 then Format.fprintf out " %4d Unreachable@\n" st_unreachable ; 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: *) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/report/configure.ac���������������������������������������������������0000644�0001750�0001750�00000004317�12155630227�020375� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/report/register.mli���������������������������������������������������0000644�0001750�0001750�00000003635�12155630227�020440� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Report Properties Status --- *) (* -------------------------------------------------------------------------- *) val print : unit -> unit (* Local Variables: compile-command: "make -C ../.." End: *) ���������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/report/report_parameters.ml�������������������������������������������0000644�0001750�0001750�00000004127�12155630227�022176� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.Register (struct let name = "report" let shortname = "report" let help = "Properties Status Report (experimental)" end) module Enabled = False (struct let option_name = "-report" let help = "display a summary of properties status" end) module PrintProperties = False (struct let option_name = "-report-print-properties" let help = "print not only the locations, but also the \ properties themselves" end) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/������������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�015332� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/setWithNearest.mli������������������������������������������������0000644�0001750�0001750�00000003064�12155630226�021013� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (* File modified by CEA (Commissariat à l'énergie atomique et aux *) (* énergies alternatives). *) (**************************************************************************) (** Set equiped with operations to find nearest element greater or less than the required value *) module type S = sig include Datatype.Set val nearest_elt_le: elt -> t -> elt val nearest_elt_ge: elt -> t -> elt end (** Output signature of the functor {!SetWithNearest.Make}. *) module Make (Ord : Datatype.S) : S with type elt = Ord.t (** Functor building an implementation of the set structure given a totally ordered type. *) (* Local Variables: compile-command: "make -C ../.." End: *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/hook.ml�����������������������������������������������������������0000644�0001750�0001750�00000006077�12155630226�016640� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module type S = sig type param type result val extend: (param -> result) -> unit val extend_once: (param -> result) -> unit val apply: param -> result val is_empty: unit -> bool val clear: unit -> unit val length: unit -> int end module type Iter_hook = S with type result = unit let add_once v queue = let already = Queue.fold (fun b v' -> b || v' == v) false queue in if not already then Queue.add v queue module Build(P:sig type t end) = struct type param = P.t type result = unit let hooks = Queue.create () let extend f = Queue.add f hooks let extend_once f = add_once f hooks let apply arg = Queue.iter (fun f -> f arg) hooks (* [JS 06 October 2008] the following code iter in reverse order without changing the order of the queue itself. let list = ref [] in Queue.iter (fun f -> list := f :: !list) hooks; List.iter (fun f -> f arg) !list *) let is_empty () = Queue.is_empty hooks let clear () = Queue.clear hooks let length () = Queue.length hooks end module Fold(P:sig type t end) = struct type param = P.t type result = P.t let hooks = Queue.create () let extend f = Queue.add f hooks let extend_once f = add_once f hooks let apply arg = Queue.fold (fun arg f -> f arg) arg hooks let is_empty () = Queue.is_empty hooks let clear () = Queue.clear hooks let length () = Queue.length hooks end module Make(X:sig end) = Build(struct type t = unit end) (* Local Variables: compile-command: "make -C ../.." End: *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/extlib.ml���������������������������������������������������������0000644�0001750�0001750�00000027022�12155630226�017160� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let nop _ = () external id: 'a -> 'a = "%identity" let adapt_filename f = let change_suffix ext = try Filename.chop_extension f ^ ext with Invalid_argument _ -> f ^ ext in change_suffix (if Dynlink_common_interface.is_native then ".cmxs" else ".cmo") (* [max_cpt t1 t2] returns the maximum of [t1] and [t2] wrt the total ordering induced by tags creation. This ordering is defined as follow: forall tags t1 t2, t1 <= t2 iff t1 is before t2 in the finite sequence [0; 1; ..; max_int; min_int; min_int-1; -1] *) let max_cpt c1 c2 = max (c1 + min_int) (c2 + min_int) - min_int let number_to_color n = let color = ref 0 in let number = ref n in for _i = 0 to 7 do color := (!color lsl 1) + (if !number land 1 <> 0 then 1 else 0) + (if !number land 2 <> 0 then 256 else 0) + (if !number land 4 <> 0 then 65536 else 0); number := !number lsr 3 done; !color (* ************************************************************************* *) (** {2 Function builders} *) (* ************************************************************************* *) exception Unregistered_function of string let mk_labeled_fun s = raise (Unregistered_function (Printf.sprintf "Function '%s' not registered yet" s)) let mk_fun s = ref (fun _ -> mk_labeled_fun s) (* ************************************************************************* *) (** {2 Function combinators} *) (* ************************************************************************* *) let ($) f g x = f (g x) let swap f x y = f y x (* ************************************************************************* *) (** {2 Lists} *) (* ************************************************************************* *) let as_singleton = function | [a] -> a | _ -> invalid_arg "Extlib.as_singleton" let rec last = function | [] -> invalid_arg "Extlib.last" | [a] -> a | _ :: l -> last l let filter_out f ls = List.filter (fun x -> not (f x)) ls let filter_map filter f l = let rec aux = function [] -> [] | x::tl -> if filter x then f x :: aux tl else aux tl in aux l let filter_map' f filter l= let rec aux = function | [] -> [] | x::tl -> let x' = f x in if filter x' then x' :: aux tl else aux tl in aux l let product_fold f acc e1 e2 = List.fold_left (fun acc e1 -> List.fold_left (fun acc e2 -> f acc e1 e2) acc e2) acc e1 let product f e1 e2 = product_fold (fun acc e1 e2 -> f e1 e2 ::acc) [] e1 e2 let find_index f l = let rec aux i = function [] -> raise Not_found | x::l -> if f x then i else aux (i+1) l in aux 0 l let rec list_compare cmp_elt l1 l2 = if l1 == l2 then 0 else match l1, l2 with | [], [] -> assert false (* included in l1 == l2 above *) | [], _ :: _ -> 1 | _ :: _, [] -> -1 | v1::r1, v2::r2 -> let c = cmp_elt v1 v2 in if c = 0 then list_compare cmp_elt r1 r2 else c let list_of_opt = function | None -> [] | Some x -> [x] let opt_of_list = function | [] -> None | [a] -> Some a | _ -> raise (Invalid_argument "Extlib.opt_of_list") let rec find_opt f = function | [] -> raise Not_found | e :: q -> match f e with | None -> find_opt f q | Some v -> v let iteri f l = let i = ref 0 in List.iter (fun x -> f !i x; incr i) l let mapi f l = let res = snd (List.fold_left (fun (i,acc) x -> (i+1,f i x :: acc)) (0,[]) l) in List.rev res (* ************************************************************************* *) (** {2 Options} *) (* ************************************************************************* *) let has_some = function None -> false | Some _ -> true let may f = function | None -> () | Some x -> f x (** [may_map f ?dft x] applies [f] to the value of [x] if exists. Otherwise returns the default value [dft]. Assume that either [x] or [dft] is defined. *) let may_map f ?dft x = match x, dft with | None, None -> assert false | None, Some dft -> dft | Some x, _ -> f x let opt_map f = function | None -> None | Some x -> Some (f x) let opt_conv default = function | None -> default | Some x -> x let opt_fold f o b = match o with | None -> b | Some a -> f a b let merge_opt f k o1 o2 = match o1,o2 with | None, None -> None | Some x, None | None, Some x -> Some x | Some x1, Some x2 -> Some (f k x1 x2) let opt_bind f = function | None -> None | Some x -> f x let opt_filter f = function | None -> None | (Some x) as o -> if f x then o else None let the = function None -> invalid_arg "Extlib.the" | Some x -> x let find_or_none f v = try Some(f v) with Not_found -> None let opt_equal f v1 v2 = match v1, v2 with | None, None -> true | Some _, None | None, Some _ -> false | Some v1, Some v2 -> f v1 v2 let opt_compare f v1 v2 = match v1, v2 with | None, None -> 0 | Some _, None -> 1 | None, Some _ -> -1 | Some v1, Some v2 -> f v1 v2 (* ************************************************************************* *) (** Booleans *) (* ************************************************************************* *) let xor x y = if x then not y else y (* ************************************************************************* *) (** {2 Performance} *) (* ************************************************************************* *) external getperfcount: unit -> int = "getperfcount" external getperfcount1024: unit -> int = "getperfcount1024" let gentime counter ?msg f x = let c1 = counter () in let res = f x in let c2 = counter () in Format.printf "Time%s: %d@." (match msg with None -> "" | Some s -> " of " ^ s) (c2 - c1); res let time ?msg f x = gentime getperfcount ?msg f x let time1024 ?msg f x = gentime getperfcount1024 ?msg f x (* The two functions below are not exported right now *) let _time' name f = let cpt = ref 0 in fun x -> let b = getperfcount () in let res = f x in let e = getperfcount () in let diff = e - b in cpt := !cpt + diff; Format.eprintf "timing of %s: %d (%d)@." name !cpt diff; res let _time2 name f = let cpt = ref 0 in fun x y -> let b = getperfcount () in let res = f x y in let e = getperfcount () in let diff = e - b in cpt := !cpt + diff; Format.eprintf "timing of %s: %d (%d)@." name !cpt diff; res external address_of_value: 'a -> int = "address_of_value" (* ************************************************************************* *) (** {2 Exception catcher} *) (* ************************************************************************* *) let try_finally ~finally f x = try let r = f x in finally (); r with e -> finally (); raise e (* ************************************************************************* *) (** System commands *) (* ************************************************************************* *) let safe_remove f = try Unix.unlink f with Unix.Unix_error _ -> () let rec safe_remove_dir d = try Array.iter (fun a -> let f = Printf.sprintf "%s/%s" d a in if Sys.is_directory f then safe_remove_dir f else safe_remove f ) (Sys.readdir d) ; Unix.rmdir d with Unix.Unix_error _ | Sys_error _ -> () let cleanup_at_exit f = at_exit (fun () -> safe_remove f) exception Temp_file_error of string let temp_file_cleanup_at_exit ?(debug=false) s1 s2 = let file, out = try Filename.open_temp_file s1 s2 with Sys_error s -> raise (Temp_file_error s) in (try close_out out with Unix.Unix_error _ -> ()); at_exit (fun () -> if debug then begin (* If the caller decided to erase this file after all, don't print anything *) if Sys.file_exists file then Format.printf "@[[extlib] Debug flag was set: not removing file %s@]@." file; end else safe_remove file) ; file let temp_dir_cleanup_at_exit base = let rec try_dir_cleanup_at_exit limit base = let file = Filename.temp_file base ".tmp" in let dir = Filename.chop_extension file ^ ".dir" in try Unix.mkdir dir 0o700 ; at_exit (fun () -> safe_remove_dir dir ; safe_remove file) ; dir with Unix.Unix_error _ -> if limit < 0 then let msg = Printf.sprintf "Impossible to create temporary directory ('%s')" dir in raise (Temp_file_error msg) else try_dir_cleanup_at_exit (pred limit) base in try_dir_cleanup_at_exit 10 base external terminate_process: int -> unit = "terminate_process" (* In src/buckx/buckx_c.c *) external usleep: int -> unit = "ml_usleep" (* In src/buckx/buckx_c.c ; man usleep for details. *) (* ************************************************************************* *) (** Strings *) (* ************************************************************************* *) let string_prefix ?(strict=false) prefix s = let add = if strict then 1 else 0 in String.length s >= String.length prefix + add && String.sub s 0 (String.length prefix) = prefix let string_del_prefix ?(strict=false) prefix s = if string_prefix ~strict prefix s then Some (String.sub s (String.length prefix) (String.length s - String.length prefix)) else None let string_split s i = let s1 = String.sub s 0 i in let s2 = String.sub s (i+1) (String.length s - i -1) in (s1,s2) let make_unique_name mem ?(sep=" ") ?(start=2) from = let rec build base id = let fullname = base ^ sep ^ string_of_int id in if mem fullname then build base (succ id) else id,fullname in if mem from then build from start else (0,from) (* ************************************************************************* *) (** Comparison functions *) (* ************************************************************************* *) external compare_basic: 'a -> 'a -> int = "%compare" let pretty_position fmt p = Format.fprintf fmt "<f:%s l:%d bol:%d c:%d>" p.Lexing.pos_fname p.Lexing.pos_lnum p.Lexing.pos_bol p.Lexing.pos_cnum (* Local Variables: compile-command: "make -C ../.." End: *) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/no_dynlink_opt.ml�������������������������������������������������0000644�0001750�0001750�00000005334�12155630226�020721� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* Implementation of [Dynlink_common_interface] when no dynlink is available *) module type OldDynlink = sig val loadfile : string -> unit val allow_unsafe_modules : bool -> unit val init : unit -> unit val digest_interface : string -> string list -> Digest.t end exception Unsupported_Feature of string let fail s = fun _ -> raise (Unsupported_Feature s) let is_native = true let adapt_filename = fail "adapt_filename" let loadfile = fail "loadfile" let allow_unsafe_modules = fail "allow_unsafe_modules" let init = fail "init" type linking_error = Undefined_global of string | Unavailable_primitive of string | Uninitialized_global of string type error = Not_a_bytecode_file of string | Inconsistent_import of string | Unavailable_unit of string | Unsafe_file | Linking_error of string * linking_error | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string | Inconsistent_implementation of string exception Error of error let error_message = fail "error_message" let digest_interface = fail "digest_interface" (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/indexer.mli�������������������������������������������������������0000644�0001750�0001750�00000005117�12155630226�017501� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Indexer implements ordered collection of items with random access. It is suitable for building fast access operations in GUI tree and list widgets. *) module type Elt = sig type t val compare : t -> t -> int end module Make(E : Elt) : sig type t val size : t -> int (** Number of elements in the collection. Constant time. *) val mem : E.t -> t -> bool (** Log complexity. *) val get : int -> t -> E.t (** raises Not_found. Log complexity. *) val index : E.t -> t -> int (** raise Not_found. Log complexity. *) val empty : t val add : E.t -> t -> t (** Log complexity. *) val remove : E.t -> t -> t (** Log complexity. *) val filter : (E.t -> bool) -> t -> t (** Linear. *) val update : E.t option -> E.t option -> t -> int * int * t (** [update x y t] replaces [x] by [y] and returns the range [a..b] of modified indices. Log complexity. *) val iter : (E.t -> unit) -> t -> unit (** Linear. *) val iteri : (int -> E.t -> unit) -> t -> unit (** Linear. *) end �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/qstack.mli��������������������������������������������������������0000644�0001750�0001750�00000011055�12155630226�017327� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Mutable stack in which it is possible to add data at the end (like a queue) and to handle non top elements. Current implementation is double linked list. *) module type DATA = sig type t val equal: t -> t -> bool end module Make(D: DATA) : sig type t exception Empty val create: unit -> t (** Create a new empty stack. *) val singleton: D.t -> t (** Create a new qstack with a single element. @since Boron-20100401 *) val is_empty: t -> bool (** Test whether the stack is empty or not. *) val clear: t -> unit (** Remove all the elements of a stack. *) val add: D.t -> t -> unit (** Add at the beginning of the stack. Complexity: O(1). *) val add_at_end: D.t -> t -> unit (** Add at the end of the stack. Complexity: O(1). *) val top: t -> D.t (** Return the top element of the stack. Raise [Empty] if the stack is empty. Complexity: amortized O(1). *) val mem: D.t -> t -> bool (** Return [true] if the data exists in the stack and [false] otherwise. Complexity: O(n). *) val filter: (D.t -> bool) -> t -> D.t list (** Return all data of the stack satisfying the specified predicate. The order of the data in the input stack is preserved. Not tail recursive. *) val find: (D.t -> bool) -> t -> D.t (** Return the first data of the stack satisfying the specified predicate. @raise Not_found if there is no such data in the stack *) val remove: D.t -> t -> unit (** Remove an element from the stack. Complexity: O(n). *) val move_at_top: D.t -> t -> unit (** Move the element [x] at the top of the stack [s]. Complexity: O(n). @raise Invalid_argument if [not (mem x s)]. *) val move_at_end: D.t -> t -> unit (** Move the element [x] at the end of the stack [s]. Complexity: O(n). @raise Invalid_argument if [not (mem x s)]. @since Beryllium-20090901 *) val iter: (D.t -> unit) -> t -> unit (** Iter on all the elements from the top to the end of the stack. Not tail recursive. *) val map: (D.t -> D.t) -> t -> unit (** Replace in-place all the elements of the stack by mapping the old one. Not tail recursive. @since Beryllium-20090901 *) val fold: ('a -> D.t -> 'a) -> 'a -> t -> 'a (** Fold on all the elements from the top to the end of the stack. Not tail recursive. *) val nth: int -> t -> D.t (** @return the n-th element of the stack, if any. @raise Invalid_argument if there is not enough element in the stack. @since Beryllium-20090901 *) val length: t -> int (** @return the length of the stack @since Beryllium-20090901 *) val idx: D.t -> t -> int (** @return the index of the element in the stack @raise Not_found if the element is not in the stack This function is not tail recursive @since Beryllium-20090901 *) end (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/extlib.mli��������������������������������������������������������0000644�0001750�0001750�00000027701�12155630226�017335� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Useful operations. This module does not depend of any of frama-c module. @plugin development guide *) val nop: 'a -> unit (** Do nothing. *) external id: 'a -> 'a = "%identity" (** identity function. @since Oxygen-20120901 *) val adapt_filename: string -> string (** Ensure that the given filename has the extension "cmo" in bytecode and "cmxs" in native *) val max_cpt: int -> int -> int (** [max_cpt t1 t2] returns the maximum of [t1] and [t2] wrt the total ordering induced by tags creation. This ordering is defined as follow: forall tags t1 t2, t1 <= t2 iff t1 is before t2 in the finite sequence [0; 1; ..; max_int; min_int; min_int-1; -1] *) val number_to_color: int -> int (* ************************************************************************* *) (** {2 Function builders} *) (* ************************************************************************* *) exception Unregistered_function of string (** Never catch it yourself: let the kernel do the job. @since Oxygen-20120901 *) val mk_labeled_fun: string -> 'a (** To be used to initialized a reference over a labeled function. @since Oxygen-20120901 @raise Unregistered_function when not properly initialized *) val mk_fun: string -> ('a -> 'b) ref (** Build a reference to an unitialized function @raise Unregistered_function when not properly initialized *) (* ************************************************************************* *) (** {2 Function combinators} *) (* ************************************************************************* *) val ($) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c (** Composition. *) val swap: ('a -> 'b -> 'c) -> 'b -> 'a -> 'c (** Swap arguments. *) (* ************************************************************************* *) (** {2 Lists} *) (* ************************************************************************* *) val as_singleton: 'a list -> 'a (** returns the unique element of a singleton list. @raise Invalid_argument on a non singleton list. *) val last: 'a list -> 'a (** returns the last element of a list. @raise Invalid_argument on an empty list @since Nitrogen-20111001 *) val filter_out: ('a -> bool) -> 'a list -> 'a list (** Filter out elements that pass the test *) val filter_map: ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list val filter_map': ('a -> 'b) -> ('b -> bool) -> 'a list -> 'b list (** Combines [filter] and [map]. *) val product_fold: ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a (** [product f acc l1 l2] is similar to [fold_left f acc l12] with l12 the list of all pairs of an elt of [l1] and an elt of [l2] *) val product: ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [product f l1 l2] applies [f] to all the pairs of an elt of [l1] and an element of [l2]. *) val find_index: ('a -> bool) -> 'a list -> int (** returns the index (starting at 0) of the first element verifying the condition @raise Not_found if no element in the list matches the condition *) val list_compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int (** Generic list comparison function, where the elements are compared with the specified function @since Boron-20100401 *) val list_of_opt: 'a option -> 'a list (** converts an option into a list with 0 or 1 elt. @since Carbon-20111201-beta2+dev *) val opt_of_list: 'a list -> 'a option (** converts a list with 0 or 1 element into an option. @raise Invalid_argument on lists with more than one argument @since Oxygen-20120901 *) val find_opt : ('a -> 'b option) -> 'a list -> 'b (** [find_option p l] returns the value [p e], [e] being the first element of [l] such that [p e] is not [None]. Raise [Not_found] if there is no such value the list l. @since Nitrogen-20111001 *) val iteri: (int -> 'a -> unit) -> 'a list -> unit (** Same as iter, but the function to be applied take also as argument the index of the element (starting from 0). Tail-recursive @since Nitrogen-20111001 *) val mapi: (int -> 'a -> 'b) -> 'a list -> 'b list (** Same as map, but the function to be applied take also as argument the index of the element (starting from 0). Tail-recursive @since Oxygen-20120901 *) (* ************************************************************************* *) (** {2 Options} *) (* ************************************************************************* *) (** [true] iff its argument is [Some x] @since Nitrogen-20111001 *) val has_some: 'a option -> bool val may: ('a -> unit) -> 'a option -> unit val opt_conv: 'a -> 'a option -> 'a (** [opt_conv default v] returns [default] if [v] is [None] and [a] if [v] is [Some a] *) val may_map: ('a -> 'b) -> ?dft:'b -> 'a option -> 'b (** [may_map f ?dft x] applies [f] to the value of [x] if exists. Otherwise returns the default value [dft]. Assume that either [x] or [dft] is defined. *) val opt_map: ('a -> 'b) -> 'a option -> 'b option val opt_fold: ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b (** @since Oxygen-20120901 *) (** [merge f k a b] returns - [None] if both [a] and [b] are [None] - [Some a'] (resp. [b'] if [b] (resp [a]) is [None] and [a] (resp. [b]) is [Some] - [f k a' b'] if both [a] and [b] are [Some] It is mainly intended to be used with Map.merge @since Oxygen-20120901 *) val merge_opt: ('a -> 'b -> 'b -> 'b) -> 'a -> 'b option -> 'b option -> 'b option (** [opt_bind f x] returns [None] if [x] is [None] and [f y] if is [Some y] (monadic bind) @since Nitrogen-20111001 *) val opt_bind: ('a -> 'b option) -> 'a option -> 'b option val opt_filter: ('a -> bool) -> 'a option -> 'a option val the: 'a option -> 'a (** @raise Invalid_argument if the value is none. @plugin development guide *) val find_or_none: ('a -> 'b) -> 'a -> 'b option val opt_equal : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool val opt_compare : ('a -> 'a -> int) -> 'a option -> 'a option -> int (** @since Boron-20100401 *) (* ************************************************************************* *) (** {2 Booleans} *) (* ************************************************************************* *) val xor: bool -> bool -> bool (** exclusive-or. @since Oxygen-20120901 *) (* ************************************************************************* *) (** {2 Strings} *) (* ************************************************************************* *) val string_prefix: ?strict:bool -> string -> string -> bool (** [string_prefix ~strict p s] returns [true] if and only if [p] is a prefix of the string [s]. If [strict] is true, the prefix must be strict (that is, [s] must moreover be strictly longer than [p]. [strict] is false by default. @since Boron-20100401 *) val string_del_prefix: ?strict:bool -> string -> string -> string option (** [string_del_prefix ~strict p s] returns [None] if [p] is not a prefix of [s] and Some [s1] iff [s=p^s1]. @since Oxygen-20120901 *) val string_split: string -> int -> string * string (** [string_split s i] returns the beginning of [s] up to char [i-1] and the end of [s] starting from char [i+1] @raise Invalid_argument if [i] is not in the range [[0,(length s -1)]] @since Oxygen-20120901 *) val make_unique_name: (string -> bool) -> ?sep:string -> ?start:int -> string -> int*string (** [make_unique_name mem s] returns [(0, s)] when [(mem s)=false] otherwise returns [(n,new_string)] such that [new_string] is derived from [(s,sep,start)] and [(mem new_string)=false] and [n<>0] @since Oxygen-20120901 *) (* ************************************************************************* *) (** {2 Performance} *) (* ************************************************************************* *) external getperfcount: unit -> int = "getperfcount" external getperfcount1024: unit -> int = "getperfcount1024" val time: ?msg:string -> ('a -> 'b) -> 'a -> 'b val time1024: ?msg:string -> ('a -> 'b) -> 'a -> 'b external address_of_value: 'a -> int = "address_of_value" (* ************************************************************************* *) (** {2 Exception catcher} *) (* ************************************************************************* *) val try_finally: finally:(unit -> unit) -> ('a -> 'b) -> 'a -> 'b (* ************************************************************************* *) (** System commands *) (* ************************************************************************* *) val cleanup_at_exit: string -> unit (** [cleanup_at_exit file] indicates that [file] must be removed when the program exits (except if exit is caused by a signal). If [file] does not exist, nothing happens. *) exception Temp_file_error of string val temp_file_cleanup_at_exit: ?debug:bool -> string -> string -> string (** Similar to [Filename.temp_file] except that the temporary file will be deleted at the end of the execution (see above), unless [debug] is set to true, in which case a message with the name of the kept file will be printed. @raise Temp_file_error if the temp file cannot be created. @modify Nitrogen-20111001 may now raise Temp_file_error @modify Oxygen-20120901 optional debug argument *) val temp_dir_cleanup_at_exit: string -> string (** @raise Temp_file_error if the temp dir cannot be created. @modify Nitrogen-20111001 may now raise Temp_file_error *) val safe_remove: string -> unit (** Tries to delete a file and never fails. *) val safe_remove_dir: string -> unit val terminate_process: int -> unit (** Terminate a process id. *) val usleep: int -> unit (** Unix function that sleep for [n] microseconds. See [man usleep] for details. Should not be used under Win32. *) (* ************************************************************************* *) (** Comparison functions *) (* ************************************************************************* *) (** Use this function instead of [Pervasives.compare], as this makes it easier to find incorrect uses of the latter *) external compare_basic: 'a -> 'a -> int = "%compare" (* ************************************************************************* *) (** Printing Lexing.position *) (* ************************************************************************* *) val pretty_position: Format.formatter -> Lexing.position -> unit (* Local Variables: compile-command: "make -C ../.." End: *) ���������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/dynlink_common_interface.mli��������������������������������������0000644�0001750�0001750�00000007731�12155630226�023107� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Wrapper for [Dynlink] compatible with all OCaml versions. *) module type OldDynlink = sig (** {6 Dynamic loading of compiled files} *) val loadfile : string -> unit (** In bytecode: load the given bytecode object file ([.cmo] file) or bytecode library file ([.cma] file), and link it with the running program. In native code: load the given OCaml plugin file (usually [.cmxs]), and link it with the running program. All toplevel expressions in the loaded compilation units are evaluated. No facilities are provided to access value names defined by the unit. Therefore, the unit must register itself its entry points with the main program, e.g. by modifying tables of functions. *) (** {6 Access control} *) val allow_unsafe_modules : bool -> unit (** Govern whether unsafe object files are allowed to be dynamically linked. A compilation unit is ``unsafe'' if it contains declarations of external functions, which can break type safety. By default, dynamic linking of unsafe object files is not allowed. In native code, this function does nothing; object files with external functions are always allowed to be dynamically linked. *) (** {6 Deprecated, initialization} *) val init : unit -> unit (** @deprecated Initialize the [Dynlink] library. This function is called automatically when needed. *) (**/**) (** {6 Internal functions} *) val digest_interface : string -> string list -> Digest.t end include OldDynlink exception Unsupported_Feature of string (** Dynamic loading of object files. *) val is_native: bool (** [true] if the program is native, [false] if the program is bytecode. *) (** {6 Error reporting} *) type linking_error = Undefined_global of string | Unavailable_primitive of string | Uninitialized_global of string type error = Not_a_bytecode_file of string | Inconsistent_import of string | Unavailable_unit of string | Unsafe_file | Linking_error of string * linking_error | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string | Inconsistent_implementation of string exception Error of error (** Errors in dynamic linking are reported by raising the [Error] exception with a description of the error. *) val error_message : error -> string (** Convert an error description to a printable message. *) (* Local Variables: compile-command: "make -C ../.." End: *) ���������������������������������������frama-c-Fluorine-20130601/src/lib/pretty_utils.mli��������������������������������������������������0000644�0001750�0001750�00000011447�12155630226�020615� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Pretty-printer utilities. *) (* ********************************************************************** *) (** {2 pretty-printing to a string} *) (* ********************************************************************** *) val sfprintf: ('a,Format.formatter,unit,string) format4 -> 'a (** similar as Format.sprintf, but %a are allowed in the formatting string*) val to_string: (Format.formatter -> 'a -> unit) -> 'a -> string (** {2 separators} *) val pp_print_string_fill : Format.formatter -> string -> unit (** transforms every space in a string in breakable spaces.*) val escape_underscores : string -> string (* ********************************************************************** *) (** {2 pretty printers for standard types} *) (* ********************************************************************** *) type sformat = (unit,Format.formatter,unit) Pervasives.format type 'a formatter = Format.formatter -> 'a -> unit type ('a,'b) formatter2 = Format.formatter -> 'a -> 'b -> unit val pp_list: ?pre:sformat -> ?sep:sformat -> ?last:sformat -> ?suf:sformat -> (** pretty prints a list. The optional arguments stands for - the prefix to output before a non-empty list (default: open a box) - the separator between two elements (default: nothing) - the last separator to be put just before the last element (default:sep) - the suffix to output after a non-empty list (default: close box) *) 'a formatter -> 'a list formatter val pp_array: ?pre:sformat -> ?sep:sformat -> ?suf:sformat -> (int,'a) formatter2 -> 'a array formatter (** pretty prints an array. The optional arguments stands for - the prefix to output before a non-empty list (default: open a box) - the separator between two elements (default: nothing) - the suffix to output after a non-empty list (default: close box) *) val pp_iter: ?pre:sformat -> ?sep:sformat -> ?suf:sformat -> (('a -> unit) -> 'b -> unit) -> 'a formatter -> 'b formatter (** pretty prints any structure using an iterator on it. The argument [pre] (resp. [suf]) is output before (resp. after) the iterator is started (resp. has ended). The optional argument [sep] is output bewteen two calls to the ['a formatter]. Default: open a box for [pre], close a box for [suf], nothing for [sep]. *) val pp_opt: ?pre:sformat -> ?suf:sformat -> 'a formatter -> 'a option formatter (** pretty-prints an optional value. Prefix and suffix default to "@[" and "@]" respectively. Nothing is printed if the option is [None]. *) val pp_cond: ?pr_false:sformat -> bool -> sformat formatter (** [pp_cond cond f s] pretty-prints [s] if cond is [true] and the optional pr_false, which defaults to nothing, otherwise *) val pp_flowlist: ?left:sformat -> ?sep:sformat -> ?right:sformat -> 'a formatter -> 'a list formatter val pp_blocklist: ?left:sformat -> ?right:sformat -> 'a formatter -> 'a list formatter val pp_open_block : Format.formatter -> ('a,Format.formatter,unit) format -> 'a val pp_close_block : Format.formatter -> ('a,Format.formatter,unit) format -> 'a val pp_trail : 'a formatter -> 'a formatter (** pretty-prints its contents inside an '(** ... **)' horizontal block trailed with '*' *) (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/rangemap.mli������������������������������������������������������0000644�0001750�0001750�00000024320�12155630226�017632� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file was originally part of Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright (C) 1996 INRIA *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* *) (* All rights reserved. *) (* *) (* This file is distributed under the terms of the GNU Library General *) (* Public License version 2, with the special exception on linking *) (* described below. See the GNU Library General Public License version *) (* 2 for more details (enclosed in the file licenses/LGPLv2). *) (* *) (* As a special exception to the GNU Library General Public License, *) (* you may link, statically or dynamically, a "work that uses the *) (* Library" with a publicly distributed version of the Library to *) (* produce an executable file containing portions of the Library, and *) (* distribute that executable file under terms of your choice, without *) (* any of the additional requirements listed in clause 6 of the GNU *) (* Library General Public License. By "a publicly distributed version *) (* of the Library", we mean either the unmodified Library as *) (* distributed by INRIA, or a modified version of the Library that is *) (* distributed under the conditions defined in clause 2 of the GNU *) (* Library General Public License. This exception does not however *) (* invalidate any other reasons why the executable file might be *) (* covered by the GNU Library General Public License. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives). *) (* *) (**************************************************************************) (** Association tables over ordered types. This module implements applicative association tables, also known as finite maps or dictionaries, given a total ordering function over the keys. All operations over maps are purely applicative (no side-effects). The implementation uses balanced binary trees, and therefore searching and insertion take time logarithmic in the size of the map. Compared to Ocaml's standard libary, this implementation caches at each node the hash of the tree (which is computed in an associative manner), and contains some functions not yet present in the caml implementation. @plugin development guide *) module type S = sig type key (** The type of the map keys. *) type value type rangemap (** The type of maps from type [key] to type [value]. *) include Datatype.S with type t = rangemap val create : t -> key -> value -> t -> t val empty: t (** The empty map. *) val is_empty: t -> bool (** Test whether a map is empty or not. *) val add: key -> value -> t -> t (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. *) val singleton: key -> value -> t (** [singleton x y] returns the one-element map that contains a binding [y] for [x]. *) val find: key -> t -> value (** [find x m] returns the current binding of [x] in [m], or raises [Not_found] if no such binding exists. *) val remove: key -> t -> t (** [remove x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. *) val mem: key -> t -> bool (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) val iter: (key -> value -> unit) -> t -> unit (** [iter f m] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated value as second argument. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. Only current bindings are presented to [f]: bindings hidden by more recent bindings are not passed to [f]. *) val map: (value -> value) -> t -> t (** [map f m] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val mapi: (key -> value -> value) -> t -> t (** Same as {!Map.S.map}, but the function receives as arguments both the key and the associated value for each binding of the map. *) val mapii: (key -> value -> key*value) -> t -> t (** Same as {!Map.S.mapi}, but the function also returns a new key. the modification applied on the keys must be compatible with the order on the keys. *) val fold: (key -> value -> 'a -> 'a) -> t -> 'a -> 'a (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m] (in increasing order), and [d1 ... dN] are the associated data. *) val for_all: (key -> value -> bool) -> t -> bool (** [for_all p m] checks if all the bindings of the map satisfy the predicate [p]. *) val exists: (key -> value -> bool) -> t -> bool (** [exists p m] checks if at least one binding of the map satisfy the predicate [p]. *) val filter: (key -> value -> bool) -> t -> t (** [filter p m] returns the map with all the bindings in [m] that satisfy predicate [p]. *) val partition: (key -> value -> bool) -> t -> t * t (** [partition p m] returns a pair of maps [(m1, m2)], where [m1] contains all the bindings of [s] that satisfy the predicate [p], and [m2] is the map with all the bindings of [s] that do not satisfy [p]. *) val cardinal: t -> int (** Return the number of bindings of a map. *) val bindings: t -> (key * value) list (** Return the list of all bindings of the given map. The returned list is sorted in increasing order with respect to the ordering on keys *) val min_binding: t -> (key * value) (** Return the smallest binding of the given map (with respect to the [Ord.compare] ordering), or raise [Not_found] if the map is empty. *) val max_binding: t -> (key * value) (** Same as {!Map.S.min_binding}, but returns the largest binding of the given map. *) val choose: t -> (key * value) (** Return one binding of the given map, or raise [Not_found] if the map is empty. Which binding is chosen is unspecified, but equal bindings will be chosen for equal maps. *) val merge: (key -> value option -> value option -> value option) -> t -> t -> t (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] and of [m2]. The presence of each such binding, and the corresponding value, is determined with the function [f]. *) val for_all2: (key -> value option -> value option -> bool) -> t -> t -> bool (** [for_all2 f m1 m2] returns true if and only if [f k v1 v2] holds for each [k] present in either [m1] and [m2], [v_i] being [Some (find k m_i)] if [k] is in [m_i], and [None] otherwise (for [i=1] or [i=2]) *) val exists2: (key -> value option -> value option -> bool) -> t -> t -> bool (** [exists2 f m1 m2] returns true if and only there exists [k] present in [m1] or [m2] such that [f k v1 v2] holds, [v_i] being [Some (find k m_i)] if [k] is in [m_i], and [None] otherwise (for [i=1] or [i=2]) *) val iter2: (key -> value option -> value option -> unit) -> t -> t -> unit (** [iter2 f m1 m2] computes [f k v1 v2] for each [k] present in either [m1] or [m2] (the [k] being presented in ascending order), [v_i] being [Some (find k m_i)] if [k] is in [m_i], and [None] otherwise (for [i=1] or [i=2]) *) val fold2: (key -> value option -> value option -> 'a -> 'a) -> t -> t -> 'a -> 'a (** [fold2 f m1 m2 v] computes [(f k_N v1_N v2_N... (f k_1 v1_1 v2_1 a)...)] where [k_1 ... k_N] are all the keys of all the bindings in either [m1] or [m2] (in increasing order), [vi_j] being [Some (find k_j m_i)] if [k_j] is in [m_i], and [None] otherwise (for [i=1] or [i=2]) *) end type fuzzy_order = Above | Below | Match (** Datatype with a function that approximately equality in a constant-time way. *) module type Value = sig include Datatype.S (** [fast_equal] is used to reduce memory allocation in some cases. It is valid to always return [false]; the only constraint is that [true] must not be returned if [equal] returns [false]. *) val fast_equal: t -> t -> bool end (** Extension of the above signature, with specific functions acting on range of values *) module Make (Ord : Datatype.S) (Value : Value): sig include S with type key = Ord.t and type value = Value.t val fold_range: (key -> fuzzy_order) -> (key -> Value.t -> 'a -> 'a) -> t -> 'a -> 'a val height: t -> int val concerned_intervals: (key -> key -> fuzzy_order) -> key -> t -> (key*Value.t) list exception Empty_rangemap val lowest_binding : t -> key * Value.t exception No_such_binding val lowest_binding_above : (key -> bool) -> t -> key * Value.t val add_whole : (key -> key -> fuzzy_order) -> key -> Value.t -> t -> t val remove_whole : (key -> key -> fuzzy_order) -> key -> t -> t end (* Local Variables: compile-command: "make -C ../.." End: *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/integer.mli�������������������������������������������������������0000644�0001750�0001750�00000007364�12155630226�017506� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Extension of [Big_int] compatible with [Zarith]. @since Nitrogen-20111001 *) type t val equal : t -> t -> bool val compare : t -> t -> int val le : t -> t -> bool val ge : t -> t -> bool val lt : t -> t -> bool val gt : t -> t -> bool val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val native_div : t -> t -> t val rem : t -> t -> t val pos_div : t -> t -> t val divexact: t -> t -> t (** faster, but produces correct results only when b evenly divides a. *) val c_div : t -> t -> t val c_rem : t -> t -> t val div_rem: t -> t -> (t * t) (** [div_rem a b] returns [(pos_div a b, pos_rem a b)] *) val cast: size:t -> signed:bool -> value:t -> t val abs : t -> t val one : t val two : t val four : t val onethousand : t val minus_one : t val is_zero : t -> bool val is_one : t -> bool val pgcd : t -> t -> t val ppcm : t -> t -> t val min : t -> t -> t val max : t -> t -> t val length : t -> t -> t (** b - a + 1 *) val of_int : int -> t val of_int64 : Int64.t -> t val of_int32 : Int32.t -> t val to_int64 : t -> int64 val to_int : t -> int (** @raise Failure if the argument does not fit in an OCaml int *) val to_float : t -> float val neg : t -> t val succ : t -> t val pred : t -> t val round_up_to_r : min:t -> r:t -> modu:t -> t val round_down_to_r : max:t -> r:t -> modu:t -> t val pos_rem : t -> t -> t val shift_left : t -> t -> t val shift_right : t -> t -> t val logand : t -> t -> t val logor : t -> t -> t val logxor : t -> t -> t val lognot : t -> t val power_two : int -> t val two_power : t -> t val extract_bits : start:t -> stop:t -> t -> t val small_nums : t array val zero : t val eight : t val thirtytwo : t val div : t -> t -> t val billion_one : t val hash : t -> int val shift_right_logical : t -> t -> t val max_int64 : t val min_int64 : t val bits_of_max_float : t val bits_of_most_negative_float : t val of_string : string -> t val to_string : t -> string val add_2_64 : t -> t val is_even : t -> bool val round_down_to_zero : t -> t -> t val power_int_positive_int: int -> int -> t val to_num : t -> Num.num val popcount: t -> int val pretty : ?hexa:bool -> t Pretty_utils.formatter (* Local Variables: compile-command: "make -C ../.." End: *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/filepath.ml�������������������������������������������������������0000644�0001750�0001750�00000004347�12155630226�017472� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Sysutil let base_dir = Sys.getcwd () (* Normalize a filename: make it relative if it is "close" to the current directory and results in a shorter path. *) let normalize filename = (** if filename is relative things can be messy *) let absfilename = absolutize_filename base_dir filename in let newfilename = relativize_filename base_dir absfilename in let newfilename = match Extlib.string_del_prefix ~strict:true "./" newfilename with | Some f -> f | None -> newfilename in if String.length newfilename < String.length filename then newfilename else filename ;; (* Local Variables: compile-command: "make -C ../.." End: *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/floating_point.mli������������������������������������������������0000644�0001750�0001750�00000005733�12155630226�021063� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Floating-point operations. @plugin development guide *) external set_round_downward : unit -> unit = "set_round_downward" external set_round_upward : unit -> unit = "set_round_upward" external set_round_nearest_even : unit -> unit = "set_round_nearest_even" external round_to_single_precision_float: float -> float = "round_to_float" val max_single_precision_float: float val most_negative_single_precision_float: float external sys_single_precision_of_string: string -> float = "single_precision_of_string" (** If [s] is parsed as [(n, l, u)], then [n] is the nearest approximation of [s] with the desired precision. Moreover, [l] and [u] are the most precise float such that [l <= s <= u], again with this precision. Consistent with [logic_real] definition in Cil_types. *) type parsed_float = { f_nearest : float ; f_lower : float ; f_upper : float ; } val single_precision_of_string: string -> parsed_float val double_precision_of_string: string -> parsed_float val pretty_normal : use_hex : bool -> Format.formatter -> float -> unit val pretty : Format.formatter -> float -> unit exception Float_Non_representable_as_Int64 val truncate_to_integer: float -> Integer.t (** Raises [Float_Non_representable_as_Int64] if the float value cannot be represented as an Int64 or as an unsigned Int64. *) (* Local Variables: compile-command: "make -C ../.. byte" End: *) �������������������������������������frama-c-Fluorine-20130601/src/lib/qstack.ml���������������������������������������������������������0000644�0001750�0001750�00000010364�12155630226�017160� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module type DATA = sig type t val equal: t -> t -> bool end module Make(D: DATA) = struct type t = { mutable first: D.t list; mutable last: D.t list } exception Empty let create () = { first = []; last = [] } let is_empty t = t.first = [] && t.last = [] let clear t = t.first <- []; t.last <- [] let add x t = t.first <- x :: t.first let add_at_end x t = t.last <- x :: t.last let singleton x = let q = create () in add x q; q let transfer t = assert (t.first = []); List.iter (fun x -> add x t) t.last; t.last <- [] let top t = match t.first, t.last with | [], [] -> raise Empty | [], _ :: _ -> transfer t; (match t.first with | [] -> assert false | x :: _ -> x) | x :: _, _ -> x let mem x t = let list_mem x = List.exists (D.equal x) in list_mem x t.first || list_mem x t.last let filter f t = let l = List.find_all f t.last in List.fold_right (fun x acc -> if f x then x :: acc else acc) t.first l let find f t = try List.find f t.last with Not_found -> List.find f (List.rev t.first) (* the returned boolean is a flag which is [true] when removing occurs. *) let remove_from_list x = let rec aux acc = function | [] -> List.rev acc, false | y :: l when D.equal x y -> List.rev acc @ l, true | y :: l -> aux (y :: acc) l in aux [] let remove_with_flag x t = let first, b = remove_from_list x t.first in if b then begin t.first <- first; b end else let last, b = remove_from_list x t.last in t.last <- last; b let remove x t = ignore (remove_with_flag x t) let move_at_top x t = if not (remove_with_flag x t) then invalid_arg "Qstack.move_at_top"; add x t let move_at_end x t = if not (remove_with_flag x t) then invalid_arg "Qstack.move_at_end"; add_at_end x t let iter f t = List.iter f t.first; List.fold_right (fun p () -> f p) t.last () let map f t = t.first <- List.map f t.first; t.last <- List.rev_map (fun p -> f p) t.last let fold f acc t = let acc = List.fold_left f acc t.first in List.fold_right (fun x acc -> f acc x) t.last acc let length t = List.length t.first + List.length t.last let nth n t = try List.nth t.first n with Failure _ -> try List.nth (List.rev t.last) (n - List.length t.first) with Failure s -> invalid_arg s let idx x t = let i = ref 0 in try iter (fun e -> if D.equal e x then raise Exit; incr i) t; raise Not_found with Exit -> !i end (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/bad_dynlink_311_or_higher.ml��������������������������������������0000644�0001750�0001750�00000007613�12155630226�022565� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* Should not be in this module, but must happen very early in the boot process *) let () = Printexc.record_backtrace true (* Implementation of [Dynlink_common_interface] compatible with OCaml >=3.11 whenever [Dynlink] **does not** correctly work. *) module type OldDynlink = sig val loadfile : string -> unit val allow_unsafe_modules : bool -> unit val init : unit -> unit val digest_interface : string -> string list -> Digest.t end exception Unsupported_Feature of string let fail s = fun _ -> raise (Unsupported_Feature s) let is_native = Dynlink.is_native let adapt_filename = if is_native then fail "adapt_filename" else Dynlink.adapt_filename let loadfile = if is_native then fail "loadfile" else Dynlink.loadfile let loadfile_private = if is_native then fail "loadfile_private" else Dynlink.loadfile_private let allow_unsafe_modules = if is_native then fail "allow_unsafe_modules" else Dynlink.allow_unsafe_modules let init = if is_native then fail "init" else Dynlink.init let clear_available_units = if is_native then fail "clear_available_units" else Dynlink.clear_available_units let add_available_units = if is_native then fail "add_available_units" else Dynlink.add_available_units let add_interfaces = if is_native then fail "add_interfaces" else Dynlink.add_interfaces let default_available_units = if is_native then fail "default_available_units" else Dynlink.default_available_units let prohibit = if is_native then fail "prohibit" else Dynlink.prohibit let allow_only = if is_native then fail "allow_only" else Dynlink.allow_only type linking_error = Dynlink.linking_error = Undefined_global of string | Unavailable_primitive of string | Uninitialized_global of string type error = Dynlink.error = Not_a_bytecode_file of string | Inconsistent_import of string | Unavailable_unit of string | Unsafe_file | Linking_error of string * linking_error | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string | Inconsistent_implementation of string exception Error = Dynlink.Error let error_message = if is_native then fail "error_message" else Dynlink.error_message let digest_interface = if is_native then fail "digest_interface" else Dynlink.digest_interface (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) ���������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/binary_cache.ml���������������������������������������������������0000644�0001750�0001750�00000030426�12155630226�020302� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module MemoryFootprint = State_builder.Int_ref (struct let name = "Binary_cache.MemoryFootprint" let dependencies = [] let default () = 2 end) let get_size () = match MemoryFootprint.get () with 1 -> 512 | 2 -> 1024 | _ -> 2048 module type Cacheable = sig type t val hash : t -> int val sentinel : t val equal : t -> t -> bool end module type Result = sig type t val sentinel : t end module Array_2 = struct type ('a, 'b) t let (clear : ('a, 'b) t -> 'a -> 'b -> unit) = fun t a b -> let t = Obj.repr t in let size2 = Obj.size t in let i = ref 0 in while (!i < size2) do let base = !i in Obj.set_field t (base) (Obj.repr a); Obj.set_field t (base+1) (Obj.repr b); i := base + 2; done let (make : int -> 'a -> 'b -> ('a, 'b) t) = fun size a b -> let size2 = 2 * size in let t = Obj.obj (Obj.new_block 0 size2) in clear t a b; t let (set : ('a, 'b) t -> int -> 'a -> 'b -> unit) = fun t i a b -> let t = Obj.repr t in let base = 2 * i in Obj.set_field t (base) (Obj.repr a); Obj.set_field t (base+1) (Obj.repr b) let (get0 : ('a, 'b) t -> int -> 'a) = fun t i -> let t = Obj.repr t in let base = 2 * i in Obj.obj (Obj.field t (base)) let (get1 : ('a, 'b) t -> int -> 'b) = fun t i -> let t = Obj.repr t in let base = 2 * i in Obj.obj (Obj.field t (base+1)) end module Array_3 = struct type ('a, 'b, 'c) t let (clear : ('a, 'b, 'c) t -> 'a -> 'b -> 'c -> unit) = fun t a b c -> let t = Obj.repr t in let size3 = Obj.size t in let i = ref 0 in while (!i < size3) do let base = !i in Obj.set_field t (base) (Obj.repr a); Obj.set_field t (base+1) (Obj.repr b); Obj.set_field t (base+2) (Obj.repr c); i := base + 3; done let (make : int -> 'a -> 'b -> 'c -> ('a, 'b, 'c) t) = fun size a b c -> let size3 = 3 * size in let t = Obj.obj (Obj.new_block 0 size3) in clear t a b c; t let (set : ('a, 'b, 'c) t -> int -> 'a -> 'b -> 'c -> unit) = fun t i a b c -> let t = Obj.repr t in let base = 3 * i in Obj.set_field t (base) (Obj.repr a); Obj.set_field t (base+1) (Obj.repr b); Obj.set_field t (base+2) (Obj.repr c) let (get0 : ('a, 'b, 'c) t -> int -> 'a) = fun t i -> let t = Obj.repr t in let base = 3 * i in Obj.obj (Obj.field t (base)) let (get1 : ('a, 'b, 'c) t -> int -> 'b) = fun t i -> let t = Obj.repr t in let base = 3 * i in Obj.obj (Obj.field t (base+1)) let (get2 : ('a, 'b, 'c) t -> int -> 'c) = fun t i -> let t = Obj.repr t in let base = 3 * i in Obj.obj (Obj.field t (base+2)) end module Array_7 = struct type ('a, 'b, 'c, 'd, 'e, 'f, 'g) t let (clear : ('a , 'b , 'c , 'd , 'e , 'f , 'g) t -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> unit) = fun t a b c d e f g -> let t = Obj.repr t in let size7 = Obj.size t in let i = ref 0 in while (!i < size7) do let base = !i in Obj.set_field t (base) (Obj.repr a); Obj.set_field t (base+1) (Obj.repr b); Obj.set_field t (base+2) (Obj.repr c); Obj.set_field t (base+3) (Obj.repr d); Obj.set_field t (base+4) (Obj.repr e); Obj.set_field t (base+5) (Obj.repr f); Obj.set_field t (base+6) (Obj.repr g); i := base + 7; done let (make : int -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> ('a , 'b , 'c , 'd , 'e , 'f , 'g) t) = fun size a b c d e f g -> let size7 = 7 * size in let t = Obj.obj (Obj.new_block 0 size7) in clear t a b c d e f g; t let (set : ('a, 'b, 'c, 'd, 'e, 'f, 'g) t -> int -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> unit) = fun t i a b c d e f g -> let t = Obj.repr t in let base = 7 * i in Obj.set_field t (base) (Obj.repr a); Obj.set_field t (base+1) (Obj.repr b); Obj.set_field t (base+2) (Obj.repr c); Obj.set_field t (base+3) (Obj.repr d); Obj.set_field t (base+4) (Obj.repr e); Obj.set_field t (base+5) (Obj.repr f); Obj.set_field t (base+6) (Obj.repr g) let (get0 : ('a, 'b, 'c, 'd, 'e, 'f, 'g) t -> int -> 'a) = fun t i -> let t = Obj.repr t in let base = 7 * i in Obj.obj (Obj.field t (base)) let (get1 : ('a, 'b, 'c, 'd, 'e, 'f, 'g) t -> int -> 'b) = fun t i -> let t = Obj.repr t in let base = 7 * i in Obj.obj (Obj.field t (base+1)) let (get2 : ('a, 'b, 'c, 'd, 'e, 'f, 'g) t -> int -> 'c) = fun t i -> let t = Obj.repr t in let base = 7 * i in Obj.obj (Obj.field t (base+2)) let (get3 : ('a, 'b, 'c, 'd, 'e, 'f, 'g) t -> int -> 'd) = fun t i -> let t = Obj.repr t in let base = 7 * i in Obj.obj (Obj.field t (base+3)) let (get4 : ('a, 'b, 'c, 'd, 'e, 'f, 'g) t -> int -> 'e) = fun t i -> let t = Obj.repr t in let base = 7 * i in Obj.obj (Obj.field t (base+4)) let (get5 : ('a, 'b, 'c, 'd, 'e, 'f, 'g) t -> int -> 'f) = fun t i -> let t = Obj.repr t in let base = 7 * i in Obj.obj (Obj.field t (base+5)) let (get6 : ('a, 'b, 'c, 'd, 'e, 'f, 'g) t -> int -> 'g) = fun t i -> let t = Obj.repr t in let base = 7 * i in Obj.obj (Obj.field t (base+6)) end module Make_Symetric (H: Cacheable) (R: Result) = struct let size = get_size () let cache = Array_3.make size H.sentinel H.sentinel R.sentinel let mask = pred size let clear () = Array_3.clear cache H.sentinel H.sentinel R.sentinel let hash = H.hash let merge f a0 a1 = let a0, a1, h0, h1 = let h0 = hash a0 in let h1 = hash a1 in if h0 < h1 then a0, a1, h0, h1 else a1, a0, h1, h0 in let has = h1 lsl 5 - h1 + h0 in let has = has land mask in if H.equal (Array_3.get0 cache has) a0 && H.equal (Array_3.get1 cache has) a1 then begin (* Format.printf "Cache O@."; *) Array_3.get2 cache has end else let result = f a0 a1 in (* Format.printf "Cache N@."; *) Array_3.set cache has a0 a1 result; result end module Make_Asymetric (H: Cacheable) (R: Result) = struct let size = 1024 (*get_size ()*) let cache = Array_3.make size H.sentinel H.sentinel R.sentinel let mask = pred size let clear () = Array_3.clear cache H.sentinel H.sentinel R.sentinel let merge f a0 a1 = let h0 = H.hash a0 in let h1 = H.hash a1 in let has = h1 lsl 5 - h1 + h0 in let has = has land mask in if H.equal (Array_3.get0 cache has) a0 && H.equal (Array_3.get1 cache has) a1 then begin (* Format.printf "Cache O@."; *) Array_3.get2 cache has end else let result = f a0 a1 in (* Format.printf "Cache N@."; *) Array_3.set cache has a0 a1 result; result end module Array_Bit = struct let make size = let size = (size + 7) lsr 3 in String.make size (char_of_int 0) let get s i = let c = i lsr 3 in let b = 1 lsl (i land 7) in (Char.code s.[c]) land b <> 0 let set s i v = let c = i lsr 3 in let b = 1 lsl (i land 7) in let oldcontents = Char.code s.[c] in let newcontents = if v then b lor oldcontents else let mask = lnot b in oldcontents land mask in s.[c] <- Char.chr newcontents let clear s = let zero = char_of_int 0 in String.fill s 0 (String.length s) zero end module Make_Binary (H0: Cacheable) (H1: Cacheable) = struct let size = get_size() let cache = Array_2.make size H0.sentinel H1.sentinel let result = Array_Bit.make size let mask = pred size let clear () = Array_2.clear cache H0.sentinel H1.sentinel; Array_Bit.clear result let merge f a0 a1 = let has = let h0 = H0.hash a0 in let h1 = H1.hash a1 in 599 * h0 + h1 in let has = has land mask in if H0.equal (Array_2.get0 cache has) a0 && H1.equal (Array_2.get1 cache has) a1 then begin (* Format.printf "Cache O@."; *) Array_Bit.get result has end else let r = f a0 a1 in (* Format.printf "Cache N@."; *) Array_2.set cache has a0 a1; Array_Bit.set result has r; r end module Make_Symetric_Binary (H0: Cacheable) = struct let size = get_size() let cache = Array_2.make size H0.sentinel H0.sentinel let result = Array_Bit.make size let mask = pred size let clear () = Array_2.clear cache H0.sentinel H0.sentinel; Array_Bit.clear result let hash = H0.hash let merge f a0 a1 = let a0, a1, h0, h1 = let h0 = hash a0 in let h1 = hash a1 in if h0 < h1 then a0, a1, h0, h1 else a1, a0, h1, h0 in let has = h1 lsl 5 - h1 + h0 in let has = has land mask in if H0.equal (Array_2.get0 cache has) a0 && H0.equal (Array_2.get1 cache has) a1 then begin (* Format.printf "Cache O@."; *) Array_Bit.get result has end else let r = f a0 a1 in (* Format.printf "Cache N@."; *) Array_2.set cache has a0 a1; Array_Bit.set result has r; r end module Make_Het1_1_4 (H0: Cacheable) (H1: Cacheable) (H2: Cacheable) (R: Result) = struct let size = get_size () let cache = Array_7.make size H0.sentinel H1.sentinel H2.sentinel H2.sentinel H2.sentinel H2.sentinel R.sentinel let mask = pred size let clear () = Array_7.clear cache H0.sentinel H1.sentinel H2.sentinel H2.sentinel H2.sentinel H2.sentinel R.sentinel let merge f a0 a1 a2 a3 a4 a5 = let has = H0.hash a0 + 4909 * (H1.hash a1) + 127 * (H2.hash a2) + 971 * (H2.hash a3) + 31 * (H2.hash a4) + 7907 * (H2.hash a5) in let has = has land mask in if H0.equal (Array_7.get0 cache has) a0 && H1.equal (Array_7.get1 cache has) a1 && H2.equal (Array_7.get2 cache has) a2 && H2.equal (Array_7.get3 cache has) a3 && H2.equal (Array_7.get4 cache has) a4 && H2.equal (Array_7.get5 cache has) a5 then begin (* Format.printf "Cache O@."; *) Array_7.get6 cache has end else let result = f () in (* Format.printf "Cache N@."; *) Array_7.set cache has a0 a1 a2 a3 a4 a5 result; result end (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/hptset.mli��������������������������������������������������������0000644�0001750�0001750�00000013670�12155630226�017355� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Sets over ordered types. This module implements the set data structure. All operations over sets are purely applicative (no side-effects). *) (** Input signature of the functor {!Set.Make}. *) module type Id_Datatype = sig include Datatype.S val id: t -> int end (** Output signature of the functor {!Set.Make}. *) module type S = sig type elt (** The type of the set elements. *) include Datatype.S_with_collections (** The datatype of sets. *) val empty: t (** The empty set. *) val is_empty: t -> bool (** Test whether a set is empty or not. *) val mem: elt -> t -> bool (** [mem x s] tests whether [x] belongs to the set [s]. *) val add: elt -> t -> t (** [add x s] returns a set containing all elements of [s], plus [x]. If [x] was already in [s], [s] is returned unchanged. *) val singleton: elt -> t (** [singleton x] returns the one-element set containing only [x]. *) val remove: elt -> t -> t (** [remove x s] returns a set containing all elements of [s], except [x]. If [x] was not in [s], [s] is returned unchanged. *) val elements: t -> elt list val union: t -> t -> t (** Set union. *) val inter: t -> t -> t (** Set intersection. *) (** Set difference. *) val diff: t -> t -> t (* val compare: t -> t -> int (** Total ordering between sets. Can be used as the ordering function for doing sets of sets. *) *) val subset: t -> t -> bool (** [subset s1 s2] tests whether the set [s1] is a subset of the set [s2]. *) val iter: (elt -> unit) -> t -> unit (** [iter f s] applies [f] in turn to all elements of [s]. The elements of [s] are presented to [f] in increasing order with respect to the ordering over the type of the elements. *) val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], where [x1 ... xN] are the elements of [s], in increasing order. *) val for_all: (elt -> bool) -> t -> bool (** [for_all p s] checks if all elements of the set satisfy the predicate [p]. *) val exists: (elt -> bool) -> t -> bool (** [exists p s] checks if at least one element of the set satisfies the predicate [p]. *) val filter: (elt -> bool) -> t -> t (** [filter p s] returns the set of all elements in [s] that satisfy predicate [p]. *) val partition: (elt -> bool) -> t -> t * t (** [partition p s] returns a pair of sets [(s1, s2)], where [s1] is the set of all the elements of [s] that satisfy the predicate [p], and [s2] is the set of all the elements of [s] that do not satisfy [p]. *) val cardinal: t -> int (** Return the number of elements of a set. *) val min_elt: t -> elt (** Return the smallest element of the given set (with respect to the [Ord.compare] ordering), or raise [Not_found] if the set is empty. *) val max_elt: t -> elt (** Same as {!Set.S.min_elt}, but returns the largest element of the given set. *) val contains_single_elt: t -> elt option val choose: t -> elt (** Return one element of the given set, or raise [Not_found] if the set is empty. Which element is chosen is unspecified, but equal elements will be chosen for equal sets. *) val split: elt -> t -> t * bool * t (** [split x s] returns a triple [(l, present, r)], where [l] is the set of elements of [s] that are strictly less than [x]; [r] is the set of elements of [s] that are strictly greater than [x]; [present] is [false] if [s] contains no element equal to [x], or [true] if [s] contains an element equal to [x]. *) val intersects: t -> t -> bool (** [intersects s1 s2] returns [true] if and only if [s1] and [s2] have an element in common *) (** Clear all the caches used internally by the functions of this module. Those caches are not project-aware, so this function must be called at least each a project switch occurs. *) val clear_caches: unit -> unit end module Make(X: Id_Datatype) (Initial_Values : sig val v : X.t list list end) (Datatype_deps: sig val l : State.t list end) : sig include S with type elt = X.t val self : State.t end (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/integer.ml.bigint�������������������������������������������������0000644�0001750�0001750�00000022740�12155630226�020603� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) type t = Big_int.big_int include Big_int let equal = eq_big_int let compare = compare_big_int (* Nb of significant digits in a "word" of Big_int. *) let nb_digits_of_big_int = let r = let rec nb_digits y = if 1 = num_digits_big_int (power_int_positive_int 2 y) then nb_digits (y + 1) else y in nb_digits 1 in r let base = power_int_positive_int 2 nb_digits_of_big_int let base16bits = power_int_positive_int 2 16 (* If X is such that x = let f a x =(a * base) + x in List.fold_left f 0 X, and Y such that y = let f a y =(a * base) + y in List.fold_left f 0 Y, we have map2_base base op x y = let f a x y =(a * base) + (op x y) in List.fold_left f 0 X Y *) let map2_base b op x y = let rec map2_base_rec a x y = let (qx, mx) = quomod_big_int x b and (qy, my) = quomod_big_int y b in let res_m = op mx my and res_q = if (eq_big_int zero_big_int qx) && (eq_big_int zero_big_int qy) then a else map2_base_rec a qx qy in add_big_int (mult_big_int res_q b) res_m in map2_base_rec zero_big_int x y let bitwise_op_positive_big_int op x y = assert (ge_big_int x zero_big_int); assert (ge_big_int y zero_big_int); let g = let f u v = assert(is_int_big_int u) ; assert(is_int_big_int v) ; let r = op (int_of_big_int u) (int_of_big_int v) in big_int_of_int (r) in map2_base base16bits f in let r = map2_base base g x y in assert (ge_big_int r zero_big_int); r let lnot_big_int w = minus_big_int (succ_big_int w) let shift_left_big_int x y = (* idem multiplication *) mult_big_int x (power_int_positive_big_int 2 y) let shift_right_big_int x y = (* idem division rounding to -oo *) div_big_int x (power_int_positive_big_int 2 y) let power_two = let h = Hashtbl.create 7 in fun k -> try Hashtbl.find h k with Not_found -> let p = power_int_positive_int 2 k in Hashtbl.add h k p; p let two_power y = try let k = int_of_big_int y in power_two k with Failure _ -> assert false let log_shift_right_big_int x y = (* no meaning for negative value of x *) if (lt_big_int x zero_big_int) then raise (Invalid_argument "log_shift_right_big_int") else shift_right_big_int x y let bitwise_op_big_int op x y = let (positive_x, op_sx) = if gt_big_int zero_big_int x then (lnot_big_int x, (fun u v -> op (lnot u) v)) else (x, op) in let (positive_y, op_sx_sy) = if gt_big_int zero_big_int y then (lnot_big_int y, (fun u v -> op_sx u (lnot v))) else (y, op_sx) in let (positive_op_map, op_map) = if 0 = (op_sx_sy 0 0) then (op_sx_sy, (fun w -> w)) else ((fun u v -> lnot (op_sx_sy u v)), lnot_big_int) in op_map (bitwise_op_positive_big_int positive_op_map positive_x positive_y) let land_big_int = bitwise_op_big_int (land) let lor_big_int = bitwise_op_big_int (lor) let lxor_big_int = bitwise_op_big_int (lxor) (* Get the value encoded from the 'first' to 'last' bit of 'x' : Shift right 'x' and apply a mask on it. The result is: div (mod x (2**(last+1))) (2**first) *) let bitwise_extraction first_bit last_bit x = assert (first_bit <= last_bit);(* first_bit <= last_bit *) assert (first_bit >= 0); (* first_bit >= 0 *) let q = div_big_int x (power_int_positive_int 2 first_bit) in let r = mod_big_int q (power_int_positive_int 2 (1 + last_bit - first_bit)) in r (* To export *) let small_nums = Array.init 33 (fun i -> big_int_of_int i) let zero = zero_big_int let one = unit_big_int let two = small_nums.(2) let four = small_nums.(4) let eight = small_nums.(8) let thirtytwo = small_nums.(32) let onethousand = big_int_of_int 1000 let billion_one = big_int_of_int 1_000_000_001 let is_zero v = (sign_big_int v) = 0 let rem = mod_big_int let div = div_big_int let divexact = div_big_int let div_rem = quomod_big_int let mul = mult_big_int let sub = sub_big_int let abs = abs_big_int let succ = succ_big_int let pred = pred_big_int let neg = minus_big_int let add = add_big_int let hash c = let i = try int_of_big_int c with Failure _ -> int_of_big_int (rem c billion_one) in 197 + i let shift_right_logical = log_shift_right_big_int let shift_right = shift_right_big_int let shift_left = shift_left_big_int let logand = land_big_int let lognot = lnot_big_int let logor = lor_big_int let logxor = lxor_big_int let le = le_big_int let lt = lt_big_int let ge = ge_big_int let gt = gt_big_int let to_int v = try int_of_big_int v with Failure "int_of_big_int" -> failwith "to_int" let of_int i = if 0 <= i && i <= 32 then small_nums.(i) else big_int_of_int i let of_int64 i = big_int_of_int64 i let to_int64 i = int64_of_big_int i let of_int32 i = big_int_of_string (Int32.to_string i) let max_int64 = of_int64 Int64.max_int let min_int64 = of_int64 Int64.min_int let bits_of_max_float = of_int64 (Int64.bits_of_float max_float) let bits_of_most_negative_float = of_int64 (Int64.bits_of_float (-. max_float)) let of_string = big_int_of_string let to_string = string_of_big_int let to_float = float_of_big_int let minus_one = pred zero let two_power_60 = power_two 60 let two_power_64 = power_two 64 let add_2_64 x = add two_power_64 x let pretty ?(hexa=false) fmt v = let rec aux v = if gt v two_power_60 then let quo, rem = quomod_big_int v two_power_60 in aux quo; Format.fprintf fmt "%015LX" (to_int64 rem) else Format.fprintf fmt "%LX" (to_int64 v) in if hexa then if equal v zero then Format.pp_print_string fmt "0" else if gt v zero then (Format.pp_print_string fmt "0x"; aux v) else (Format.pp_print_string fmt "-0x"; aux (minus_big_int v)) else Format.pp_print_string fmt (to_string v) let is_one v = equal one v let pos_div = div let pos_rem = rem let native_div = div let c_div u v = let bad_div = div u v in if (lt u zero) && not (is_zero (rem u v)) then if lt v zero then pred bad_div else succ bad_div else bad_div let c_rem u v = sub u (mul v (c_div u v)) let cast ~size ~signed ~value = let factor = two_power size in let mask = two_power (sub size one) in if (not signed) then pos_rem value factor else if equal (logand mask value) zero then logand value (pred mask) else logor (lognot (pred mask)) value let two_power = two_power let power_two = power_two let extract_bits ~start ~stop v = assert (ge start zero && ge stop start); (*Format.printf "%a[%a..%a]@\n" pretty v pretty start pretty stop;*) let r = bitwise_extraction (to_int start) (to_int stop) v in (*Format.printf "%a[%a..%a]=%a@\n" pretty v pretty start pretty stop pretty r;*) r let is_even v = is_zero (logand one v) (** [pgcd u 0] is allowed and returns [u] *) let pgcd u v = let r = if is_zero v then u else gcd_big_int u v in r let ppcm u v = if u = zero || v = zero then zero else native_div (mul u v) (pgcd u v) let length u v = succ (sub v u) let min = min_big_int let max = max_big_int let round_down_to_zero v modu = mul (pos_div v modu) modu (** [round_up_to_r m r modu] is the smallest number [n] such that [n]>=[m] and [n] = [r] modulo [modu] *) let round_up_to_r ~min:m ~r ~modu = add (add (round_down_to_zero (pred (sub m r)) modu) r) modu (** [round_down_to_r m r modu] is the largest number [n] such that [n]<=[m] and [n] = [r] modulo [modu] *) let round_down_to_r ~max:m ~r ~modu = add (round_down_to_zero (sub m r) modu) r let to_num = Num.num_of_big_int (* only for x >= 0 *) let popcount x = let rec aux x acc = if is_zero x then acc else let acc = acc + (to_int (logand x one)) in aux (shift_right x one) acc in aux x 0 ��������������������������������frama-c-Fluorine-20130601/src/lib/binary_cache.mli��������������������������������������������������0000644�0001750�0001750�00000005505�12155630226�020453� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Very low-level abstract functorial caches. Do not use them unless you understand what happens in this module, and do not forget that those caches are not aware of projects. *) module MemoryFootprint : State_builder.Ref with type data = int module type Cacheable = sig type t val hash : t -> int val sentinel : t val equal : t -> t -> bool end module type Result = sig type t val sentinel : t end module Make_Symetric(H : Cacheable)(R : Result): sig val clear : unit -> unit val merge : (H.t -> H.t -> R.t) -> H.t -> H.t -> R.t end module Make_Asymetric(H : Cacheable)(R : Result): sig val clear : unit -> unit val merge : (H.t -> H.t -> R.t) -> H.t -> H.t -> R.t end module Make_Binary(H0 : Cacheable)(H1 : Cacheable): sig val clear : unit -> unit val merge : (H0.t -> H1.t -> bool) -> H0.t -> H1.t -> bool end module Make_Symetric_Binary(H0 : Cacheable): sig val clear : unit -> unit val merge : (H0.t -> H0.t -> bool) -> H0.t -> H0.t -> bool end module Make_Het1_1_4 (H0 : Cacheable)(H1 : Cacheable)(H2 : Cacheable) (R : Result): sig val clear : unit -> unit val merge : (unit -> R.t) -> H0.t -> H1.t -> H2.t -> H2.t -> H2.t -> H2.t -> R.t end (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/dynlink_311_or_higher.ml������������������������������������������0000644�0001750�0001750�00000004216�12155630226�021753� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* Should not be in this module, but must happen very early in the boot process *) let () = Printexc.record_backtrace true (* Implementation of [Dynlink_common_interface] compatible with OCaml >=3.11 whenever [Dynlink] does correctly work. *) module type OldDynlink = sig val loadfile : string -> unit val allow_unsafe_modules : bool -> unit val init : unit -> unit val digest_interface : string -> string list -> Digest.t end exception Unsupported_Feature of string include Dynlink (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/indexer.ml��������������������������������������������������������0000644�0001750�0001750�00000013077�12155630226�017334� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* -------------------------------------------------------------------------- *) (* --- Index of items --- *) (* -------------------------------------------------------------------------- *) module type Elt = sig type t val compare : t -> t -> int end module Make(E : Elt) = struct type t = | Empty | Node of int * t * E.t * t (* -------------------------------------------------------------------------- *) (* --- Access --- *) (* -------------------------------------------------------------------------- *) let size = function Empty -> 0 | Node(n,_,_,_) -> n let rec lookup n a = function | Empty -> raise Not_found | Node(_,p,e,q) -> let cmp = E.compare a e in if cmp < 0 then lookup n a p else if cmp > 0 then lookup (n+size p+1) a q else n + size p let index = lookup 0 let rindex e t = try index e t with Not_found -> (-1) let rec mem a = function | Empty -> false | Node(_,p,e,q) -> let cmp = E.compare a e in if cmp < 0 then mem a p else if cmp > 0 then mem a q else true let rec get k = function | Empty -> raise Not_found | Node(_,p,e,q) -> let n = size p in if k < n then get k p else if k > n then get (k-n-1) q else e let rec iter f = function | Empty -> () | Node(_,p,e,q) -> iter f p ; f e ; iter f q let rec walk n f = function | Empty -> () | Node(_,p,e,q) -> let m = n + size p in walk n f p ; f m e ; walk (m+1) f q let iteri = walk 0 (* -------------------------------------------------------------------------- *) (* --- Constructors --- *) (* -------------------------------------------------------------------------- *) let empty = Empty let node p e q = Node(size p + size q + 1,p,e,q) (*TODO: can be better *) let rec balance p e q = match p , q with | Node(_,p1,x,p2) , _ when size q < size p1 -> node p1 x (balance p2 e q) | _ , Node(_,q1,y,q2) when size p < size q2 -> node (balance p e q1) y q2 | _ -> node p e q (* -------------------------------------------------------------------------- *) (* --- Add,Remove --- *) (* -------------------------------------------------------------------------- *) let rec add a = function | Empty -> Node(1,Empty,a,Empty) | Node(n,p,e,q) -> let cmp = E.compare a e in if cmp < 0 then balance (add a p) e q else if cmp > 0 then balance p e (add a q) else Node(n,p,a,q) (* requires x<y for each x in p and y in q *) let rec join p q = match p,q with | Empty,r | r,Empty -> r | Node(n,p1,x,p2) , Node(m,q1,y,q2) -> if n >= m then balance p1 x (join p2 q) else balance (join p q1) y q2 let rec remove a = function | Empty -> Empty | Node(_,p,e,q) -> let cmp = E.compare a e in if cmp < 0 then balance (remove a p) e q else if cmp > 0 then balance p e (remove a q) else join p q let rec filter f = function | Empty -> Empty | Node(_,p,e,q) -> let p = filter f p in let q = filter f q in if f e then balance p e q else join p q (* -------------------------------------------------------------------------- *) (* --- Update --- *) (* -------------------------------------------------------------------------- *) let update x y t = match x , y with | None , None -> (* identify *) 0,-1,t | Some x , None -> (* remove x *) let i = rindex x t in if i < 0 then 0,-1,t else i,size t-1,remove x t | None , Some y -> (* add y *) let t = add y t in let j = index y t in j , size t-1 , t | Some x , Some y -> let i = rindex x t in if i < 0 then let t = add y t in let j = rindex y t in j , size t-1 , t else let t = add y (remove x t) in let j = rindex y t in min i j , max i j , t end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/pretty_utils.ml���������������������������������������������������0000644�0001750�0001750�00000012622�12155630226�020440� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let sfprintf fmt = let b = Buffer.create 20 in let return fmt = Format.pp_print_flush fmt (); Buffer.contents b in Format.kfprintf return (Format.formatter_of_buffer b) fmt let to_string pp x = let b = Buffer.create 20 in let f = Format.formatter_of_buffer b in pp f x ; Format.pp_print_flush f () ; Buffer.contents b let rec pp_print_string_fill out s = if String.contains s ' ' then begin let i = String.index s ' ' in let l = String.length s in let s1 = String.sub s 0 i in let s2 = String.sub s (i+1) (l - i - 1) in Format.fprintf out "%s@ %a" s1 pp_print_string_fill s2 end else Format.pp_print_string out s type sformat = (unit,Format.formatter,unit) Pervasives.format type 'a formatter = Format.formatter -> 'a -> unit type ('a,'b) formatter2 = Format.formatter -> 'a -> 'b -> unit let pp_list ?(pre=format_of_string "@[") ?(sep=format_of_string "@,") ?(last=sep) ?(suf=format_of_string "@]") pp_elt f l = let rec aux f = function | [] -> assert false | [ e ] -> Format.fprintf f "%a" pp_elt e | [ e1; e2 ] -> Format.fprintf f "%a%(%)%a" pp_elt e1 last pp_elt e2 | e :: l -> Format.fprintf f "%a%(%)%a" pp_elt e sep aux l in match l with | [] -> () | _ :: _ as l -> Format.fprintf f "%(%)%a%(%)" pre aux l suf let pp_array ?(pre=format_of_string "@[") ?(sep=format_of_string "") ?(suf=format_of_string "@]") pp_elt f xs = match xs with | [| |] -> () | xs -> begin Format.fprintf f pre ; pp_elt f 0 xs.(0) ; for i = 1 to Array.length xs - 1 do Format.fprintf f sep ; pp_elt f i xs.(i) ; done ; Format.fprintf f suf ; end let pp_iter ?(pre=format_of_string "@[") ?(sep=format_of_string "") ?(suf=format_of_string "@]") iter pp fmt v = let need_sep = ref false in Format.fprintf fmt pre; iter (fun v -> if !need_sep then Format.fprintf fmt sep else need_sep := true; pp fmt v; ) v; Format.fprintf fmt suf; ;; let pp_opt ?(pre=format_of_string "@[") ?(suf=format_of_string "@]") pp_elt f = function | None -> () | Some v -> Format.fprintf f "%(%)%a%(%)" pre pp_elt v suf let pp_cond ?(pr_false=format_of_string "") cond f pr_true = Format.fprintf f "%(%)" (if cond then pr_true else pr_false) let escape_underscores = Str.global_replace (Str.regexp_string "_") "__" let pp_flowlist ?(left=format_of_string "(") ?(sep=format_of_string ",") ?(right=format_of_string ")") f out = function | [] -> Format.fprintf out "%(%)%(%)" left right | x::xs -> begin Format.fprintf out "@[<hov 1>%(%)%a" left f x ; List.iter (fun x -> Format.fprintf out "%(%)@,%a" sep f x) xs ; Format.fprintf out "%(%)@]" right ; end let pp_blocklist ?(left=format_of_string "{") ?(right=format_of_string "}") f out = function | [] -> Format.fprintf out "%(%)%(%)" left right | xs -> Format.fprintf out "@[<hv 0>%(%)@[<hv 2>" left ; List.iter (fun x -> Format.fprintf out "@ %a" f x) xs ; Format.fprintf out "@]@ %(%)@]" right let pp_open_block out msg = Format.fprintf out ("@[<hv 0>@[<hv 2>" ^^ msg) let pp_close_block out msg = Format.fprintf out ("@]@ " ^^ msg ^^ "@]") let pp_trail pp fmt x = begin Format.fprintf fmt "@[<h 0>(**" ; let out newlined fmt s k n = for i=k to k+n-1 do if !newlined then ( Format.fprintf fmt "@\n * " ; newlined := false ) ; if s.[i] = '\n' then newlined := true else Format.pp_print_char fmt s.[i] done in let nwl = ref true in let ftt = Format.make_formatter (out nwl fmt) (fun () -> ()) in pp ftt x ; Format.pp_print_flush ftt () ; Format.fprintf fmt "@\n **)@]" ; end (* Local Variables: compile-command: "make -C ../.." End: *) ��������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/bag.ml������������������������������������������������������������0000644�0001750�0001750�00000012611�12155630226�016420� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ------------------------------------------------------------------------ *) (* --- List with constant-time concat --- *) (* ------------------------------------------------------------------------ *) type 'a t = | Empty | Elt of 'a | Add of 'a * 'a t | App of 'a t * 'a | List of 'a list | Concat of 'a t * 'a t let empty = Empty let elt x = Elt x let length t = let rec scan n = function | Empty -> n | Elt _ -> succ n | Add(_,t) | App(t,_) -> scan (succ n) t | List xs -> n + List.length xs | Concat(a,b) -> scan (scan n a) b in scan 0 t let add x = function | Empty -> Elt x | t -> Add(x,t) let append t x = match t with | Empty -> Elt x | t -> App(t,x) let list = function | [] -> Empty | [x] -> Elt x | xs -> List xs let concat a b = match a,b with | Empty,c | c,Empty -> c | Elt x,t -> Add(x,t) | t,Elt x -> App(t,x) | Concat(a,b),c -> Concat(a,Concat(b,c)) (* 1-time optim *) | _ -> Concat(a,b) let rec ulist = function | [] -> Empty | x::xs -> concat x (ulist xs) let rec map f = function | Empty -> Empty | Elt x -> Elt (f x) | Add(x,t) -> Add(f x,map f t) | App(t,x) -> App(map f t,f x) | List xs -> List(List.map f xs) | Concat(a,b) -> Concat(map f a,map f b) let rec umap f = function | Empty -> Empty | Elt x -> f x | Add(x,t) -> concat (f x) (umap f t) | App(t,x) -> concat (umap f t) (f x) | List xs -> umap_list f xs | Concat(a,b) -> concat (umap f a) (umap f b) and umap_list f = function | [] -> Empty | x::xs -> concat (f x) (umap_list f xs) let rec iter f = function | Empty -> () | Elt x -> f x | Add(x,t) -> f x ; iter f t | App(t,x) -> iter f t ; f x | List xs -> List.iter f xs | Concat(a,b) -> iter f a ; iter f b let rec fold_left f w = function | Empty -> w | Elt x -> f w x | Add(x,t) -> fold_left f (f w x) t | App(t,x) -> f (fold_left f w t) x | List xs -> List.fold_left f w xs | Concat(a,b) -> fold_left f (fold_left f w a) b let rec fold_right f t w = match t with | Empty -> w | Elt x -> f x w | Add(x,t) -> f x (fold_right f t w) | App(t,x) -> fold_right f t (f x w) | List xs -> List.fold_right f xs w | Concat(a,b) -> fold_right f a (fold_right f b w) let rec filter f = function | Empty -> Empty | Elt x as e -> if f x then e else Empty | Add(x,ts) -> if f x then add x (filter f ts) else filter f ts | App(ts,x) -> let ts = filter f ts in if f x then append ts x else ts | List xs -> list (List.filter f xs) | Concat(a,b) -> concat (filter f a) (filter f b) let rec partition f = function | Empty -> Empty , Empty | Elt x as e -> if f x then e,Empty else Empty,e | Add(x,ts) -> let pos,neg = partition f ts in if f x then add x pos , neg else pos , add x neg | App(ts,x) -> let ok = f x in let pos,neg = partition f ts in if ok then append pos x , neg else pos , append neg x | List xs -> let pos,neg = List.partition f xs in list pos , list neg | Concat(a,b) -> let apos,aneg = partition f a in let bpos,bneg = partition f b in concat apos bpos , concat aneg bneg let rec is_empty = function | Empty | List [] -> true | Add _ | App _ | Elt _ | List _ -> false | Concat(a,b) -> is_empty a && is_empty b let rec singleton = function | Elt x | List [x] -> Some x | Empty | List _ -> None | Add(x,t) | App(t,x) -> if is_empty t then Some x else None | Concat(a,b) -> match singleton a with | Some x -> if is_empty b then Some x else None | None -> if is_empty a then singleton b else None let rec collect t xs = match t with | Elt x -> x :: xs | Empty -> xs | Add(x,t) -> x :: collect t xs | App(t,x) -> collect t (x::xs) | List ys -> ys @ xs | Concat(a,b) -> collect a (collect b xs) let elements t = collect t [] �����������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/bitvector.ml������������������������������������������������������0000644�0001750�0001750�00000010305�12155630226�017666� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ------------------------------------------------------------------------ *) (* --- Bit Vector Library --- *) (* ------------------------------------------------------------------------ *) type t = string let max_size = 1 lsl 20 let create n = let s = n lsr 3 in if s > max_size then raise (Invalid_argument "Bitvector.create") ; let r = n land 7 in String.make (if r > 0 then succ s else s) '\000' let pp_bits fmt x = for k=7 downto 0 do Format.pp_print_char fmt (if x land (1 lsl k) > 0 then '1' else '0') done let pp_elts fmt x = for k=0 to 7 do Format.pp_print_char fmt (if x land (1 lsl k) > 0 then '1' else '0') done let pretty fmt s = for i=0 to String.length s - 1 do if i > 0 then Format.pp_print_space fmt () ; pp_elts fmt (int_of_char s.[i]) ; done let is_empty s = try for i=0 to String.length s - 1 do if s.[i] <> '\000' then raise Exit ; done ; true with Exit -> false let set s k = let p = k lsr 3 in if p >= String.length s then raise (Invalid_argument "Bitvector.set") ; let r = k land 7 in let b = int_of_char s.[p] lor (1 lsl r) in s.[p] <- char_of_int b let clear s k = let p = k lsr 3 in if p >= String.length s then raise (Invalid_argument "Bitvector.clear") ; let r = k land 7 in let b = int_of_char s.[p] land (lnot (1 lsl r)) in s.[p] <- char_of_int b let mem s k = let p = k lsr 3 in if p >= String.length s then raise (Invalid_argument "Bitvector.mem") ; let r = k land 7 in int_of_char s.[p] land (1 lsl r) > 0 let low = [| 0b00000001 ; (* 0: bits 0..0 *) 0b00000011 ; (* 1: bits 0..1 *) 0b00000111 ; (* 2: bits 0..2 *) 0b00001111 ; (* 3: bits 0..3 *) 0b00011111 ; (* 4: bits 0..4 *) 0b00111111 ; (* 5: bits 0..5 *) 0b01111111 ; (* 6: bits 0..6 *) |] let high = [| 0b11111110 ; (* 0: bits 1..7 *) 0b11111100 ; (* 1: bits 2..7 *) 0b11111000 ; (* 2: bits 3..7 *) 0b11110000 ; (* 3: bits 4..7 *) 0b11100000 ; (* 4: bits 5..7 *) 0b11000000 ; (* 5: bits 6..7 *) 0b10000000 ; (* 6: bits 7..7 *) |] let set_range s a b = if b-a < 8 then for i=a to b do set s i done else let p = let i = a land 7 in let p0 = a lsr 3 in if i=0 then p0 else (* Sets bits i..7 of p0 *) let x = int_of_char s.[p0] lor high.(i-1) in s.[p0] <- char_of_int x ; succ p0 in let q = let j = b land 7 in let q0 = b lsr 3 in if j=7 then q0 else (* Sets bits 0..j of q0 *) let x = int_of_char s.[q0] lor low.(j) in s.[q0] <- char_of_int x ; pred q0 in for i=p to q do s.[i] <- '\255' done ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/filepath.mli������������������������������������������������������0000644�0001750�0001750�00000003543�12155630226�017640� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Functions manipulating filepaths. *) (** Normalize a filename: make it relative if it is "close" to the current working directory and results in a shorter path. *) val normalize: string -> string (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/hptset.ml���������������������������������������������������������0000644�0001750�0001750�00000012245�12155630226�017201� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module type S = sig type elt include Datatype.S_with_collections val empty: t val is_empty: t -> bool val mem: elt -> t -> bool val add: elt -> t -> t val singleton: elt -> t val remove: elt -> t -> t val elements: t -> elt list val union: t -> t -> t val inter: t -> t -> t val diff: t -> t -> t val subset: t -> t -> bool val iter: (elt -> unit) -> t -> unit val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a val for_all: (elt -> bool) -> t -> bool val exists: (elt -> bool) -> t -> bool val filter: (elt -> bool) -> t -> t val partition: (elt -> bool) -> t -> t * t val cardinal: t -> int val min_elt: t -> elt val max_elt: t -> elt val contains_single_elt: t -> elt option val choose: t -> elt val split: elt -> t -> t * bool * t val intersects: t -> t -> bool val clear_caches: unit -> unit end module type Id_Datatype = sig include Datatype.S val id: t -> int end module Make(X: Id_Datatype) (Initial_Values : sig val v : X.t list list end) (Datatype_deps: sig val l : State.t list end) = struct include Hptmap.Make (X) (Datatype.Unit) (Hptmap.Comp_unused) (struct let v = List.map (List.map (fun k -> k, ())) Initial_Values.v end) (Datatype_deps) type elt = X.t let add k = add k () let iter f = iter (fun x () -> f x) let fold f = fold (fun x () -> f x) let elements s = fold (fun h t -> h::t) s [] let contains_single_elt s = match is_singleton s with Some (k, _v) -> Some k | None -> None let min_elt s = fst (min_binding s) let max_elt s = fst (max_binding s) let choose = min_elt let filter f s = fold (fun x acc -> if f x then add x acc else acc) s empty let partition f s = fold (fun x (w, wo) -> if f x then add x w, wo else w, add x wo) s (empty, empty) let mem x s = try find x s; true with Not_found -> false let diff s1 s2 = fold (fun x acc -> if mem x s2 then acc else add x acc) s1 empty let inter s1 s2 = fold (fun x acc -> if mem x s1 then add x acc else acc) s2 empty (* let inter = time2 "inter" inter *) let binary_unit _ _ = () let union = symetric_merge ~cache:("Hptset.union", 12) ~decide_none:binary_unit ~decide_some:binary_unit (* let union = time2 "union" union *) let singleton x = add x empty exception Elt_found let exists f s = try iter (fun x -> if f x then raise Elt_found) s; false with Elt_found -> true let for_all f s = try iter (fun x -> if not (f x) then raise Elt_found) s; true with Elt_found -> false exception Not_incl let subset = generic_is_included Not_incl ~cache:("Hptset.subset", 12) ~decide_fst:(fun _ () -> raise Not_incl) ~decide_snd:binary_unit ~decide_both:binary_unit let subset s1 s2 = try subset s1 s2 ; true with Not_incl -> false (* let subset = time2 "subset" subset *) let cardinal s = fold (fun _ acc -> acc + 1) s 0 (* let cardinal = time "cardinal" cardinal *) let pretty = if X.pretty == Datatype.undefined then Datatype.undefined else Pretty_utils.pp_iter ~pre:"@[<hov 1>{" ~sep:",@ " ~suf:"}@]" iter X.pretty let split key t = let l, pres, r = split key t in l, pres <> None, r let intersects = let aux = generic_symetric_existential_predicate Hptmap.Found_inter do_it_intersect ~decide_one:(fun _ _ -> ()) ~decide_both:(fun _ _ -> raise Hptmap.Found_inter) in fun s1 s2 -> try aux s1 s2; false with Hptmap.Found_inter -> true end (* Local Variables: compile-command: "make -C ../.." End: *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/rangemap.ml�������������������������������������������������������0000644�0001750�0001750�00000044266�12155630226�017474� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file was originally part of Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright (C) 1996 INRIA *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* *) (* All rights reserved. *) (* *) (* This file is distributed under the terms of the GNU Library General *) (* Public License version 2, with the special exception on linking *) (* described below. See the GNU Library General Public License version *) (* 2 for more details (enclosed in the file licenses/LGPLv2). *) (* *) (* As a special exception to the GNU Library General Public License, *) (* you may link, statically or dynamically, a "work that uses the *) (* Library" with a publicly distributed version of the Library to *) (* produce an executable file containing portions of the Library, and *) (* distribute that executable file under terms of your choice, without *) (* any of the additional requirements listed in clause 6 of the GNU *) (* Library General Public License. By "a publicly distributed version *) (* of the Library", we mean either the unmodified Library as *) (* distributed by INRIA, or a modified version of the Library that is *) (* distributed under the conditions defined in clause 2 of the GNU *) (* Library General Public License. This exception does not however *) (* invalidate any other reasons why the executable file might be *) (* covered by the GNU Library General Public License. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives). *) (* *) (**************************************************************************) type fuzzy_order = Above | Below | Match module type S = sig type key type value type rangemap include Datatype.S with type t = rangemap val create : t -> key -> value -> t -> t val empty: t val is_empty: t -> bool val add: key -> value -> t -> t val singleton: key -> value -> t val find: key -> t -> value val remove: key -> t -> t val mem: key -> t -> bool val iter: (key -> value -> unit) -> t -> unit val map: (value -> value) -> t -> t val mapi: (key -> value -> value) -> t -> t val mapii: (key -> value -> key*value) -> t -> t val fold: (key -> value -> 'a -> 'a) -> t -> 'a -> 'a val for_all: (key -> value -> bool) -> t -> bool val exists: (key -> value -> bool) -> t -> bool val filter: (key -> value -> bool) -> t -> t val partition: (key -> value -> bool) -> t -> t * t val cardinal: t -> int val bindings: t -> (key * value) list val min_binding: t -> (key * value) val max_binding: t -> (key * value) val choose: t -> (key * value) val merge: (key -> value option -> value option -> value option) -> t -> t -> t val for_all2: (key -> value option -> value option -> bool) -> t -> t -> bool val exists2: (key -> value option -> value option -> bool) -> t -> t -> bool val iter2: (key -> value option -> value option -> unit) -> t -> t -> unit val fold2: (key -> value option -> value option -> 'a -> 'a) -> t -> t -> 'a -> 'a end module type Value = sig include Datatype.S val fast_equal: t -> t -> bool end module Make(Ord: Datatype.S)(Value: Value) = struct type key = Ord.t type value = Value.t type rangemap = | Empty | Node of rangemap * key * Value.t * rangemap * int * int (* the last two are height and hash in this order *) let height = function | Empty -> 0 | Node(_,_,_,_,h,_) -> h let hash = function | Empty -> 0 | Node(_,_,_,_,_,h) -> h let create l x d r = let x_h = Ord.hash x in let d_h = Value.hash d in let hl = height l and hr = height r in let hashl = hash l and hashr = hash r in let hashbinding = 31 * x_h + d_h in let hashtree = hashl lxor hashbinding lxor hashr in Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1), hashtree) let bal l x d r = let hl = match l with Empty -> 0 | Node(_,_,_,_,h,_) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,_,h,_) -> h in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Rangemap.bal" | Node(ll, lv, ld, lr, _, _) -> if height ll >= height lr then create ll lv ld (create lr x d r) else begin match lr with Empty -> invalid_arg "Rangemap.bal" | Node(lrl, lrv, lrd, lrr, _, _)-> create (create ll lv ld lrl) lrv lrd (create lrr x d r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Rangemap.bal" | Node(rl, rv, rd, rr, _, _) -> if height rr >= height rl then create (create l x d rl) rv rd rr else begin match rl with Empty -> invalid_arg "Rangemap.bal" | Node(rll, rlv, rld, rlr, _, _) -> create (create l x d rll) rlv rld (create rlr rv rd rr) end end else create l x d r let empty = Empty let is_empty = function Empty -> true | _ -> false let singleton x v = create Empty x v Empty let rec add x data = function Empty -> create Empty x data Empty | Node(l, v, d, r, _, _) as node -> let c = Ord.compare x v in if c = 0 then if Value.fast_equal d data then node else create l x data r else if c < 0 then bal (add x data l) v d r else bal l v d (add x data r) let rec find x = function | Empty -> raise Not_found | Node(l, v, d, r, _, _) -> let c = Ord.compare x v in if c = 0 then d else find x (if c < 0 then l else r) let rec mem x = function | Empty -> false | Node(l, v, _d, r, _, _) -> let c = Ord.compare x v in c = 0 || mem x (if c < 0 then l else r) let rec max_binding = function | Empty -> raise Not_found | Node(_l, x, d, Empty, _, _) -> (x, d) | Node(_l, _x, _d, r, _, _) -> max_binding r let rec min_binding = function | Empty -> raise Not_found | Node(Empty, x, d, _r, _, _) -> (x, d) | Node(l, _x, _d, _r, _, _) -> min_binding l let choose = min_binding let rec remove_min_binding = function | Empty -> invalid_arg "Rangemap.remove_min_elt" | Node(Empty, _x, _d, r, _, _) -> r | Node(l, x, d, r, _, _) -> bal (remove_min_binding l) x d r let merge t1 t2 = match (t1, t2) with | (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let (x, d) = min_binding t2 in bal t1 x d (remove_min_binding t2) let rec remove x = function | Empty -> Empty | Node(l, v, d, r, _, _h) -> let c = Ord.compare x v in if c = 0 then merge l r else if c < 0 then bal (remove x l) v d r else bal l v d (remove x r) let rec iter f = function | Empty -> () | Node(l, v, d, r, _, _) -> iter f l; f v d; iter f r let rec map f = function | Empty -> Empty | Node(l, v, d, r, _, _h) -> create (map f l) v (f d) (map f r) let rec mapi f = function | Empty -> Empty | Node(l, v, d, r, _, _h) -> create (mapi f l) v (f v d) (mapi f r) let rec mapii f = function | Empty -> Empty | Node(l, v, d, r, _, _) -> let new_v, new_d = f v d in create (mapii f l) new_v new_d (mapii f r) let rec fold f m accu = match m with | Empty -> accu | Node(l, v, d, r, _, _) -> fold f r (f v d (fold f l accu)) let rec for_all p = function Empty -> true | Node(l, v, d, r, _, _) -> p v d && for_all p l && for_all p r let rec exists p = function Empty -> false | Node(l, v, d, r, _, _) -> p v d || exists p l || exists p r let filter p s = let rec filt accu = function | Empty -> accu | Node(l, v, d, r, _, _) -> filt (filt (if p v d then add v d accu else accu) l) r in filt Empty s let partition p s = let rec part (t, f as accu) = function | Empty -> accu | Node(l, v, d, r, _, _) -> part (part (if p v d then (add v d t, f) else (t, add v d f)) l) r in part (Empty, Empty) s (* Same as create and bal, but no assumptions are made on the relative heights of l and r. *) let rec join l v d r = match (l, r) with (Empty, _) -> add v d r | (_, Empty) -> add v d l | (Node(ll, lv, ld, lr, lh, _), Node(rl, rv, rd, rr, rh, _)) -> if lh > rh + 2 then bal ll lv ld (join lr v d r) else if rh > lh + 2 then bal (join l v d rl) rv rd rr else create l v d r (* Merge two trees l and r into one. All elements of l must precede the elements of r. No assumption on the heights of l and r. *) let concat t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let (x, d) = min_binding t2 in join t1 x d (remove_min_binding t2) let concat_or_join t1 v d t2 = match d with | Some d -> join t1 v d t2 | None -> concat t1 t2 let rec split x = function Empty -> (Empty, None, Empty) | Node(l, v, d, r, _, _) -> let c = Ord.compare x v in if c = 0 then (l, Some d, r) else if c < 0 then let (ll, pres, rl) = split x l in (ll, pres, join rl v d r) else let (lr, pres, rr) = split x r in (join l v d lr, pres, rr) let rec merge f s1 s2 = match (s1, s2) with (Empty, Empty) -> Empty | (Node (l1, v1, d1, r1, h1, _), _) when h1 >= height s2 -> let (l2, d2, r2) = split v1 s2 in concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2) | (_, Node (l2, v2, d2, r2, _h2, _)) -> let (l1, d1, r1) = split v2 s1 in concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2) | _ -> assert false type enumeration = End | More of key * Value.t * rangemap * enumeration let rec cons_enum m e = match m with | Empty -> e | Node(l, v, d, r, _, _) -> cons_enum l (More(v, d, r, e)) let compare m1 m2 = let rec compare_aux e1 e2 = match (e1, e2) with | (End, End) -> 0 | (End, _) -> -1 | (_, End) -> 1 | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> let c = Ord.compare v1 v2 in if c <> 0 then c else let c = Value.compare d1 d2 in if c <> 0 then c else compare_aux (cons_enum r1 e1) (cons_enum r2 e2) in compare_aux (cons_enum m1 End) (cons_enum m2 End) let equal m1 m2 = let rec equal_aux e1 e2 = match (e1, e2) with | (End, End) -> true | (End, _) -> false | (_, End) -> false | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> Ord.equal v1 v2 && Value.equal d1 d2 && equal_aux (cons_enum r1 e1) (cons_enum r2 e2) in equal_aux (cons_enum m1 End) (cons_enum m2 End) let fold2 f m1 m2 r = let rec aux e1 e2 r = match e1, e2 with | (End, End) -> r | (End, More (k, v, t, e)) -> f k None (Some v) (aux End (cons_enum t e) r) | (More (k, v, t, e), End) -> f k (Some v) None (aux (cons_enum t e) End r) | (More (k1, v1, t1, e1'), More (k2, v2, t2, e2')) -> let c = Ord.compare k1 k2 in if c = 0 then f k1 (Some v1) (Some v2) (aux (cons_enum t1 e1') (cons_enum t2 e2') r) else if c < 0 then f k1 (Some v1) None (aux (cons_enum t1 e1') e2 r) else f k2 (Some v2) None (aux e1 (cons_enum t2 e2') r) in aux (cons_enum m1 End) (cons_enum m2 End) r (* iter2, exists2 and for_all2 are essentially the same implementation as fold2 with the appropriate default value and operator, but we cannot use fold, as ";", "||" and "&&" are lazy... *) let iter2 f m1 m2 = let rec aux e1 e2 = match e1, e2 with | (End, End) -> () | (End, More (k, v, t, e)) -> f k None (Some v); aux End (cons_enum t e) | (More (k, v, t, e), End) -> f k (Some v) None; aux (cons_enum t e) End | (More (k1, v1, t1, e1'), More (k2, v2, t2, e2')) -> let c = Ord.compare k1 k2 in if c = 0 then ( f k1 (Some v1) (Some v2); aux (cons_enum t1 e1') (cons_enum t2 e2') ) else if c < 0 then ( f k1 (Some v1) None; aux (cons_enum t1 e1') e2 ) else ( f k2 (Some v2) None; aux e1 (cons_enum t2 e2') ) in aux (cons_enum m1 End) (cons_enum m2 End) let exists2 f m1 m2 = let rec aux e1 e2 = match e1, e2 with | (End, End) -> false | (End, More (k, v, t, e)) -> f k None (Some v) || aux End (cons_enum t e) | (More (k, v, t, e), End) -> f k (Some v) None || aux (cons_enum t e) End | (More (k1, v1, t1, e1'), More (k2, v2, t2, e2')) -> let c = Ord.compare k1 k2 in if c = 0 then f k1 (Some v1) (Some v2) || aux (cons_enum t1 e1') (cons_enum t2 e2') else if c < 0 then f k1 (Some v1) None || aux (cons_enum t1 e1') e2 else f k2 (Some v2) None || aux e1 (cons_enum t2 e2') in aux (cons_enum m1 End) (cons_enum m2 End) let for_all2 f m1 m2 = let rec aux e1 e2 = match e1, e2 with | (End, End) -> true | (End, More (k, v, t, e)) -> f k None (Some v) && aux End (cons_enum t e) | (More (k, v, t, e), End) -> f k (Some v) None && aux (cons_enum t e) End | (More (k1, v1, t1, e1'), More (k2, v2, t2, e2')) -> let c = Ord.compare k1 k2 in if c = 0 then f k1 (Some v1) (Some v2) && aux (cons_enum t1 e1') (cons_enum t2 e2') else if c < 0 then f k1 (Some v1) None && aux (cons_enum t1 e1') e2 else f k2 (Some v2) None && aux e1 (cons_enum t2 e2') in aux (cons_enum m1 End) (cons_enum m2 End) let rec cardinal = function | Empty -> 0 | Node(l, _, _, r, _, _) -> cardinal l + 1 + cardinal r let rec bindings_aux accu = function | Empty -> accu | Node(l, v, d, r, _, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l let bindings s = bindings_aux [] s let rec fold_range o f m accu = match m with | Empty -> accu | Node(l, v, d, r, _, _) -> let compar = o v in let accu1 = match compar with | Match | Above -> fold_range o f l accu | Below -> accu in let accu2 = match compar with | Match -> f v d accu1 | Above | Below -> accu1 in match compar with | Match | Below -> fold_range o f r accu2 | Above -> accu2 let cons k v l = (k,v) :: l let concerned_intervals fuzzy_order i m = fold_range (fuzzy_order i) cons m [] let remove_whole fuzzy_order i m = fold_range (fuzzy_order i) (fun k _v acc -> remove k acc) m m let add_whole fuzzy_order i v m = let removed = remove_whole fuzzy_order i m in add i v removed exception Empty_rangemap (* This is actually a copy of [min_binding], but raises [Empty_rangemap] instead of [Not_found]... *) let rec lowest_binding m = match m with | Node(Empty,k,v,_,_, _) -> k,v | Node(t,_,_,_,_, _) -> lowest_binding t | Empty -> raise Empty_rangemap exception No_such_binding let rec lowest_binding_above o m = match m with | Node(l,k,v,r,_, _) -> if o k then begin try lowest_binding_above o l with No_such_binding -> k,v end else lowest_binding_above o r | Empty -> raise No_such_binding include Datatype.Make (struct type t = rangemap let name = "(" ^ Ord.name ^ ", " ^ Value.name ^ ") rangemap" open Structural_descr let r = Recursive.create () let structural_descr = Structure (Sum [| [| recursive_pack r; Ord.packed_descr; Value.packed_descr; recursive_pack r; p_int; p_int |] |] ) let () = Recursive.update r structural_descr let reprs = List.fold_left (fun acc k -> List.fold_left (fun acc v -> (Node(Empty, k, v, Empty, 0, 0)) :: acc) acc Value.reprs) [ Empty ] Ord.reprs let equal = equal let compare = compare let hash = hash let rehash = Datatype.identity let copy = if Ord.copy == Datatype.undefined || Value.copy == Datatype.undefined then Datatype.undefined else let rec aux = function | Empty -> Empty | Node (l,x,d,r,_,_) -> let l = aux l in let x = Ord.copy x in let d = Value.copy d in let r = aux r in create l x d r in aux let internal_pretty_code = Datatype.undefined let pretty = Datatype.undefined let varname = Datatype.undefined let mem_project = if Ord.mem_project == Datatype.never_any_project && Value.mem_project == Datatype.never_any_project then Datatype.never_any_project else (fun s -> exists (fun k v -> Ord.mem_project s k || Value.mem_project s v)) end) let () = Type.set_ml_name ty None end (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/bag.mli�����������������������������������������������������������0000644�0001750�0001750�00000004441�12155630226�016573� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** List with constant-time concat operation. @since Carbon-20101201 *) type 'a t val empty : 'a t val elt : 'a -> 'a t val add : 'a -> 'a t -> 'a t val append : 'a t -> 'a -> 'a t val list : 'a list -> 'a t val ulist : 'a t list -> 'a t val concat : 'a t -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t val umap : ('a -> 'b t) -> 'a t -> 'b t val iter : ('a -> unit) -> 'a t -> unit val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b val filter : ('a -> bool) -> 'a t -> 'a t val partition : ('a -> bool) -> 'a t -> 'a t * 'a t val length : 'a t -> int val is_empty : 'a t -> bool val singleton : 'a t -> 'a option val elements : 'a t -> 'a list �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/hook.mli����������������������������������������������������������0000644�0001750�0001750�00000006361�12155630226�017005� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Hook builder. A hook is a bunch of functions which can be extended and applied at any program point. *) (** Output signature. *) module type S = sig type param (** Type of the parameter of the functions registered in the hook. *) type result (** Type of the result of the functions. result can be unit (for iterative hooks) or param (for folding hooks) *) val extend: (param -> result) -> unit (** Add a new function to the hook. If [once] is true, the hook is added if and only if it was not already present. Comparison is done using [(==)]. Default is false. *) val extend_once: (param -> result) -> unit (** Same as [extend], but the hook is added only if is is not already present; the comparison is made using [(==)] @since Oxygen-20120901 *) val apply: param -> result (** Apply all the functions of the hook on the given parameter. These functions are applied from the least recently entered to the most recently entered.*) val is_empty: unit -> bool (** Is no function already registered in the hook? *) val clear: unit -> unit (** Clear the hook. *) val length: unit -> int (** Number of registered functions. *) end module type Iter_hook = S with type result = unit (** Make a new empty hook from a given type of parameters. *) module Build(P:sig type t end) : Iter_hook with type param = P.t (** Make a new empty hook from [unit]. *) module Make(X:sig end) : S with type param = unit and type result = unit module Fold(P: sig type t end): S with type param = P.t and type result = P.t (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/hashtbl_common_interface.ml���������������������������������������0000644�0001750�0001750�00000005040�12155630226�022702� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module type S = sig include Hashtbl.S val iter_sorted: ?cmp:(key -> key -> int) -> (key -> 'a -> unit) -> 'a t -> unit val fold_sorted: ?cmp:(key -> key -> int) -> (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b end let hash = Hashtbl.hash let hash_param = Hashtbl.hash_param module Make(H: Hashtbl.HashedType) : S with type key = H.t = struct include Hashtbl.Make(H) let fold_sorted ?(cmp=Pervasives.compare) f h acc = let module Aux = struct type t = key let compare = cmp end in let module M = Map.Make(Aux) in let add k v m = try let l = v :: M.find k m in M.add k l m with Not_found -> M.add k [v] m in let map = fold add h M.empty in let fold_k k l acc = List.fold_left (fun acc v -> f k v acc) acc (List.rev l) in M.fold fold_k map acc let iter_sorted ?cmp f h = fold_sorted ?cmp (fun k v () -> f k v) h () end (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/setWithNearest.ml�������������������������������������������������0000644�0001750�0001750�00000025517�12155630226�020651� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (* File modified by CEA (Commissariat à l'énergie atomique et aux *) (* énergies alternatives). *) (**************************************************************************) (* Sets over ordered types, derived from the file Set.ml of the Objective Caml library. No function modification, only extra functions have been added. *) module type S = sig include Datatype.Set val nearest_elt_le: elt -> t -> elt val nearest_elt_ge: elt -> t -> elt end module Make(Ord: Datatype.S) = struct module S = struct type elt = Ord.t type tt = Empty | Node of tt * elt * tt * int (* Sets are represented by balanced binary trees (the heights of the children differ by at most 2 *) let height = function | Empty -> 0 | Node(_, _, _, h) -> h (* Creates a new node with left son l, value v and right son r. We must have all elements of l < v < all elements of r. l and r must be balanced and | height l - height r | <= 2. Inline expansion of height for better speed. *) let create l v r = let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) (* Same as create, but performs one step of rebalancing if necessary. Assumes l and r balanced and | height l - height r | <= 3. Inline expansion of create for better speed in the most frequent case where no rebalancing is required. *) let bal l v r = let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Set.bal" | Node(ll, lv, lr, _) -> if height ll >= height lr then create ll lv (create lr v r) else begin match lr with Empty -> invalid_arg "Set.bal" | Node(lrl, lrv, lrr, _)-> create (create ll lv lrl) lrv (create lrr v r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Set.bal" | Node(rl, rv, rr, _) -> if height rr >= height rl then create (create l v rl) rv rr else begin match rl with Empty -> invalid_arg "Set.bal" | Node(rll, rlv, rlr, _) -> create (create l v rll) rlv (create rlr rv rr) end end else Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) (* Insertion of one element *) let rec add x = function | Empty -> Node(Empty, x, Empty, 1) | Node(l, v, r, _) as t -> let c = Ord.compare x v in if c = 0 then t else if c < 0 then bal (add x l) v r else bal l v (add x r) (* Same as create and bal, but no assumptions are made on the relative heights of l and r. *) let rec join l v r = match (l, r) with | (Empty, _) -> add v r | (_, Empty) -> add v l | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) -> if lh > rh + 2 then bal ll lv (join lr v r) else if rh > lh + 2 then bal (join l v rl) rv rr else create l v r (* Smallest and greatest element of a set *) let rec min_elt = function | Empty -> raise Not_found | Node(Empty, v, _r, _) -> v | Node(l, _v, _r, _) -> min_elt l let rec max_elt = function | Empty -> raise Not_found | Node(_l, v, Empty, _) -> v | Node(_l, _v, r, _) -> max_elt r (* Remove the smallest element of the given set *) let rec remove_min_elt = function | Empty -> invalid_arg "Set.remove_min_elt" | Node(Empty, _v, r, _) -> r | Node(l, v, r, _) -> bal (remove_min_elt l) v r (* Merge two trees l and r into one. All elements of l must precede the elements of r. Assume | height l - height r | <= 2. *) let merge t1 t2 = match (t1, t2) with | (Empty, t) -> t | (t, Empty) -> t | (_, _) -> bal t1 (min_elt t2) (remove_min_elt t2) (* Merge two trees l and r into one. All elements of l must precede the elements of r. No assumption on the heights of l and r. *) let concat t1 t2 = match (t1, t2) with | (Empty, t) -> t | (t, Empty) -> t | (_, _) -> join t1 (min_elt t2) (remove_min_elt t2) (* Splitting. split x s returns a triple (l, present, r) where - l is the set of elements of s that are < x - r is the set of elements of s that are > x - present is false if s contains no element equal to x, or true if s contains an element equal to x. *) let rec split x = function | Empty -> (Empty, false, Empty) | Node(l, v, r, _) -> let c = Ord.compare x v in if c = 0 then (l, true, r) else if c < 0 then let (ll, pres, rl) = split x l in (ll, pres, join rl v r) else let (lr, pres, rr) = split x r in (join l v lr, pres, rr) (* Implementation of the set operations *) let empty = Empty let is_empty = function Empty -> true | _ -> false let rec mem x = function | Empty -> false | Node(l, v, r, _) -> let c = Ord.compare x v in c = 0 || mem x (if c < 0 then l else r) let singleton x = Node(Empty, x, Empty, 1) let rec remove x = function | Empty -> Empty | Node(l, v, r, _) -> let c = Ord.compare x v in if c = 0 then merge l r else if c < 0 then bal (remove x l) v r else bal l v (remove x r) let rec union s1 s2 = match (s1, s2) with | (Empty, t2) -> t2 | (t1, Empty) -> t1 | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> if h1 >= h2 then if h2 = 1 then add v2 s1 else begin let (l2, _, r2) = split v1 s2 in join (union l1 l2) v1 (union r1 r2) end else if h1 = 1 then add v1 s2 else begin let (l1, _, r1) = split v2 s1 in join (union l1 l2) v2 (union r1 r2) end let rec inter s1 s2 = match (s1, s2) with | (Empty, _t2) -> Empty | (_t1, Empty) -> Empty | (Node(l1, v1, r1, _), t2) -> match split v1 t2 with (l2, false, r2) -> concat (inter l1 l2) (inter r1 r2) | (l2, true, r2) -> join (inter l1 l2) v1 (inter r1 r2) let rec diff s1 s2 = match (s1, s2) with | (Empty, _t2) -> Empty | (t1, Empty) -> t1 | (Node(l1, v1, r1, _), t2) -> match split v1 t2 with (l2, false, r2) -> join (diff l1 l2) v1 (diff r1 r2) | (l2, true, r2) -> concat (diff l1 l2) (diff r1 r2) type enumeration = End | More of elt * tt * enumeration let rec cons_enum s e = match s with | Empty -> e | Node(l, v, r, _) -> cons_enum l (More(v, r, e)) let rec compare_aux e1 e2 = match (e1, e2) with | (End, End) -> 0 | (End, _) -> -1 | (_, End) -> 1 | (More(v1, r1, e1), More(v2, r2, e2)) -> let c = Ord.compare v1 v2 in if c <> 0 then c else compare_aux (cons_enum r1 e1) (cons_enum r2 e2) let compare s1 s2 = compare_aux (cons_enum s1 End) (cons_enum s2 End) let equal s1 s2 = compare s1 s2 = 0 let rec subset s1 s2 = match (s1, s2) with | Empty, _ -> true | _, Empty -> false | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) -> let c = Ord.compare v1 v2 in if c = 0 then subset l1 l2 && subset r1 r2 else if c < 0 then subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2 else subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2 let rec iter f = function | Empty -> () | Node(l, v, r, _) -> iter f l; f v; iter f r let rec fold f s accu = match s with | Empty -> accu | Node(l, v, r, _) -> fold f r (f v (fold f l accu)) let rec for_all p = function | Empty -> true | Node(l, v, r, _) -> p v && for_all p l && for_all p r let rec exists p = function | Empty -> false | Node(l, v, r, _) -> p v || exists p l || exists p r let filter p s = let rec filt accu = function | Empty -> accu | Node(l, v, r, _) -> filt (filt (if p v then add v accu else accu) l) r in filt Empty s let partition p s = let rec part (t, f as accu) = function | Empty -> accu | Node(l, v, r, _) -> part (part (if p v then (add v t, f) else (t, add v f)) l) r in part (Empty, Empty) s let rec cardinal = function | Empty -> 0 | Node(l, _v, r, _) -> cardinal l + 1 + cardinal r let rec elements_aux accu = function | Empty -> accu | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l let elements s = elements_aux [] s let choose = min_elt (************************* Extra functions **************************) (* The nearest value of [s] le [v]. Raise Not_found if none *) let rec nearest_elt_le x = function | Empty -> raise Not_found | Node(l, v, r, _) -> let c = Ord.compare x v in if c = 0 then v else if c < 0 then nearest_elt_le x l else let rec nearest w x = function Empty -> w | Node(l, v, r, _) -> let c = Ord.compare x v in if c = 0 then v else if c < 0 then nearest w x l else nearest v x r in nearest v x r (* The nearest value of [s] ge [v]. Raise Not_found if none *) let rec nearest_elt_ge x = function | Empty -> raise Not_found | Node(l, v, r, _) -> let c = Ord.compare x v in if c = 0 then v else if c < 0 then let rec nearest w x = function Empty -> w | Node(l, v, r, _) -> let c = Ord.compare x v in if c = 0 then v else if c < 0 then nearest v x l else nearest w x r in nearest v x l else nearest_elt_ge x r end let nearest_elt_ge = S.nearest_elt_ge let nearest_elt_le = S.nearest_elt_le include Datatype.Set (struct type t = S.tt include S end) (Ord) (struct let module_name = "useless" end) end (* Local Variables: compile-command: "make -C ../.." End: *) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/hashtbl_common_interface.mli��������������������������������������0000644�0001750�0001750�00000004357�12155630226�023065� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Wrapper for [Hashtbl] compatible with all OCaml versions. *) module type S = sig include Hashtbl.S val iter_sorted: ?cmp:(key -> key -> int) -> (key -> 'a -> unit) -> 'a t -> unit (** Iter on the hashtbl, but respecting the order induced by [cmp]. Use [Pervasives.compare] if [cmp] not given. *) val fold_sorted: ?cmp:(key -> key -> int) -> (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** Fold on the hashtbl, but respecting the order induced by [cmp]. Use [Pervasives.compare] if [cmp] not given. *) end module Make(H: Hashtbl.HashedType) : S with type key = H.t val hash : 'a -> int val hash_param : int -> int -> 'a -> int ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/floating_point.ml�������������������������������������������������0000644�0001750�0001750�00000023723�12155630226�020711� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) external set_round_downward: unit -> unit = "set_round_downward" external set_round_upward: unit -> unit = "set_round_upward" external set_round_nearest_even: unit -> unit = "set_round_nearest_even" external round_to_single_precision_float: float -> float = "round_to_float" external sys_single_precision_of_string: string -> float = "single_precision_of_string" let max_single_precision_float = Int32.float_of_bits 0x7f7fffffl let most_negative_single_precision_float = -. max_single_precision_float type parsed_float = { f_nearest : float ; f_lower : float ; f_upper : float ; } let inf ~man_size ~max_exp = let biggest_not_inf = ldexp (2.0 -. ldexp 1.0 (~- man_size)) max_exp in { f_lower = biggest_not_inf ; f_nearest = infinity ; f_upper = infinity ; } (* [s = num * 2^exp / den] hold *) let make_float ~num ~den ~exp ~man_size ~min_exp ~max_exp = assert (Integer.gt num Integer.zero); assert (Integer.gt den Integer.zero); let size_bi = Integer.of_int man_size in let ssize_bi = Integer.of_int (succ man_size) in let min_exp = min_exp - man_size in let den = ref den in let exp = ref exp in while Integer.ge num (Integer.shift_left !den ssize_bi) do den := Integer.shift_left !den Integer.one; incr exp done; let den = !den in let shifted_den = Integer.shift_left den size_bi in let num = ref num in while Integer.lt !num shifted_den && !exp > min_exp do num := Integer.shift_left !num Integer.one; decr exp done; let num = !num in let exp = !exp in if exp > max_exp then inf ~man_size ~max_exp else let man = Integer.native_div num den in let rem = Integer.sub num (Integer.mul den man) in let rem2 = (* twice the remainder *) Integer.shift_left rem Integer.one in let man = Integer.to_int64 man in (* Format.printf "pre-rounding: num den man rem: %a %a %Ld %a@." (Integer.pretty ~hexa:false) num (Integer.pretty ~hexa:false) den man (Integer.pretty ~hexa:false) rem; *) let lowb = ldexp (Int64.to_float man) exp in if Integer.is_zero rem2 then { f_lower = lowb ; f_nearest = lowb ; f_upper = lowb ; } else let upb = ldexp (Int64.to_float (Int64.succ man)) exp in if Integer.lt rem2 den || (Integer.equal rem2 den && (Int64.logand man Int64.one) = 0L) then { f_lower = lowb ; f_nearest = lowb ; f_upper = upb ; } else { f_lower = lowb ; f_nearest = upb ; f_upper = upb ; } let exp = "[eE][+]?\\(-?[0-9]+\\)" let dot = "[.]" let numopt = "\\([0-9]*\\)" let num = "\\([0-9]+\\)" let numdotfrac = Str.regexp (numopt ^ dot ^ numopt) let numdotfracexp = Str.regexp (numopt ^ dot ^ numopt ^ exp) let numexp = Str.regexp (num ^ exp) exception Shortcut of parsed_float let zero = { f_lower = 0.0 ; f_nearest = 0.0 ; f_upper = 0.0 } (* [man_size] is the size of the mantissa, [min_exp] the frontier exponent between normalized and denormalized numbers *) let parse_float ~man_size ~min_exp ~max_exp s = (* Format.printf "parse: %s@." s; *) let match_exp group = let s = Str.matched_group group s in try int_of_string s with Failure _ -> (* Format.printf "Error in exponent: %s@." s; *) if s.[0] = '-' then raise (Shortcut { f_lower = 0.0 ; f_nearest = 0.0 ; f_upper = ldexp 1.0 (min_exp - man_size) ; }) else raise (Shortcut (inf ~man_size ~max_exp)) in try (* At the end of the function, [s = num * 2^exp / den] *) let num, den, exp = if Str.string_match numdotfracexp s 0 then let n = Str.matched_group 1 s in let frac = Str.matched_group 2 s in let len_frac = String.length frac in let num = Integer.of_string (n ^ frac) in let den = Integer.power_int_positive_int 5 len_frac in if Integer.is_zero num then raise (Shortcut zero); let exp10 = match_exp 3 in if exp10 >= 0 then Integer.mul num (Integer.power_int_positive_int 5 exp10), den, exp10 - len_frac else num, Integer.mul den (Integer.power_int_positive_int 5 (~- exp10)), exp10 - len_frac else if Str.string_match numdotfrac s 0 then let n = Str.matched_group 1 s in let frac = Str.matched_group 2 s in let len_frac = String.length frac in Integer.of_string (n ^ frac), Integer.power_int_positive_int 5 len_frac, ~- len_frac else if Str.string_match numexp s 0 then let n = Str.matched_group 1 s in let num = Integer.of_string n in if Integer.is_zero num then raise (Shortcut zero); let exp10 = match_exp 2 in if exp10 >= 0 then Integer.mul num (Integer.power_int_positive_int 5 exp10), Integer.one, exp10 else num, (Integer.power_int_positive_int 5 (~- exp10)), exp10 else (Format.printf "Could not parse floating point number %S@." s; assert false) in if Integer.is_zero num then zero else make_float ~num ~den ~exp ~man_size ~min_exp ~max_exp with Shortcut r -> r let is_hex s = let l = String.length s in l >= 2 && s.[0] = '0' && (s.[1] = 'x' || s.[1] = 'X') let single_precision_of_string s = if is_hex s then let f = sys_single_precision_of_string s in { f_lower = f ; f_nearest = f ; f_upper = f } else (* decimal *) parse_float ~man_size:23 ~min_exp:(-126) ~max_exp:127 s let double_precision_of_string s = if is_hex s then let f = float_of_string s in { f_lower = f ; f_nearest = f ; f_upper = f } else (* decimal *) parse_float ~man_size:52 ~min_exp:(-1022) ~max_exp:1023 s let pretty_normal ~use_hex fmt f = let double_norm = Int64.shift_left 1L 52 in let double_mask = Int64.pred double_norm in let i = Int64.bits_of_float f in let s = 0L <> (Int64.logand Int64.min_int i) in let i = Int64.logand Int64.max_int i in let exp = Int64.to_int (Int64.shift_right_logical i 52) in let man = Int64.logand i double_mask in let s = if s then "-" else "" in if exp = 2047 then begin if man = 0L then Format.fprintf fmt "%sinf" s else Format.fprintf fmt "NaN" end else let firstdigit, exp = if exp <> 0 then 1, (exp - 1023) else 0, -1022 in if not use_hex then begin let firstdigit, man, exp = if 0 < exp && exp <= 12 then begin Int64.to_int (Int64.shift_right_logical (Int64.logor man double_norm) (52 - exp)), Int64.logand (Int64.shift_left man exp) double_mask, 0 end else firstdigit, man, exp in let d = Int64.float_of_bits (Int64.logor 0x3ff0000000000000L man) in let d, re = if d >= 1.5 then d -. 1.5, 5000000000000000L else d -. 1.0, 0L in let d = d *. 1e16 in let decdigits = Int64.add re (Int64.of_float d) in if exp = 0 then Format.fprintf fmt "%s%d.%016Ld" s firstdigit decdigits else Format.fprintf fmt "%s%d.%016Ld*2^%d" s firstdigit decdigits exp end else Format.fprintf fmt "%s0x%d.%013Lxp%d" s firstdigit man exp let pretty fmt f = let use_hex = Kernel.FloatHex.get() in set_round_nearest_even(); if use_hex || (Kernel.FloatNormal.get ()) then pretty_normal ~use_hex fmt f else begin let r = Format.sprintf "%.*g" 12 f in if (String.contains r '.' || String.contains r 'e' || String.contains r 'E') || (match classify_float f with | FP_normal | FP_subnormal | FP_zero -> false | FP_infinite | FP_nan -> true) then Format.pp_print_string fmt r else Format.fprintf fmt "%s." r end exception Float_Non_representable_as_Int64 (* If the argument [x] is not in the range [min_64_float, 2*max_64_float], raise Float_Non_representable_as_Int64. This is the most reasonable as a floating-point number may represent an exponentially large integer. *) let truncate_to_integer = let min_64_float = Int64.to_float Int64.min_int in let max_64_float = let open Int64 in float_of_bits (pred (bits_of_float (to_float max_int))) in fun x -> if min_64_float <= x && x <= max_64_float then Integer.of_int64 (Int64.of_float x) else if min_64_float <= x && x <= (2. *. max_64_float) then Integer.add (Integer.of_int64 (Int64.of_float (x +. min_64_float))) (Integer.power_two 63) else raise Float_Non_representable_as_Int64 (* Local Variables: compile-command: "make -C ../.. byte" End: *) ���������������������������������������������frama-c-Fluorine-20130601/src/lib/integer.ml.zarith�������������������������������������������������0000644�0001750�0001750�00000014613�12155630226�020630� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) type t = Z.t include Big_int_Z let equal = Z.equal let compare = Z.compare let shift_left_big_int x y = Z.shift_left x (Z.to_int y) let shift_right_big_int x y = Z.shift_right x (Z.to_int y) let power_two k = Z.shift_left Z.one k (* let h = Hashtbl.create 7 in fun k -> try Hashtbl.find h k with Not_found -> let p = power_int_positive_int 2 k in Hashtbl.add h k p; p *) let two_power y = try let k = Z.to_int y in power_two k with Z.Overflow -> assert false let log_shift_right_big_int x y = (* no meaning for negative value of x *) if (lt_big_int x zero_big_int) then raise (Invalid_argument "log_shift_right_big_int") else shift_right_big_int x y let popcount = Z.popcount (* To export *) let small_nums = Array.init 33 (fun i -> big_int_of_int i) let zero = zero_big_int let one = unit_big_int let minus_one = minus_big_int unit_big_int let two = Z.of_int 2 let four = Z.of_int 4 let eight = Z.of_int 8 let thirtytwo = Z.of_int 32 let onethousand = Z.of_int 1000 let billion_one = Z.of_int 1_000_000_001 let two_power_60 = power_two 60 let two_power_64 = power_two 64 let is_zero v = (sign_big_int v) = 0 let rem = mod_big_int let div = div_big_int let mul = mult_big_int let sub = sub_big_int let abs = abs_big_int let succ = succ_big_int let pred = pred_big_int let neg = minus_big_int let add = add_big_int let hash = Z.hash let shift_right_logical = log_shift_right_big_int let shift_right = shift_right_big_int let shift_left = shift_left_big_int let logand = Z.logand let lognot = Z.lognot let logor = Z.logor let logxor = Z.logxor let le = le_big_int let lt = lt_big_int let ge = ge_big_int let gt = gt_big_int let to_int v = try Z.to_int v with Z.Overflow -> failwith "to_int" let of_int = Z.of_int let of_int64 = Z.of_int64 let of_int32 = Z.of_int32 let to_int64 = Z.to_int64 let max_int64 = of_int64 Int64.max_int let min_int64 = of_int64 Int64.min_int let bits_of_max_float = of_int64 (Int64.bits_of_float max_float) let bits_of_most_negative_float = of_int64 (Int64.bits_of_float (-. max_float)) let of_string = big_int_of_string let to_string = string_of_big_int let to_float = float_of_big_int let add_2_64 x = add two_power_64 x let pretty ?(hexa=false) fmt v = let rec aux v = if gt v two_power_60 then let quo, rem = quomod_big_int v two_power_60 in aux quo; Format.fprintf fmt "%015LX" (to_int64 rem) else Format.fprintf fmt "%LX" (to_int64 v) in if hexa then if equal v zero then Format.pp_print_string fmt "0" else if gt v zero then (Format.pp_print_string fmt "0x"; aux v) else (Format.pp_print_string fmt "-0x"; aux (minus_big_int v)) else Format.pp_print_string fmt (to_string v) let is_one v = equal one v let pos_div = div let pos_rem = rem let native_div = div let divexact = Z.divexact let div_rem = Z.div_rem let c_div u v = let bad_div = div u v in if (lt u zero) && not (is_zero (rem u v)) then if lt v zero then pred bad_div else succ bad_div else bad_div let c_rem u v = sub u (mul v (c_div u v)) let cast ~size ~signed ~value = if (not signed) then let factor = two_power size in logand value (pred factor) else let mask = two_power (sub size one) in let p_mask = pred mask in if equal (logand mask value) zero then logand value p_mask else logor (lognot p_mask) value let length u v = succ (sub v u) let extract_bits ~start ~stop v = assert (ge start zero && ge stop start); (*Format.printf "%a[%a..%a]@\n" pretty v pretty start pretty stop;*) let r = Z.extract v (to_int start) (to_int (length start stop)) in (*Format.printf "%a[%a..%a]=%a@\n" pretty v pretty start pretty stop pretty r;*) r let is_even v = is_zero (logand one v) (** [pgcd u 0] is allowed and returns [u] *) let pgcd u v = let r = if is_zero v then u else gcd_big_int u v in r let ppcm u v = if u = zero || v = zero then zero else native_div (mul u v) (pgcd u v) let min = min_big_int let max = max_big_int let round_down_to_zero v modu = mul (pos_div v modu) modu (** [round_up_to_r m r modu] is the smallest number [n] such that [n]>=[m] and [n] = [r] modulo [modu] *) let round_up_to_r ~min:m ~r ~modu = add (add (round_down_to_zero (pred (sub m r)) modu) r) modu (** [round_down_to_r m r modu] is the largest number [n] such that [n]<=[m] and [n] = [r] modulo [modu] *) let round_down_to_r ~max:m ~r ~modu = add (round_down_to_zero (sub m r) modu) r let to_num b = Num.num_of_big_int (Big_int.big_int_of_string (Big_int_Z.string_of_big_int b)) ���������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/lib/bitvector.mli�����������������������������������������������������0000644�0001750�0001750�00000004421�12155630226�020041� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ------------------------------------------------------------------------ *) (** Bitvector naive implementation. @since Carbon-20101201 *) (* ------------------------------------------------------------------------ *) type t val create : int -> t (** A vector of [n] bits *) val mem : t -> int -> bool val set : t -> int -> unit val clear : t -> int -> unit val set_range : t -> int -> int -> unit val is_empty : t -> bool val pretty : Format.formatter -> t -> unit (** Bit vector, as blocs of 8-bits separated by space, first bits to last bits from left to right. *) val pp_bits : Format.formatter -> int -> unit (** 0b... format, for bytes only, most significant bits on left. *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/buckx/����������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�015700� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/buckx/buckx.mli�������������������������������������������������������0000644�0001750�0001750�00000004671�12155630231�017525� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Undocumented. Do not use this module if you don't know what you are doing. *) (* [JS 2011/10/03] To the authors/users of this module: please document it. *) module MemoryFootprint : State_builder.Ref with type data = int module type WeakHashable = sig type t val equal : t -> t -> bool val hash : t -> int val pretty : Format.formatter -> t -> unit val id : string end module type S = sig type data type t val create : int -> t val merge : t -> data -> data val iter : t -> (data -> unit) -> unit val clear : t -> unit val release : t -> unit val shallow_copy : t -> t val addr : t -> int val overwrite : old:t -> fresh:t -> unit val pretty_debug : Format.formatter -> t -> int -> unit end module MakeBig (H : WeakHashable) : (S with type data = H.t) (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) �����������������������������������������������������������������������frama-c-Fluorine-20130601/src/buckx/mybigarray.c����������������������������������������������������0000644�0001750�0001750�00000003614�12155630231�020214� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ /* $Id: mybigarray.c,v 1.2 2008-11-04 10:05:05 uid568 Exp $ */ #include "caml/bigarray.h" #include "caml/mlvalues.h" value mybigarray_alignment (value ba) { long data; #ifndef Caml_ba_data_val data = (long)Data_bigarray_val(ba); #else data = (long)Caml_ba_data_val(ba); #endif return Val_long(data); } ��������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/buckx/buckx.ml��������������������������������������������������������0000644�0001750�0001750�00000005637�12155630231�017357� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module MemoryFootprint = State_builder.Ref (Datatype.Int) (struct let name = "Buckx.MemoryFootprint" let dependencies = [] let default () = 2 end) module type WeakHashable = sig type t val equal : t -> t -> bool val hash : t -> int val pretty : Format.formatter -> t -> unit val id : string end module type S = sig type data type t val create : int -> t val merge : t -> data -> data val iter : t -> (data -> unit) -> unit val clear : t -> unit val release : t -> unit val shallow_copy : t -> t val addr : t -> int val overwrite : old:t -> fresh:t -> unit val pretty_debug : Format.formatter -> t -> int -> unit end;; module MakeBig(H:WeakHashable) = struct module W = Weak.Make(H) type t = W.t ref let addr _t = 0 type data = H.t let create c = ref (W.create c) let merge t d = W.merge !t d let iter t f = W.iter f (!t) let clear t = W.clear (!t) let release _t = () let pretty_debug _ = assert false let shallow_copy t = ref !t let overwrite ~old ~fresh = old := !fresh end let () = let gc_params = Gc.get () in Gc.set { gc_params with Gc.minor_heap_size = 1 lsl 18 ; major_heap_increment = 1 lsl 22; (* space_overhead = 40 ; max_overhead = 100 *) }; (* Local Variables: compile-command: "LC_ALL=C make -C ../.." End: *) �������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/buckx/buckx_c.c�������������������������������������������������������0000644�0001750�0001750�00000010740�12155630231�017462� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/**************************************************************************/ /* */ /* This file is part of Frama-C. */ /* */ /* Copyright (C) 2007-2013 */ /* 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). */ /* */ /**************************************************************************/ #ifdef _WIN32 /* Must be the first included header */ #include "windows.h" #endif #include "caml/mlvalues.h" #include "caml/alloc.h" #include "caml/bigarray.h" #include "caml/fail.h" #include <assert.h> #include <stdlib.h> // Some BSD flavors do not implement all of C99 #if defined(__OpenBSD__) || defined(__NetBSD__) # include <ieeefp.h> # define FE_DOWNWARD FP_RM # define FE_UPWARD FP_RP # define FE_TONEAREST FP_RN # define fegetround() fpgetround() # define fesetround(RM) fpsetround(RM) #else # include <fenv.h> #endif #include <float.h> #include <math.h> #if defined(__i386__) #define GETCOUNTER(low,high) \ __asm__ volatile ("rdtsc" : "=a" (low), "=d" (high)); #else #if defined(__x86_64__) #define GETCOUNTER(low,high) \ { \ unsigned int __a,__d; \ asm volatile("rdtsc" : "=a" (__a), "=d" (__d)); \ low = ((unsigned long)__a) | (((unsigned long)__d)<<32); \ high = 0; \ } #else #define GETCOUNTER(low,high) \ { low = 0; high = 0; } #endif #endif value getperfcount1024(value dum) { unsigned long l,h,acc; GETCOUNTER(l,h); acc = (l >> 10) | (h << 22); return (acc | 1); } value getperfcount(value dum) { unsigned long l, h; GETCOUNTER(l,h); return (l | 1); } value address_of_value(value v) { return (Val_long(((unsigned long)v)/sizeof(long))); } value round_to_float(value d) { float f = Double_val(d); return caml_copy_double(f); } value set_round_downward(value dummy) { fesetround(FE_DOWNWARD); return Val_unit; } value set_round_upward(value dummy) { fesetround(FE_UPWARD); return Val_unit; } value set_round_nearest_even(value dummy) { fesetround(FE_TONEAREST); return Val_unit; } /* Some compilers apply the C90 standard stricly and do not prototype strtof() although it is available in the C library. */ float strtof(const char *, char **); value single_precision_of_string(value str) { char *end; float f = strtof((const char *)str, &end); if (end != (char *)str + caml_string_length(str)) caml_failwith("single_precision_of_string"); double d = f; return caml_copy_double(d); } #include <signal.h> value terminate_process(value v) { long pid = Long_val(v); #if _POSIX_C_SOURCE >= 1 || _XOPEN_SOURCE || _POSIX_SOURCE || __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ kill(pid,9); #else #ifdef _WIN32 TerminateProcess((HANDLE)pid,9); #else #warning Does your system have kill()? #endif #endif return Val_unit; } #include <unistd.h> value ml_usleep(value v) { usleep( Int_val(v) ); return Val_unit ; } #if 0 extern double cos_rd(double); /* toward -inf */ extern double cos_ru(double); /* toward +inf */ extern unsigned long long crlibm_init(void); value caml_cos_rd(value arg) { return caml_copy_double(cos_rd(Double_val(arg))); } value caml_cos_ru(value arg) { return caml_copy_double(cos_ru(Double_val(arg))); } value caml_crlibm_init(value dummy) { crlibm_init(); return Val_unit; } #endif ��������������������������������frama-c-Fluorine-20130601/src/type/�����������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�015545� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/type/datatype.ml������������������������������������������������������0000644�0001750�0001750�00000173177�12155630171�017733� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ********************************************************************** *) (** {2 Type declarations} *) (* ********************************************************************** *) type 'a t = { equal: 'a -> 'a -> bool; compare: 'a -> 'a -> int; hash: 'a -> int; copy: 'a -> 'a; internal_pretty_code: Type.precedence -> Format.formatter -> 'a -> unit; pretty_code: Format.formatter -> 'a -> unit; pretty: Format.formatter -> 'a -> unit; varname: 'a -> string; mem_project: (Project_skeleton.t -> bool) -> 'a -> bool } type 'a info = 'a t module type Ty = sig type t val ty: t Type.t end module type S_no_copy = sig include Ty val name: string val descr: t Descr.t val packed_descr: Structural_descr.pack val reprs: t list val equal: t -> t -> bool val compare: t -> t -> int val hash: t -> int val pretty_code: Format.formatter -> t -> unit val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit val pretty: Format.formatter -> t -> unit val varname: t -> string val mem_project: (Project_skeleton.t -> bool) -> t -> bool end module type S = sig include S_no_copy val copy: t -> t end (* ********************************************************************** *) (** {2 Getters from a type value} *) (* ********************************************************************** *) module Infos = Type.Ty_tbl(struct type 'a t = 'a info end) let info_tbl = Infos.create 97 let internal_info s ty = try Infos.find info_tbl ty with Not_found -> Format.eprintf "Internal Datatype.info error: no %s for %S@." s (Type.name ty); assert false 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} *) (* ********************************************************************** *) let undefined _ = assert false let identity x = x let never_any_project _ _ = false let from_compare _ _ = assert false let from_pretty_code _ _ = assert false let pp_fail _ _ _ = assert false module type Undefined = sig val structural_descr: Structural_descr.t val equal: 'a -> 'a -> bool val compare: 'a -> 'a -> int val hash: 'a -> int val rehash: 'a -> 'a val copy: 'a -> 'a val internal_pretty_code: Type.precedence -> Format.formatter -> 'a -> unit val pretty: Format.formatter -> 'a -> unit val varname: 'a -> string val mem_project: (Project_skeleton.t -> bool) -> 'a -> bool end module Partial_undefined = struct let equal = undefined let compare = undefined let hash = undefined let copy = undefined let internal_pretty_code = undefined let pretty = undefined let varname = undefined let mem_project = undefined end module Undefined = struct include Partial_undefined let structural_descr = Structural_descr.Unknown let rehash = undefined end module Serializable_undefined = struct include Partial_undefined let structural_descr = Structural_descr.Abstract let rehash = identity let mem_project = never_any_project end (* ********************************************************************** *) (** {2 Generic builders} *) (* ********************************************************************** *) let valid_varname s = let r = Str.regexp "[^A-Za-z0-9_]+" in let s = Str.global_replace r "__" s in String.uncapitalize s let check f fname tname fstr = assert (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; false end else 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 val rehash: t -> t val copy: t -> t val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit val pretty: Format.formatter -> t -> unit val varname: t -> string val mem_project: (Project_skeleton.t -> bool) -> t -> bool end) = struct let name = Type.name T.ty (* let () = Format.printf "datatype %S@." name*) let equal = if T.equal == from_compare then (fun x y -> T.compare x y = 0) else T.equal let compare = T.compare let hash = T.hash let rehash = T.rehash let copy = T.copy let internal_pretty_code = T.internal_pretty_code let pretty_code = if T.internal_pretty_code == undefined then undefined else if T.internal_pretty_code == pp_fail then pp_fail Type.NoPar else fun fmt x -> (* Format.printf "pretty code %s@." name;*) let buf = Buffer.create 17 in let buffmt = Format.formatter_of_buffer buf in Format.fprintf buffmt "%a@?" (T.internal_pretty_code Type.NoPar) x; let f = Scanf.format_from_string (String.escaped (Buffer.contents buf)) "" in Format.fprintf fmt f let pretty = if T.pretty == from_pretty_code then pretty_code else T.pretty let varname = if T.varname == undefined then undefined else fun x -> valid_varname (T.varname x) let mem_project = T.mem_project let info = { equal = equal; compare = compare; hash = hash; copy = copy; internal_pretty_code = internal_pretty_code; pretty_code = pretty_code; pretty = pretty; varname = varname; mem_project = mem_project } let () = Infos.add info_tbl T.ty info 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 else 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 = T.reprs (* [Type.reprs] is not usable in the "no-obj" mode *) end module type Make_input = sig type t val name: string val rehash: t -> t val structural_descr: Structural_descr.t val reprs: t list val equal: t -> t -> bool val compare: t -> t -> int val hash: t -> int val copy: t -> t val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit val pretty: Format.formatter -> t -> unit val varname: t -> string val mem_project: (Project_skeleton.t -> bool) -> t -> bool end let is_module_name s = let l = Str.split (Str.regexp "\\.") s in List.for_all(fun x -> String.length x > 0 && x.[0] = Char.uppercase x.[0]) l module Make(X: Make_input) = struct module T = struct include X let name = if is_module_name X.name then X.name ^ ".t" else X.name let ml_name = if is_module_name X.name then Some (X.name ^ ".ty") else None let ty = Type.register ~name ~ml_name X.structural_descr X.reprs end include T include Build(T) end module type Set = sig include Set.S val ty: t Type.t val name: string val descr: t Descr.t val packed_descr: Structural_descr.pack val reprs: t list val hash: t -> int val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit val pretty_code: Format.formatter -> t -> unit val pretty: Format.formatter -> t -> unit val varname: t -> string val mem_project: (Project_skeleton.t -> bool) -> t -> bool val copy: t -> t end module type Map = sig include Map.S module Key: S with type t = key module Make(Data: S) : S with type t = Data.t t end module type Hashtbl_with_descr = sig include Hashtbl_common_interface.S val structural_descr: Structural_descr.t -> Structural_descr.t end module type Hashtbl = sig include Hashtbl_with_descr val make_type: 'a Type.t -> 'a t Type.t (** @since Fluorine-20130401 *) 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 module type S_with_collections = sig include S module Set: Set with type elt = t module Map: Map with type key = t module Hashtbl: Hashtbl with type key = t end (* ****************************************************************************) (** {2 Polymorphic signature} *) (* ****************************************************************************) module type Polymorphic = sig include Type.Polymorphic module Make(T: S) : S with type t = T.t poly end (* local argument of below functors: not visible from outside *) let poly_name_ref = ref "" (* ****************************************************************************) (** {2 Polymorphic2 } *) (* ****************************************************************************) module type Polymorphic2 = sig include Type.Polymorphic2 module Make(T1: S)(T2: S) : S with type t = (T1.t, T2.t) poly end module type Polymorphic2_input = sig include Type.Polymorphic2_input val mk_equal: ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t -> bool val mk_compare: ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int val mk_hash: ('a -> int) -> ('b -> int) -> ('a, 'b) t -> int val map: ('a -> 'a) -> ('b -> 'b) -> ('a, 'b) t -> ('a, 'b) t val mk_internal_pretty_code: (Type.precedence -> Format.formatter -> 'a -> unit) -> (Type.precedence -> Format.formatter -> 'b -> unit) -> Type.precedence -> Format.formatter -> ('a, 'b) t -> unit val mk_pretty: (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> Format.formatter -> ('a, 'b) t -> unit val mk_varname: ('a -> string) -> ('b -> string) -> ('a, 'b) t -> string val mk_mem_project: ((Project_skeleton.t -> bool) -> 'a -> bool) -> ((Project_skeleton.t -> bool) -> 'b -> bool) -> (Project_skeleton.t -> bool) -> ('a, 'b) t -> bool end module Polymorphic2(P: Polymorphic2_input) = struct include Type.Polymorphic2(P) (* cannot declare [name] locally in instantiate since it prevents OCaml generalization *) let name = !poly_name_ref let instantiate ty1 ty2 = let res, first = instantiate ty1 ty2 in if first && name <> "" then begin let ml_name = Type.sfprintf "Datatype.%s %a %a" name (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt) ty1 (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt) ty2 in Type.set_ml_name res (Some ml_name) end; res, first let () = poly_name_ref := "" module Make(T1: S)(T2: S) = struct module T = struct type t = (T1.t, T2.t) P.t let ty, _is_new = instantiate T1.ty T2.ty end include T include Build (struct include T let reprs = if Type.may_use_obj () then Type.reprs ty else [] 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 end) let descr, packed_descr = mk_full_descr (Descr.of_structural ty (P.structural_descr (Descr.str T1.descr) (Descr.str T2.descr))) end end (* ****************************************************************************) (** {2 Polymorphic3 } *) (* ****************************************************************************) module type Polymorphic3 = sig include Type.Polymorphic3 module Make(T1:S)(T2:S)(T3:S) : S with type t = (T1.t, T2.t, T3.t) poly end module Polymorphic3 (P: sig include Type.Polymorphic3_input val mk_equal: ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('c -> 'c -> bool) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> bool val mk_compare: ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('c -> 'c -> int) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> int val mk_hash: ('a -> int) -> ('b -> int) -> ('c -> int) -> ('a, 'b, 'c) t -> int val map: ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t val mk_internal_pretty_code: (Type.precedence -> Format.formatter -> 'a -> unit) -> (Type.precedence -> Format.formatter -> 'b -> unit) -> (Type.precedence -> Format.formatter -> 'c -> unit) -> Type.precedence -> Format.formatter -> ('a, 'b, 'c) t -> unit val mk_pretty: (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> (Format.formatter -> 'c -> unit) -> Format.formatter -> ('a, 'b, 'c) t -> unit val mk_varname: ('a -> string) -> ('b -> string) -> ('c -> string) -> ('a, 'b, 'c) t -> string val mk_mem_project: ((Project_skeleton.t -> bool) -> 'a -> bool) -> ((Project_skeleton.t -> bool) -> 'b -> bool) -> ((Project_skeleton.t -> bool) -> 'c -> bool) -> (Project_skeleton.t -> bool) -> ('a, 'b, 'c) t -> bool end) = struct include Type.Polymorphic3(P) (* cannot declare [name] locally in instantiate since it prevents OCaml generalization *) let name = !poly_name_ref let instantiate ty1 ty2 ty3 = let res, first = instantiate ty1 ty2 ty3 in if first && name <> "" then begin let ml_name = Type.sfprintf "Datatype.%s %a %a %a" name (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt) ty1 (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt) ty2 (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt) ty3 in Type.set_ml_name res (Some ml_name) end; res, first let () = poly_name_ref := "" module Make(T1: S)(T2: S)(T3: S) = struct module T = struct type t = (T1.t, T2.t, T3.t) P.t let ty, _is_new = instantiate T1.ty T2.ty T3.ty end include T include Build (struct include T let reprs = if Type.may_use_obj () then Type.reprs ty else [] let build mk f1 f2 f3 = if mk == undefined || f1 == undefined || f2 == undefined || f3 == undefined then undefined else mk f1 f2 f3 let compare = build P.mk_compare T1.compare T2.compare T3.compare let equal = build P.mk_equal T1.equal T2.equal T3.equal let hash = build P.mk_hash T1.hash T2.hash T3.hash let rehash = identity let copy = let mk f1 f2 f3 = 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 f3 in build mk T1.copy T2.copy T3.copy let internal_pretty_code = let mk f1 f2 f3 = if f1 == pp_fail || f2 == pp_fail || f3 == pp_fail then pp_fail else fun p fmt x -> P.mk_internal_pretty_code f1 f2 f3 p fmt x in build mk T1.internal_pretty_code T2.internal_pretty_code T3.internal_pretty_code let pretty = build P.mk_pretty T1.pretty T2.pretty T3.pretty let varname = build P.mk_varname T1.varname T2.varname T3.varname let mem_project = let mk f1 f2 f3 = if P.mk_mem_project == undefined then undefined else if f1 == never_any_project && f2 == never_any_project && f3 == never_any_project then never_any_project else P.mk_mem_project f1 f2 f3 in build mk T1.mem_project T2.mem_project T3.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.str T3.descr))) end end (* ****************************************************************************) (** {2 Polymorphic4 } *) (* ****************************************************************************) module type Polymorphic4 = sig include Type.Polymorphic4 module Make(T1:S)(T2:S)(T3:S)(T4:S) : S with type t = (T1.t, T2.t, T3.t, T4.t) poly end module Polymorphic4 (P: sig include Type.Polymorphic4_input val mk_equal: ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('c -> 'c -> bool) -> ('d -> 'd -> bool) -> ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t -> bool val mk_compare: ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('c -> 'c -> int) -> ('d -> 'd -> int) -> ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t -> int val mk_hash: ('a -> int) -> ('b -> int) -> ('c -> int) -> ('d -> int) -> ('a, 'b, 'c, 'd) t -> int val map: ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('d -> 'd) -> ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t val mk_internal_pretty_code: (Type.precedence -> Format.formatter -> 'a -> unit) -> (Type.precedence -> Format.formatter -> 'b -> unit) -> (Type.precedence -> Format.formatter -> 'c -> unit) -> (Type.precedence -> Format.formatter -> 'd -> unit) -> Type.precedence -> Format.formatter -> ('a, 'b, 'c, 'd) t -> unit val mk_pretty: (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> (Format.formatter -> 'c -> unit) -> (Format.formatter -> 'd -> unit) -> Format.formatter -> ('a, 'b, 'c, 'd) t -> unit val mk_varname: ('a -> string) -> ('b -> string) -> ('c -> string) -> ('d -> string) -> ('a, 'b, 'c, 'd) t -> string val mk_mem_project: ((Project_skeleton.t -> bool) -> 'a -> bool) -> ((Project_skeleton.t -> bool) -> 'b -> bool) -> ((Project_skeleton.t -> bool) -> 'c -> bool) -> ((Project_skeleton.t -> bool) -> 'd -> bool) -> (Project_skeleton.t -> bool) -> ('a, 'b, 'c, 'd) t -> bool end) = struct include Type.Polymorphic4(P) (* cannot declare [name] locally in instantiate since it prevents OCaml generalization *) let name = !poly_name_ref let instantiate ty1 ty2 ty3 ty4 = let res, first = instantiate ty1 ty2 ty3 ty4 in if first && name <> "" then begin let ml_name = Type.sfprintf "Datatype.%s %a %a %a %a" name (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt) ty1 (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt) ty2 (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt) ty3 (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt) ty4 in Type.set_ml_name res (Some ml_name) end; res, first let () = poly_name_ref := "" module Make(T1: S)(T2: S)(T3: S)(T4: S) = struct module T = struct type t = (T1.t, T2.t, T3.t, T4.t) P.t let ty, _is_new = instantiate T1.ty T2.ty T3.ty T4.ty end include T include Build (struct include T let reprs = if Type.may_use_obj () then Type.reprs ty else [] let build mk f1 f2 f3 f4 = if mk == undefined || f1 == undefined || f2 == undefined || f3 == undefined || f4 == undefined then undefined else mk f1 f2 f3 f4 let compare = build P.mk_compare T1.compare T2.compare T3.compare T4.compare let equal = build P.mk_equal T1.equal T2.equal T3.equal T4.equal let hash = build P.mk_hash T1.hash T2.hash T3.hash T4.hash let rehash = identity let copy = let mk f1 f2 f3 f4 = 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 f3 f4 in build mk T1.copy T2.copy T3.copy T4.copy let internal_pretty_code = let mk f1 f2 f3 f4 = if f1 == pp_fail || f2 == pp_fail || f3 == pp_fail || f4 == pp_fail then pp_fail else fun p fmt x -> P.mk_internal_pretty_code f1 f2 f3 f4 p fmt x in build mk T1.internal_pretty_code T2.internal_pretty_code T3.internal_pretty_code T4.internal_pretty_code let pretty = build P.mk_pretty T1.pretty T2.pretty T3.pretty T4.pretty let varname = build P.mk_varname T1.varname T2.varname T3.varname T4.varname let mem_project = let mk f1 f2 f3 f4 = if P.mk_mem_project == undefined then undefined else if f1 == never_any_project && f2 == never_any_project && f3 == never_any_project && f4 == never_any_project then never_any_project else P.mk_mem_project f1 f2 f3 f4 in build mk T1.mem_project T2.mem_project T3.mem_project T4.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.str T3.descr) (Descr.str T4.descr))) end end (* ****************************************************************************) (** {3 Pair} *) (* ****************************************************************************) let () = poly_name_ref := "pair" module Pair_arg = struct type ('a, 'b) t = 'a * 'b let module_name = "Datatype.Pair" let reprs a b = [ a, b ] let structural_descr d1 d2 = Structural_descr.t_tuple [| Structural_descr.pack d1; Structural_descr.pack d2 |] let mk_equal f1 f2 (x1,x2) (y1,y2) = f1 x1 y1 && f2 x2 y2 let mk_compare f1 f2 (x1,x2 as x) (y1,y2 as y) = if x == y then 0 else let n = f1 x1 y1 in if n = 0 then f2 x2 y2 else n let mk_hash f1 f2 (x1,x2) = f1 x1 + 1351 * f2 x2 let map f1 f2 (x1,x2) = f1 x1, f2 x2 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 in Type.par p Type.Tuple fmt pp let mk_pretty f1 f2 fmt p = Format.fprintf fmt "@[(%a)@]" (mk_internal_pretty_code (fun _ -> f1) (fun _ -> f2) Type.Basic) p let mk_varname = undefined let mk_mem_project mem1 mem2 f (x1, x2) = mem1 f x1 && mem2 f x2 end module rec Pair_name: sig val name: 'a Type.t -> 'b Type.t -> string end = struct 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 in arg ty1 ^ " * " ^ arg ty2 end and Poly_pair : sig include Type.Polymorphic2 with type ('a,'b) poly = 'a * 'b module Make(T1: S)(T2: S) : S with type t = (T1.t, T2.t) poly end = struct (* Split the functor argument in 2 modules such that ocaml is able to safely evaluate the recursive modules *) include Polymorphic2(struct include Pair_arg include Pair_name end) end module Pair = Poly_pair.Make let pair (type typ1) (type typ2) (ty1: typ1 Type.t) (ty2: typ2 Type.t) = let module Make(X: sig type t val ty: t Type.t end) = struct type t = X.t let ty = X.ty let name = Type.name X.ty let descr = Descr.of_type X.ty let packed_descr = Descr.pack descr let reprs = Type.reprs X.ty let equal = equal X.ty let compare = compare X.ty let hash = hash X.ty let copy = copy X.ty let internal_pretty_code = internal_pretty_code X.ty let pretty_code = pretty_code X.ty let pretty = from_pretty_code let varname = varname ty let mem_project = mem_project X.ty end in let module L = Pair (Make(struct type t = typ1 let ty = ty1 end)) (Make(struct type t = typ2 let ty = ty2 end)) in L.ty (* ****************************************************************************) (** {3 Function} *) (* ****************************************************************************) module Function (T1: sig include Ty val label: (string * (unit -> t) option) option end) (T2: Ty) = struct module T = struct type t = T1.t -> T2.t let ty, _is_new = Type.Function.instantiate ?label:T1.label T1.ty T2.ty let compare = undefined let equal = (==) let hash = undefined let rehash = undefined let copy = undefined let internal_pretty_code = undefined 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) end let func (type typ1) (type typ2) ?label (ty1: typ1 Type.t) (ty2: typ2 Type.t) = let module L = Function (struct type t = typ1 let ty = ty1 let label = label end) (struct type t = typ2 let ty = ty2 end) in L.ty let optlabel_func lab dft = func ~label:(lab, Some dft) let func2 ?label1 ty1 ?label2 ty2 ty_ret = func ?label:label1 ty1 (func ?label:label2 ty2 ty_ret) let func3 ?label1 ty1 ?label2 ty2 ?label3 ty3 ty_ret = func2 ?label1 ty1 ?label2 ty2 (func ?label:label3 ty3 ty_ret) let func4 ?label1 ty1 ?label2 ty2 ?label3 ty3 ?label4 ty4 ty_ret = func3 ?label1 ty1 ?label2 ty2 ?label3 ty3 (func ?label:label4 ty4 ty_ret) let is_function_or_pair ty = Type.Function.is_instance_of ty || Poly_pair.is_instance_of ty (* ****************************************************************************) (** {2 Polymorphic generator} *) (* ****************************************************************************) module type Polymorphic_input = sig include Type.Polymorphic_input val mk_equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val mk_compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val mk_hash: ('a -> int) -> 'a t -> int val map: ('a -> 'a) -> 'a t -> 'a t val mk_internal_pretty_code: (Type.precedence -> Format.formatter -> 'a -> unit) -> Type.precedence -> Format.formatter -> 'a t -> unit val mk_pretty: (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit val mk_varname: ('a -> string) -> 'a t -> string val mk_mem_project: ((Project_skeleton.t -> bool) -> 'a -> bool) -> (Project_skeleton.t -> bool) -> 'a t -> bool end module Polymorphic(P: Polymorphic_input) = struct include Type.Polymorphic(P) (* cannot declare [name] locally in instantiate since it prevents OCaml generalization *) let name = !poly_name_ref let instantiate ty = let res, first = instantiate ty in if first && name <> "" then begin let ml_name = Type.sfprintf "Datatype.%s %a" name (fun fmt ty -> Type.pp_ml_name ty Type.Call fmt) ty in Type.set_ml_name res (Some ml_name) end; res, first let () = poly_name_ref := "" module Make(X: S) = struct module T = struct type t = X.t P.t let ty, _is_new = instantiate X.ty end include T 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 (* [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 let reprs = if Type.may_use_obj () then Type.reprs ty else [] end) let descr, packed_descr = mk_full_descr (Descr.of_structural ty (P.structural_descr (Descr.str X.descr))) end end (* ****************************************************************************) (** {3 Reference} *) (* ****************************************************************************) let () = poly_name_ref := "t_ref" module Poly_ref = Polymorphic (struct type 'a t = 'a ref let name ty = Type.par_ty_name is_function_or_pair ty ^ " ref" let module_name = "Datatype.Ref" let reprs ty = [ ref ty ] let structural_descr = Structural_descr.t_ref let mk_equal f x y = f !x !y let mk_compare f x y = if x == y then 0 else f !x !y 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 mk_pretty f 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) module Ref = Poly_ref.Make let t_ref (type typ) (ty: typ Type.t) = let module L = Ref(struct type t = typ let ty = ty let name = Type.name ty let descr = Descr.of_type ty let packed_descr = Descr.pack descr let reprs = Type.reprs ty let equal = equal ty let compare = compare ty let hash = hash ty let copy = copy ty let internal_pretty_code = internal_pretty_code ty let pretty_code = pretty_code ty let pretty = from_pretty_code let varname = varname ty let mem_project = mem_project ty end) in L.ty (* ****************************************************************************) (** {3 Option} *) (* ****************************************************************************) let () = poly_name_ref := "option" module Poly_option = Polymorphic (struct type 'a t = 'a option let name ty = Type.par_ty_name is_function_or_pair ty ^ " option" let module_name = "Type.Option" 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 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 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 let mk_pretty f 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) module Option = Poly_option.Make let option (type typ) (ty: typ Type.t) = let module L = Option(struct type t = typ let ty = ty let name = Type.name ty let descr = Descr.of_type ty let packed_descr = Descr.pack descr let reprs = Type.reprs ty let equal = equal ty let compare = compare ty let hash = hash ty let copy = copy ty let internal_pretty_code = internal_pretty_code ty let pretty_code = pretty_code ty let pretty = from_pretty_code let varname = varname ty let mem_project = mem_project ty end) in L.ty (* ****************************************************************************) (** {3 List} *) (* ****************************************************************************) let () = poly_name_ref := "list" module Poly_list = Polymorphic (struct type 'a t = 'a list let name ty = Type.par_ty_name is_function_or_pair ty ^ " list" let module_name = "Datatype.List" 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 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 exception Too_long of int (* Do not spend too much time hashing long lists... *) let mk_hash f l = try snd (List.fold_left (fun (length,acc) d -> if length > 15 then raise (Too_long acc); length+1, 257 * acc + f d) (0,1) l) with Too_long n -> n 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 mk_pretty f 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) module Caml_list = List module List = Poly_list.Make let list (type typ) (ty: typ Type.t) = let module L = List(struct type t = typ let ty = ty let name = Type.name ty let descr = Descr.of_type ty let packed_descr = Descr.pack descr let reprs = Type.reprs ty let equal = equal ty let compare = compare ty let hash = hash ty let copy = copy ty let internal_pretty_code = internal_pretty_code ty let pretty_code = pretty_code ty let pretty = from_pretty_code let varname = varname ty let mem_project = mem_project ty end) in L.ty (* ****************************************************************************) (** {3 Queue} *) (* ****************************************************************************) let () = poly_name_ref := "queue" module Poly_queue = Polymorphic (struct type 'a t = 'a Queue.t 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 structural_descr = Structural_descr.t_queue let mk_equal = undefined let mk_compare = undefined let mk_hash = undefined let map = undefined let mk_internal_pretty_code = undefined 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 end) module Queue = Poly_queue.Make let queue (type typ) (ty: typ Type.t) = let module L = Queue(struct type t = typ let ty = ty let name = Type.name ty let descr = Descr.of_type ty let packed_descr = Descr.pack descr let reprs = Type.reprs ty let equal = equal ty let compare = compare ty let hash = hash ty let copy = copy ty let internal_pretty_code = internal_pretty_code ty let pretty_code = pretty_code ty let pretty = from_pretty_code let varname = varname ty let mem_project = mem_project ty end) in L.ty (* ****************************************************************************) (** {3 Set} *) (* ****************************************************************************) module type Functor_info = sig val module_name: string end module Initial_caml_set = Set (* ocaml functors are generative *) module Set(S: Set.S)(E: S with type t = S.elt)(Info: Functor_info) = struct let () = check E.equal "equal" E.name Info.module_name let () = check E.compare "compare" E.name Info.module_name module P = Make (struct type t = S.t let name = Info.module_name ^ "(" ^ E.name ^ ")" let structural_descr = Structural_descr.t_set_unchanged_compares (Descr.str E.descr) open S let reprs = empty :: Caml_list.map (fun r -> singleton r) E.reprs let compare = S.compare let equal = S.equal let hash = if E.hash == undefined then undefined else (fun s -> S.fold (fun e h -> 67 * E.hash e + h) s 189) let rehash = identity let copy = (* [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@;\ (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 let pretty fmt s = Format.fprintf fmt "@[<hv 2>{@ %t}@]" (fun fmt -> S.iter (fun x -> Format.fprintf fmt "@[%a;@ @]" E.pretty x) s) 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 end) include S let () = Type.set_ml_name P.ty (Some (Info.module_name ^ ".ty")) let ty = P.ty let name = P.name let descr = P.descr let packed_descr = P.packed_descr let reprs = P.reprs let equal = P.equal let compare = P.compare let hash = P.hash let internal_pretty_code = P.internal_pretty_code let pretty_code = P.pretty_code let pretty = P.pretty let varname = P.varname let mem_project = P.mem_project let copy = P.copy end (* ****************************************************************************) (** {3 Map} *) (* ****************************************************************************) module Initial_caml_map = Map module Map(M: Map.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 module P = Polymorphic (struct type 'a t = 'a M.t let 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 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 ] 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 "@[@[%a@] -> @[%a@]@];@ " 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 end) include M module Key = Key module Make = P.Make end (* ****************************************************************************) (** {3 Hashtbl} *) (* ****************************************************************************) module Initial_caml_hashtbl = Hashtbl_common_interface (* ocaml functors are generative *) module Hashtbl (H: Hashtbl_with_descr)(Key: S with type t = H.key)(Info : Functor_info) = struct let () = check Key.equal "equal" Key.name Info.module_name let () = check Key.hash "hash" Key.name Info.module_name module P = Polymorphic (struct type 'a t = 'a H.t let name ty = Info.module_name ^ "(" ^ Key.name ^ ", " ^ Type.name ty ^ ")" let module_name = Info.module_name let structural_descr = H.structural_descr let reprs x = [ 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 let map f_value tbl = (* first mapping which reverses the binding order *) let h = H.create (H.length tbl) (* may be very memory-consuming *) in H.iter (fun k v -> H.add h k (f_value v)) tbl; (* copy which reverses again the binding order: so we get the right order *) let h2 = H.create (H.length tbl) (* may be very memory-consuming *) in H.iter (fun k v -> H.add h2 k v) h; h2 let mk_internal_pretty_code = undefined 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 end) include H let make_type (type typ) (ty: typ Type.t) = let module M = P.Make(struct type t = typ include Undefined let ty = ty let name = Type.name ty let descr = Descr.of_type ty let packed_descr = Descr.pack descr let reprs = Type.reprs ty let pretty_code = undefined end) in M.ty 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 end (* ****************************************************************************) (** {3 Weak hashtbl} *) (* ****************************************************************************) module type Sub_caml_weak_hashtbl = sig type data type t val create: int -> t val add: t -> data -> unit end module Initial_caml_weak = Weak module Weak(W: Sub_caml_weak_hashtbl)(D: S with type t = W.data) = struct include Make (struct include Undefined type t = W.t let name = "Weak(" ^ D.name ^ ")" let reprs = let w = W.create 0 in Caml_list.iter (W.add w) D.reprs; [ w ] end) let () = Type.set_ml_name ty None; end module Caml_weak_hashtbl(D: S) = struct let () = check D.equal "equal" D.name "Caml_weak_hashtbl" let () = check D.compare "hash" D.name "Caml_weak_hashtbl" module W = Initial_caml_weak.Make(D) include W module Datatype = Weak(W)(D) end (* ****************************************************************************) (** {2 Simple type values} *) (* ****************************************************************************) module With_collections(X: S)(Info: Functor_info) = struct module D = X include D module Set = Set (Initial_caml_set.Make(D)) (D) (struct let module_name = Info.module_name ^ ".Set" end) module Map = Map (Initial_caml_map.Make(D)) (D) (struct let module_name = Info.module_name ^ ".Map" end) module Hashtbl = Hashtbl (struct include Initial_caml_hashtbl.Make(D) (* Override "sorted" iterators by using the datatype comparison function if it has been supplied *) let iter_sorted ?cmp = match cmp with | None -> if D.compare == undefined then iter_sorted ?cmp:None else iter_sorted ~cmp:D.compare | Some cmp -> iter_sorted ~cmp let fold_sorted ?cmp = match cmp with | None -> if D.compare == undefined then fold_sorted ?cmp:None else fold_sorted ~cmp:D.compare | Some cmp -> fold_sorted ~cmp let structural_descr = Structural_descr.t_hashtbl_unchanged_hashs (Descr.str D.descr) end) (D) (struct let module_name = Info.module_name ^ ".Hashtbl" end) end module Make_with_collections(X: Make_input) = With_collections (Make(X)) (struct let module_name = String.capitalize X.name end) (* ****************************************************************************) (** {2 Predefined datatype} *) (* ****************************************************************************) module Simple_type (X: sig type t val name: string val reprs: t list val pretty: Format.formatter -> t -> unit val copy: t -> t val varname: t -> string val compare: t -> t -> int val equal: t -> t -> bool end) = struct let module_name = "Datatype." ^ String.capitalize X.name include With_collections (Make(struct type t = X.t let name = X.name let reprs = X.reprs let structural_descr = Structural_descr.Abstract let equal = X.equal let compare = X.compare let hash = Initial_caml_hashtbl.hash let rehash = identity let copy = X.copy let internal_pretty_code = if X.pretty == undefined then undefined else fun _ -> X.pretty let pretty = X.pretty let varname = X.varname let mem_project = never_any_project end)) (struct let module_name = module_name end) let () = Type.set_ml_name ty (Some ("Datatype." ^ name)) end module Unit = Simple_type (struct type t = unit let name = "unit" let reprs = [ () ] let copy = identity let compare () () = 0 let equal () () = true let pretty fmt () = Format.fprintf fmt "()" let varname = undefined end) let unit = Unit.ty module Bool = Simple_type (struct type t = bool let name = "bool" let reprs = [ true ] let copy = identity let compare : bool -> bool -> int = Pervasives.compare let equal : bool -> bool -> bool = (=) let pretty fmt b = Format.fprintf fmt "%B" b let varname _ = "b" end) let bool = Bool.ty module Int = struct include Simple_type (struct type t = int let name = "int" let reprs = [ 2 ] let copy = identity let compare : int -> int -> int = Pervasives.compare let equal : int -> int -> bool = (=) let pretty fmt n = Format.fprintf fmt "%d" n let varname _ = "n" end) let compare : int -> int -> int = Pervasives.compare end let int = Int.ty module Int32 = Simple_type (struct type t = int32 let name = "int32" let reprs = [ Int32.zero ] let copy = identity let compare = Int32.compare let equal : int32 -> int32 -> bool = (=) let pretty fmt n = Format.fprintf fmt "%ld" n let varname _ = "n32" end) let int32 = Int32.ty module Int64 = Simple_type (struct type t = int64 let name = "int64" let reprs = [ Int64.zero ] let copy = identity let compare = Int64.compare let equal : int64 -> int64 -> bool = (=) let pretty fmt n = Format.fprintf fmt "%Ld" n let varname _ = "n64" end) let int64 = Int64.ty module Nativeint = Simple_type (struct type t = nativeint let name = "nativeint" let reprs = [ Nativeint.zero ] let copy = identity let compare = Nativeint.compare let equal : nativeint -> nativeint -> bool = (=) let pretty fmt n = Format.fprintf fmt "%nd" n let varname _ = "native_n" end) let nativeint = Nativeint.ty module Float = Simple_type (struct type t = float let name = "float" let reprs = [ 0.1 ] let copy = identity let compare : float -> float -> int = Pervasives.compare let equal : float -> float -> bool = (=) let pretty fmt f = Format.fprintf fmt "%f" f let varname _ = "f" end) let float = Float.ty module Char = Simple_type (struct type t = char let name = "char" let reprs = [ ' ' ] let copy = identity let compare = Char.compare let equal : char -> char -> bool = (=) let pretty fmt c = Format.fprintf fmt "%c" c let varname _ = "c" end) let char = Char.ty module String = Simple_type (struct type t = string let name = "string" let reprs = [ "" ] let copy = String.copy let compare = String.compare let equal : string -> string -> bool = (=) let pretty fmt s = Format.fprintf fmt "%S" s let varname _ = "s" end) let string = String.ty module Formatter = Make (struct type t = Format.formatter let name = "Datatype.Formatter" let reprs = [ Format.std_formatter ] let structural_descr = Structural_descr.Unknown let equal = undefined let compare = undefined let hash = undefined let rehash = undefined let copy = undefined let internal_pretty_code = undefined let pretty = undefined let varname _ = "fmt" let mem_project = never_any_project end) let formatter = Formatter.ty module Big_int = Make_with_collections (struct type t = Integer.t let name = "Datatype.Big_int" let reprs = [ Integer.zero ] let structural_descr = Structural_descr.Abstract let equal = Integer.equal let compare = Integer.compare let hash = Integer.hash let rehash = identity let copy = identity let internal_pretty_code par fmt n = let pp fmt = Format.fprintf fmt "Big_int.big_int_of_string %S" (Integer.to_string n) in Type.par par Type.Call fmt pp let pretty = Integer.pretty ~hexa:false let varname _ = "big_n" let mem_project = never_any_project end) let big_int = Big_int.ty (* ****************************************************************************) (** {3 Triple} *) (* ****************************************************************************) let () = poly_name_ref := "triple" module Triple_arg = struct type ('a, 'b, 'c) t = 'a * 'b * 'c let module_name = "Datatype.Triple" let reprs a b c = [ a, b, c ] let structural_descr d1 d2 d3 = Structural_descr.t_tuple [| Structural_descr.pack d1; Structural_descr.pack d2; Structural_descr.pack d3 |] let mk_equal f1 f2 f3 (x1,x2,x3) (y1,y2,y3) = f1 x1 y1 && f2 x2 y2 && f3 x3 y3 let mk_compare f1 f2 f3 (x1,x2,x3 as x) (y1,y2,y3 as y) = if x == y then 0 else let n = f1 x1 y1 in if n = 0 then let n = f2 x2 y2 in if n = 0 then f3 x3 y3 else n else n let mk_hash f1 f2 f3 (x1,x2,x3) = f1 x1 + 1351 * f2 x2 + 257 * f3 x3 let map f1 f2 f3 (x1,x2,x3) = f1 x1, f2 x2, f3 x3 let mk_internal_pretty_code f1 f2 f3 p fmt (x1, x2, x3) = let pp fmt = Format.fprintf fmt "@[<hv 2>%a,@;%a,@;%a@]" (f1 Type.Tuple) x1 (f2 Type.Tuple) x2 (f3 Type.Tuple) x3 in Type.par p Type.Tuple fmt pp let mk_pretty f1 f2 f3 fmt p = Format.fprintf fmt "@[(%a)@]" (mk_internal_pretty_code (fun _ -> f1) (fun _ -> f2) (fun _ -> f3) Type.Basic) p let mk_varname = undefined let mk_mem_project mem1 mem2 mem3 f (x1, x2, x3) = mem1 f x1 && mem2 f x2 && mem3 f x3 end module rec Triple_name: sig val name: 'a Type.t -> 'b Type.t -> 'c Type.t -> string end = struct let name ty1 ty2 ty3 = let arg ty = Type.par_ty_name (fun ty -> Type.Function.is_instance_of ty || Poly_pair.is_instance_of ty || Poly_triple.is_instance_of ty) ty in arg ty1 ^ " * " ^ arg ty2 ^ " * " ^ arg ty3 end and Poly_triple : sig include Type.Polymorphic3 with type ('a,'b,'c) poly = 'a * 'b * 'c module Make(T1: S)(T2: S)(T3:S) : S with type t = (T1.t, T2.t, T3.t) poly end = (* Split the functor argument in 2 modules such that ocaml is able to safely evaluate the recursive modules *) Polymorphic3(struct include Triple_arg include Triple_name end) module Triple = Poly_triple.Make let triple (type typ1) (type typ2) (type typ3) (ty1: typ1 Type.t) (ty2: typ2 Type.t) (ty3: typ3 Type.t) = let module Make(X: sig type t val ty: t Type.t end) = struct type t = X.t let ty = X.ty let name = Type.name X.ty let descr = Descr.of_type X.ty let packed_descr = Descr.pack descr let reprs = Type.reprs X.ty let equal = equal X.ty let compare = compare X.ty let hash = hash X.ty let copy = copy X.ty let internal_pretty_code = internal_pretty_code X.ty let pretty_code = pretty_code X.ty let pretty = from_pretty_code let varname = varname ty let mem_project = mem_project X.ty end in let module L = Triple (Make(struct type t = typ1 let ty = ty1 end)) (Make(struct type t = typ2 let ty = ty2 end)) (Make(struct type t = typ3 let ty = ty3 end)) in L.ty (* ****************************************************************************) (** {3 Quadruple} *) (* ****************************************************************************) let () = poly_name_ref := "quadruple" module Quadruple_arg = struct type ('a, 'b, 'c, 'd) t = 'a * 'b * 'c * 'd let module_name = "Datatype.Quadruple" let reprs a b c d = [ a, b, c, d ] let structural_descr d1 d2 d3 d4 = Structural_descr.t_tuple [| Structural_descr.pack d1; Structural_descr.pack d2; Structural_descr.pack d3; Structural_descr.pack d4 |] let mk_equal f1 f2 f3 f4 (x1,x2,x3,x4) (y1,y2,y3,y4) = f1 x1 y1 && f2 x2 y2 && f3 x3 y3 && f4 x4 y4 let mk_compare f1 f2 f3 f4 (x1,x2,x3,x4 as x) (y1,y2,y3,y4 as y) = if x == y then 0 else let n = f1 x1 y1 in if n = 0 then let n = f2 x2 y2 in if n = 0 then let n = f3 x3 y3 in if n = 0 then f4 x4 y4 else n else n else n let mk_hash f1 f2 f3 f4 (x1,x2,x3,x4) = f1 x1 + 1351 * f2 x2 + 257 * f3 x3 + 997 * f4 x4 let map f1 f2 f3 f4 (x1,x2,x3,x4) = f1 x1, f2 x2, f3 x3, f4 x4 let mk_internal_pretty_code f1 f2 f3 f4 p fmt (x1, x2, x3, x4) = let pp fmt = Format.fprintf fmt "@[<hv 2>%a,@;%a,@;%a,@;%a@]" (f1 Type.Tuple) x1 (f2 Type.Tuple) x2 (f3 Type.Tuple) x3 (f4 Type.Tuple) x4 in Type.par p Type.Tuple fmt pp let mk_pretty f1 f2 f3 f4 fmt p = Format.fprintf fmt "@[(%a)@]" (mk_internal_pretty_code (fun _ -> f1) (fun _ -> f2) (fun _ -> f3) (fun _ -> f4) Type.Basic) p let mk_varname = undefined let mk_mem_project mem1 mem2 mem3 mem4 f (x1, x2, x3, x4) = mem1 f x1 && mem2 f x2 && mem3 f x3 && mem4 f x4 end module rec Quadruple_name: sig val name: 'a Type.t -> 'b Type.t -> 'c Type.t -> 'd Type.t -> string end = struct let name ty1 ty2 ty3 ty4 = let arg ty = Type.par_ty_name (fun ty -> Type.Function.is_instance_of ty || Poly_pair.is_instance_of ty || Poly_triple.is_instance_of ty || Poly_quadruple.is_instance_of ty) ty in arg ty1 ^ " * " ^ arg ty2 ^ " * " ^ arg ty3 ^ " * " ^ arg ty4 end and Poly_quadruple : sig include Type.Polymorphic4 with type ('a,'b,'c,'d) poly = 'a * 'b * 'c * 'd module Make(T1: S)(T2: S)(T3:S)(T4:S) : S with type t = (T1.t, T2.t, T3.t, T4.t) poly end = struct (* Split the functor argument in 2 modules such that ocaml is able to safely evaluate the recursive modules *) include Polymorphic4 (struct include Quadruple_arg include Quadruple_name end) end module Quadruple = Poly_quadruple.Make let quadruple (type typ1) (type typ2) (type typ3) (type typ4) (ty1: typ1 Type.t) (ty2: typ2 Type.t) (ty3: typ3 Type.t) (ty4: typ4 Type.t) = let module Make(X: sig type t val ty: t Type.t end) = struct type t = X.t let ty = X.ty let name = Type.name X.ty let descr = Descr.of_type X.ty let packed_descr = Descr.pack descr let reprs = Type.reprs X.ty let equal = equal X.ty let compare = compare X.ty let hash = hash X.ty let copy = copy X.ty let internal_pretty_code = internal_pretty_code X.ty let pretty_code = pretty_code X.ty let pretty = from_pretty_code let varname = varname ty let mem_project = mem_project X.ty end in let module L = Quadruple (Make(struct type t = typ1 let ty = ty1 end)) (Make(struct type t = typ2 let ty = ty2 end)) (Make(struct type t = typ3 let ty = ty3 end)) (Make(struct type t = typ4 let ty = ty4 end)) in L.ty module Pair_with_collections(T1: S)(T2: S)(Info:Functor_info) = With_collections(Pair(T1)(T2))(Info) module Triple_with_collections(T1: S)(T2: S)(T3: S)(Info:Functor_info) = With_collections(Triple(T1)(T2)(T3))(Info) module Quadruple_with_collections(T1:S)(T2:S)(T3:S)(T4:S)(Info:Functor_info) = With_collections(Quadruple(T1)(T2)(T3)(T4))(Info) module Option_with_collections(T:S)(Info:Functor_info) = With_collections (Option(T))(Info) module List_with_collections(T:S)(Info:Functor_info) = With_collections (List(T))(Info) (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/type/type.ml����������������������������������������������������������0000644�0001750�0001750�00000060174�12155630171�017071� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ****************************************************************************) (* ****************************************************************************) (* ****************************************************************************) (* Disclaimer ---------- This module uses very unsafe caml features (module Obj). Modify it at your own risk. Sometimes the caml type system does not help you here. Introducing a bug here may introduce some "segmentation faults" in Frama-C *) let use_obj = ref true let no_obj () = use_obj := false let may_use_obj () = !use_obj (* ****************************************************************************) (* ****************************************************************************) (* ****************************************************************************) (** Precedences used for generating the minimal number of parenthesis in combination with function {!par} below. *) type precedence = | Basic | Call | Tuple | List | NoPar (* p1 <= p2 *) let lower_prec p1 p2 = match p1, p2 with | NoPar, _ | _, Basic -> true | x, y when x = y -> true | List, (Tuple | Call) | Tuple, Call -> true | _, _ -> false let par p_caller p_callee fmt pp = (* if p_callee <= p_caller then parenthesis else no parenthesis *) if lower_prec p_callee p_caller then Format.fprintf fmt "(%t)" pp else Format.fprintf fmt "%t" pp type concrete_repr = { name: string; digest: Digest.t; structural_descr: Structural_descr.t; mutable abstract: bool; mutable pp_ml_name: precedence -> Format.formatter -> unit } (* phantom type *) type 'a t = concrete_repr type 'a ty = 'a t (* non-phantom type: the type variable is used here *) type 'a full_t = { ty: 'a t; reprs: 'a list } (* ****************************************************************************) (** {2 Type values are comparable} *) (* ****************************************************************************) module Comparable = struct let equal x y = x.digest = y.digest let compare x y = String.compare x.digest y.digest let hash x = Hashtbl.hash x.digest end include Comparable module Tbl = Hashtbl.Make(struct type t = concrete_repr include Comparable end) (* ****************************************************************************) (** {2 Global useful values} *) (* ****************************************************************************) let types : (string (* name *), Obj.t full_t) Hashtbl.t = Hashtbl.create 97 let embedded_types: concrete_repr Tbl.t = Tbl.create 7 let dummy = { name = ""; digest = ""; structural_descr = Structural_descr.Unknown; abstract = false; pp_ml_name = fun _ _ -> assert false } (* ****************************************************************************) (** {2 Main functions} *) (* ****************************************************************************) let mk_dyn_pp name = function | None -> let pp fmt = let plugin_name = match Str.split (Str.regexp_string ".") name with | [] -> None | p :: _ -> Some p in match plugin_name with | None -> Format.fprintf fmt "(failwith \"%s is not a printable type name\")" name | Some p -> Format.fprintf fmt "%s.ty" p in (fun p fmt -> par p Basic fmt pp) | Some s -> let prec = try ignore (Str.search_forward (Str.regexp " ") name 0); Call with Not_found -> Basic in fun p fmt -> par p prec fmt (fun fmt -> Format.fprintf fmt "%s" s) exception AlreadyExists of string let register ?(closure=false) ~name ~ml_name structural_descr reprs = let error () = invalid_arg ("Type.register: invalid reprs for type " ^ name) in (* Format.printf "type %S@." name;*) match reprs with | [] -> error () | r :: _ when Obj.tag (Obj.repr r) = Obj.closure_tag && not closure -> (* all the representants have the same types: thus that is correct to check only the first one *) error () | _ -> if Hashtbl.mem types name then raise (AlreadyExists name); 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 | _ -> 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; abstract = false; 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 let add_abstract_types = ref (fun _ _ -> ()) 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.Abstract' in `no obj' mode" let () = let p = match Str.split (Str.regexp_string ".") T.name with | [] -> failwith "name as argument of `Type.Abstract' must be a valid OCaml \ type name" | p :: _ -> p in !add_abstract_types p T.name end (* cannot use [Pretty_utils] here *) let sfprintf fmt = let b = Buffer.create 20 in let return fmt = Format.pp_print_flush fmt (); Buffer.contents b in Format.kfprintf return (Format.formatter_of_buffer b) fmt let name ty = ty.name let structural_descr ty = ty.structural_descr let digest ty = ty.digest let pp_ml_name ty = ty.pp_ml_name let ml_name ty = sfprintf "%t" (ty.pp_ml_name Basic) let unsafe_reprs ty = (Hashtbl.find types ty.name).reprs let reprs ty = if !use_obj then let l = try unsafe_reprs ty with Not_found -> assert false in List.map Obj.obj l else [] let set_ml_name ty ml_name = let pp = mk_dyn_pp ty.name ml_name in ty.pp_ml_name <- pp let rec get_embedded_type_names ty = let sub_ty = try Tbl.find_all embedded_types ty with Not_found -> [] in let sub_ty_names = List.fold_left (fun acc ty -> get_embedded_type_names ty @ acc) [] sub_ty in ty.name :: sub_ty_names (* ****************************************************************************) (** {2 Polymorphic type values} *) (* ****************************************************************************) module type Polymorphic_input = sig val name: 'a t -> string val module_name: string val structural_descr: Structural_descr.t -> Structural_descr.t type 'a t val reprs: 'a -> 'a t list end module type Polymorphic = sig type 'a poly val instantiate: 'a t -> 'a poly t * bool val is_instance_of: 'a t -> bool val get_instance: 'a poly t -> 'a t end module Polymorphic(T: Polymorphic_input) = struct module Tbl = struct let memo : concrete_repr Tbl.t = Tbl.create 17 let instances: concrete_repr Tbl.t = Tbl.create 17 let add instance ty = Tbl.add memo instance ty; Tbl.add instances ty instance; Tbl.add embedded_types ty instance let find = Tbl.find memo let find_instance = Tbl.find instances let mem_instance = Tbl.mem memo end type 'a poly = 'a T.t let ml_name from_ty = sfprintf "%s.instantiate %t" T.module_name (from_ty.pp_ml_name Call) let instantiate (ty:'a t) = if !use_obj then try 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 else dummy, false let is_instance_of = Tbl.mem_instance let get_instance (ty:'a poly t) = try Tbl.find_instance ty with Not_found -> (* static typing ensures than [ty] has already been instantiated. *) assert false end module type Polymorphic2_input = sig val name: 'a t -> 'b t -> string val module_name: string val structural_descr: Structural_descr.t -> Structural_descr.t -> Structural_descr.t type ('a, 'b) t val reprs: 'a -> 'b -> ('a, 'b) t list end module type Polymorphic2 = sig type ('a, 'b) poly val instantiate: 'a t -> 'b t -> ('a, 'b) poly t * bool val is_instance_of: 'a t -> bool val get_instance: ('a, 'b) poly t -> 'a t * 'b t end module Concrete_pair = Hashtbl.Make (struct type t = concrete_repr * concrete_repr let hash (x,y) = Hashtbl.hash (hash x, hash y) let equal (x1,y1) (x2,y2) = equal x1 x2 && equal y1 y2 end) module Polymorphic2(T: Polymorphic2_input) = struct type ('a, 'b) poly = ('a, 'b) T.t let memo_tbl : concrete_repr Concrete_pair.t = Concrete_pair.create 17 let instances : (concrete_repr * concrete_repr) Tbl.t = Tbl.create 17 let ml_name from_ty1 from_ty2 = sfprintf "%s.instantiate %t %t" T.module_name (from_ty1.pp_ml_name Call) (from_ty2.pp_ml_name Call) let instantiate a b = if !use_obj then let key = a, b in try 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; Tbl.add embedded_types ty a; Tbl.add embedded_types ty b; ty, true else dummy, false let is_instance_of ty = Tbl.mem instances ty let get_instance (ty:('a, 'b) poly t) = try Tbl.find instances ty with Not_found -> (* static typing ensures than [ty] has already been instantiated. *) assert false end (* ****************************************************************************) (** {2 Functional types} *) (* ****************************************************************************) let par_ty_name test ty = if test ty then Format.sprintf "(%s)" ty.name else Format.sprintf "%s" ty.name module Function = struct type ('a, 'b) poly = 'a -> 'b type instance = { arg: concrete_repr; ret: concrete_repr; label: string option } module Memo = Hashtbl.Make (struct 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 : (instance * Obj.t (* default value of the optional label *) option) Tbl.t = Tbl.create 17 let is_instance_of ty = Tbl.mem instances ty let get_instance (ty:('a, 'b) poly t) = try let instance, _ = Tbl.find instances ty in instance.arg, instance.ret, instance.label with Not_found -> (* static typing ensures than [ty] has already been instantiated. *) assert false 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) with Not_found -> (* 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" let name label ty1 ty2 = (match label with None -> "" | Some l -> "~" ^ l ^ ":") ^ par_ty_name is_instance_of ty1 ^ " -> " ^ name ty2 let ml_name label ty1 ty2 = sfprintf "Datatype.func%s %t %t" (match label with None -> "" | Some l -> " ~label:(" ^ l ^ ", None)") (ty1.pp_ml_name Call) (ty2.pp_ml_name Call) 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) in let key = { arg = a; ret = b; label = l } in try 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); Tbl.add embedded_types ty a; Tbl.add embedded_types ty b; ty, true else dummy, false end (* ****************************************************************************) (** {2 Polymorphic3} *) (* ****************************************************************************) module type Polymorphic3_input = sig val name: 'a t -> 'b t -> 'c t -> string val module_name: string val structural_descr: Structural_descr.t -> Structural_descr.t -> Structural_descr.t -> Structural_descr.t type ('a, 'b, 'c) t val reprs: 'a -> 'b -> 'c -> ('a, 'b, 'c) t list end module type Polymorphic3 = sig type ('a, 'b, 'c) poly val instantiate: 'a t -> 'b t -> 'c t -> ('a, 'b, 'c) poly t * bool val is_instance_of: 'a t -> bool val get_instance: ('a, 'b, 'c) poly t -> 'a t * 'b t * 'c t end module Concrete_triple = Hashtbl.Make (struct type t = concrete_repr * concrete_repr * concrete_repr let hash (x,y,z) = Hashtbl.hash (hash x, hash y, hash z) let equal (x1,y1,z1) (x2,y2,z2) = equal x1 x2 && equal y1 y2 && equal z1 z2 end) module Polymorphic3(T:Polymorphic3_input) = struct type ('a, 'b, 'c) poly = ('a, 'b, 'c) T.t let memo_tbl: concrete_repr Concrete_triple.t = Concrete_triple.create 17 let instances : (concrete_repr * concrete_repr * concrete_repr) Tbl.t = Tbl.create 17 let ml_name from_ty1 from_ty2 from_ty3 = sfprintf "%s.instantiate %t %t %t" T.module_name (from_ty1.pp_ml_name Call) (from_ty2.pp_ml_name Call) (from_ty3.pp_ml_name Call) let instantiate a b c = if !use_obj then let key = a, b, c in try Concrete_triple.find memo_tbl key, false with Not_found -> let reprs = List.fold_left (fun acc r1 -> List.fold_left (fun acc r2 -> List.fold_left (fun acc r3 -> T.reprs r1 r2 r3 @ acc) acc (unsafe_reprs c)) acc (unsafe_reprs b)) [] (unsafe_reprs a) in let ty = register ~name:(T.name a b c) ~ml_name:(Some (ml_name a b c)) (T.structural_descr a.structural_descr b.structural_descr c.structural_descr) reprs in Concrete_triple.add memo_tbl key ty; Tbl.add instances ty key; Tbl.add embedded_types ty a; Tbl.add embedded_types ty b; Tbl.add embedded_types ty c; ty, true else dummy, false let is_instance_of ty = Tbl.mem instances ty let get_instance (ty:('a, 'b, 'c) poly t) = try Tbl.find instances ty with Not_found -> (* static typing ensures than [ty] has already been instantiated. *) assert false end (* ****************************************************************************) (** {2 Polymorphic4} *) (* ****************************************************************************) module type Polymorphic4_input = sig val name: 'a t -> 'b t -> 'c t -> 'd t -> string val module_name: string val structural_descr: Structural_descr.t -> Structural_descr.t -> Structural_descr.t -> Structural_descr.t -> Structural_descr.t type ('a, 'b, 'c, 'd) t val reprs: 'a -> 'b -> 'c -> 'd -> ('a, 'b, 'c, 'd) t list end module type Polymorphic4 = sig type ('a, 'b, 'c, 'd) poly val instantiate: 'a t -> 'b t -> 'c t -> 'd t -> ('a, 'b, 'c, 'd) poly t * bool val is_instance_of: 'a t -> bool val get_instance: ('a, 'b, 'c, 'd) poly t -> 'a t * 'b t * 'c t * 'd t end module Concrete_quadruple = Hashtbl.Make (struct type t = concrete_repr * concrete_repr * concrete_repr * concrete_repr let hash (x,y,z,t) = Hashtbl.hash (hash x, hash y, hash z, hash t) let equal (x1,y1,z1,t1) (x2,y2,z2,t2) = equal x1 x2 && equal y1 y2 && equal z1 z2 && equal t1 t2 end) module Polymorphic4(T:Polymorphic4_input) = struct type ('a, 'b, 'c, 'd) poly = ('a, 'b, 'c, 'd) T.t let memo_tbl : concrete_repr Concrete_quadruple.t = Concrete_quadruple.create 17 let instances : (concrete_repr * concrete_repr * concrete_repr * concrete_repr) Tbl.t = Tbl.create 17 let ml_name from_ty1 from_ty2 from_ty3 from_ty4 = sfprintf "%s.instantiate %t %t %t %t" T.module_name (from_ty1.pp_ml_name Call) (from_ty2.pp_ml_name Call) (from_ty3.pp_ml_name Call) (from_ty4.pp_ml_name Call) let instantiate a b c d = if !use_obj then let key = a, b, c, d in try Concrete_quadruple.find memo_tbl key, false with Not_found -> let reprs = List.fold_left (fun acc r1 -> List.fold_left (fun acc r2 -> List.fold_left (fun acc r3 -> List.fold_left (fun acc r4 -> T.reprs r1 r2 r3 r4 @ acc) acc (unsafe_reprs d)) acc (unsafe_reprs c)) acc (unsafe_reprs b)) [] (unsafe_reprs a) in let ty = register ~name:(T.name a b c d) ~ml_name:(Some (ml_name a b c d)) (T.structural_descr a.structural_descr b.structural_descr c.structural_descr d.structural_descr) reprs in Concrete_quadruple.add memo_tbl key ty; Tbl.add instances ty key; Tbl.add embedded_types ty a; Tbl.add embedded_types ty b; Tbl.add embedded_types ty c; Tbl.add embedded_types ty d; ty, true else dummy, false let is_instance_of ty = Tbl.mem instances ty let get_instance (ty:('a, 'b, 'c, 'd) poly t) = try Tbl.find instances ty with Not_found -> (* static typing ensures than [ty] has already been instantiated. *) assert false end (* ****************************************************************************) (** {2 Heterogeneous Tables} *) (* ****************************************************************************) module Ty_tbl(Info: sig type 'a t end) = struct type t = Obj.t Tbl.t 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 module Obj_tbl: sig type 'a t val create: unit -> 'a t val add: 'a t -> 'b ty -> 'b -> 'a -> unit val find: 'a t -> 'b ty -> 'b -> 'a val mem: 'a t -> 'b ty -> 'b -> bool val iter: 'b t -> ('a ty -> 'a -> 'b -> unit) -> unit end = struct module O = Hashtbl.Make(struct 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 (* Buggy code with OCaml 4.01, deactivated for now (* 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)*) (* to be tested (suggested by Damien D.): add a 'xor 0' *) (* Obj.magic (Obj.field x 0)*) 0 else Hashtbl.hash x else 0 end) type 'a t = 'a O.t Tbl.t let create () = Tbl.create 7 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 in O.replace tytbl (Obj.repr k) v let find tbl ty k = if !use_obj then O.find (Tbl.find tbl ty) (Obj.repr k) else invalid_arg "cannot call function 'find' in the 'no obj' mode" let mem tbl ty k = try let objs = Tbl.find tbl ty in assert !use_obj; O.mem objs (Obj.repr k) with Not_found -> false let iter tbl f = Tbl.iter (fun ty objs -> O.iter (fun o v -> f ty (Obj.obj o) v) objs) tbl end module type Heterogeneous_table = sig type key type 'a info type t val create: int -> t 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 val iter: (key -> 'a ty -> 'a info -> unit) -> t -> unit val fold: (key -> 'a ty -> 'a info -> 'b -> 'b) -> t -> 'b -> 'b end module Make_tbl (Key: sig include Hashtbl.HashedType val to_string: t -> string end) (Info: sig type 'a t end) = struct type key = Key.t type 'a info = 'a Info.t type data = { ty: concrete_repr; o: Obj.t } module H = Hashtbl.Make(Key) type t = data H.t exception Incompatible_type of string 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); 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)) let find tbl s ty = if !use_obj then let name = Key.to_string s in 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" let iter f tbl = if !use_obj then H.iter (fun k v -> f k v.ty (Obj.obj v.o)) tbl else invalid_arg "cannot call function 'iter' in the 'no obj' mode" let fold f tbl acc = if !use_obj then H.fold (fun k v acc -> f k v.ty (Obj.obj v.o) acc) tbl acc else invalid_arg "cannot call function 'fold' in the 'no obj' mode" end module String_tbl = Make_tbl (struct type t = string let hash x = Hashtbl.hash x let equal : string -> string -> bool = (=) let to_string x = x end) (* Local Variables: compile-command: "make -C ../.." End: *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/type/structural_descr.ml����������������������������������������������0000644�0001750�0001750�00000027436�12155630171�021504� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ********************************************************************** *) (** {2 Type declarations} *) (* ********************************************************************** *) type single_pack = Unmarshal.t type t = Unknown | Abstract | Structure of structure | T_pack of single_pack and structure = Sum of pack array array | Array of pack and pack = Nopack | Pack of single_pack | Recursive of recursive and recursive = t ref (* ********************************************************************** *) (** {2 Injection into Unmarshal} *) (* ********************************************************************** *) module Recursive = struct let create () = ref Unknown let update x t = x := t (* internals *) module Tbl = Hashtbl.Make (struct type t = recursive let equal = (==) let hash = Hashtbl.hash end) let positions = Tbl.create 7 let arrays = Tbl.create 7 let add_position r i j = Tbl.add positions r (i, j) let add_array a = Tbl.iter (fun r p -> Tbl.add arrays r (a, p)) positions; Tbl.clear positions let finalize t u = (* there are not so many mutually recursive values: linear time is ok *) Tbl.iter (fun r (a, (i, j)) -> if !r == t then a.(i).(j) <- u) arrays; Tbl.clear arrays end exception Cannot_pack let pack_to_unmarshal i j = function | Nopack -> raise Cannot_pack | Pack d -> d | Recursive r -> Recursive.add_position r i j; Unmarshal.Abstract (* will be updated later *) let structure_to_unmarshal = function | Sum arr -> let a = Array.mapi (fun i -> Array.mapi (pack_to_unmarshal i)) arr in Recursive.add_array a; Unmarshal.Sum a | Array d -> Unmarshal.Array (pack_to_unmarshal 0 0 d) let to_unmarshal = function | Unknown -> raise Cannot_pack | Abstract -> Unmarshal.Abstract | Structure s as x -> let y = Unmarshal.Structure (structure_to_unmarshal s) in Recursive.finalize x y; y | T_pack p -> p let pack d = try Pack (to_unmarshal d) with Cannot_pack -> Nopack let pack_from_unmarshal d = Pack d let unsafe_pack = pack_from_unmarshal let structure_from_unmarshal = function | Unmarshal.Sum arr -> Sum (Array.map (Array.map pack_from_unmarshal) arr) | Unmarshal.Dependent_pair _ -> assert false (* not structural *) | Unmarshal.Array d -> Array (pack_from_unmarshal d) let from_unmarshal = function | Unmarshal.Abstract -> Abstract | Unmarshal.Structure s -> Structure (structure_from_unmarshal s) | Unmarshal.Transform _ | Unmarshal.Return _ | Unmarshal.Dynamic _ -> assert false (* not structural *) let recursive_pack r = Recursive r (* ********************************************************************** *) (** {2 Predefined values} *) (* ********************************************************************** *) let p_abstract = unsafe_pack Unmarshal.Abstract let p_unit = unsafe_pack Unmarshal.t_unit let p_int = unsafe_pack Unmarshal.t_int let p_string = unsafe_pack Unmarshal.t_string let p_float = unsafe_pack Unmarshal.t_float let p_bool = unsafe_pack Unmarshal.t_bool let p_int32 = unsafe_pack Unmarshal.t_int32 let p_int64 = unsafe_pack Unmarshal.t_int64 let p_nativeint = unsafe_pack Unmarshal.t_nativeint let t_unit = from_unmarshal Unmarshal.t_unit let t_int = from_unmarshal Unmarshal.t_int let t_string = from_unmarshal Unmarshal.t_string let t_float = from_unmarshal Unmarshal.t_float let t_bool = from_unmarshal Unmarshal.t_bool let t_int32 = from_unmarshal Unmarshal.t_int32 let t_int64 = from_unmarshal Unmarshal.t_int64 let t_nativeint = from_unmarshal Unmarshal.t_nativeint let poly f a = try from_unmarshal (f (to_unmarshal a)) with Cannot_pack -> Unknown let poly_arr f a = try let d = f (Array.mapi (pack_to_unmarshal 0) a) in from_unmarshal d with Cannot_pack -> Unknown let t_record = poly_arr Unmarshal.t_record let t_tuple = poly_arr Unmarshal.t_tuple let t_list = poly Unmarshal.t_list let t_ref = poly Unmarshal.t_ref let t_option = poly Unmarshal.t_option let t_array = poly Unmarshal.t_array let t_queue = poly Unmarshal.t_queue let t_set_unchanged_compares = poly Unmarshal.t_set_unchangedcompares let poly2 f a b = try from_unmarshal (f (to_unmarshal a) (to_unmarshal b)) with Cannot_pack -> Unknown let t_map_unchanged_compares = poly2 Unmarshal.t_map_unchangedcompares let t_hashtbl_unchanged_hashs = poly2 (Unmarshal.t_hashtbl_unchangedhashs) (* ********************************************************************** *) (** {2 Internals} *) (* ********************************************************************** *) (* ********************************************************************** *) (* {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 = Hashtbl.Make (struct type u = t type t = u let equal = (==) let hash = Hashtbl.hash end) let visited = Tbl.create 7 let rec cleanup_unmarshal_structure = function | Unmarshal.Sum arr -> Unmarshal.Sum (Array.map (Array.map cleanup_unmarshal) arr) | Unmarshal.Array p -> Unmarshal.Array (cleanup_unmarshal p) | Unmarshal.Dependent_pair _ -> assert false and cleanup_unmarshal = function | Unmarshal.Abstract as x -> x | Unmarshal.Transform(x, _) | Unmarshal.Return(x, _) -> cleanup_unmarshal x | Unmarshal.Structure s as x -> if Unmarshal_tbl.mem unmarshal_visited x then Unmarshal.Abstract (* not so good, but so much simpler *) else begin Unmarshal_tbl.add unmarshal_visited x (); Unmarshal.Structure (cleanup_unmarshal_structure s) end | Unmarshal.Dynamic _ -> assert false let rec cleanup_pack = function | Nopack as x -> x | Recursive r -> let x = ref Unknown in Tbl.add visited !r x; Recursive x | Pack p -> Pack (cleanup_unmarshal p) and cleanup_structure = function | Sum arr -> Sum (Array.map (Array.map cleanup_pack) arr) | Array p -> Array (cleanup_pack p) and cleanup_aux = function | Unknown | Abstract as x -> x | Structure s as x -> let x' = Structure (cleanup_structure s) in (try let r = Tbl.find visited x in r := x' with Not_found -> ()); x' | T_pack p -> T_pack (cleanup_unmarshal p) let cleanup x = assert (Unmarshal_tbl.length unmarshal_visited = 0 && Tbl.length visited = 0); let x = cleanup_aux x in Unmarshal_tbl.clear unmarshal_visited; Tbl.clear visited; x (* ********************************************************************** *) (* {3 are_consistent} *) (* ********************************************************************** *) let unmarshal_consistent_visited = Unmarshal_tbl.create 7 let consistent_visited = Tbl.create 7 let rec are_consistent_unmarshal_structures s1 s2 = match s1, s2 with | 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 done; true with Invalid_argument _ | Exit -> false) | Unmarshal.Array d1, Unmarshal.Array d2 | Unmarshal.Dependent_pair(d1, _), Unmarshal.Dependent_pair(d2, _) | Unmarshal.Dependent_pair(d1, _), Unmarshal.Sum [| [| d2; _ |] |] | Unmarshal.Sum [| [| d1; _ |] |], Unmarshal.Dependent_pair(d2, _) -> are_consistent_unmarshal d1 d2 | Unmarshal.Sum _, Unmarshal.Array _ | Unmarshal.Array _, Unmarshal.Sum _ | (Unmarshal.Array _ | Unmarshal.Sum _), Unmarshal.Dependent_pair _ | Unmarshal.Dependent_pair _, (Unmarshal.Array _ | Unmarshal.Sum _) -> false and are_consistent_unmarshal d1 d2 = match d1, d2 with | Unmarshal.Abstract, Unmarshal.Abstract | Unmarshal.Dynamic _, _ | _, Unmarshal.Dynamic _ -> true | Unmarshal.Return(d1, _), d2 | d1, Unmarshal.Return(d2, _) | Unmarshal.Transform(d1, _), d2 | d1, Unmarshal.Transform(d2, _) -> are_consistent_unmarshal d1 d2 | Unmarshal.Structure s1, Unmarshal.Structure s2 -> (try let d2' = Unmarshal_tbl.find unmarshal_consistent_visited d1 in d2 == d2' with Not_found -> (* Keep already visited terms in order to prevent looping when visiting recursive terms. However, remove them from the table after visiting in order to not pollute it when visiting cousins: fixed bts #1277. Would be better to use a persistent table instead of a mutable one, but not possible to provide a (terminating) comparison. *) Unmarshal_tbl.add unmarshal_consistent_visited d1 d2; let b = are_consistent_unmarshal_structures s1 s2 in Unmarshal_tbl.remove unmarshal_consistent_visited d1; b) | _, _ -> false let are_consistent_pack p1 p2 = match p1, p2 with | Nopack, Nopack -> true | Pack s1, Pack s2 -> are_consistent_unmarshal s1 s2 | Recursive _, _ | _, Recursive _ -> invalid_arg "unbound recursive structural descriptors" | Nopack, Pack _ | Pack _, Nopack -> false let rec are_consistent_structures s1 s2 = match s1, s2 with | 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 done; true with Invalid_argument _ | Exit -> false) | Array d1, Array d2 -> are_consistent_pack d1 d2 | Sum _, Array _ | Array _, Sum _ -> false and are_consistent_aux d1 d2 = match d1, d2 with | Unknown, Unknown | Abstract, Abstract -> true | Structure s1, Structure s2 -> (try let d2' = Tbl.find consistent_visited d1 in d2 == d2' with Not_found -> Tbl.add consistent_visited d1 d2; are_consistent_structures s1 s2) | d, T_pack s | T_pack s, d -> are_consistent_unmarshal (to_unmarshal d) s | _, _ -> false let are_consistent d1 d2 = assert (Unmarshal_tbl.length unmarshal_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; b (* Local Variables: compile-command: "make -C ../.." End: *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/type/type.mli���������������������������������������������������������0000644�0001750�0001750�00000035332�12155630171�017240� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Type value. A type value is a value representing a static ML monomorphic type. This API is quite low level. Prefer to use module {!Datatype} instead whenever possible. @plugin development guide *) (* ****************************************************************************) (** {2 Type declaration} *) (* ****************************************************************************) type 'a t (** Type of type values. For each monomorphic type [ty], a value of type [ty t] dynamically represents the type [ty]. Such a value is called a type value and should be unique for each static monomorphic type. @plugin development guide *) type 'a ty = 'a t (* ****************************************************************************) (** {2 Pretty printing materials} *) (* ****************************************************************************) (** Precedences used for generating the minimal number of parenthesis in combination with function {!par} below. *) type precedence = | Basic (** @plugin development guide *) | Call (** @plugin development guide *) | Tuple | List | NoPar (** [par context myself fmt pp] puts parenthesis around the verbatim prints by [pp] according to the precedence [myself] of the verbatim and to the precedence [context] of the caller of the pretty printer. [fmt] is the output formatter. The typical use is the following: [let pretty_print p_caller fmt x = let pp fmt = Format.fprintf "..." ... x ... in let myself = Call in par p_caller myself fmt pp] @plugin development guide *) val par: precedence -> precedence -> Format.formatter -> (Format.formatter -> unit) -> unit (** [par_ty_name f ty] puts parenthesis around the name of the [ty] iff [f ty] is [true]. @since Carbon-20101201 *) val par_ty_name: ('a t -> bool) -> 'a t -> string (* ****************************************************************************) (** {2 Constructor and getters} *) (* ****************************************************************************) exception AlreadyExists of string (** May be raised by {!register}. @plugin development guide *) val register: ?closure:bool -> name:string -> ml_name:string option -> Structural_descr.t -> 'a list -> 'a t (** [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. [closure] is true iff the type is a function type. [name] is the name of the type. Must be a valid OCaml type name (eventually prefixed by a module path). [ml_name] is the OCaml name of the registered type value. @raise AlreadyExists if the given name is already used by another type. @raise Invalid_argument if [reprs] is the empty list @modify Boron-20100401 request a list of representant, not only a single one @modify Carbon-20101201 [value_name] is now [ml_name]. Must provide a structural descriptor. Argument [pp] does not exist anymore. *) (** Apply this functor to access to the abstract type of the given name. @since Nitrogen-20111001 @plugin development guide *) module Abstract(T: sig val name: string end): sig type t val ty: t ty end val name: 'a t -> string (** @plugin development name *) 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 get_embedded_type_names: 'a t -> string list (** Get the list of names containing in the type represented by the given type value. For instance [get_embedded_type_names (Datatype.func Datatype.unit (Datatype.list Datatype.int))] returns [ "unit -> int list"; "unit"; "int list"; "int" ]. @since Oxygen-20120901 *) 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 (* ****************************************************************************) (** {2 Type values are comparable} *) (* ****************************************************************************) val equal: 'a t -> 'b t -> bool val compare: 'a t -> 'b t -> int val hash: 'a t -> int (* ****************************************************************************) (** {2 Polymorphic type values} Functors for handling polymorphic type: one type value must be registered for each monomorphic instance of a polymorphic type. *) (* ****************************************************************************) module type Polymorphic_input = sig val name: 'a t -> string (** How to build a name for each monomorphic instance of the type value from the underlying type. *) val module_name: string (** The name of the built module. *) val structural_descr: Structural_descr.t -> Structural_descr.t (** How to build the structural descriptor for each monomorphic instance. @since Carbon-20101201 *) type 'a t (** Static polymorphic type corresponding to its dynamic counterpart to register. *) val reprs: 'a -> 'a t list (** How to make the representant of each monomorphic instance of the polymorphic type value from an underlying representant. *) end (** For a polymorphic type value with one type variable, you must use an implementation of this signature. *) module type Polymorphic = sig type 'a poly (** Type of the polymorphic type (for instance ['a list]). It must be instantiated before used. See function [instantiate] below. *) 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]. *) 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]. *) val get_instance: 'a poly t -> 'a t (** [get_instance ty] returns the type value used to create the given monomorphic instantiation. *) end (** Generic implementation of polymorphic type value. *) module Polymorphic(T:Polymorphic_input) : Polymorphic with type 'a poly = 'a T.t (** See module {!Polymorphic_input}: very same functions with one additional argument corresponding to the second type variable. *) module type Polymorphic2_input = sig val name: 'a t -> 'b t -> string val module_name: string val structural_descr: Structural_descr.t -> Structural_descr.t -> Structural_descr.t type ('a, 'b) t val reprs: 'a -> 'b -> ('a, 'b) t list end (** Same as {!Polymorphic} for polymorphic types with two type variables. *) module type Polymorphic2 = sig type ('a, 'b) poly val instantiate: 'a t -> 'b t -> ('a, 'b) poly t * bool val is_instance_of: 'a t -> bool val get_instance: ('a, 'b) poly t -> 'a t * 'b t end (** Generic implementation of polymorphic type value with two type variables. *) module Polymorphic2(T:Polymorphic2_input) : Polymorphic2 with type ('a, 'b) poly = ('a, 'b) T.t (** Instance of {!Polymorphic2} for functions: same signature than {!Polymorphic2} with possibility to specify a label for the function parameter. *) module Function : sig type ('a, 'b) poly 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,Some f)] for an optional labelized parameter [p], with default value [f ()]. *) val is_instance_of: 'a t -> bool val get_instance: ('a, 'b) poly t -> 'a t * 'b t * string option val get_optional_argument: ('a, 'b) poly t -> (unit -> 'a) option end (** See module {!Polymorphic_input}: very same functions with two additional arguments corresponding to the second and third type variables. @since Oxygen-20120901 *) module type Polymorphic3_input = sig val name: 'a t -> 'b t -> 'c t -> string val module_name: string val structural_descr: Structural_descr.t -> Structural_descr.t -> Structural_descr.t -> Structural_descr.t type ('a, 'b, 'c) t val reprs: 'a -> 'b -> 'c -> ('a, 'b, 'c) t list end (** Same as {!Polymorphic} for polymorphic types with three type variables. @since Oxygen-20120901 *) module type Polymorphic3 = sig type ('a, 'b, 'c) poly val instantiate: 'a t -> 'b t -> 'c t -> ('a, 'b, 'c) poly t * bool val is_instance_of: 'a t -> bool val get_instance: ('a, 'b, 'c) poly t -> 'a t * 'b t * 'c t end (** Generic implementation of polymorphic type value with three type variables. @since Oxygen-20120901 *) module Polymorphic3(T:Polymorphic3_input) : Polymorphic3 with type ('a, 'b, 'c) poly = ('a, 'b, 'c) T.t (** See module {!Polymorphic_input}: very same functions with three additional arguments corresponding to the additional type variables. @since Oxygen-20120901 *) module type Polymorphic4_input = sig val name: 'a t -> 'b t -> 'c t -> 'd t -> string val module_name: string val structural_descr: Structural_descr.t -> Structural_descr.t -> Structural_descr.t -> Structural_descr.t -> Structural_descr.t type ('a, 'b, 'c, 'd) t val reprs: 'a -> 'b -> 'c -> 'd -> ('a, 'b, 'c, 'd) t list end (** Same as {!Polymorphic} for polymorphic types with four type variables. @since Oxygen-20120901 *) module type Polymorphic4 = sig type ('a, 'b, 'c, 'd) poly val instantiate: 'a t -> 'b t -> 'c t -> 'd t -> ('a, 'b, 'c, 'd) poly t * bool val is_instance_of: 'a t -> bool val get_instance: ('a, 'b, 'c, 'd) poly t -> 'a t * 'b t * 'c t * 'd t end (** Generic implementation of polymorphic type value with four type variables. @since Oxygen-20120901 *) module Polymorphic4(T:Polymorphic4_input) : Polymorphic4 with type ('a, 'b, 'c, 'd) poly = ('a, 'b, 'c, 'd) T.t (* ****************************************************************************) (** {2 Heterogeneous Tables} These tables are safe to use but nevertheless not for casual users. *) (* ****************************************************************************) (** @since Carbon-20101201 *) module type Heterogeneous_table = sig type key (** @since Carbon-20101201 *) type 'a info type t (** Type of heterogeneous (hash)tables indexed by values of type Key.t. 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 -> 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]. @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 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]. *) val iter: (key -> 'a ty -> 'a info -> unit) -> t -> unit (** @since Oxygen-20120901 *) val fold: (key -> 'a ty -> 'a info -> 'b -> 'b) -> t -> 'b -> 'b (** @since Fluorine-20130401 *) end (** Build an heterogeneous table associating keys to info. Not efficient for types registered without ml name. @since Carbon-20101201 *) module Make_tbl (Key: sig include Hashtbl.HashedType val to_string: t -> string end) (Info: sig type 'a t end) : Heterogeneous_table with type key = Key.t and type 'a info = 'a Info.t (** Heterogeneous tables indexed by string. *) module String_tbl(Info: sig type 'a t end) : Heterogeneous_table with type key = string and type 'a info = 'a Info.t (** Heterogeneous tables indexed by type value. Roughly the same signature that [Hashtbl.S]. *) module Ty_tbl(Info: sig type 'a t end) : sig type t val create: int -> t val add: t -> 'b ty -> 'b Info.t -> unit val find: t -> 'b ty -> 'b Info.t end (** Heterogeneous table for the keys, but polymorphic for the values. *) module Obj_tbl: sig type 'a t val create: unit -> 'a t val add: 'a t -> 'b ty -> 'b -> 'a -> unit val find: 'a t -> 'b ty -> 'b -> 'a val mem: 'a t -> 'b ty -> 'b -> bool val iter: 'b t -> ('a ty -> 'a -> 'b -> unit) -> unit end (**/**) (* ****************************************************************************) (** {2 Internal API} *) (* ****************************************************************************) val no_obj: unit -> unit (** 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. *) val add_abstract_types: (string -> string -> unit) ref val sfprintf: ('a,Format.formatter,unit,string) format4 -> 'a (** similar as Format.sprintf, but %a are allowed in the formatting string*) (**/**) (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/type/descr.mli��������������������������������������������������������0000644�0001750�0001750�00000013352�12155630171�017355� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Type descriptor for safe unmarshalling. This module provides a safe API on top of modules {!Unmarshal} of {!Structural_descr}, using module {!Type}. This module offers the same powerfulness than {!Unmarshal}, but in a safe way. *) (* ********************************************************************** *) (** {2 Type declaration} *) (* ********************************************************************** *) type 'a t (** Type of a type descriptor. *) (* ********************************************************************** *) (** {2 Predefined type descriptors} *) (* ********************************************************************** *) val t_unit: unit t val t_int : int t val t_string : string t val t_float : float t val t_bool : bool t val t_int32 : int32 t val t_int64 : int64 t val t_nativeint : nativeint t val unmarshable: 'a t (** Descriptor for unmarshalable types. @since Carbon-20101201 *) val is_unmarshable: 'a t -> bool (** @since Carbon-20101201 *) (* ********************************************************************** *) (** {2 Type descriptor builders} *) (* ********************************************************************** *) exception Invalid_descriptor (** @since Carbon-20101201 *) (** {3 Builders for standard OCaml types} *) val t_record : Structural_descr.pack array -> 'a -> 'a t (** Type descriptor for records (the length of the array must be equal to the number of fields in the record). @raise Invalid_descriptor if the descriptor cannot be built. *) val t_tuple : Structural_descr.pack array -> 'a -> 'a t (** Type descriptor for tuples of any range (the length of the array range is the range of the tuple). @raise Invalid_descriptor if the descriptor cannot be built. *) val t_pair: 'a t -> 'b t -> ('a * 'b) t (** Type descriptor for pairs (2-tuples). Safer that [t_tuple] for pairs. @raise Invalid_descriptor if the descriptor cannot be built. *) val t_list : 'a t -> 'a list t (** Type descriptor for lists. @raise Invalid_descriptor if the descriptor cannot be built. *) val t_ref : 'a t -> 'a ref t (** Type descriptor for references. @raise Invalid_descriptor if the descriptor cannot be built. *) val t_option : 'a t -> 'a option t (** Type descriptor for options. @raise Invalid_descriptor if the descriptor cannot be built. *) val t_queue: 'a t -> 'a Queue.t t (** Type descriptor for queues. @raise Invalid_descriptor if the descriptor cannot be built. *) (** {3 Builders from others datatypes of the Type library} *) val of_type: 'a Type.t -> 'a t (** Type descriptor from the type value. @since Carbon-20101201 *) val of_structural: 'a Type.t -> Structural_descr.t -> 'a t (** Type descriptor from the structural descriptor. The given type value ensures safety. @since Carbon-20101201 *) (** {3 Builders mapping {!Unmarshal}'s transformers} *) val dependent_pair: 'a t -> ('a -> 'b t) -> ('a * 'b) t (** Similar to {!Unmarshal.Dependent_pair}, but safe. @raise Invalid_descriptor if the descriptor cannot be built. *) val transform: 'a t -> ('a -> 'a) -> 'a t (** Similar to {!Unmarshal.Transform}, but safe. @raise Invalid_descriptor if the given descriptor is incorrect. *) val return: 'a t -> (unit -> 'a) -> 'a t (** Similar to {!Unmarshal.Return}, but safe. @raise Invalid_descriptor if the descriptor cannot be built. *) val dynamic: (unit -> 'a t) -> 'a t (** Similar to {!Unmarshal.Dynamic}. @raise Invalid_descriptor if the descriptor cannot be built. *) (* ********************************************************************** *) (** {2 Coercions} *) (* ********************************************************************** *) val str: 'a t -> Structural_descr.t (** @raise Invalid_descriptor if the given descriptor is incorrect. @since Carbon-20101201 *) val pack: 'a t -> Structural_descr.pack (** @since Carbon-20101201 *) (* ********************************************************************** *) (** {2 Safe unmarshaling} *) (* ********************************************************************** *) val input_val: in_channel -> 'a t -> 'a (** @since Carbon-20101201 *) (* Local Variables: compile-command: "make -C ../.." End: *) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/type/descr.ml���������������������������������������������������������0000644�0001750�0001750�00000015524�12155630171�017207� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Structural_descr (* ********************************************************************** *) (** {2 Type declaration} *) (* ********************************************************************** *) type 'a t = pack 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} *) (* ********************************************************************** *) let unmarshable = pack Unknown let is_unmarshable x = x = unmarshable 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} *) (* ********************************************************************** *) exception Invalid_descriptor = Cannot_pack (** {3 Builders for standard OCaml types} *) let t_record x _ = try let x = Array.map (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 -> unmarshable let t_tuple = t_record let t_pair x y = match x, y with | (Nopack | Recursive _), _ | _, (Nopack | Recursive _) -> unmarshable | 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 -> uncheck_pack (f (coerce x)) let t_list = t_poly Unmarshal.t_list let t_ref = t_poly Unmarshal.t_ref let t_option = t_poly Unmarshal.t_option let t_queue = t_poly Unmarshal.t_queue (** {3 Builders from others datatypes of the Type library} *) let of_type ty = pack (Type.structural_descr ty) let of_structural ty d = let ty_d = Type.structural_descr ty in if not (Type.may_use_obj ()) || Structural_descr.are_consistent ty_d d then pack d else invalid_arg "Descr.of_structural: inconsistent descriptor" (** {3 Builders mapping transformers of {!Unmarshal}} *) let dependent_pair a fb = match a with | Nopack -> unmarshable | Recursive _ -> raise Invalid_descriptor | Pack a -> let f x = match fb (Obj.obj x) with | Nopack | Recursive _ -> raise Invalid_descriptor | Pack b -> coerce b in 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 -> 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 uncheck_pack (Unmarshal.Dynamic f) module Unmarshal_tbl = Hashtbl.Make (struct type t = Unmarshal.t let equal = (==) let hash = Hashtbl.hash (* [JS 2012/07/10] what about recursive datatypes? Look like [hash] could loop... *) end) let visited = Unmarshal_tbl.create 7 let rec transform_unmarshal_structure term x = function | Unmarshal.Sum arr -> 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) arr; List.iter (fun (a, i) -> a.(i) <- term) !l | Unmarshal.Dependent_pair(d, _) | Unmarshal.Array d -> transform_unmarshal term x d and transform_unmarshal term x = function | Unmarshal.Abstract | Unmarshal.Dynamic _ -> () | Unmarshal.Structure s as y -> if not (Unmarshal_tbl.mem visited y) then begin Unmarshal_tbl.add visited y (); transform_unmarshal_structure term x s end | Unmarshal.Return(d, _) | Unmarshal.Transform(d, _) as y -> (* TODO: not possible to change the return/transform by [term] if its == to [x] (since this value is immutable). Hopefully this case should never occur. *) assert (x != y); transform_unmarshal term x d let transform descr f = match descr with | Nopack -> raise Cannot_pack | Recursive _ -> raise Invalid_descriptor | Pack d -> let d = coerce d in let term = Unmarshal.Transform(d, fun x -> Obj.repr (f (Obj.obj x))) in transform_unmarshal term d d; Unmarshal_tbl.clear visited; uncheck_pack term (* ********************************************************************** *) (** {2 Coercions} *) (* ********************************************************************** *) let str = function | Nopack -> Unknown | Pack p -> T_pack p | Recursive _ -> raise Invalid_descriptor let pack x = x (* ********************************************************************** *) (** {2 Safe unmarshaling} *) (* ********************************************************************** *) let input_val cin = function | Nopack | Recursive _ -> invalid_arg "Descr.input_val: unmarshable value" | Pack d -> Unmarshal.input_val cin (coerce d) (* Local Variables: compile-command: "make -C ../.." End: *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/type/structural_descr.mli���������������������������������������������0000644�0001750�0001750�00000014354�12155630171�021650� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Internal representations of OCaml type as first class values. These values are called structural descriptors. @since Carbon-20101201 *) (* ********************************************************************** *) (** {2 Type declarations} *) (* ********************************************************************** *) (** Type used for handling (possibly mutually) recursive structural descriptors. See module {!Recursive}. *) type recursive type single_pack = private Unmarshal.t (** 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. Example: the structural descriptor of [A | B of int * bool | C of string] is [Structure (Sum [| [| p_int; p_bool |]; [| p_string |] |])]. Ok, in this case, just [Abstract] is valid too. *) type t = | Unknown (** Use it either for unmarshable types or if you don't know its internal representation. In any case, values of types with this descriptor will never be written on disk. *) | Abstract (** The data is marshable as an usual OCaml value. No specific processing will be applied on any part of such a data. *) | Structure of structure (** Provide a description of the representation of data. @plugin development guide *) | T_pack of single_pack (** Internal use only. Do not use it outside the library *) (** Description with details. *) and structure = | Sum of pack array array (** [Sum c] describes a non-array type where [c] is an array describing the non-constant constructors of the type being described (in the order of their declarations in that type). Each element of this latter array is an array of [t] that describes (in order) the fields of the corresponding constructor. @plugin development guide *) | Array of pack (** The data is an array of values of the same type, each value being described by the pack. *) (* ********************************************************************** *) (** {2 Pack builders} *) (* ********************************************************************** *) val pack: t -> pack (** Pack a structural descriptor in order to embed it inside another one. @plugin development guide *) 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 [d] and use [Recursive r] in places where [d] should be put. Call [Recursive.update r d] after building [d]. Here is an example for [type t = A | B of t]: [let r = Recursive.create () in let d = Structure (Sum [| [| Recursive r |] |]) in Recursive.update r d] *) module Recursive: sig val create: unit -> recursive val update: recursive -> t -> unit end (* ********************************************************************** *) (** {2 Predefined descriptors} *) (* ********************************************************************** *) val t_unit : t val t_int : t val t_string : t val t_float : t val t_bool : t val t_int32 : t val t_int64 : t val t_nativeint : t val t_record : pack array -> t val t_tuple : pack array -> t val t_list : t -> t val t_ref : t -> t val t_option : t -> t val t_array : t -> t val t_queue: t -> t (** Use the functions below only if the compare/hash functions cannot change by marshalling. *) val t_set_unchanged_compares: t -> t val t_map_unchanged_compares: t -> t -> t val t_hashtbl_unchanged_hashs: t -> t -> t (** Packed versions of predefined descriptors. *) val p_abstract: pack (** Equivalent to [pack Abstract] *) val p_unit : pack val p_int : pack (** @plugin development guide *) val p_string : pack val p_float : pack val p_bool : pack val p_int32 : pack val p_int64 : pack val p_nativeint : pack (* ********************************************************************** *) (** {2 Internals} These values must be used only inside the Type library. *) (* ********************************************************************** *) exception Cannot_pack val unsafe_pack: Unmarshal.t -> pack (** @raise Cannot_pack if packing failed. *) val cleanup: t -> t val are_consistent: t -> t -> bool (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/type/datatype.mli�����������������������������������������������������0000644�0001750�0001750�00000055747�12155630171�020106� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** A datatype provides useful values for types. It is a high-level API on top of module {!Type}. @since Carbon-20101201 @plugin development guide *) (* ********************************************************************** *) (** {2 Type declarations} *) (* ********************************************************************** *) (** Values associated to each datatype. Some others are provided directly in module {!Type}. *) type 'a t = private { equal: 'a -> 'a -> bool; compare: 'a -> 'a -> int; hash: 'a -> int; copy: 'a -> 'a; internal_pretty_code: Type.precedence -> Format.formatter -> 'a -> unit; pretty_code: Format.formatter -> 'a -> unit; pretty: Format.formatter -> 'a -> unit; varname: 'a -> string; mem_project: (Project_skeleton.t -> bool) -> 'a -> bool } (** A type with its type value. *) module type Ty = sig type t val ty: t Type.t end (** All values associated to a datatype, excepted [copy]. *) module type S_no_copy = sig include Ty val name: string (** Unique name of the datatype. *) val descr: t Descr.t (** Datatype descriptor. *) val packed_descr: Structural_descr.pack (** Packed version of the descriptor. *) val reprs: t list (** List of representents of the descriptor. *) val equal: t -> t -> bool (** Equality: same spec than [Pervasives.(=)]. *) val compare: t -> t -> int (** Comparison: same spec than [Pervasives.compare]. *) val hash: t -> int (** Hash function: same spec than [Hashtbl.hash]. *) val pretty_code: Format.formatter -> t -> unit (** Pretty print each value in an ML-like style: the result must be a valid OCaml expression. Only useful for journalisation. *) val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit (** Same spec than [pretty_code], but must take care of the precedence of the context in order to put parenthesis if required. See {!Type.par}. *) val pretty: Format.formatter -> t -> unit (** Pretty print each value in an user-friendly way. *) val varname: t -> string (** A good prefix name to use for an OCaml variable of this type. Only useful for journalisation. *) val mem_project: (Project_skeleton.t -> bool) -> t -> bool (** [mem_project f x] must return [true] iff there is a value [p] of type [Project.t] in [x] such that [f p] returns [true]. *) end (** All values associated to a datatype. *) module type S = sig include S_no_copy val copy: t -> t (** Deep copy: no possible sharing between [x] and [copy x]. *) end (* ********************************************************************** *) (** {2 Getters from a type value} *) (* ********************************************************************** *) val info: 'a Type.t -> 'a t val equal: 'a Type.t -> 'a -> 'a -> bool val compare: 'a Type.t -> 'a -> 'a -> int val hash: 'a Type.t -> 'a -> int val copy: 'a Type.t -> 'a -> 'a val internal_pretty_code: 'a Type.t -> Type.precedence -> Format.formatter -> 'a -> unit val pretty_code: 'a Type.t -> Format.formatter -> 'a -> unit val pretty: 'a Type.t -> Format.formatter -> 'a -> unit val varname: 'a Type.t -> 'a -> string val mem_project: 'a Type.t -> (Project_skeleton.t -> bool) -> 'a -> bool (* ********************************************************************** *) (** {2 Easy builders} *) (* ********************************************************************** *) val undefined: 'a -> 'b (** Must be used if you don't want to implement a required function. @plugin development guide *) val identity: 'a -> 'a (** Must be used if you want to implement a required function by [fun x -> x]. Only useful for implementing [rehash] and [copy]. @plugin development guide *) val from_compare: 'a -> 'a -> bool (** Must be used for [equal] in order to implement it by [compare x y = 0] (with your own [compare] function). *) val from_pretty_code: Format.formatter -> 'a -> unit (** Must be used for [pretty] in order to implement it by [pretty_code] provided by the datatype from your own [internal_pretty_code] function. *) val never_any_project: (Project_skeleton.t -> bool) -> 'a -> bool (** Must be used for [mem_project] if values of your type does never contain any project. @plugin development guide *) val pp_fail: Type.precedence -> Format.formatter -> 'a -> unit (** Must be used for [internal_pretty_code] if this pretty-printer must fail only when called. @plugin development guide *) (** Sub-signature of {!S}. @plugin development guide *) module type Undefined = sig val structural_descr: Structural_descr.t val equal: 'a -> 'a -> bool val compare: 'a -> 'a -> int val hash: 'a -> int val rehash: 'a -> 'a val copy: 'a -> 'a val internal_pretty_code: Type.precedence -> Format.formatter -> 'a -> unit val pretty: Format.formatter -> 'a -> unit val varname: 'a -> string val mem_project: (Project_skeleton.t -> bool) -> 'a -> bool end (** Each values in these modules are undefined. The usual way to use it is: [module X: Datatype.S = struct include Undefined type t = ... let reprs = ... let name = ... (* define only useful functions for this datatype *) end] *) module Undefined: Undefined (** Same as {!Undefined}, but the type is supposed to be marshalable by the standard OCaml way (in particular, no hash-consing or projects inside the type). @plugin development guide *) module Serializable_undefined: Undefined (* ********************************************************************** *) (** {2 Generic builders} *) (* ********************************************************************** *) (** Input signature of {!Make} and {!Make_with_collections}. Values to implement in order to get a datatype. Feel free to use easy builders (see above) for easy implementation. *) module type Make_input = sig type t (** Type for this datatype *) val name: string (** Unique name for this datatype. If the name is a valid ocaml module name, then it must really corresponds to the module name you are defining by applying the functor. Otherwise, put the name you want as long as it does not clash with any other datatype name. *) val rehash: t -> t (** How to rehashconsed values. Must be {!identity} if you do not use 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}. *) val structural_descr: Structural_descr.t val reprs: t list (** Must be non-empty.*) val equal: t -> t -> bool val compare: t -> t -> int val hash: t -> int val copy: t -> t val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit val pretty: Format.formatter -> t -> unit val varname: t -> string val mem_project: (Project_skeleton.t -> bool) -> t -> bool end (** Generic datatype builder. @plugin development guide *) module Make(X: Make_input): S with type t = X.t (** Additional info for building [Set], [Map] and [Hashtbl]. *) module type Functor_info = sig val module_name: string (** Must be a valid OCaml module name corresponding to the module name you are defining by applying the functor. *) end (** A standard OCaml set signature extended with datatype operations. *) module type Set = sig include Set.S val ty: t Type.t val name: string val descr: t Descr.t val packed_descr: Structural_descr.pack val reprs: t list val hash: t -> int val internal_pretty_code: Type.precedence -> Format.formatter -> t -> unit val pretty_code: Format.formatter -> t -> unit val pretty: Format.formatter -> t -> unit val varname: t -> string val mem_project: (Project_skeleton.t -> bool) -> t -> bool val copy: t -> t end (** A standard OCaml map signature extended with datatype operations. *) module type Map = sig include Map.S module Key: S with type t = key (** Datatype for the keys of the map. *) module Make(Data: S) : S with type t = Data.t t (** Build a datatype of the map according to the datatype of values in the map. *) end (** Marshallable collectors with hashtbl-like interface. *) module type Hashtbl_with_descr = sig include Hashtbl_common_interface.S val structural_descr: Structural_descr.t -> Structural_descr.t end (** A standard OCaml hashtbl signature extended with datatype operations. *) module type Hashtbl = sig include Hashtbl_with_descr val make_type: 'a Type.t -> 'a t Type.t (** @since Fluorine-20130401 *) 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. *) module Make(Data: S) : S with type t = Data.t t (** Build a datatype of the hashtbl according to the datatype of values in the hashtbl. *) end (** A datatype for a type [t] extended with predefined set, map and hashtbl over [t]. *) module type S_with_collections = sig include S module Set: Set with type elt = t module Map: Map with type key = t module Hashtbl: Hashtbl with type key = t end (** Generic comparable datatype builder: functions [equal], [compare] and [hash] must not be {!undefined}. *) module Make_with_collections(X: Make_input): S_with_collections with type t = X.t (** Add sets, maps and hashtables modules to an existing datatype, provided the [equal], [compare] and [hash] functions are not {!undefined}. @since Oxygen-20120901 *) module With_collections(X: S)(Info: Functor_info): S_with_collections with type t = X.t (* ****************************************************************************) (** {2 Predefined datatype} *) (* ****************************************************************************) module Unit: S_with_collections with type t = unit val unit: unit Type.t (** @plugin development guide *) module Bool: S_with_collections with type t = bool val bool: bool Type.t (** @plugin development guide *) (** @plugin development guide *) module Int: S_with_collections with type t = int val int: int Type.t (** @plugin development guide *) module Int32: S_with_collections with type t = int32 val int32: int32 Type.t module Int64: S_with_collections with type t = int64 val int64: int64 Type.t module Nativeint: S_with_collections with type t = nativeint val nativeint: nativeint Type.t module Float: S_with_collections with type t = float val float: float Type.t module Char: S_with_collections with type t = char val char: char Type.t (** @plugin development guide *) (** @plugin development guide *) module String: S_with_collections with type t = string val string: string Type.t (** @plugin development guide *) module Formatter: S with type t = Format.formatter val formatter: Format.formatter Type.t module Big_int: S_with_collections with type t = Integer.t val big_int: Big_int.t Type.t (* ****************************************************************************) (** {2 Generic functors for polymorphic types} *) (* ****************************************************************************) (** Output signature of {!Polymorphic}. *) module type Polymorphic = sig include Type.Polymorphic module Make(T: S) : S with type t = T.t poly (** Create a datatype for a monomorphic instance of the polymorphic type. *) end (** Functor for polymorphic types with only 1 type variable. @plugin development guide *) module Polymorphic (P: sig include Type.Polymorphic_input val mk_equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val mk_compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val mk_hash: ('a -> int) -> 'a t -> int val map: ('a -> 'a) -> 'a t -> 'a t val mk_internal_pretty_code: (Type.precedence -> Format.formatter -> 'a -> unit) -> Type.precedence -> Format.formatter -> 'a t -> unit val mk_pretty: (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit val mk_varname: ('a -> string) -> 'a t -> string val mk_mem_project: ((Project_skeleton.t -> bool) -> 'a -> bool) -> (Project_skeleton.t -> bool) -> 'a t -> bool end) : Polymorphic with type 'a poly = 'a P.t (** Output signature of {!Polymorphic2}. *) module type Polymorphic2 = sig include Type.Polymorphic2 module Make(T1: S)(T2: S) : S with type t = (T1.t, T2.t) poly end (** Functor for polymorphic types with 2 type variables. @plugin development guide *) module Polymorphic2 (P: sig include Type.Polymorphic2_input val mk_equal: ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t -> bool val mk_compare: ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int val mk_hash: ('a -> int) -> ('b -> int) -> ('a, 'b) t -> int val map: ('a -> 'a) -> ('b -> 'b) -> ('a, 'b) t -> ('a, 'b) t val mk_internal_pretty_code: (Type.precedence -> Format.formatter -> 'a -> unit) -> (Type.precedence -> Format.formatter -> 'b -> unit) -> Type.precedence -> Format.formatter -> ('a, 'b) t -> unit val mk_pretty: (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> Format.formatter -> ('a, 'b) t -> unit val mk_varname: ('a -> string) -> ('b -> string) -> ('a, 'b) t -> string val mk_mem_project: ((Project_skeleton.t -> bool) -> 'a -> bool) -> ((Project_skeleton.t -> bool) -> 'b -> bool) -> (Project_skeleton.t -> bool) -> ('a, 'b) t -> bool end) : Polymorphic2 with type ('a, 'b) poly = ('a, 'b) P.t (** Output signature of {!Polymorphic3}. @since Oxygen-20120901 *) module type Polymorphic3 = sig include Type.Polymorphic3 module Make(T1:S)(T2:S)(T3:S) : S with type t = (T1.t, T2.t, T3.t) poly end (** Functor for polymorphic types with 3 type variables. @since Oxygen-20120901 *) module Polymorphic3 (P: sig include Type.Polymorphic3_input val mk_equal: ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('c -> 'c -> bool) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> bool val mk_compare: ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('c -> 'c -> int) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> int val mk_hash: ('a -> int) -> ('b -> int) -> ('c -> int) -> ('a, 'b, 'c) t -> int val map: ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t val mk_internal_pretty_code: (Type.precedence -> Format.formatter -> 'a -> unit) -> (Type.precedence -> Format.formatter -> 'b -> unit) -> (Type.precedence -> Format.formatter -> 'c -> unit) -> Type.precedence -> Format.formatter -> ('a, 'b, 'c) t -> unit val mk_pretty: (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> (Format.formatter -> 'c -> unit) -> Format.formatter -> ('a, 'b, 'c) t -> unit val mk_varname: ('a -> string) -> ('b -> string) -> ('c -> string) -> ('a, 'b, 'c) t -> string val mk_mem_project: ((Project_skeleton.t -> bool) -> 'a -> bool) -> ((Project_skeleton.t -> bool) -> 'b -> bool) -> ((Project_skeleton.t -> bool) -> 'c -> bool) -> (Project_skeleton.t -> bool) -> ('a, 'b, 'c) t -> bool end) : Polymorphic3 with type ('a, 'b, 'c) poly = ('a, 'b, 'c) P.t (** Output signature of {!Polymorphic4}. @since Oxygen-20120901 *) module type Polymorphic4 = sig include Type.Polymorphic4 module Make(T1:S)(T2:S)(T3:S)(T4:S) : S with type t = (T1.t, T2.t, T3.t, T4.t) poly end (** Functor for polymorphic types with 4 type variables. @since Oxygen-20120901 *) module Polymorphic4 (P: sig include Type.Polymorphic4_input val mk_equal: ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('c -> 'c -> bool) -> ('d -> 'd -> bool) -> ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t -> bool val mk_compare: ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('c -> 'c -> int) -> ('d -> 'd -> int) -> ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t -> int val mk_hash: ('a -> int) -> ('b -> int) -> ('c -> int) -> ('d -> int) -> ('a, 'b, 'c, 'd) t -> int val map: ('a -> 'a) -> ('b -> 'b) -> ('c -> 'c) -> ('d -> 'd) -> ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t val mk_internal_pretty_code: (Type.precedence -> Format.formatter -> 'a -> unit) -> (Type.precedence -> Format.formatter -> 'b -> unit) -> (Type.precedence -> Format.formatter -> 'c -> unit) -> (Type.precedence -> Format.formatter -> 'd -> unit) -> Type.precedence -> Format.formatter -> ('a, 'b, 'c, 'd) t -> unit val mk_pretty: (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> (Format.formatter -> 'c -> unit) -> (Format.formatter -> 'd -> unit) -> Format.formatter -> ('a, 'b, 'c, 'd) t -> unit val mk_varname: ('a -> string) -> ('b -> string) -> ('c -> string) -> ('d -> string) -> ('a, 'b, 'c, 'd) t -> string val mk_mem_project: ((Project_skeleton.t -> bool) -> 'a -> bool) -> ((Project_skeleton.t -> bool) -> 'b -> bool) -> ((Project_skeleton.t -> bool) -> 'c -> bool) -> ((Project_skeleton.t -> bool) -> 'd -> bool) -> (Project_skeleton.t -> bool) -> ('a, 'b, 'c, 'd) t -> bool end) : Polymorphic4 with type ('a, 'b, 'c, 'd) poly = ('a, 'b, 'c, 'd) P.t (* ****************************************************************************) (** {2 Predefined functors for polymorphic types} *) (* ****************************************************************************) module Poly_pair: Polymorphic2 with type ('a, 'b) poly = 'a * 'b (** @plugin development guide *) module Pair(T1: S)(T2: S): S with type t = T1.t * T2.t module Pair_with_collections(T1: S)(T2: S)(Info: Functor_info): S_with_collections with type t = T1.t * T2.t val pair: 'a Type.t -> 'b Type.t -> ('a * 'b) Type.t module Poly_ref: Polymorphic with type 'a poly = 'a ref (** @plugin development guide *) module Ref(T: S) : S with type t = T.t ref val t_ref: 'a Type.t -> 'a ref Type.t 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 (** @plugin development guide *) module List(T: S) : S with type t = T.t list module List_with_collections(T:S)(Info:Functor_info): S_with_collections with type t = T.t list (** @since Fluorine-20130401 *) val list: 'a Type.t -> 'a list Type.t (** @plugin development guide *) module Poly_queue: Polymorphic with type 'a poly = 'a Queue.t val queue: 'a Type.t -> 'a Queue.t Type.t module Queue(T: S) : S with type t = T.t Queue.t module Triple(T1: S)(T2: S)(T3: S): S with type t = T1.t * T2.t * T3.t val triple: 'a Type.t -> 'b Type.t -> 'c Type.t -> ('a * 'b * 'c) Type.t (** @since Fluorine-20130401 *) 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 val quadruple: 'a Type.t -> 'b Type.t -> 'c Type.t -> 'd Type.t -> ('a * 'b * 'c * 'd) Type.t (** @since Fluorine-20130401 *) (** @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 (** @plugin development guide *) module Function (T1: sig include S val label: (string * (unit -> t) option) option end) (T2: S) : S with type t = T1.t -> T2.t val func: ?label:string * (unit -> 'a) option -> 'a Type.t -> 'b Type.t -> ('a -> 'b) Type.t (** @plugin development guide *) val optlabel_func: string -> (unit -> 'a) -> 'a Type.t -> 'b Type.t -> ('a -> 'b) Type.t (** [optlabel_func lab dft ty1 ty2] is equivalent to [func ~label:(lab, Some dft) ty1 ty2] *) val func2: ?label1:string * (unit -> 'a) option -> 'a Type.t -> ?label2:string * (unit -> 'b) option -> 'b Type.t -> 'c Type.t -> ('a -> 'b -> 'c) Type.t (** @plugin development guide *) val func3: ?label1:string * (unit -> 'a) option -> 'a Type.t -> ?label2:string * (unit -> 'b) option -> 'b Type.t -> ?label3:string * (unit -> 'c) option -> 'c Type.t -> 'd Type.t -> ('a -> 'b -> 'c -> 'd) Type.t (** @plugin development guide *) val func4: ?label1:string * (unit -> 'a) option -> 'a Type.t -> ?label2:string * (unit -> 'b) option -> 'b Type.t -> ?label3:string * (unit -> 'c) option -> 'c Type.t -> ?label4:string * (unit -> 'd) option -> 'd Type.t -> 'e Type.t -> ('a -> 'b -> 'c -> 'd -> 'e) Type.t 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) : Map with type 'a t = 'a M.t and type key = M.key and module Key = Key module Hashtbl (H: Hashtbl_with_descr)(Key: S with type t = H.key)(Info : Functor_info): Hashtbl with type 'a t = 'a H.t and type key = H.key and module Key = Key module type Sub_caml_weak_hashtbl = sig type data type t val create: int -> t val add: t -> data -> unit end module Caml_weak_hashtbl(D: S): sig include Weak.S with type t = Weak.Make(D).t and type data = D.t module Datatype: S with type t = t end module Weak(W: Sub_caml_weak_hashtbl)(D: S with type t = W.data) : S with type t = W.t (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������frama-c-Fluorine-20130601/src/project/��������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�016232� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/project/state.mli�����������������������������������������������������0000644�0001750�0001750�00000015653�12155630226�020071� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** A state is a project-compliant mutable value. @since Carbon-20101201 @plugin development guide *) open Project_skeleton (* ************************************************************************** *) (** {2 Type declarations} *) (* ************************************************************************** *) include Datatype.S_with_collections (** Operations on the local state required for registering a new state via {!State_builder.Register}. The local state is the mutable value which you would like to be project-compliant. *) module type Local = sig type t (** Type of the state to register. *) 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). *) 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). *) val get: unit -> t (** How to access to the current state. Be aware of invariants 3 and 4 below. *) val set: t -> unit (** How to change the current state. Be aware of invariants 3 and 4 below. *) (** The four following invariants must hold. {ol {- [create ()] returns a fresh value} {- forall [(p:t)] [copy p] returns a fresh value} {- forall [(p:t)], [create () = (clear p; set p; get ())]} {- forall [(p1:t),(p2:t)] such that [p1 != p2], [(set p1; get ()) != s2]} } *) val clear_some_projects: (Project_skeleton.t -> bool) -> t -> bool (** [clear_if_project f x] must clear any value [v] of type project of [x] such that [f v] is [true]. Of course, if the type [t] does not contain any object of type [project], this function should do nothing and safely returns [fun _ -> false]. @return [true] iff at least one element of [x] has been cleared. @since Boron-20100401 *) end (* ************************************************************************** *) (** {2 Getters and setters} *) (* ************************************************************************** *) val get_name: t -> string (** Name of a state. @since Carbon-20101201 *) val set_name: t -> string -> unit (** Set the name of the given state. @since Carbon-20101201 *) val get_unique_name: t -> string (** 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 dummy: t (** A dummy state. @since Carbon-20101201 @plugin development guide *) val dummy_unique_name: string val is_dummy: t -> bool (** @return true if the given state is {!dummy}. @since Carbon-20101201 *) exception Unknown val get: string -> t (** @return the state corresponding to the given unique name. @raise Unknown if there is no such state. @since Carbon-20101201 *) 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 Internals} All this stuff should not be used outside of the Project library.*) (* ************************************************************************** *) (** @since Carbon-20101201 *) type state_on_disk = { on_disk_value: Obj.t; on_disk_computed: bool; on_disk_saved: bool; on_disk_digest: Digest.t } (** @since Carbon-20101201 *) type private_ops = private { mutable descr: Structural_descr.pack; create: project -> unit; remove: project -> unit; mutable clear: project -> unit; mutable clear_some_projects: (project -> bool) -> project -> bool; 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 (** @raise Incompatible_datatype if [state_on_disk] is not compatible with the datatype expected by Frama-C's state *) } exception Incompatible_datatype of string val dummy_state_on_disk: state_on_disk val private_ops: t -> private_ops (** @since Carbon-20101201 *) (* ************************************************************************** *) (** {3 State generators} *) (* ************************************************************************** *) val create: descr:Structural_descr.pack -> create:(project -> unit) -> remove:(project -> unit) -> clear:(project -> unit) -> clear_some_projects:((project -> bool) -> project -> bool) -> 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) -> unique_name:string -> name:string -> t (** @since Carbon-20101201 @modify Nitrogen-20111001 add the [on_update] argument *) val delete: t -> unit (** @since Carbon-20101201 *) (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/project/project_skeleton.ml�������������������������������������������0000644�0001750�0001750�00000006022�12155630226�022140� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ************************************************************************** *) (** {2 Logging machinery} *) (* ************************************************************************** *) module Output = struct include Log.Register (struct let channel = Log.kernel_channel_name let label = Log.kernel_label_name let verbose_atleast n = !Cmdline.kernel_verbose_atleast_ref n let debug_atleast n = !Cmdline.kernel_debug_atleast_ref n end) let dkey = register_category "project" end (* ************************************************************************** *) (** {2 Type declaration} *) (* ************************************************************************** *) type t = { pid: int; mutable name: string; mutable unique_name: string } type project = t (* ************************************************************************** *) (** {2 Constructor} *) (* ************************************************************************** *) let dummy = { pid = 0; name = ""; unique_name = ""} module Make_setter(X: sig val mem: string -> bool end) = struct let make_unique_name s = snd (Extlib.make_unique_name X.mem ~sep:" " s) let make = let pid = ref 0 in fun name -> incr pid; { pid = !pid; name = name; unique_name = make_unique_name name } let set_name p s = p.unique_name <- make_unique_name s; p.name <- s end (* Local Variables: compile-command: "make -C ../.." End: *) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/project/state_selection.mli�������������������������������������������0000644�0001750�0001750�00000015762�12155630226�022137� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** A state selection is a set of states with operations for easy handling of state dependencies. @since Carbon-20101201 @plugin development guide *) (* ************************************************************************** *) (** {2 Type declarations} *) (* ************************************************************************** *) type t (** Type of a state selection. @since Carbon-20101201 *) val ty: t Type.t (** Type value representing {!t}. @since Carbon-20101201 *) (* ************************************************************************** *) (** {2 Generic Builders} *) (* ************************************************************************** *) val empty: t (** The empty selection. @since Carbon-20101201 *) val full: t (** The selection containing all the states. @since Carbon-20101201 *) val singleton: State.t -> t (** The selection containing only the given state. @since Carbon-20101201 *) val of_list: State.t list -> t (** The selection containing only the given list of states. @since Carbon-20101201 *) (* ************************************************************************** *) (** {2 Generic Getters} *) (* ************************************************************************** *) val is_empty: t -> bool (** @return [true] iff the selection is empty. @since Carbon-20101201 *) val is_full: t -> bool (** @return [true] iff the selection contains all the states. @since Carbon-20101201 *) val mem: t -> State.t -> bool (* ************************************************************************** *) (** {2 Specific selections} *) (* ************************************************************************** *) (** Operations over selections which depend on a State Dependency Graph implementation. @since Carbon-20101201 *) module type S = sig (* ************************************************************************ *) (** {2 Builders from dependencies} *) (* ************************************************************************ *) val with_dependencies: State.t -> t (** The selection containing the given state and all its dependencies. @since Carbon-20101201 @plugin development guide *) val only_dependencies: State.t -> t (** The selection containing all the dependencies of the given state (but not this state itself). @since Carbon-20101201 *) val with_codependencies: State.t -> t (** The selection containing the given state and all its co-dependencies. @since Carbon-20101201 *) val only_codependencies: State.t -> t (** The selection containing all the co-dependencies of the given state (but not this state itself). @since Carbon-20101201 *) (* ************************************************************************ *) (** {2 Builders by operations over sets} *) (* ************************************************************************ *) val union: t -> t -> t (** Union of two selections. @since Carbon-20101201 *) val list_union: t list -> t (** Union of an arbitrary number of selection (0 gives an empty selection) @since Oxygen-20120901 *) val list_state_union: ?deps:(State.t -> t) -> State.t list -> t (** Union of an arbitrary number of states (0 gives an empty selection). Optional [deps] arguments indicates how to handle dependencies. Defaults to {! State_selection.singleton} @since Oxygen-20120901 *) val diff: t -> t -> t (** Difference between two selections. @since Carbon-20101201 *) (* ************************************************************************ *) (** {2 Specific Getters} *) (* ************************************************************************ *) val cardinal: t -> int (** Size of a selection. @since Carbon-20101201 *) val to_list: t -> State.t list (** Convert a selection into a list of states. @since Fluorine-20130401 *) val pretty: Format.formatter -> t -> unit (** Display a selection iff kernel debug mode is on. @since Carbon-20101201 *) (** {3 Iterators} *) val iter_succ: (State.t -> unit) -> t -> State.t -> unit (** Iterate over the successor of a state in a selection. The order is unspecified. @since Carbon-20101201 *) val fold_succ: (State.t -> 'a -> 'a) -> t -> State.t -> 'a -> 'a (** Iterate over the successor of a state in a selection. The order is unspecified. @since Carbon-20101201 *) val iter: (State.t -> unit) -> t -> unit (** Iterate over a selection. The order is unspecified. @since Carbon-20101201 *) val fold: (State.t -> 'a -> 'a) -> t -> 'a -> 'a (** Fold over a selection. The order is unspecified. @since Carbon-20101201 *) val iter_in_order: (State.t -> unit) -> t -> unit (** Iterate over a selection in a topological ordering compliant with the State Dependency Graph. Less efficient that {!iter}. @since Carbon-20101201 *) val fold_in_order: (State.t -> 'a -> 'a) -> t -> 'a -> 'a (** Fold over a selection in a topological ordering compliant with the State Dependency Graph. Less efficient that {!iter}. @since Carbon-20101201 *) end (** Operations over selections which depend on {!State_dependency_graph.graph}. @since Carbon-20101201 @deprecated Oxygen-20120901 directly use equivalent top-level function instead. *) module Static: S include S (* Local Variables: compile-command: "make -C ../.." End: *) ��������������frama-c-Fluorine-20130601/src/project/state_builder.ml����������������������������������������������0000644�0001750�0001750�00000056307�12155630226�021427� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Project_skeleton.Output (* ************************************************************************* *) (** {3 Signatures} *) (* ************************************************************************* *) module type Info = sig val name: string val dependencies : State.t list end module type Info_with_size = sig include Info val size: int end module type S = sig val self: State.t val name: string 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 (* ************************************************************************* *) (** {3 Proxies} *) (* ************************************************************************* *) module Proxy = struct type kind = Backward | Forward | Both type t = { state: State.t; kind: kind } let get p = p.state let extend_state states k s = let add_deps () = State_dependency_graph.add_dependencies ~from:s states in let add_codeps () = State_dependency_graph.add_codependencies ~onto:s states in match k with | Backward -> add_deps () | Forward -> add_codeps () | Both -> add_deps (); add_codeps () let extend states p = extend_state states p.kind p.state let do_nothing _ = () let do_nothing_2 _ _ = () open State let create name kind 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 ~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 in State_dependency_graph.add_state s []; extend_state states kind s; { state = s; kind = kind } end (* ************************************************************************* *) (** {3 Register} *) (* ************************************************************************* *) module States = struct module S = Type.String_tbl(struct type 'a t = Project.t -> 'a * bool end) let states = S.create 997 let add k ty v = S.add states k ty v let find ?(prj=Project.current ()) k ty = S.find states k ty prj let iter ?(prj=Project.current ()) f = S.iter (fun name ty get -> let s, b = get prj in f name ty s b) states let fold ?(prj=Project.current ()) f acc = S.fold (fun name ty get acc -> let s, b = get prj in f name ty s b acc) states acc end module Register (D: Datatype.S) (Local_state: State.Local with type t = D.t) (Info: sig include Info val unique_name: string end) : S with module Datatype = D = struct let internal_name = ref "" let debug ~level op_name p = debug ~dkey ~level "%s %S (project %s)" op_name !internal_name (Project.get_unique_name p) module Datatype = D module Tbl = Hashtbl.Make(Project) include Info type t = { mutable state: Local_state.t; mutable computed: bool } (* Project --> plugin state. *) let tbl : t Tbl.t = Tbl.create 7 let find p = Tbl.find tbl p let mem p = Tbl.mem tbl p let add p s = Tbl.replace tbl p { state = s; computed = false } let remove p = assert (mem p); Tbl.remove tbl p let commit p = if Project.is_current p then try 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) 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:8 "updating" p; Update_hook.apply s; Local_state.set s end let update p = update_with ~force:false p (find p).state let change ~force p x = let v = find p in v.state <- x.state; v.computed <- x.computed; update_with ~force p v.state let clean () = (* Format.printf "cleaning %s@." !internal_name;*) Local_state.set (Local_state.create ()); Tbl.clear tbl let create = let first = ref true in fun p -> assert (not (mem p)); (* For efficiency purpose, do not create the initial project twice: directly get it *) let mk () = if !first then begin first := false; Local_state.get () end else begin debug ~level:4 "creating" p; let s = Local_state.create () in update_with ~force:false p s; s end in let s = mk () in add p s let clear p = debug ~level:4 "clearing" p; let v = find p in Local_state.clear v.state; v.computed <- false; update_with ~force:false p v.state let clear_some_projects f p = assert (not (f p)); let has_cleared = Local_state.clear_some_projects f (find p).state in if has_cleared then debug ~level:4 "erasing dangling project pointers" p; has_cleared let copy src dst = debug ~level:4 ("copying to " ^ Project.get_unique_name dst) src; let v = find src in change ~force:false dst { v with state = Datatype.copy v.state } (* ******* TOUCH THE FOLLOWING AT YOUR OWN RISK: DANGEROUS CODE ******** *) let must_save = ref (not (Descr.is_unmarshable Datatype.descr)) let marshal : (Datatype.t -> Obj.t) ref = ref Obj.repr let unmarshal : (Obj.t -> Datatype.t) ref = ref Obj.obj let howto_marshal (go_in:Datatype.t -> 'a) (go_out:'a -> Datatype.t) = must_save := true; marshal := (fun x -> Obj.repr (go_in x)); unmarshal := fun x -> go_out (Obj.obj x) let serialize p = assert Cmdline.use_obj; commit p; let v = find p in let obj = if !must_save then begin debug ~level:4 "serializing" p; !marshal v.state end else Obj.repr () in { State.on_disk_value = obj; on_disk_computed = v.computed; on_disk_saved = !must_save; on_disk_digest = Type.digest Datatype.ty } let unserialize p new_s = assert Cmdline.use_obj; if Type.digest Datatype.ty = new_s.State.on_disk_digest then begin let s, computed = if !must_save && new_s.State.on_disk_saved then begin debug ~level:4 "unserializing" p; !unmarshal new_s.State.on_disk_value, new_s.State.on_disk_computed end 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 begin clear p; raise (State.Incompatible_datatype !internal_name) end (* ********************************************************************* *) let mark_as_computed ?(project=(Project.current ())) () = (find project).computed <- true let is_computed ?(project=(Project.current ())) () = (find project).computed let self = let descr = if !must_save then Descr.pack Datatype.descr else Structural_descr.p_unit in State.create (* we will marshal the value [()] if the state is unmarshable *) ~descr ~create ~remove ~clear ~clear_some_projects ~copy ~commit ~update ~on_update:(fun f -> Update_hook.extend (fun _ -> f ())) ~serialize ~unserialize ~clean ~unique_name ~name:Info.name let name = State.get_name self let () = internal_name := State.get_unique_name self; (* register this state in the static graph and in projects *) State_dependency_graph.add_state self dependencies; States.add Info.name D.ty (fun p -> let s = Tbl.find tbl p in s.state, s.computed); Project.iter_on_projects create end (* ************************************************************************* *) (** {3 References} *) (* ************************************************************************* *) module type Ref = sig include S type data val set: data -> unit val get: unit -> data val clear: unit -> unit end module Ref (Data: Datatype.S) (Info: sig include Info val default: unit -> Data.t end) = struct type data = Data.t let create () = ref (Info.default ()) let state = ref (create ()) include Register (Datatype.Ref(Data)) (struct type t = data ref let create = create let clear tbl = tbl := Info.default () let get () = !state let set x = state := x let clear_some_projects f x = if Data.mem_project f !x then begin clear x; true end else false end) (struct include Info let unique_name = name end) let set v = !state := v let get () = !(!state) let clear () = !state := Info.default () end module type Option_ref = sig include Ref val memo: ?change:(data -> data) -> (unit -> data) -> data val map: (data -> data) -> data option val may: (data -> unit) -> unit val get_option : unit -> data option end module Option_ref(Data:Datatype.S)(Info: Info) = struct type data = Data.t let create () = ref None let state = ref (create ()) module D = Datatype.Ref(Datatype.Option(Data)) include Register (D) (struct type t = data option ref let create = create let clear tbl = tbl := None let get () = !state let set x = state := x let clear_some_projects f x = if D.mem_project f x then begin clear x; true end else false end) (struct include Info let unique_name = name end) let set v = !state := Some v let get () = match !(!state) with None -> raise Not_found | Some v -> v let get_option () = !(!state) let clear () = !state := None let memo ?change f = try let old = get () in Extlib.may_map ~dft:old (fun f -> let v = f old in set v; v) change with Not_found -> let data = f () in set data; data let map f = Extlib.opt_map f !(!state) let may f = Extlib.may f !(!state) end 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 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 module Int_ref(Info: sig include Info val default: unit -> int end) = Ref(Datatype.Int)(Info) module Zero_ref(Info: Info ) = Int_ref(struct include Info let default () = 0 end) module Bool_ref(Info: sig include Info val default: unit -> bool end) = Ref(Datatype.Bool)(struct include Info let default = Info.default end) module False_ref(Info:Info) = Bool_ref(struct include Info let default () = false end) module True_ref(Info:Info) = Bool_ref(struct include Info let default () = true end) module Float_ref(Info: sig include Info val default: unit -> float end) = Ref(Datatype.Float)(Info) (* ************************************************************************* *) (** {3 References on a set} *) (* ************************************************************************* *) module type Set_ref = sig include Ref type elt val add: elt -> unit val is_empty: unit -> bool val mem: elt -> bool val fold: (elt -> 'a -> 'a) -> 'a -> 'a val iter: (elt -> unit) -> unit end module Set_ref(S: Datatype.Set)(Info: Info) = struct include Ref(S)(struct include Info let default () = S.empty end) type elt = S.elt let apply f = f (get ()) let is_empty () = apply S.is_empty let add x = set (apply (S.add x)) let mem x = apply (S.mem x) let fold f = apply (S.fold f) let iter f = apply (S.iter f) end (* ************************************************************************* *) (** {3 Hashtbl} *) (* ************************************************************************* *) module type Hashtbl = sig include S type key type data val replace: key -> data -> unit val add: key -> data -> unit val clear: unit -> unit val length: unit -> int val iter: (key -> data -> unit) -> unit val iter_sorted: ?cmp:(key -> key -> int) -> (key -> data -> unit) -> unit val fold: (key -> data -> 'a -> 'a) -> 'a -> 'a val fold_sorted: ?cmp:(key -> key -> int) -> (key -> data -> 'a -> 'a) -> 'a -> 'a val memo: ?change:(data -> data) -> (key -> data) -> key -> data val find: key -> data val find_all: key -> data list val mem: key -> bool val remove: key -> unit end module Initial_caml_hashtbl = Hashtbl module Hashtbl (H: Datatype.Hashtbl) (Data: Datatype.S) (Info: Info_with_size) = struct type key = H.key type data = Data.t let create () = H.create Info.size let state = ref (create ()) module D = H.Make(Data) include Register (D) (struct type t = data H.t let create = create let clear = H.clear let get () = !state let set x = state := x let clear_some_projects f h = (* Format.printf "%S: %S %S@." Info.name H.Key.name Data.name;*) let x = if D.mem_project == Datatype.never_any_project then 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 <> [] in (* Format.printf "DONE@.";*) x end) (struct include Info let unique_name = name end) let clear () = H.clear !state let length () = H.length !state let replace key v = H.replace !state key v let add key v = H.add !state key v let find key = H.find !state key let find_all key = H.find_all !state key let mem key = H.mem !state key let remove key = H.remove !state key let iter f = H.iter f !state let iter_sorted ?cmp f = H.iter_sorted ?cmp f !state let fold f acc = H.fold f !state acc let fold_sorted ?cmp f acc = H.fold_sorted ?cmp f !state acc let memo ?change f key = try let old = find key in Extlib.may_map ~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; data end module Int_hashtbl = Hashtbl(Datatype.Int.Hashtbl) (* ************************************************************************* *) (** {3 Weak Hashtbl} *) (* ************************************************************************* *) module type Weak_hashtbl = sig include S type data val merge: data -> data val add: data -> unit val clear: unit -> unit val count: unit -> int val iter: (data -> unit) -> unit val fold: (data -> 'a -> 'a) -> 'a -> 'a val find: data -> data val find_all: data -> data list val mem: data -> bool val remove: data -> unit end module Weak_hashtbl (W: Weak.S) (Data: Datatype.S with type t = W.data) (Info: Info_with_size) = struct type data = W.data let create () = W.create Info.size let state = ref (create ()) include Register (Datatype.Weak(W)(Data)) (struct type t = W.t let create = create let clear = W.clear let get () = !state let set x = state := x let clear_some_projects f h = if Data.mem_project == Datatype.never_any_project then 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 <> [] end) (struct include Info let unique_name = name end) let merge k = W.merge !state k let add k = W.add !state k let clear () = W.clear !state let count () = W.count !state let iter f = W.iter f !state let fold f acc = W.fold f !state acc let find k = W.find !state k let find_all k = W.find_all !state k let mem k = W.mem !state k let remove k = W.remove !state k end module Caml_weak_hashtbl(Data: Datatype.S) = Weak_hashtbl(Weak.Make(Data))(Data) module Hashconsing_tbl (Data: sig include Datatype.S val equal_internal: t -> t -> bool val hash_internal: t -> int val initial_values: t list end) (Info: Info_with_size) = struct (* OCaml module typing requires to name this module. Too bad :-( *) module W = struct include Weak.Make (struct 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 let create size = let h = create size in add_initial_values h; h let clear t = clear t; add_initial_values t (* 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 *) end include Weak_hashtbl(W)(Data)(Info) end (* ************************************************************************* *) (** {3 Counters} *) (* ************************************************************************* *) module type Counter = sig val next : unit -> int val get: unit -> int val self: State.t end (* Create a fresh, shared reference among projects. The projectification is only required for correct marshalling. *) module SharedCounter(Info : sig val name : string end) = struct let cpt = ref 0 module Cpt = Register (struct include Datatype.Int 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 end) (struct let name = Info.name let unique_name = Info.name let dependencies = [] end) let next () = incr cpt ; !cpt let get () = !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 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 = [] end) let next () = incr !cpt ; !(!cpt) let get () = !(!cpt) let self = Cpt.self end (* ************************************************************************* *) (** {3 Queue} *) (* ************************************************************************* *) module type Queue = sig type elt val add: elt -> unit val iter: (elt -> unit) -> unit val is_empty: unit -> bool end module Queue(Data: Datatype.S)(Info: Info) = struct type elt = Data.t let state = ref (Queue.create ()) include Register (Datatype.Queue(Data)) (struct type t = elt Queue.t let create = Queue.create let clear = Queue.clear let get () = !state let set x = state := x let clear_some_projects f q = if Data.mem_project == Datatype.never_any_project then 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 end) (struct include Info let unique_name = name end) let add x = Queue.add x !state let iter f = Queue.iter f !state let is_empty () = Queue.is_empty !state end (* ************************************************************************* *) (** {3 Apply Once} *) (* ************************************************************************* *) let apply_once name dep f = let module First = True_ref (struct let dependencies = dep let name = name end) in (fun () -> if First.get () then begin First.set false; try f (); if First.get () then First.set false (* assert (verify (First.get () = false) "%s is supposed to be applied once, but resets itself its status" name) *) with exn -> First.set true; raise exn end), First.self (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/project/project_skeleton.mli������������������������������������������0000644�0001750�0001750�00000006015�12155630226�022313� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** This module should not be used outside of the Project library. @since Carbon-20101201 *) (* ************************************************************************** *) (** {2 Logging machinery} *) (* ************************************************************************** *) (** @since Carbon-20101201 *) module Output : sig include Log.Messages val dkey: category (** @since Oxygen-20121001+dev *) end (* ************************************************************************** *) (** {2 Type declaration} *) (* ************************************************************************** *) type t = private { pid: int; mutable name: string; mutable unique_name: string } (** @since Carbon-20101201 @plugin development guide *) type project = t (** @since Carbon-20101201 *) (* ************************************************************************** *) (** {2 Constructor} *) (* ************************************************************************** *) val dummy: t (** @since Carbon-20101201 *) (** @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 *) val set_name: t -> string -> unit (** @since Carbon-20101201 *) end (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/project/state_selection.ml��������������������������������������������0000644�0001750�0001750�00000017273�12155630226�021765� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module Selection = Graph.Persistent.Digraph.ConcreteBidirectional(State) type state_selection = | Full | Subset of Selection.t let empty = Subset Selection.empty let full = Full let singleton s = Subset (Selection.add_vertex Selection.empty s) let of_list l = Subset (List.fold_left Selection.add_vertex Selection.empty l) 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 include Datatype.Undefined type t = state_selection let name = "State_selection" let reprs = [ full; empty; singleton State.dummy ] let internal_pretty_code p_caller fmt = function | Full -> Format.fprintf fmt "@[State_selection.full@]" | Subset sel -> 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 | 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 end) module type S = sig val with_dependencies: State.t -> t val only_dependencies: State.t -> t val with_codependencies: State.t -> t val only_codependencies: State.t -> t val union: t -> t -> t val list_union: t list -> t val list_state_union: ?deps:(State.t -> t) -> State.t list -> t val diff: t -> t -> t val cardinal: t -> int val to_list: t -> State.t list val pretty: Format.formatter -> t -> unit val iter_succ: (State.t -> unit) -> t -> State.t -> unit val fold_succ: (State.t -> 'a -> 'a) -> t -> State.t -> 'a -> 'a val iter: (State.t -> unit) -> t -> unit val fold: (State.t -> 'a -> 'a) -> t -> 'a -> 'a val iter_in_order: (State.t -> unit) -> t -> unit val fold_in_order: (State.t -> 'a -> 'a) -> t -> 'a -> 'a end module Static = struct 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') State_dependency_graph.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 let with_dependencies s = Subset (transitive_closure State_dependency_graph.G.fold_succ s) let with_codependencies s = Subset (transitive_closure State_dependency_graph.G.fold_pred s) let only_dependencies s = let g = transitive_closure State_dependency_graph.G.fold_succ s in Subset (Selection.remove_vertex g s) let only_codependencies s = let g = transitive_closure State_dependency_graph.G.fold_pred s in Subset (Selection.remove_vertex g s) let diff sel1 sel2 = match sel1, sel2 with | _, Full -> Subset Selection.empty | Full, sel2 when is_empty sel2 -> Full | Full, Subset sel2 -> let selection = State_dependency_graph.G.fold_vertex (fun v acc -> if Selection.mem_vertex sel2 v then acc else Selection.add_vertex acc v) State_dependency_graph.graph Selection.empty in let sel = State_dependency_graph.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) State_dependency_graph.graph selection in Subset sel | Subset sel1, Subset sel2 -> Subset (Selection.fold_vertex (fun v acc -> Selection.remove_vertex acc v) sel2 sel1) let union = let module O = Graph.Oper.P(Selection) in fun sel1 sel2 -> match sel1, sel2 with | Full, _ | _, Full -> Full | Subset sel1, Subset sel2 -> Subset (O.union sel1 sel2) let list_union l = List.fold_left union (Subset Selection.empty) l let list_state_union ?(deps=singleton) l = List.fold_left (fun acc state -> union acc (deps state)) (Subset Selection.empty) l let cardinal = function | Full -> State_dependency_graph.G.nb_vertex State_dependency_graph.graph | Subset sel -> Selection.nb_vertex sel let iter_succ f sel v = match sel with | Full -> State_dependency_graph.G.iter_succ f State_dependency_graph.graph v | Subset sel -> Selection.iter_succ f sel v let fold_succ f sel v acc = match sel with | Full -> State_dependency_graph.G.fold_succ f State_dependency_graph.graph v acc | Subset sel -> Selection.fold_succ f sel v acc let iter f = function | Full -> State_dependency_graph.G.iter_vertex f State_dependency_graph.graph | Subset sel -> Selection.iter_vertex f sel let fold f s acc = match s with | Full -> State_dependency_graph.G.fold_vertex f State_dependency_graph.graph acc | Subset sel -> Selection.fold_vertex f sel acc let to_list s = fold (fun s acc -> s :: acc) s [] module TG = State_topological.Make(State_dependency_graph.G) module TS = State_topological.Make(Selection) let iter_in_order f = function | Full -> TG.iter f State_dependency_graph.graph | Subset sel -> TS.iter f sel let fold_in_order f s acc = match s with | Full -> TG.fold f State_dependency_graph.graph acc | Subset sel -> TS.fold f sel acc let pretty fmt sel = Format.fprintf fmt "contents of the selection:@\n"; let mem s = State_dependency_graph.G.mem_vertex State_dependency_graph.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 ^ "\")")) sel; Format.pp_print_flush fmt () end include Static (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/project/project.ml����������������������������������������������������0000644�0001750�0001750�00000065346�12155630226�020252� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* ************************************************************************** *) (** {2 Project skeleton} *) (* ************************************************************************** *) open Project_skeleton open Output (* re-exporting record fields *) type project = t = private { pid : int; mutable name : string; mutable unique_name : string } let rehash_ref = ref (fun _ -> assert false) module D = Datatype.Make (struct 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 |] let reprs = [ dummy ] let equal = (==) let compare p1 p2 = Datatype.Int.compare p1.pid p2.pid let hash p = p.pid 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 pretty fmt p = Format.fprintf fmt "project %S" p.unique_name let varname p = "p_" ^ p.name let mem_project f x = f x end) include D module Project_tbl = Hashtbl.Make(D) (* ************************************************************************** *) (** {2 States operations} *) (* ************************************************************************** *) let current_selection = ref State_selection.empty let get_current_selection () = !current_selection module States_operations = struct module H = Hashtbl open State module Hashtbl = H let iter f x = current_selection := State_selection.full; State_dependency_graph.G.iter_vertex (fun s -> f s x) State_dependency_graph.graph let iter_on_selection ?(selection=State_selection.full) f x = current_selection := selection; State_selection.iter (fun s -> f s x) selection let fold_on_selection ?(selection=State_selection.full) f x = current_selection := selection; State_selection.fold (fun s -> f s x) selection let create = iter (fun s -> (private_ops s).create) let remove = iter (fun s -> (private_ops s).remove) let clean = iter (fun s -> (private_ops s).clean) let commit ?selection = iter_on_selection ?selection (fun s -> (private_ops s).commit) let update ?selection = iter_on_selection ?selection (fun s -> (private_ops s).update) let clear ?(selection=State_selection.full) p = 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 begin current_selection := selection; State_selection.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.union (State_selection.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 ~dkey ~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)) ()) end let copy ?selection src = iter_on_selection ?selection (fun s -> (private_ops s).copy src) let serialize ?selection p = fold_on_selection ?selection (fun s p acc -> (get_unique_name s, (private_ops s).serialize p) :: acc) p [] let unserialize ?selection dst loaded_states = let pp_err fmt n msg_sing msg_plural = if n > 0 then begin warning ~once:true fmt n (if n = 1 then "" else "s") (if n = 1 then msg_sing else msg_plural) end in let tbl = Hashtbl.create 97 in List.iter (fun (k, v) -> Hashtbl.add tbl k v) loaded_states; let invalid_on_disk = State.Hashtbl.create 7 in 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; (* do not remove if [State.Incompatible_datatype] occurs *) Hashtbl.remove tbl n with | Not_found -> assert false | State.Incompatible_datatype _ -> (* datatype of [s] on disk is incompatible with the one in RAM: as [dst] is a new project, [s] is already equal to its default value. However must clear the dependencies for consistency, but it is doable only when all states are loaded. *) State.Hashtbl.add invalid_on_disk s ()) with Not_found -> (* [s] is in RAM but not on disk: silently ignore it! 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). *) ()) (); (* warns for the saved states that cannot be loaded (either they are not in RAM or they are incompatible). *) let nb_ignored = Hashtbl.fold (fun _ s n -> if s.on_disk_saved then succ n else n) tbl 0 in pp_err "%d state%s in saved file ignored. \ %s this Frama-C configuration." nb_ignored "It is invalid in" "They are invalid in"; if debug_atleast 1 then Hashtbl.iter (fun k s -> if s.on_disk_saved then debug ~dkey "ignoring state %s" k) tbl; (* after loading, reset dependencies of incompatible states *) let to_be_cleared = State.Hashtbl.fold (fun s () -> State_selection.union (State_selection.only_dependencies s)) invalid_on_disk State_selection.empty in let nb_cleared = State_selection.cardinal to_be_cleared in if nb_cleared > 0 then begin pp_err "%d state%s in memory reset to their default value. \ %s this Frama_C configuration." nb_cleared "It is inconsistent in" "They are inconsistent in"; clear ~selection:to_be_cleared dst end end let guarded_feedback selection level fmt_msg = if verbose_atleast level then if State_selection.is_full selection then feedback ~level fmt_msg else let n = State_selection.cardinal selection in if n = 0 then 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)" in feedback ~level ~append:states fmt_msg; else Log.nullprintf fmt_msg let dft_sel () = State_selection.full module Q = Qstack.Make(struct type t = project let equal = equal end) let projects = Q.create () (* The stack of projects. *) let current () = Q.top projects let is_current p = equal p (current ()) let iter_on_projects f = Q.iter f projects let fold_on_projects f acc = Q.fold f acc projects let find_all name = Q.filter (fun p -> p.name = name) projects let from_unique_name uname = Q.find (fun p -> p.unique_name = uname) projects module Mem = struct let mem s = try ignore (from_unique_name s); true with Not_found -> false end module Setter = Make_setter(Mem) let unjournalized_set_name p s = feedback ~level:2 "renaming project %S to %S" p.unique_name s; Setter.set_name p s let set_name = Journal.register "Project.set_name" (Datatype.func2 ty Datatype.string Datatype.unit) unjournalized_set_name module Create_Hook = Hook.Build(struct type t = project end) let register_create_hook = Create_Hook.extend let force_create name = feedback ~level:2 "creating project %S" name; let p = Setter.make name in feedback ~level:3 "its unique name is %S" p.unique_name; Q.add_at_end p projects; States_operations.create p; Create_Hook.apply p; p let journalized_create = Journal.register "Project.create" (Datatype.func Datatype.string ty) force_create (* do not journalise the first call to [create] *) let create = let first = ref true in fun name -> let p = if !first then force_create name else journalized_create name in first := false; p let get_name p = p.name let get_unique_name p = p.unique_name exception NoProject = Q.Empty module Set_Current_Hook_User = Hook.Build (struct type t = project end) module Set_Current_Hook = Hook.Build(struct type t = project end) let register_after_set_current_hook ~user_only = if user_only then Set_Current_Hook_User.extend else Set_Current_Hook.extend let unjournalized_set_current = let apply_hook = ref false in fun on selection p -> if not (Q.mem p projects) then invalid_arg ("Project.set_current: " ^ p.unique_name ^ " does not exist"); let old = current () in States_operations.commit ~selection old; (try Q.move_at_top p projects with Invalid_argument _ -> assert false); let level = if on then 3 else 2 in guarded_feedback selection level "%S is now the current project" p.unique_name; assert (equal p (current ())); States_operations.update ~selection p; (* do not apply hook if an hook calls [set_current] *) if not !apply_hook then begin apply_hook := true; if not on then Set_Current_Hook_User.apply old; Set_Current_Hook.apply old; apply_hook := false end let journalized_set_current = let lbl = Datatype.optlabel_func in Journal.register "Project.set_current" (lbl "on" (fun () -> false) Datatype.bool (lbl "selection" dft_sel State_selection.ty (Datatype.func ty Datatype.unit))) unjournalized_set_current let set_current ?(on=false) ?(selection=State_selection.full) p = if not (equal p (current ())) then journalized_set_current on selection p let on ?selection p f x = let old_current = current () in let set p = set_current ~on:true ?selection p in let go () = set p; let r = f x in set old_current; r in if debug_atleast 1 then go () else begin try go () with e -> set old_current; raise e end (* [set_current] must never be called internally. *) module Hide_set_current = struct let set_current () = assert false end open Hide_set_current (* Silence warning on unused and unexported functions *) let () = if false then set_current () exception Cannot_remove of string module Before_remove = Hook.Build(struct type t = project end) let register_before_remove_hook = Before_remove.extend let unjournalized_remove project = feedback ~level:2 "removing project %S" project.unique_name; if Q.length projects = 1 then raise (Cannot_remove project.unique_name); Before_remove.apply project; States_operations.remove project; let old_current = current () in Q.remove project projects; if equal project old_current then begin (* we removed the current project. So there is a new current project and we have to update the local states according to it. *) let c = current () in States_operations.update c; Set_Current_Hook_User.apply c end; (* clear all the states of other projects referring to the delete project *) Q.iter (States_operations.clear_some_projects (equal project)) projects (* Gc.major ()*) let journalized_remove = Journal.register "Project.remove" (Datatype.optlabel_func "project" current ty (Datatype.func Datatype.unit Datatype.unit)) (fun project () -> unjournalized_remove project) let remove ?(project=current()) () = journalized_remove project () let remove_all () = feedback ~level:2 "removing all existing projects"; try iter_on_projects Before_remove.apply; States_operations.clean (); Q.clear projects; Gc.full_major () with NoProject -> () let journalized_copy = let lbl = Datatype.optlabel_func in Journal.register "Project.copy" (lbl "selection" dft_sel State_selection.ty (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; States_operations.commit ~selection src; States_operations.copy ~selection src dst) let copy ?(selection=State_selection.full) ?(src=current()) dst = journalized_copy selection src dst module Before_Clear_Hook = Hook.Build(struct type t = project end) let register_todo_before_clear = Before_Clear_Hook.extend let register_todo_on_clear = deprecated "Project.register_todo_on_clear" ~now:"Project.register_todo_before_clear" register_todo_before_clear module After_Clear_Hook = Hook.Build(struct type t = project end) let register_todo_after_clear = After_Clear_Hook.extend let journalized_clear = let lbl = Datatype.optlabel_func in Journal.register "Project.clear" (lbl "selection" dft_sel State_selection.ty (lbl "project" current ty (Datatype.func Datatype.unit Datatype.unit))) (fun selection project () -> guarded_feedback selection 2 "clearing project %S" project.unique_name; Before_Clear_Hook.apply project; States_operations.clear ~selection project; After_Clear_Hook.apply project; (*Gc.major ()*)) let clear ?(selection=State_selection.full) ?(project=current()) () = journalized_clear selection project () let unjournalized_clear_all () = Q.iter States_operations.clear projects; Gc.full_major () let clear_all = Journal.register "Project.clear_all" (Datatype.func Datatype.unit Datatype.unit) unjournalized_clear_all (* ************************************************************************** *) (* Save/load *) (* ************************************************************************** *) exception IOError = Sys_error module Before_load = Hook.Make(struct end) let register_before_load_hook = Before_load.extend module After_load = Hook.Make(struct end) let register_after_load_hook = After_load.extend module After_global_load = Hook.Make(struct end) let register_after_global_load_hook = After_global_load.extend let magic = 9 (* magic number *) let save_projects selection projects filename = if Cmdline.use_obj then begin let cout = open_out_bin filename in output_value cout Config.version; output_value cout magic; 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 in (* projects are stored on disk from the current one to the last project *) output_value cout (List.rev states); close_out cout; end else abort "saving a file is not supported in the 'no obj' mode" let unjournalized_save selection project filename = guarded_feedback selection 2 "saving project %S into file %S" project.unique_name filename; save_projects selection (Q.singleton project) filename let journalized_save = let lbl = Datatype.optlabel_func in Journal.register "Project.save" (lbl "selection" dft_sel State_selection.ty (lbl "project" current ty (Datatype.func Datatype.string Datatype.unit))) unjournalized_save let save ?(selection=State_selection.full) ?(project=current()) filename = journalized_save selection project filename let unjournalized_save_all selection filename = guarded_feedback selection 2 "saving the current session into file %S" filename; save_projects selection projects filename let journalized_save_all = let lbl = Datatype.optlabel_func in Journal.register "Project.save_all" (lbl "selection" dft_sel State_selection.ty (Datatype.func Datatype.string Datatype.unit)) unjournalized_save_all let save_all ?(selection=State_selection.full) filename = journalized_save_all selection filename module Descr = struct let project_under_copy_ref: project option ref = ref None (* The project which is currently copying. Only set by [create_by_copy]. In this case, there is no possible dangling project pointers (projects at saving time and at loading time are the same). Furthermore, we have to merge pre-existing projects and loaded projects, except the project under copy. *) 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 end) let rehash_cache : project Rehash.t = Rehash.create 7 let existing_projects : unit Project_tbl.t = Project_tbl.create 7 let rehash p = (* Format.printf "REHASHING %S (%d;%x)@." p.unique_name p.pid (Extlib.address_of_value p);*) try Rehash.find rehash_cache p with Not_found -> let v = create p.name (* real name set when loading the key project *) in Rehash.add rehash_cache p v; v let () = rehash_ref := rehash let init project_under_copy = assert (Rehash.length rehash_cache = 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) [] projects let finalize loaded_states selection = (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 | Some _ -> ()); Rehash.clear rehash_cache; Project_tbl.clear existing_projects let global_state name selection = 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 *) in Descr.t_record [| 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 to [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) in Descr.t_list final_one_state let input_val = Descr.input_val end let load_projects ~project_under_copy selection ?name filename = if Cmdline.use_obj then begin let cin = open_in_bin filename in let gen_read f cin = try f cin with Failure s -> close_in cin; raise (IOError s) in let read = gen_read input_value in 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) end in check_magic cin (fun x -> x) Config.version; check_magic cin (fun n -> "magic number " ^ string_of_int n) magic; let ocamlgraph_counter = read cin in 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 in close_in cin; Descr.finalize loaded_states selection; Graph.Blocks.after_unserialization ocamlgraph_counter; (* [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 [] 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 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" let unjournalized_load ~project_under_copy selection name filename = guarded_feedback selection 2 "loading the project saved in file %S" filename; match load_projects ~project_under_copy selection ?name filename with | [ p ] -> p | [] | _ :: _ :: _ -> assert false let journalized_load = let lbl = Datatype.optlabel_func in Journal.register "Project.load" (lbl "selection" dft_sel State_selection.ty (lbl "name" (fun () -> None) (Datatype.option Datatype.string) (Datatype.func Datatype.string ty))) (unjournalized_load ~project_under_copy:None) let load ?(selection=State_selection.full) ?name filename = journalized_load selection name filename let unjournalized_load_all selection filename = remove_all (); guarded_feedback selection 2 "loading the session saved in file %S" filename; try ignore (load_projects ~project_under_copy:None selection filename) with IOError _ as e -> unjournalized_set_current false selection (create "default"); raise e let journalized_load_all = let lbl = Datatype.optlabel_func in Journal.register "Project.load_all" (lbl "selection" dft_sel State_selection.ty (Datatype.func Datatype.string Datatype.unit)) unjournalized_load_all let load_all ?(selection=State_selection.full) filename = journalized_load_all selection filename module Create_by_copy_hook = Hook.Build(struct type t = project * project end) let create_by_copy_hook f = Create_by_copy_hook.extend (fun (src, dst) -> f src dst) 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 = try Extlib.temp_file_cleanup_at_exit "frama_c_create_by_copy" ".sav" with Extlib.Temp_file_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 in Extlib.safe_remove filename; Create_by_copy_hook.apply (src, prj); prj with e -> Extlib.safe_remove filename; raise e let journalized_create_by_copy = let lbl = Datatype.optlabel_func in Journal.register "Project.create_by_copy" (lbl "selection" dft_sel State_selection.ty (lbl "src" current ty (Datatype.func Datatype.string ty))) unjournalized_create_by_copy let create_by_copy ?(selection=State_selection.full) ?(src=current()) name = journalized_create_by_copy selection src name (* ************************************************************************** *) (** {2 Undoing} *) (* ************************************************************************** *) module Undo = struct let short_filename = "frama_c_undo_restore" let filename = ref "" let clear_breakpoint () = Extlib.safe_remove !filename let restore () = if Cmdline.use_obj then begin try Journal.prevent load_all !filename; Journal.restore (); clear_breakpoint () with IOError s -> feedback "cannot restore the last breakpoint: %S" s; clear_breakpoint () end let breakpoint () = if Cmdline.use_obj then begin clear_breakpoint (); filename := (try Extlib.temp_file_cleanup_at_exit short_filename ".sav" with Extlib.Temp_file_error s -> abort "cannot create temporary file: %s" s); Journal.prevent save_all !filename; Journal.save () end end (* Exporting Datatype for an easy external use *) module Datatype = D (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/project/state_builder.mli���������������������������������������������0000644�0001750�0001750�00000040667�12155630226�021602� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** State builders. Provide ways to implement signature [State_builder.S]. Depending on the builder, also provide some additional useful information. @plugin development guide *) (* ************************************************************************* *) (* ************************************************************************* *) (** {2 Low-level Builder} *) (* ************************************************************************* *) (* ************************************************************************* *) (** Additional information required by {!State_builder.Register}. *) module type Info = sig val name: string (** Name of the internal state. *) val dependencies : State.t list (** Dependencies of this internal state. *) end module type Info_with_size = sig include Info val size: int (** Initial size for the hash table. *) end (** Output signature of {!State_builder.Register}. *) module type S = sig val self: State.t (** The kind of the registered state. *) val name: string val mark_as_computed: ?project:Project.t -> unit -> unit (** Indicate that the registered state will not change again for the given project (default is [current ()]). *) val is_computed: ?project:Project.t -> unit -> bool (** Returns [true] iff the registered state will not change again for the given project (default is [current ()]). *) (** Exportation of some inputs (easier use of [State_builder.Register]). *) 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 *) end (** [Register(Datatype)(State)(Info)] registers a new state. [Datatype] represents the datatype of a state, [Local_state] explains how to deal with the client-side state and [Info] are additional required information. @plugin development guide *) module Register (Datatype: Datatype.S) (Local_state: State.Local with type t = Datatype.t) (Info: sig include Info val unique_name: string end) : S with module Datatype = Datatype (* ************************************************************************* *) (* ************************************************************************* *) (** {2 High-level Builders} *) (* ************************************************************************* *) (* ************************************************************************* *) (* ************************************************************************* *) (** {3 References} *) (* ************************************************************************* *) (** Output signature of [Ref]. *) module type Ref = sig include S type data (** Type of the referenced value. *) val set: data -> unit (** Change the referenced value. *) val get: unit -> data (** Get the referenced value. *) val clear: unit -> unit (** Reset the reference to its default value. *) end (** @plugin development guide *) module Ref (Data:Datatype.S) (Info:sig include Info val default: unit -> Data.t end) : Ref with type data = Data.t (** Output signature of [OptionRef]. *) module type Option_ref = sig 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]. *) val map: (data -> data) -> data option val may: (data -> unit) -> unit val get_option : unit -> data option (** @since Beryllium-20090901 *) end (** Build a reference on an option. *) module Option_ref(Data:Datatype.S)(Info: Info) : Option_ref with type data = Data.t (** Output signature of [ListRef]. @since Boron-20100401 *) 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 (** Build a reference on a list. @since Boron-20100401 *) module List_ref(Data:Datatype.S)(Info: Info) : List_ref with type data = Data.t list and type data_in_list = Data.t (** Build a reference on an integer. @since Carbon-20101201 *) module Int_ref(Info:sig include Info val default: unit -> int end) : Ref with type data = int (** Build a reference on an integer, initialized with [0]. @since Carbon-20101201 *) module Zero_ref(Info:Info) : Ref with type data = int (** Build a reference on a boolean. @since Oxygen-20120901 *) module Bool_ref(Info:sig include Info val default: unit -> bool end) : Ref with type data = bool (** Build a reference on a boolean, initialized with [false]. @since Carbon-20101201 *) module False_ref(Info:Info): Ref with type data = bool (** Build a reference on a boolean, initialized with [true]. @since Carbon-20101201 *) module True_ref(Info:Info): Ref with type data = bool (** Build a reference on a float. @since Oxygen-20120901 *) module Float_ref(Info:sig include Info val default: unit -> float end) : Ref with type data = float (* ************************************************************************* *) (** {3 Weak Hashtbl} *) (* ************************************************************************* *) (** Output signature of builders of hashtables. @since Boron-20100401 *) module type Weak_hashtbl = sig 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}) *) 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 *) 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 *) val clear: unit -> unit (** Clear the table. @since Boron-20100401 *) val count: unit -> int (** Length of the table. @since Boron-20100401 *) val iter: (data -> unit) -> unit (** @since Boron-20100401 *) val fold: (data -> 'a -> 'a) -> 'a -> 'a (** @since Boron-20100401 *) 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 *) val find_all: data -> data list (** [find_all x] returns a list of all the instances of [x] found in t. @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 *) 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 *) end (** Build a weak hashtbl over a datatype [Data] from a reference implementation [W]. @since Boron-20100401 *) module Weak_hashtbl (W: Weak.S)(Data: Datatype.S with type t = W.data)(Info: Info_with_size) : Weak_hashtbl with type data = W.data (** Build a weak hashtbl over a datatype [Data] by using [Weak.Make] provided by the OCaml standard library. Note that the table is not saved on disk. @since Boron-20100401 *) module Caml_weak_hashtbl(Data: Datatype.S)(Info: Info_with_size) : Weak_hashtbl with type data = Data.t (** Weak hashtbl dedicated to hashconsing. Note that the resulting table is not saved on disk. @since Boron-20100401 *) module Hashconsing_tbl (Data: sig include Datatype.S (** The hashconsed datatype *) val equal_internal: t -> t -> bool (** Equality on the datatype internally used by the built table. *) val hash_internal: t -> int (** 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. *) end) (Info: Info_with_size) : Weak_hashtbl with type data = Data.t (* ************************************************************************* *) (** {3 Hashtables} IMPORTANT: that is INCORRECT to use projectified hashtables if keys have a custom [rehash] function (see {!Project.DATATYPE_OUTPUT.rehash}) *) (* ************************************************************************* *) (** Output signature of builders of hashtables. *) 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}) *) type key type data val replace: key -> data -> unit (** Add a new binding. The previous one is removed. *) val add: key -> data -> unit (** Add a new binding. The previous one is only hidden. *) val clear: unit -> unit (** Clear the table. *) val length: unit -> int (** Length of the table. *) val iter: (key -> data -> unit) -> unit val iter_sorted: ?cmp:(key -> key -> int) -> (key -> data -> unit) -> unit val fold: (key -> data -> 'a -> 'a) -> 'a -> 'a val fold_sorted: ?cmp:(key -> key -> int) -> (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]. *) val find: key -> data (** Return the current binding of the given key. @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 val remove: key -> unit end (** @plugin development guide *) module Hashtbl (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) module Int_hashtbl(Data: Datatype.S)(Info:Info_with_size): Hashtbl with type key = int and type data = Data.t (* ************************************************************************* *) (** {3 References on a set} *) (* ************************************************************************* *) (** Output signature of builders of references on a set. *) module type Set_ref = sig include Ref type elt val add: elt -> unit val is_empty: unit -> bool val mem: elt -> bool val fold: (elt -> 'a -> 'a) -> 'a -> 'a val iter: (elt -> unit) -> unit end module Set_ref(S: Datatype.Set)(Info: Info) : Set_ref with type elt = S.elt and type data = S.t (* ************************************************************************* *) (** {3 Queue} *) (* ************************************************************************* *) module type Queue = sig type elt val add: elt -> unit val iter: (elt -> unit) -> unit val is_empty: unit -> bool end module Queue(Data: Datatype.S)(Info: Info) : Queue with type elt = Data.t (* ************************************************************************* *) (** {3 Proxies} *) (* ************************************************************************* *) (** State proxy. A proxy is a state which does not correspond to any useful mutable value. Its goal is only to reduce the number of dependencies between groups of states. @since Carbon-20101201 *) module Proxy : sig type t (** Proxy type. *) type kind = | 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. *) val create: string -> kind -> State.t list -> t (** [create s k sk l] creates a new proxy with the given name, kinds and states inside it. *) val extend: State.t list -> t -> unit (** Add some states in the given proxy. *) val get: t -> State.t (** Getting the state corresponding to a proxy. *) end (* ************************************************************************* *) (** {3 Counters} *) (* ************************************************************************* *) module type Counter = sig val next : unit -> int (** Increments the counter and returns a fresh value *) val get: unit -> int (** @return the current value of the counter, without incrementing it. @since Fluorine-20130401 *) val self: State.t (** @since Oxygen-20120901 *) end (** Creates a counter that is shared among all projects, but which is marshalling-compliant. @since Carbon-20101201 *) module SharedCounter(Info : sig val name : string end) : Counter (** Creates a projectified counter. @since Nitrogen-20111001 *) module Counter(Info : sig val name : string end) : Counter (* ************************************************************************* *) (** {3 Useful operations} *) (* ************************************************************************* *) 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. *) (** @since Fluorine-20130401 *) module States: sig val iter: ?prj:Project.t -> (string -> 'a Type.t -> 'a -> bool -> unit) -> unit (** iterates a function [f] over all registered states. Arguments of [f] are its name, its type value, its value for the given project ([Project.current ()] by default) and a boolean which indicates if it is already computed. @since Fluorine-20130401 *) val fold: ?prj:Project.t -> (string -> 'a Type.t -> 'a -> bool -> 'acc -> 'acc) -> 'acc -> 'acc (** As iter, but for folding. @since Fluorine-20130401*) val find: ?prj:Project.t -> string -> 'a Type.t -> 'a * bool (** @return the value of a state given by its name (and if it is computed), in the given project ([Project.current ()] by default) *) end (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������������������������������������frama-c-Fluorine-20130601/src/project/state_dependency_graph.mli������������������������������������0000644�0001750�0001750�00000006725�12155630226�023450� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** State Dependency Graph. @since Carbon-20101201 *) (** {2 Signatures} *) (** Signature of a State Dependency Graph. It is compatible with the signature of OcamlGraph imperative graph [Graph.Sig.I]. @since Carbon-20101201 *) module type S = sig module G: Graph.Sig.G with type V.t = State.t and type E.t = State.t * State.t val graph: G.t val add_dependencies: from:State.t -> State.t list -> unit (** Add an edge in [graph] from the state [from] to each state of the list. @since Carbon-20101201 *) val add_codependencies: onto:State.t -> State.t list -> unit (** Add an edge in [graph] from each state of the list to the state [onto]. @since Carbon-20101201 *) val remove_dependencies: from:State.t -> State.t list -> unit (** Remove an edge in [graph] from the given state to each state of the list. @since Fluorine-20130401 *) val remove_codependencies: onto:State.t -> State.t list -> unit (** Remove an edge in [graph] from each state of the list to the state [onto]. @since Oxygen-20120901 *) end (** Signature required by [Graph.GraphViZ.Dot]. See the OcamlGraph's documentation for additional details. @since Carbon-20101201 *) module type Attributes = sig open Graph.Graphviz val graph_attributes: 'a -> DotAttributes.graph list val default_vertex_attributes: 'a -> DotAttributes.vertex list val vertex_name : State.t -> string val vertex_attributes: State.t -> DotAttributes.vertex list val default_edge_attributes: 'a -> DotAttributes.edge list val edge_attributes: State.t * State.t -> DotAttributes.edge list val get_subgraph : State.t -> DotAttributes.subgraph option end include S val add_state: State.t -> State.t list -> unit module Attributes: Attributes module Dot(A: Attributes) : sig val dump: string -> unit end val dump: string -> unit (* Local Variables: compile-command: "make -C ../.." End: *) �������������������������������������������frama-c-Fluorine-20130601/src/project/project.mli���������������������������������������������������0000644�0001750�0001750�00000031705�12155630226�020413� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** Projects management. A project groups together all the internal states of Frama-C. An internal state is roughly the result of a computation which depends of an AST. It is possible to have many projects at the same time. For registering a new state in the Frama-C projects, apply the functor {!State_builder.Register}. @plugin development guide *) (* ************************************************************************* *) (** {2 Types for project} *) (* ************************************************************************* *) include Datatype.S_no_copy with type t = Project_skeleton.t module Datatype: Datatype.S with type t = Project_skeleton.t (* re-exporting record fields *) type project = Project_skeleton.t = private { pid : int; mutable name : string; mutable unique_name : string } (** Type of a project. *) (* ************************************************************************* *) (** {2 Operations on all projects} *) (* ************************************************************************* *) val create: string -> t (** Create a new project with the given name and attach it after the existing projects (so the current project, if existing, is unchanged). The given name may be already used by another project. If there is no other project, then the new one is the current one. *) val register_create_hook: (t -> unit) -> unit (** [register_create_hook f] adds a hook on function [create]: each time a new project [p] is created, [f p] is applied. The order in which hooks are applied is the same than the order in which hooks are registered. *) exception NoProject (** May be raised by [current]. *) val current: unit -> t (** The current project. @raise NoProject if there is no project. @plugin development guide *) val is_current: t -> bool (** Check whether the given project is the current one or not. *) val iter_on_projects: (t -> unit) -> unit (** iteration on project starting with the current one. *) val fold_on_projects: ('a -> t -> 'a) -> 'a -> 'a (** folding on project starting with the current one. @since Boron-20100401 *) val find_all: string -> t list (** Find all projects with the given name. *) val clear_all: unit -> unit (** Clear all the projects: all the internal states of all the projects are now empty (wrt the action registered with {!register_todo_after_global_clear} and {!register_todo_after_clear}. *) (* ************************************************************************* *) (** {2 Operations on one project} Most operations have one additional selection as argument. If it is specified, the operation is only applied on the states of the given selection on the given project. Beware that the project may become inconsistent if your selection is incorrect. *) (* ************************************************************************* *) val get_name: t -> string (** Project name. Two projects may have the same name. *) val get_unique_name: t -> string (** @return a project name based on {!name} but different of each others [unique_name]. *) val set_name: t -> string -> unit (** Set the name of the given project. @since Boron-20100401 *) val from_unique_name: string -> t (** Return a project based on {!unique_name}. @raise Not_found if no project has this unique name. *) val set_current: ?on:bool -> ?selection:State_selection.t -> t -> unit (** Set the current project with the given one. The flag [on] is not for casual users. @raise Invalid_argument if the given project does not exist anymore. @plugin development guide *) val register_after_set_current_hook: user_only:bool -> (t -> unit) -> unit (** [register_after_set_current_hook f] adds a hook on function {!set_current}. The project given as argument to [f] is the old current project. - If [user_only] is [true], then each time {!set_current} is directly called by an user of this library, [f ()] is applied. - If [user_only] is [false], then each time {!set_current} is applied (even indirectly through {!Project.on}), [f ()] is applied. The order in which each hook is applied is unspecified. *) val on: ?selection:State_selection.t -> t -> ('a -> 'b) -> 'a -> 'b (** [on p f x] sets the current project to [p], computes [f x] then restores the current project. You should use this function if you use a project different of [current ()]. @modify Carbon-20101201 replace the optional arguments [only] and [except] by a single one [selection]. @plugin development guide *) val copy: ?selection:State_selection.t -> ?src:t -> t -> unit (** Copy a project into another one. Default project for [src] is [current ()]. Replace the destination by [src]. For each state to copy, the function [copy] given at state registration time must be fully implemented. @modify Carbon-20101201 replace the optional arguments [only] and [except] by a single one [selection]. *) val create_by_copy: ?selection:State_selection.t -> ?src:t -> string -> t (** Return a new project with the given name by copying some states from the project [src]. All the other states are initialized with their default values. Use the save/load mechanism for copying. Thus it does not require that the copy function of the copied state is implemented. All the hooks applied when loading a project are applied (see {!load}). @modify Carbon-20101201 replace the optional arguments [only] and [except] by a single one [selection]. *) val create_by_copy_hook: (t -> t -> unit) -> unit (** Register a hook to call at the end of {!create_by_copy}. The first argument of the registered function is the copy source while the second one is the created project. *) val clear: ?selection:State_selection.t -> ?project:t -> unit -> unit (** Clear the given project. Default project is [current ()]. All the internal states of the given project are now empty (wrt the action registered with {!register_todo_on_clear}). @modify Carbon-20101201 replace the optional arguments [only] and [except] by a single one [selection]. @plugin development guide *) val register_todo_on_clear: (t -> unit) -> unit (** @deprecated since Boron-20100401. Replaced by {!register_todo_before_clear} *) val register_todo_before_clear: (t -> unit) -> unit (** Register an action performed just before clearing a project. @since Boron-20100401 *) val register_todo_after_clear: (t -> unit) -> unit (** Register an action performed just after clearing a project. @since Boron-20100401 *) exception Cannot_remove of string (** Raised by [remove] *) val remove: ?project:t -> unit -> unit (** Default project is [current ()]. If the current project is removed, then the new current project is the previous current project if it still exists (and so on). @raise Cannot_remove if there is only one project. *) val register_before_remove_hook: (t -> unit) -> unit (** [register_before_remove_hook f] adds a hook called just before removing a project. @since Beryllium-20090902 *) (* ************************************************************************* *) (** {3 Inputs/Outputs} *) (* ************************************************************************* *) exception IOError of string val save: ?selection:State_selection.t -> ?project:t -> string -> unit (** Save a given project in a file. Default project is [current ()]. @raise IOError if the project cannot be saved. @modify Carbon-20101201 replace the optional arguments [only] and [except] by a single one [selection]. @plugin development guide *) val load: ?selection:State_selection.t -> ?name:string -> string -> t (** Load a file into a new project given by its name. More precisely, [load only except name file]: {ol {- creates a new project;} {- performs all the registered [before_load] actions;} {- loads the (specified) states of the project according to its description; and} {- performs all the registered [after_load] actions.} } @raise IOError if the project cannot be loaded @return the new project containing the loaded data. @modify Carbon-20101201 replace the optional arguments [only] and [except] by a single one [selection]. @plugin development guide *) val save_all: ?selection:State_selection.t -> string -> unit (** Save all the projects in a file. @modify Carbon-20101201 replace the optional arguments [only] and [except] by a single one [selection]. @raise IOError a project cannot be saved. *) val load_all: ?selection:State_selection.t -> string -> unit (** First remove all the existing project, then load all the projects from a file. For each project to load, the specification is the same than {!Project.load}. Furthermore, after loading, all the hooks registered by [register_after_set_current_hook] are applied. @modify Carbon-20101201 replace the optional arguments [only] and [except] by a single one [selection]. @raise IOError if a project cannot be loaded. *) val register_before_load_hook: (unit -> unit) -> unit (** [register_before_load_hook f] adds a hook called just before loading **each project** (more precisely, the project exists and but is empty while the hook is applied): if [n] projects are on disk, the same hook will be called [n] times (one call by project). Besides, for each project, the order in which the hooks are applied is the same than the order in which hooks are registered. *) val register_after_load_hook: (unit -> unit) -> unit (** [register_after_load_hook f] adds a hook called just after loading **each project**: if [n] projects are on disk, the same hook will be called [n] times (one call by project). Besides, for each project, the order in which the hooks are applied is the same than the order in which hooks are registered. *) val register_after_global_load_hook: (unit -> unit) -> unit (** [register_after_load_hook f] adds a hook called just after loading **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} *) (* ************************************************************************* *) val compare: t -> t -> int val equal: t -> t -> bool val hash: t -> int (* ************************************************************************* *) (** {2 Undoing} *) (* ************************************************************************* *) module Undo: sig val breakpoint: unit -> unit val restore: unit -> unit val clear_breakpoint: unit -> unit end (* Local Variables: compile-command: "make -C ../.." End: *) �����������������������������������������������������������frama-c-Fluorine-20130601/src/project/state_dependency_graph.ml�������������������������������������0000644�0001750�0001750�00000007443�12155630226�023275� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) module type S = sig module G: Graph.Sig.G with type V.t = State.t and type E.t = State.t * State.t val graph: G.t val add_dependencies: from:State.t -> State.t list -> unit val add_codependencies: onto:State.t -> State.t list -> unit val remove_dependencies: from:State.t -> State.t list -> unit val remove_codependencies: onto:State.t -> State.t list -> unit end module type Attributes = sig open Graph.Graphviz val graph_attributes: 'a -> DotAttributes.graph list val default_vertex_attributes: 'a -> DotAttributes.vertex list val vertex_name : State.t -> string val vertex_attributes: State.t -> DotAttributes.vertex list val default_edge_attributes: 'a -> DotAttributes.edge list val edge_attributes: State.t * State.t -> DotAttributes.edge list val get_subgraph : State.t -> DotAttributes.subgraph option end module Dependency_graph = Graph.Imperative.Digraph.ConcreteBidirectional(State) module Static = struct module G = Dependency_graph let graph = Dependency_graph.create ~size:7 () let add_dependencies ~from deps = List.iter (Dependency_graph.add_edge graph from) deps let add_codependencies ~onto codeps = List.iter (fun c -> Dependency_graph.add_edge graph c onto) codeps let remove_dependencies ~from deps = List.iter (Dependency_graph.remove_edge graph from) deps let remove_codependencies ~onto codeps = List.iter (fun c -> Dependency_graph.remove_edge graph c onto) codeps let add_state v deps = Dependency_graph.add_vertex graph v; add_codependencies ~onto:v deps end include Static module Attributes = struct let vertex_name s = "\"" ^ State.get_unique_name s ^ "\"" let graph_attributes _ = [ `Ratio (`Float 0.25) ] let default_vertex_attributes _ = [] let vertex_attributes s = [ `Label (String.escaped (State.get_name s)) ] let default_edge_attributes _ = [] let edge_attributes _ = [] let get_subgraph _ = None end module Dot(A:Attributes) = struct module D = Graph.Graphviz.Dot(struct include A include Dependency_graph end) let dump filename = let cout = open_out filename in D.output_graph cout graph; close_out cout end include Dot(Attributes) (* Local Variables: compile-command: "make -C ../.." End: *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/project/state.ml������������������������������������������������������0000644�0001750�0001750�00000015765�12155630226�017724� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Project_skeleton (* ************************************************************************** *) (** {2 Type declarations} *) (* ************************************************************************** *) type state_on_disk = { on_disk_value: Obj.t; on_disk_computed: bool; on_disk_saved: bool; on_disk_digest: Digest.t } type private_ops = { mutable descr: Structural_descr.pack; create: t -> unit; remove: t -> unit; mutable clear: t -> unit; mutable clear_some_projects: (t -> bool) -> t -> bool; 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 } type state = { unique_name: string; mutable name: string; private_ops: private_ops } module type Local = sig type t val create: unit -> t val clear: t -> unit val get: unit -> t val set: t -> unit val clear_some_projects: (Project_skeleton.t -> bool) -> t -> bool end (* ************************************************************************** *) (** {2 Datatype} *) (* ************************************************************************** *) let never_called _ = assert false let dummy_private_ops () = { descr = Descr.pack Descr.unmarshable; create = never_called; remove = never_called; clear = never_called; clear_some_projects = never_called; copy = never_called; commit = never_called; update = never_called; on_update = never_called; serialize = never_called; unserialize = never_called; clean = never_called } let dummy_state_on_disk = { on_disk_value = Obj.repr (); on_disk_computed = false; on_disk_saved = false; on_disk_digest = "" } let dummy_unique_name = "" let dummy = { name = ""; unique_name = dummy_unique_name; private_ops = dummy_private_ops () } module Caml_hashtbl = Hashtbl include Datatype.Make_with_collections (struct type t = state let name = "State" 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 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 pretty fmt s = Format.fprintf fmt "state %S" s.unique_name let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) let is_dummy = equal dummy (* ************************************************************************** *) (** {2 Getters} *) (* ************************************************************************** *) exception Incompatible_datatype of string let get_name s = s.name let get_unique_name s = s.unique_name let private_ops s = s.private_ops 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} *) (* ************************************************************************** *) (* ************************************************************************** *) (** {2 Internals} All this stuff should not be used outside of the Project library.*) (* ************************************************************************** *) (* ************************************************************************** *) (** {3 Managing the set of known states} *) (* ************************************************************************** *) let states : t Datatype.String.Hashtbl.t = Datatype.String.Hashtbl.create 997 exception Unknown let get s = try Datatype.String.Hashtbl.find states s with Not_found -> raise Unknown let delete s = let uname = s.unique_name in assert (Datatype.String.Hashtbl.mem states uname); Datatype.String.Hashtbl.remove states uname let add s = let uname = s.unique_name in assert (Project_skeleton.Output.verify (not (Datatype.String.Hashtbl.mem states uname)) "state %S already exists." uname); Datatype.String.Hashtbl.add states uname s let unique_name_from_name = let module M = Project_skeleton.Make_setter (struct let mem s = Datatype.String.Hashtbl.mem states s end) in M.make_unique_name (* ************************************************************************** *) (** {3 State generators} *) (* ************************************************************************** *) let create ~descr ~create ~remove ~clear ~clear_some_projects ~copy ~commit ~update ~on_update ~clean ~serialize ~unserialize ~unique_name ~name = let ops = { descr = descr; create = create; remove = remove; clear = clear; clear_some_projects = clear_some_projects; copy = copy; commit = commit; update = update; on_update = on_update; clean = clean; serialize = serialize; unserialize = unserialize } in let self = { name = name; unique_name = unique_name; private_ops = ops } in add self; self (* Local Variables: compile-command: "make -C ../.." End: *) �����������frama-c-Fluorine-20130601/src/project/state_topological.ml������������������������������������������0000644�0001750�0001750�00000006043�12155630226�022305� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* Ocamlgraph: a generic graph library for ocaml *) (* Copyright (C) 2004-2012 *) (* Sylvain Conchon, Jean-Christophe Fillitre and Julien Signoles *) (* *) (* This library is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Library General Public *) (* License version 2.1, as published by the Free Software Foundation. *) (* *) (* This library is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) (* *) (* See the GNU Library General Public License version 2.1 for more *) (* details (enclosed in the file licences/LGPLv2.1). *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives). *) (* *) (**************************************************************************) module type G = sig type t val iter_vertex : (State.t -> unit) -> t -> unit val iter_succ : (State.t -> unit) -> t -> State.t -> unit val in_degree : t -> State.t -> int end module Make(G: G) = struct module H = State.Hashtbl let fold f g acc = let degree = H.create 997 in let todo = Queue.create () in let push x = H.remove degree x; Queue.push x todo in 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 else 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) with Not_found -> (* [x] already visited *) ()) g 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) g; walk acc let iter f g = fold (fun v () -> f v) g () end (* Local Variables: compile-command: "make -C ../.." End: *) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/project/state_topological.mli�����������������������������������������0000644�0001750�0001750�00000005642�12155630226�022462� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* Ocamlgraph: a generic graph library for ocaml *) (* Copyright (C) 2004-2012 *) (* Sylvain Conchon, Jean-Christophe Fillitre and Julien Signoles *) (* *) (* This library is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Library General Public *) (* License version 2.1, as published by the Free Software Foundation. *) (* *) (* This library is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) (* *) (* See the GNU Library General Public License version 2.1 for more *) (* details (enclosed in the file licences/LGPLv2.1). *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives). *) (* *) (**************************************************************************) (** Topological ordering over states. This functor provides functions which allow iterating over a <b>state</b> graph in topological order. That is the module [Topological] from OcamlGraph, but it takes into account state clusters. *) (** Minimal graph signature to provide. Sub-signature of {!Sig.G}. *) module type G = sig type t val iter_vertex : (State.t -> unit) -> t -> unit val iter_succ : (State.t -> unit) -> t -> State.t -> unit val in_degree : t -> State.t -> int end (** Functor providing topological iterators over a graph. *) module Make(G: G) : sig val fold : (State.t -> 'a -> 'a) -> G.t -> 'a -> 'a (** [fold action g seed] allows iterating over the graph [g] in topological order. [action node accu] is called repeatedly, where [node] is the node being visited, and [accu] is the result of the [action]'s previous invocation, if any, and [seed] otherwise. If [g] contains cycles, the order is unspecified inside the cycles and every node in the cycles will be presented exactly once. *) val iter : (State.t -> unit) -> G.t -> unit (** [iter action] calls [action node] repeatedly. Nodes are (again) presented to [action] in topological order. The order is the same as for [fold]. *) end (* Local Variables: compile-command: "make -C ../.." End: *) ����������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/semantic_callgraph/���������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�020404� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/semantic_callgraph/options.ml�����������������������������������������0000644�0001750�0001750�00000004602�12155630165�022437� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) let name = "semantic callgraph" include Plugin.Register (struct let name = name let shortname = "scg" let help = "semantic stratified callgraph" end) module Filename = EmptyString (struct let option_name = "-scg" let arg_name = "filename" let help = "dump the semantic stratified callgraph to the file \ <filename> in dot format" end) module InitFunc = StringSet (struct let option_name = "-scg-init-func" let arg_name = "" let help = "use the given functions as a root service for the scg \ (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)" end) (* Local Variables: compile-command: "make -C ../.." End: *) ������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/semantic_callgraph/options.mli����������������������������������������0000644�0001750�0001750�00000003365�12155630165�022615� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) include Plugin.S val name: string module Filename: Plugin.String module InitFunc: Plugin.String_set (* Local Variables: compile-command: "make -C ../.." End: *) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/semantic_callgraph/register.ml����������������������������������������0000644�0001750�0001750�00000020127�12155630165�022570� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Db open Options module KfSorted = struct type t = Kernel_function.t (* Basic comparison of kernel function compares on vid. As this has an impact to results shown to the user, it's better to use an ordering which depends only on the input itself, not how the numbering of varinfo is done internally *) let equal = Kernel_function.equal let hash kf = Hashtbl.hash (Kernel_function.get_name kf) let compare kf1 kf2 = if kf1 == kf2 then 0 else let res = String.compare (Kernel_function.get_name kf1) (Kernel_function.get_name kf2) in if res <> 0 then res else (* Backup solution, will compare underlying varinfos ids *) Kernel_function.compare kf1 kf2 end module SetKfSorted = Set.Make(KfSorted) module SGraph = Graph.Imperative.Digraph.ConcreteLabeled (KfSorted) (struct include Cil_datatype.Stmt let default = Cil.dummyStmt end) module SGState = 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)) (struct let name = "SGState" let dependencies = [ Value.self ] end) module SCQueue = State_builder.Queue (Kernel_function) (struct let name = "SCQueue" let dependencies = [ SGState.self ] end) let callgraph () = SGState.memo (fun () -> let g = SGraph.create () in !Value.compute (); Globals.Functions.iter (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)); g) module Service = Service_graph.Make (struct let datatype_name = name type t = SGraph.t module V = struct include Kernel_function let id v = (Kernel_function.get_vi v).Cil_types.vid let name = Kernel_function.get_name let attributes v = [ `Style (if Kernel_function.is_definition v then `Bold else `Dotted) ] 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 let iter_pred = SGraph.iter_pred let fold_pred = SGraph.fold_pred end) module ServiceState = State_builder.Option_ref (Service.CallG.Datatype) (struct let name = "SemanticsServicestate" let dependencies = [ SGState.self; Kernel.MainFunction.self; InitFunc.self ] end) let get_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"; let cg = Service.compute (callgraph ()) (get_init_funcs ()) in feedback "analysis done"; ServiceState.mark_as_computed (); cg let get () = ServiceState.memo compute let dump () = let cg = get () in let file = Filename.get () in feedback ~level:2 "dumping the graph into file %s" file; try let o = open_out file in Service.output_graph o cg; close_out o with e -> error "error while dumping the semantic callgraph: %s" (Printexc.to_string e) let () = Db.register_guarded_compute "Semantic_Callgraph.dump" (fun () -> Filename.get () = "" || ServiceState.is_computed ()) Db.Semantic_Callgraph.dump dump let () = (* Do not directly use [dump]: function in [Db] is guarded and apply only if required. *) Db.Main.extend (fun _fmt -> !Db.Semantic_Callgraph.dump ()) let topologically_iter_on_functions = let module T = Graph.Topological.Make_stable(SGraph) in fun f -> (* compute on need *) if SCQueue.is_empty () then T.iter SCQueue.add (callgraph ()); SCQueue.iter f let iter_on_callers f kf = let cg = callgraph () in let visited = Kernel_function.Hashtbl.create 17 in let rec aux kf = if SGraph.mem_vertex cg kf then SGraph.iter_succ (fun caller -> if not (Kernel_function.Hashtbl.mem visited caller) then begin f caller; Kernel_function.Hashtbl.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) in aux kf let is_local_or_formal_of_caller v kf = try iter_on_callers (fun caller -> let formal_or_local = (Base.is_formal_or_local v (Kernel_function.get_definition caller)) in if formal_or_local then raise Exit) kf; false with Exit -> true let accept_base ~with_formals ~with_locals kf v = let open Cil_types in Base.is_global v || (match with_formals, with_locals, kf.fundec with | false, false, _ -> false | true, false, Definition (fundec,_) -> Base.is_formal v fundec | false, true, Definition (fundec, _) -> Base.is_local v fundec | true, true, Definition (fundec, _) -> Base.is_formal_or_local v fundec | false, _, Declaration _ -> false | true , _, Declaration (_, vd, _, _) -> Base.is_formal_of_prototype v vd ) || is_local_or_formal_of_caller v kf let () = Db.Semantic_Callgraph.topologically_iter_on_functions := topologically_iter_on_functions; let tf = Datatype.func Kernel_function.ty Datatype.Unit.ty in Db.Semantic_Callgraph.iter_on_callers := Dynamic.register ~plugin:"Semantic_callgraph" "iter_on_callers" (Datatype.func tf tf) ~journalize:false iter_on_callers; Db.Semantic_Callgraph.accept_base := accept_base; (* Local Variables: compile-command: "make -C ../.." End: *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/src/semantic_callgraph/Semantic_callgraph.mli�����������������������������0000644�0001750�0001750�00000003426�12155630165�024700� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (* $Id: Semantic_callgraph.mli,v 1.2 2008-11-04 10:05:05 uid568 Exp $ *) (** Semantic callgraph. *) (** No function is directly exported: they are registered in {!Db.Semantic_Callgraph}. *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/external/�����������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�015617� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/external/hptmap.ml��������������������������������������������������������0000644�0001750�0001750�00000102421�12155630367�017452� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file was originally part of Menhir *) (* *) (* Franois Pottier and Yann Rgis-Gianas, INRIA Rocquencourt *) (* *) (* Copyright 2005 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0, with the *) (* change described in the file licences/Q_MODIFIED_LICENSE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives). *) (* *) (**************************************************************************) (* This is an implementation of Patricia trees, following Chris Okasaki's paper at the 1998 ML Workshop in Baltimore. Both big-endian and little-endian trees are provided. Both sets and maps are implemented on top of Patricia trees. *) (* A tree is big-endian if it expects the key's most significant bits to be tested first. *) type prefix = int * int let sentinel_prefix = (-1) , (-1) exception Found_inter module Big_Endian = struct type mask = int (* The ``relevant'' bits in an integer [i] are those which are found (strictly) to the left of the single one bit in the mask [m]. We keep these bits, and set all others to 0. Okasaki uses a different convention, which allows big-endian Patricia trees to masquerade as binary search trees. This feature does not seem to be useful here. *) let mask i m = i land (lnot (2*m-1)) (* The smaller [m] is, the more bits are relevant. *) let shorter (m:int) (n:int) = m > n end (*i ------------------------------------------------------------------------ i*) (*s \mysection{Patricia-tree-based maps} *) module Tag_comp : sig type t val get_tag : t -> int val get_comp : t -> bool val encode : int -> bool -> t end = struct type t = int let get_tag x = x land max_int let get_comp x = x < 0 let encode tag comp = if comp then tag lor min_int else tag end module Comp_unused = struct let e = false let f _ _ = false let compose _ _ = false let default = false end type ('key, 'value, 'tag) tree = | Empty | Leaf of 'key * 'value * bool | Branch of int (** prefix *) * Big_Endian.mask * ('key, 'value, 'tag) tree * ('key, 'value, 'tag) tree * 'tag module Make (Key:sig include Datatype.S val id : t -> int end) (V : Datatype.S) (Comp : sig val e: bool val f : Key.t -> V.t -> bool val compose : bool -> bool -> bool val default: bool end) (Initial_Values: sig val v : (Key.t * V.t) list list end) (Datatype_deps: sig val l : State.t list end) = struct type key = Key.t type leaf_annot = bool type branch_annot = Tag_comp.t (* A tree is either empty, or a leaf node, containing both the integer key and a piece of data, or a binary node. Each binary node carries two integers. The first one is the longest common prefix of all keys in this sub-tree. The second integer is the branching bit. It is an integer with a single one bit (i.e. a power of 2), which describes the bit being tested at this node. *) type tt = (Key.t, V.t, Tag_comp.t) tree let compare = if Key.compare == Datatype.undefined || V.compare == Datatype.undefined then ( Kernel.debug "(%s, %s) ptmap, missing comparison function: %b %b" (Type.name Key.ty) (Type.name V.ty) (Key.compare == Datatype.undefined) (V.compare == Datatype.undefined); Datatype.undefined ) else let compare t1 t2 = match t1, t2 with | Empty, Empty -> 0 | Empty, _ -> -1 | _, Empty -> 1 | Leaf (k1,x1,_), Leaf (k2,x2,_) -> let c = Key.compare k1 k2 in if c <> 0 then c else V.compare x1 x2 | Leaf _, Branch _ -> -1 | Branch _, Leaf _ -> 1 | Branch (_p1,_m1,_l1,_r1,t1), Branch (_p2,_m2,_l2,_r2,t2) -> let t1 = Tag_comp.get_tag t1 in let t2 = Tag_comp.get_tag t2 in Datatype.Int.compare t1 t2 (* Taken and adapted from JCF code for the implementation without tag *) (*let c = Datatype.Int.compare p1 p2 in if c <> 0 then c else let c = Big_endian.compare m1 m2 in if c <> 0 then c else let c = compare l1 l2 in if c <> 0 then c else compare r1 r2 *) in compare let comp t = match t with Empty -> Comp.e | Leaf (_,_,c) -> c | Branch (_,_,_,_,tc) -> Tag_comp.get_comp tc let rec min_binding t = match t with Empty -> raise Not_found | Branch (_,_,left,_,_) -> min_binding left | Leaf (key, data, _) -> key, data let rec max_binding t = match t with Empty -> raise Not_found | Branch (_,_,_,right,_) -> max_binding right | Leaf (key, data, _) -> key, data let rec iter f htr = match htr with | Empty -> () | Leaf (key, data, _) -> f key data | Branch (_, _, tree0, tree1, _tl) -> iter f tree0; iter f tree1 let prettykv fmt k v = Format.fprintf fmt "%a -> %a@." Key.pretty k V.pretty v let pretty fmt tree = Format.fprintf fmt "[[@."; iter (prettykv fmt) tree; Format.fprintf fmt "]]@." let tag tr = match tr with Empty -> 27 | Leaf (k, v, _) -> Key.id k + 547 * V.hash v | Branch (_, _, _, _, tl) -> Tag_comp.get_tag tl let hash_internal tr = match tr with Empty | Leaf _ -> tag tr | Branch(p,m,l,r, _tag) -> m + 3 * p + 2017 * (tag l) + (tag r) let hash_debug = hash_internal let equal_internal htr1 htr2 = (* do not use == or compare the toplevel tags. One of the arguments is not hashconsed yet when this function is called *) match htr1, htr2 with Empty, Empty -> true | Leaf(k1, v1, _), Leaf(k2, v2, _) -> Key.equal k1 k2 && (V.equal v1 v2) | Branch(p1,m1,l1,r1,_), Branch(p2,m2,l2,r2,_) -> p1 = p2 && m1 = m2 && l1 == l2 && r1 == r2 | _,_ -> false (* [iter f m] invokes [f k x], in turn, for each binding from key [k] to element [x] in the map [m]. Keys are presented to [f] according to some unspecified, but fixed, order. *) let empty = Empty let current_tag_before_initial_values = 1 let current_tag = ref current_tag_before_initial_values let initial_values = List.map (function [k,v] -> Leaf (k, v, Comp.f k v) | [] -> Empty | _ -> assert false) Initial_Values.v let rehash_ref = ref (fun _ -> assert false) module Datatype = Datatype.Make_with_collections (struct type t = tt let name = "(" ^ Type.name Key.ty ^ ", " ^ Type.name V.ty ^ ") ptmap" open Structural_descr let r = Recursive.create () let structural_descr = Structure (Sum [| [| Key.packed_descr; V.packed_descr; p_abstract |]; [| p_abstract; p_abstract; recursive_pack r; recursive_pack r; p_abstract |] |]) let () = Recursive.update r structural_descr let reprs = [ Empty ] let equal = ( == ) let compare = compare let hash = tag let rehash x = !rehash_ref x let copy = Datatype.undefined let internal_pretty_code = Datatype.pp_fail let pretty = pretty let varname = Datatype.undefined let mem_project = Datatype.never_any_project end) let () = Type.set_ml_name Datatype.ty None include Datatype module PatriciaHashconsTbl = State_builder.Hashconsing_tbl (struct include Datatype let equal_internal = equal_internal let hash_internal = hash_internal let initial_values = initial_values end) (struct let name = Type.name ty ^ " hashconsing table" let dependencies = Datatype_deps.l let size = 137 end) let self = PatriciaHashconsTbl.self (* let inform_counter = ref 0 let inform() = let n = succ !inform_counter in inform_counter := n; if n land 16383 = 0 then let c = PatriciaHashconsTbl.count () in Format.printf "%6d nodes %s@." c name *) let wrap_Leaf k v = (* inform(); *) assert (Key.id k >= 0); (* The test k < p+m and the implementation of [highest_bit] do not work with negative keys. *) let new_tr = Leaf (k, v, Comp.f k v) in PatriciaHashconsTbl.merge new_tr let wrap_Branch p m l r = (* inform(); *) let tag = !current_tag in let comp = Comp.compose (comp l) (comp r) in let comp = match l, r with | Branch (_,ml,_,_,_), Branch (_,mr,_,_,_) when ml + mr = m -> comp | Leaf (_,_,_), Leaf (_,_,_) -> comp | _ -> Comp.compose Comp.default comp in let new_tr = Branch (p, m, l, r, Tag_comp.encode tag comp) in let result = PatriciaHashconsTbl.merge new_tr in if result == new_tr then current_tag := (succ tag) land max_int ; result let rehash_node = function | Empty -> Empty | Leaf (k, v, _) -> wrap_Leaf k v | Branch (p,m,l,r,_) -> wrap_Branch p m l r let () = rehash_ref := rehash_node (* This reference will contain a list of functions that will clear all the transient caches used in this module *) let clear_caches = ref [] (* [find k m] looks up the value associated to the key [k] in the map [m], and raises [Not_found] if no value is bound to [k]. This implementation takes branches \emph{without} checking whether the key matches the prefix found at the current node. This means that a query for a non-existent key shall be detected only when finally reaching a leaf, rather than higher up in the tree. This strategy is better when (most) queries are expected to be successful. *) let find key htr = let id = Key.id key in let rec find htr = match htr with | Empty -> raise Not_found | Leaf (key', data, _) -> if Key.equal key key' then data else raise Not_found | Branch (_, mask, tree0, tree1, _) -> find (if (id land mask) = 0 then tree0 else tree1) in find htr let mem key htr = let id = Key.id key in let rec find htr = match htr with | Empty -> false | Leaf (key', _, _) -> Key.equal key key' | Branch (_, mask, tree0, tree1, _) -> find (if (id land mask) = 0 then tree0 else tree1) in find htr (* The auxiliary function [join] merges two trees in the simple case where their prefixes disagree. Assume $t_0$ and $t_1$ are non-empty trees, with longest common prefixes $p_0$ and $p_1$, respectively. Further, suppose that $p_0$ and $p_1$ disagree, that is, neither prefix is contained in the other. Then, no matter how large $t_0$ and $t_1$ are, we can merge them simply by creating a new [Branch] node that has $t_0$ and $t_1$ as children! *) let join p0 t0 p1 t1 = let m = (* Big_Endian.branching_bit p0 p1 in (inlined) *) let v = p0 lxor p1 in (* compute highest bit. First, set all bits with weight less than the highest set bit *) let v1 = v lsr 1 in let v2 = v lsr 2 in let v = v lor v1 in let v = v lor v2 in let v1 = v lsr 3 in let v2 = v lsr 6 in let v = v lor v1 in let v = v lor v2 in let v1 = v lsr 9 in let v2 = v lsr 18 in let v = v lor v1 in let v = v lor v2 in (* then get highest bit *) (succ v) lsr 1 in let p = Big_Endian.mask p0 (* for instance *) m in if (p0 land m) = 0 then wrap_Branch p m t0 t1 else wrap_Branch p m t1 t0 (* The auxiliary function [match_prefix] tells whether a given key has a given prefix. More specifically, [match_prefix k p m] returns [true] if and only if the key [k] has prefix [p] up to bit [m]. Throughout our implementation of Patricia trees, prefixes are assumed to be in normal form, i.e. their irrelevant bits are set to some predictable value. Formally, we assume [Big_Endian.mask p m] equals [p] whenever [p] is a prefix with [m] relevant bits. This allows implementing [match_prefix] using only one call to [Big_Endian.mask]. On the other hand, this requires normalizing prefixes, as done e.g. in [join] above, where [Big_Endian.mask p0 m] has to be used instead of [p0]. *) let match_prefix k p m = Big_Endian.mask k m = p let pretty_prefix (p,m) fmt tree = let rec pretty_prefix_aux tree = match tree with Empty -> () | Leaf (k,v,_) -> if match_prefix (Key.id k) p m then prettykv fmt k v | Branch(p1,m1,l,r,_) -> if m1 <= m then begin if match_prefix p1 p m then iter (prettykv fmt) tree; end else if p land m1 = 0 then pretty_prefix_aux l else pretty_prefix_aux r in Format.fprintf fmt "[[@."; pretty_prefix_aux tree; Format.fprintf fmt "]]@." type subtree = tt exception Found_prefix of prefix * subtree * subtree let rec comp_prefixes t1 t2 = assert (t1 != t2); let all_comp = comp t1 && comp t2 in match t1, t2 with Leaf (k1, _v1, _), Leaf (k2, _v2, _) -> if Key.equal k1 k2 && all_comp then begin (* Format.printf "PREF leaves:@."; prettykv Format.std_formatter k1 _v1; prettykv Format.std_formatter k1 _v2; *) raise (Found_prefix((Key.id k1, -1), t1, t2)) end | Branch (p1, m1, l1, r1, _), Branch (p2, m2, l2, r2, _) -> if (p1 = p2) & (m1 = m2) then begin if all_comp then begin (* Format.printf "PREF subtree:@."; pretty Format.std_formatter t1; pretty Format.std_formatter t2; *) raise (Found_prefix((p1 ,m1), t1, t2)); end; let go_left = l1 != l2 in if go_left then begin let go_right = r1 != r2 in if go_right then comp_prefixes r1 r2; comp_prefixes l1 l2; end else begin assert (r1 != r2); comp_prefixes r1 r2; end end else if (Big_Endian.shorter m1 m2) & (match_prefix p2 p1 m1) then let sub1 = if (p2 land m1) = 0 then l1 else r1 in if sub1 != t2 then comp_prefixes sub1 t2 else if (Big_Endian.shorter m2 m1) & (match_prefix p1 p2 m2) then let sub2 = if (p1 land m2) = 0 then l2 else r2 in if sub2 != t1 then comp_prefixes t1 sub2 | _, _ -> () let rec find_prefix t (p, m as prefix) = match t with Empty -> None | Leaf (k, _, c) -> if Key.id k = p && m = -1 && c then Some t else None | Branch (p1, m1, l, r, tc) -> if p1 = p && m1 = m then (if Tag_comp.get_comp tc then Some t else None) else if Big_Endian.shorter m m1 then None else if match_prefix p p1 m1 then find_prefix (if p land m1 = 0 then l else r) prefix else None let hash_subtree = tag let equal_subtree = equal (* [fine_add decide k d m] returns a map whose bindings are all bindings in [m], plus a binding of the key [k] to the datum [d]. If a binding from [k] to [d0] already exists, then the resulting map contains a binding from [k] to [decide d0 d]. *) exception Unchanged let basic_add decide k d m = let id = Key.id k in let rec add t = match t with | Empty -> wrap_Leaf k d | Leaf (k0, d0, _) -> if Key.equal k k0 then let d' = decide k d0 d in if d' == d0 then raise Unchanged else wrap_Leaf k d' else join (Key.id k) (wrap_Leaf k d) (Key.id k0) t | Branch (p, m, t0, t1, _) -> if match_prefix id p m then if (id land m) = 0 then wrap_Branch p m (add t0) t1 else wrap_Branch p m t0 (add t1) else join id (wrap_Leaf k d) p t in add m let fine_add decide k d m = try basic_add decide k d m with Unchanged -> m let add k d m = fine_add (fun _ _old_binding new_binding -> new_binding) k d m let singleton k d = wrap_Leaf k d let is_singleton htr = match htr with | Leaf (k, d, _) -> Some (k, d) | Empty | Branch _ -> None let is_empty htr = match htr with | Empty -> true | Leaf _ | Branch _ -> false let rec cardinal htr = match htr with | Empty -> 0 | Leaf _ -> 1 | Branch (_, _, t0, t1, _) -> cardinal t0 + cardinal t1 let remove key m = let id = Key.id key in let rec remove htr = match htr with | Empty -> raise Not_found | Leaf (key', _, _) -> if Key.equal key key' then Empty else raise Not_found | Branch (prefix, mask, tree0, tree1, _) -> if (id land mask) = 0 then let rtree0 = remove tree0 in match rtree0 with | Empty -> tree1 | _ -> wrap_Branch prefix mask rtree0 tree1 else let rtree1 = remove tree1 in match rtree1 with | Empty -> tree0 | _ -> wrap_Branch prefix mask tree0 rtree1 in try remove m with Not_found -> m (* (** [find_and_remove k m] looks up the value [v] associated to the key [k] in the map [m], and raises [Not_found] if no value is bound to [k]. The call returns the value [v], together with the map [m] deprived from the binding from [k] to [v]. *) let find_and_remove key htr = let id = Key.id key in let rec find_and_remove htr = match htr with | Empty -> raise Not_found | Leaf (key', data, _) -> if Key.equal key key' then data, Empty else raise Not_found | Branch (prefix, mask, tree0, tree1, _) -> if (id land mask) = 0 then match find_and_remove tree0 with | data, Empty -> data, tree1 | data, tree0 -> data, (wrap_Branch prefix mask tree0 tree1) else match find_and_remove tree1 with | data, Empty -> data, tree0 | data, tree1 -> data, (wrap_Branch prefix mask tree0 tree1) in find_and_remove htr *) (* [fine_union decide m1 m2] returns the union of the maps [m1] and [m2]. If a key [k] is bound to [x1] (resp. [x2]) within [m1] (resp. [m2]), then [decide] is called. It is passed [x1] and [x2], and must return the value which shall be bound to [k] in the final map. The operation returns [m2] itself (as opposed to a copy of it) when its result is equal to [m2]. *) let reverse decision k elem1 elem2 = decision k elem2 elem1 let fine_union decide m1 m2 = let rec union s t = match s, t with | Empty, _ -> t | (Leaf _ | Branch _), Empty -> s | Leaf(key, value, _), _ -> fine_add (reverse decide) key value t | Branch _, Leaf(key, value, _) -> fine_add decide key value s | Branch(p, m, s0, s1, _), Branch(q, n, t0, t1, _) -> if (p = q) & (m = n) then (* The trees have the same prefix. Merge their sub-trees. *) let u0 = union s0 t0 and u1 = union s1 t1 in if t0 == u0 && t1 == u1 then t else (wrap_Branch p m u0 u1) else if (Big_Endian.shorter m n) & (match_prefix q p m) then (* [q] contains [p]. Merge [t] with a sub-tree of [s]. *) if (q land m) = 0 then (wrap_Branch p m (union s0 t) s1) else (wrap_Branch p m s0 (union s1 t)) else if (Big_Endian.shorter n m) & (match_prefix p q n) then (* [p] contains [q]. Merge [s] with a sub-tree of [t]. *) if (p land n) = 0 then let u0 = union s t0 in if t0 == u0 then t else (wrap_Branch q n u0 t1) else let u1 = union s t1 in if t1 == u1 then t else (wrap_Branch q n t0 u1) else (* The prefixes disagree. *) join p s q t in union m1 m2 (** [union m1 m2] returns the union of the maps [m1] and [m2]. Bindings in [m2] take precedence over those in [m1]. The operation returns [m2] itself (as opposed to a copy of it) when its result is equal to [m2]. *) let union m1 m2 = fine_union (fun _ _ d' -> d') m1 m2 let rec fold f m accu = match m with | Empty -> accu | Leaf (key, data, _) -> f key data accu | Branch (_, _, tree0, tree1, _) -> fold f tree1 (fold f tree0 accu) let rec fold_rev f m accu = match m with | Empty -> accu | Leaf (key, data, _) -> f key data accu | Branch (_, _, tree0, tree1, _) -> fold_rev f tree0 (fold_rev f tree1 accu) let rec map f htr = match htr with | Empty -> Empty | Leaf (key, data, _) -> wrap_Leaf key (f data) | Branch (p, m, tree0, tree1, _) -> wrap_Branch p m (map f tree0) (map f tree1) (* The comment below is outdated: [map] and [endo_map] do not have the same signature for [f] *) (** [endo_map] is similar to [map], but attempts to physically share its result with its input. This saves memory when [f] is the identity function. *) let rec endo_map f tree = match tree with | Empty -> tree | Leaf (key, data, _) -> let data' = f key data in if data == data' then tree else wrap_Leaf key data' | Branch (p, m, tree0, tree1, _) -> let tree0' = endo_map f tree0 in let tree1' = endo_map f tree1 in if (tree0' == tree0) && (tree1' == tree1) then tree else wrap_Branch p m tree0' tree1' let generic_fine_add decide k d m = (* there is an implicit argument which is a tree with a single binding. Where the calls to [decide] are concerned, this implicit tree is the second one *) let id = Key.id k in let rec add t = match t with | Empty -> wrap_Leaf k (decide k None (Some d)) | Leaf (k0, d0, _) -> if Key.equal k k0 then let d' = decide k (Some d0) (Some d) in if d'==d0 then t else wrap_Leaf k d' else let endo = let decided = decide k0 (Some d0) None in if decided == d0 then t else wrap_Leaf k0 decided in join id (wrap_Leaf k (decide k None (Some d))) (Key.id k0) endo | Branch (p, m, t0, t1, _) -> if match_prefix id p m then if (id land m) = 0 then let a_t0 = add t0 in let endo = endo_map (fun k x -> decide k (Some x) None) t1 in if a_t0 == t0 && endo == t1 then t else wrap_Branch p m a_t0 endo else let a_t1 = add t1 in let endo = endo_map (fun k x -> decide k (Some x) None) t0 in if a_t1 == t1 && endo == t0 then t else wrap_Branch p m endo a_t1 else let endo = endo_map (fun k x -> decide k (Some x) None) t in join id (wrap_Leaf k (decide k None (Some d))) p endo in add m module Cacheable = struct type t = tt let hash = tag let sentinel = Empty let equal = (==) end module R = struct type t = tt let sentinel = Empty end let symetric_merge ~cache:_ ~decide_none ~decide_some = let symetric_fine_add k d m = (* this function to be called when one of the trees is a single binding *) let id = Key.id k in let rec add t = match t with | Empty -> wrap_Leaf k (decide_none k d ) | Leaf (k0, d0, _) -> if Key.equal k k0 then let d' = decide_some d0 d in if d'==d0 then t else wrap_Leaf k d' else let endo = let decid = decide_none k0 d0 in if decid == d0 then t else wrap_Leaf k0 decid in join id (wrap_Leaf k (decide_none k d)) (Key.id k0) endo | Branch (p, m, t0, t1, _) -> if match_prefix id p m then if (id land m) = 0 then let a_t0 = add t0 in let endo = endo_map decide_none t1 in if a_t0 == t0 && endo == t1 then t else wrap_Branch p m a_t0 endo else let a_t1 = add t1 in let endo = endo_map decide_none t0 in if a_t1 == t1 && endo == t0 then t else wrap_Branch p m endo a_t1 else let endo = endo_map decide_none t in join id (wrap_Leaf k (decide_none k d)) p endo in add m in let module SymetricCache = Binary_cache.Make_Symetric(Cacheable)(R) in clear_caches := SymetricCache.clear :: !clear_caches; let rec union s t = if s==t then s else SymetricCache.merge uncached_union s t and uncached_union s t = match s, t with | Empty, t | t, Empty -> endo_map decide_none t | Leaf(key, value, _), t | t, Leaf(key, value, _) -> symetric_fine_add key value t | Branch(p, m, s0, s1, _), Branch(q, n, t0, t1, _) -> if (p = q) & (m = n) then (* The trees have the same prefix. Merge their sub-trees. *) let u0 = union s0 t0 and u1 = union s1 t1 in if t0 == u0 && t1 == u1 then t else wrap_Branch p m u0 u1 else if (Big_Endian.shorter m n) & (match_prefix q p m) then (* [q] contains [p]. Merge [t] with a sub-tree of [s]. *) if (q land m) = 0 then let s0_t = union s0 t in let s1_e = union s1 Empty in if s0_t == s0 && s1_e == s1 then s else wrap_Branch p m s0_t s1_e else let s0_e = union s0 Empty in let s1_t = union s1 t in if s0_e == s0 && s1_t == s1 then s else wrap_Branch p m s0_e s1_t else if (Big_Endian.shorter n m) & (match_prefix p q n) then (* [p] contains [q]. Merge [s] with a sub-tree of [t]. *) if (p land n) = 0 then let s_t0 = union s t0 in let e_t1 = union Empty t1 in if t0 == s_t0 && e_t1 == t1 then t else wrap_Branch q n s_t0 e_t1 else let s_t1 = union s t1 in let e_t0 = union Empty t0 in if t1 == s_t1 && e_t0 == t0 then t else wrap_Branch q n e_t0 s_t1 else (* The prefixes disagree. *) join p (union s Empty) q (union Empty t) in union let generic_merge ~cache ~decide = let _name, cache_size = cache in let cache_merge = if cache_size = 0 then fun f x y -> f x y else begin let module Cache = Binary_cache.Make_Asymetric(Cacheable)(R) in clear_caches := Cache.clear :: !clear_caches; Cache.merge end in let rec union s t = if s==t then s else cache_merge compute s t and compute s t = match s, t with | Empty, _ -> endo_map (fun k x -> decide k None (Some x)) t | (Leaf _ | Branch _), Empty -> endo_map (fun k x -> decide k (Some x) None) s | Leaf(key, value, _), _ -> generic_fine_add (reverse decide) key value t | Branch _, Leaf(key, value, _) -> generic_fine_add decide key value s | Branch(p, m, s0, s1, _), Branch(q, n, t0, t1, _) -> if (p = q) & (m = n) then (* The trees have the same prefix. Merge their sub-trees. *) let u0 = union s0 t0 and u1 = union s1 t1 in if t0 == u0 && t1 == u1 then t else wrap_Branch p m u0 u1 else if (Big_Endian.shorter m n) & (match_prefix q p m) then (* [q] contains [p]. Merge [t] with a sub-tree of [s]. *) if (q land m) = 0 then let s0_t = union s0 t in let s1_e = union s1 Empty in if s0_t == s0 && s1_e == s1 then s else wrap_Branch p m s0_t s1_e else let s0_e = union s0 Empty in let s1_t = union s1 t in if s0_e == s0 && s1_t == s1 then s else wrap_Branch p m s0_e s1_t else if (Big_Endian.shorter n m) & (match_prefix p q n) then (* [p] contains [q]. Merge [s] with a sub-tree of [t]. *) if (p land n) = 0 then let s_t0 = union s t0 in let e_t1 = union Empty t1 in if t0 == s_t0 && e_t1 == t1 then t else wrap_Branch q n s_t0 e_t1 else let s_t1 = union s t1 in let e_t0 = union Empty t0 in if t1 == s_t1 && e_t0 == t0 then t else wrap_Branch q n e_t0 s_t1 else (* The prefixes disagree. *) join p (union s Empty) q (union Empty t) in union let do_it_intersect s t = match s, t with Empty, _ | _, Empty -> false | _ -> if s == t then raise Found_inter else true let make_predicate cache_merge exn do_it ~decide_fst ~decide_snd ~decide_both = let rec inclusion s t = if do_it s t then match s, t with | Empty, _ -> iter decide_snd t | (Leaf _ | Branch _), Empty -> iter decide_fst s | Leaf(k1, v1, _), Leaf(k2, v2, _) -> if Key.id k1 = Key.id k2 then decide_both v1 v2 else begin decide_fst k1 v1; decide_snd k2 v2; end | Leaf(key, _value, _), Branch(p,m,l,r,_) -> let i = Key.id key in if i < p+m then begin inclusion s l; inclusion Empty r; end else begin inclusion Empty l; inclusion s r; end | Branch (p,m,l,r,_) , Leaf(key, _value, _) -> let i = Key.id key in if i < p+m then begin inclusion l t; inclusion r Empty; end else begin inclusion l Empty; inclusion r t; end | Branch _, Branch _ -> (* Beware that [compute] may swap its arguments. Do not use the result of an earlier match *) let compute s t = match s, t with | Branch(p, m, s0, s1, _), Branch(q, n, t0, t1, _) -> begin try if (p = q) & (m = n) then begin (* The trees have the same prefix. Compare their sub-trees. *) inclusion s0 t0; inclusion s1 t1 end else if (Big_Endian.shorter m n) & (match_prefix q p m) then (* [q] contains [p]. Compare [t] with a sub-tree of [s]. *) if (q land m) = 0 then begin inclusion s0 t; inclusion s1 Empty; end else begin inclusion s0 Empty; inclusion s1 t end else if (Big_Endian.shorter n m) & (match_prefix p q n) then (* [p] contains [q]. Compare [s] with a sub-tree of [t]. *) if (p land n) = 0 then begin inclusion s t0; inclusion Empty t1 end else begin inclusion s t1; inclusion Empty t0 end else begin (* The prefixes disagree. *) inclusion s Empty; inclusion Empty t; end; true with e when e = exn -> false | _ -> assert false end | _ -> assert false (* Branch/Branch comparison *) in let result = cache_merge compute s t in if not result then raise exn in inclusion let generic_is_included exn ~cache ~decide_fst ~decide_snd ~decide_both = let cache_name, _cache_size = cache in let use_comp = if cache_name = "lmap" then (fun s t -> if s==t then false else ((if comp t then raise exn); true)) else (fun s t -> s != t) in let module Cache = Binary_cache.Make_Binary(Cacheable)(Cacheable) in clear_caches := Cache.clear :: !clear_caches; make_predicate Cache.merge exn use_comp ~decide_fst ~decide_snd ~decide_both let generic_symetric_existential_predicate exn do_it ~decide_one ~decide_both = let module Cache = Binary_cache.Make_Symetric_Binary(Cacheable) in clear_caches := Cache.clear :: !clear_caches; make_predicate Cache.merge exn do_it ~decide_fst:decide_one ~decide_snd:decide_one ~decide_both let cached_fold ~cache ~temporary ~f ~joiner ~empty = let _name, cache_size = cache in let table = Hashtbl.create cache_size in if not temporary then clear_caches := (fun () -> Hashtbl.clear table) :: !clear_caches; let counter = ref 0 in fun m -> let rec traverse t = match t with Empty -> empty | Leaf(key, value, _) -> f key value | Branch(_p, _m, s0, s1, _) -> try let result = Hashtbl.find table t in (* Format.printf "find %s %d@." name !counter; *) result with Not_found -> let result0 = traverse s0 in let result1 = traverse s1 in let result = joiner result0 result1 in incr counter; if !counter >= cache_size then begin (* Format.printf "Clearing %s fold table@." name;*) Hashtbl.clear table; counter := 0; end; (* Format.printf "add %s %d@." name !counter; *) Hashtbl.add table t result; result in traverse m let cached_map ~cache ~temporary ~f = let _name, cache = cache in let table = Hashtbl.create cache in if not temporary then clear_caches := (fun () -> Hashtbl.clear table) :: !clear_caches; let counter = ref 0 in fun m -> let rec traverse t = match t with Empty -> empty | Leaf(key, value, _) -> wrap_Leaf key (f key value) | Branch(p, m, s0, s1, _) -> try let result = Hashtbl.find table t in (* Format.printf "find %s %d@." name !counter; *) result with Not_found -> let result0 = traverse s0 in let result1 = traverse s1 in let result = wrap_Branch p m result0 result1 in incr counter; if !counter >= cache then begin (* Format.printf "Clearing %s fold table@." name;*) Hashtbl.clear table; counter := 0; end; (* Format.printf "add %s %d@." name !counter; *) Hashtbl.add table t result; result in traverse m let split key htr = let id = Key.id key in let rec aux = function | Empty -> (Empty, None, Empty) | Leaf (key', data, _) -> if Key.equal key key' then (Empty, Some data, Empty) else (Empty, None, Empty) | Branch(_, mask, l, r, _) -> if (id land mask) = 0 then let (ll, pres, rl) = aux l in (ll, pres, union rl r) else let (lr, pres, rr) = aux r in (union l lr, pres, rr) in aux htr let clear_caches () = List.iter (fun f -> f ()) !clear_caches end (* Local Variables: compile-command: "make -C .." End: *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/external/hptmap.mli�������������������������������������������������������0000644�0001750�0001750�00000013354�12155630367�017631� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file was originally part of Menhir *) (* *) (* Franois Pottier and Yann Rgis-Gianas, INRIA Rocquencourt *) (* *) (* Copyright 2005 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0, with the *) (* change described in the file licences/Q_MODIFIED_LICENSE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives). *) (* *) (**************************************************************************) (** Undocumented. *) exception Found_inter module Tag_comp : sig type t val get_tag : t -> int val get_comp : t -> bool val encode : int -> bool -> t end module Comp_unused : sig val e : bool val f : 'a -> 'b -> bool val compose : bool -> bool -> bool val default : bool end type prefix val sentinel_prefix : prefix type ('k, 'v, 't) tree = private | Empty | Leaf of 'k * 'v * bool | Branch of int * int * ('k, 'v, 't) tree * ('k, 'v, 't) tree * 't module Make (Key:sig include Datatype.S val id: t -> int end) (V : Datatype.S) (Comp : sig val e: bool val f : Key.t -> V.t -> bool val compose : bool -> bool -> bool val default:bool end) (Initial_Values : sig val v : (Key.t*V.t) list list end) (Datatype_deps: sig val l : State.t list end) : sig type key = Key.t type leaf_annot = bool type branch_annot = Tag_comp.t type tt = (Key.t, V.t, Tag_comp.t) tree include Datatype.S_with_collections with type t = tt val self : State.t val empty : t (* the tag is no longer guaranteed to uniquely identify a Patricia tree, so this function will be renamed "hash" in the future *) val tag : t -> int val hash_debug : t -> int val is_empty : t -> bool (** [is_empty m] returns [true] if and only if the map [m] defines no bindings at all. *) val add : key -> V.t -> t -> t (** [add k d m] returns a map whose bindings are all bindings in [m], plus a binding of the key [k] to the datum [d]. If a binding already exists for [k], it is overridden. *) val find : key -> t -> V.t val remove : key -> t -> t (** [remove k m] returns the map [m] deprived from any binding involving [k]. *) val mem : key -> t -> bool val iter : (Key.t -> V.t -> unit) -> t -> unit val map : (V.t -> V.t) -> t -> t (** [map f m] returns the map obtained by composing the map [m] with the function [f]; that is, the map $k\mapsto f(m(k))$. *) val fold : (Key.t -> V.t -> 'b -> 'b) -> t -> 'b -> 'b (** [fold f m seed] invokes [f k d accu], in turn, for each binding from key [k] to datum [d] in the map [m]. Keys are presented to [f] in increasing order according to the map's ordering. The initial value of [accu] is [seed]; then, at each new call, its value is the value returned by the previous invocation of [f]. The value returned by [fold] is the final value of [accu]. *) val fold_rev : (Key.t -> V.t -> 'b -> 'b) -> t -> 'b -> 'b (** [fold_rev] performs exactly the same job as [fold], but presents keys to [f] in the opposite order. *) val comp_prefixes : t -> t -> unit val pretty_prefix : prefix -> Format.formatter -> t -> unit type subtree exception Found_prefix of prefix * subtree * subtree val find_prefix : t -> prefix -> subtree option val hash_subtree : subtree -> int val equal_subtree : subtree -> subtree -> bool val generic_merge : cache:(string * int) -> decide:(Key.t -> V.t option -> V.t option -> V.t) -> t -> t -> t val symetric_merge : cache:(string * int) -> decide_none:(Key.t -> V.t -> V.t) -> decide_some:(V.t -> V.t -> V.t) -> t -> t -> t val generic_is_included : exn -> cache:(string * int) -> decide_fst:(Key.t -> V.t -> unit) -> decide_snd:(Key.t -> V.t -> unit) -> decide_both:(V.t -> V.t -> unit) -> t -> t -> unit val generic_symetric_existential_predicate : exn -> (t -> t -> bool) -> decide_one:(Key.t -> V.t -> unit) -> decide_both:(V.t -> V.t -> unit) -> t -> t -> unit val do_it_intersect : t -> t -> bool val cached_fold : cache:string * int -> temporary:bool -> f:(key -> V.t -> 'b) -> joiner:('b -> 'b -> 'b) -> empty:'b -> t -> 'b val cached_map : cache:string * int -> temporary:bool -> f:(key -> V.t -> V.t) -> t -> t val singleton: key -> V.t -> t (** [singleton k d] returns a map whose only binding is from [k] to [d]. *) val is_singleton: t -> (key * V.t) option (** [is_singleton m] returns [Some (k, d)] if [m] is a singleton map that maps [k] to [d]. Otherwise, it returns [None]. *) val cardinal: t -> int (** [cardinal m] returns [m]'s cardinal, that is, the number of keys it binds, or, in other words, its domain's cardinal. *) val min_binding: t -> key * V.t val max_binding: t -> key * V.t val split: key -> t -> t * V.t option * t (** Clear all the caches used internally by the functions of this module. Those caches are not project-aware, so this function must be called at least each a project switch occurs. *) val clear_caches: unit -> unit end (* Local Variables: compile-command: "make -C .." End: *) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/external/unmarshal_test.ml������������������������������������������������0000644�0001750�0001750�00000020634�12155630367�021217� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* Copyright (C) 2009-2012 INRIA *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* * Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* * Redistributions in binary form must reproduce the above *) (* copyright notice, this list of conditions and the following *) (* disclaimer in the documentation and/or other materials provided *) (* with the distribution. *) (* * Neither the name of the <organization> nor the names of its *) (* contributors may be used to endorse or promote products derived *) (* from this software without specific prior written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY <INRIA> ''AS IS'' AND ANY *) (* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE *) (* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE *) (* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR *) (* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT *) (* OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR *) (* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT *) (* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE *) (* USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *) (* DAMAGE. *) (* *) (**************************************************************************) (* caml_unmarshal by Ineffable Casters *) (* Version 3.11.1.8 *) (* Basic testing only. *) open Printf;; open Unmarshal;; (* 0. Identification. *) printf "Testing: ";; if arch_sixtyfour then printf "64-bit " else printf "32-bit " ;; if arch_bigendian then printf "big-endian " else printf "little-endian " ;; match (Obj.magic 1.23530711838574823e-307 : string).[1] with | '1' -> printf "(floats are little-endian)...\n" | '6' -> printf "(floats are big-endian)...\n" | '5' -> printf "(floats are ARM-style mixed-endian)...\n" | _ -> printf "(floats have unknown endianness)...\n" ;; flush stdout;; (* 1. Testing without transformation function. *) let wrt v t = let oc = open_out_bin "test-file" in Marshal.to_channel oc v [Marshal.Closures]; close_out oc; let ic = open_in_bin "test-file" in let result = input_val ic t in close_in ic; result ;; let wr v = wrt v Abstract;; let check cond msg = if not cond then failwith (sprintf "test failed (%s)" msg) ;; let counter = ref 0;; let test v = incr counter; check (wr v = v) (sprintf "wr%d" !counter); ;; (* SMALL_INT, INT8, INT16, INT32, INT64 *) for i = -130 to 130 do test i; done;; for i = -32780 to -32750 do test i; done;; for i = 32750 to -32780 do test i; done;; test (-1_000_000);; test 1_000_000_000;; test (1 lsl 60);; test (-1 lsl 60);; test max_int;; test min_int;; (* SMALL_STRING, STRING8, STRING32 *) test "short";; for i = 0 to 40 do test (String.create i) done;; for i = 250 to 260 do test (String.create i) done;; test (String.create 1255);; (* DOUBLE_*, DOUBLE_ARRAY8_*, DOUBLE_ARRAY32_* *) test 0.0;; test 1.0;; test infinity;; test (-. infinity);; test 1.234e-225;; for i = 0 to 300 do test (Array.init i float_of_int) done;; (* SMALL_BLOCK, BLOCK32 *) test [1; 2; 3];; type t0 = | C01 of int | C02 of int * int | C03 of int * int * int | C04 of int * int * int * int | C05 of int * int * int * int * int | C06 of int * int * int * int * int * int | C07 of int * int * int * int * int * int * int | C08 of int | C09 of int * int * int * int * int * int * int | C10 of int * int * int * int * int * int | C11 of int * int * int * int * int | C12 of int * int * int * int | C13 of int * int * int | C14 of int * int | C15 of int | C16 of int * int * int * int * int * int * int * int ;; test [ C01 (1); C02 (1, 2); C03 (1, 2, 3); C04 (1, 2, 3, 4); C05 (1, 2, 3, 4, 5); C06 (1, 2, 3, 4, 5, 6); C07 (1, 2, 3, 4, 5, 6, 7); C08 (1); C09 (1, 2, 3, 4, 5, 6, 7); C10 (1, 2, 3, 4, 5, 6); C11 (1, 2, 3, 4, 5); C12 (1, 2, 3, 4); C13 (1, 2, 3); C14 (1, 2); C15 (1); C16 (1, 2, 3, 4, 5, 6, 7, 8); ];; type t1 = | A | B of int | C of float | D of bool | E | F | G | H | I | J ;; test [A; B 10; C 100.; D false; E; F; G; H; I];; (* SHARED8 *) let rec l = J :: I :: H :: G :: F :: E :: D true :: C 1e100 :: B (-1000) :: A :: l in let v = wr l in for i = 0 to 9; do check (List.nth l i = List.nth v i) "share1"; check (List.nth v i == List.nth v (i + 10)) "share2"; done;; let a = ref 0;; let b = ref 1;; let x = Array.make 1_000_000 a;; for i = 1 to 499_999 do x.(2 * i) <- b done;; let v = (wr x : int ref array);; check (v.(0) == v.(1)) "share3";; check (v.(1) == v.(999_999)) "share4";; check (v.(2) == v.(400_000)) "share5";; check (v.(2) == v.(999_998)) "share6";; (* SHARED8, SHARED16, SHARED32 *) for i = 1 to 499_999 do x.(2 * i) <- ref i done;; let v = (wr x : int ref array);; v.(0) := -1;; for i = 1 to 499_999 do check (!(v.(2 * i)) = i) "share7"; check (v.(2 * i + 1) == v.(0)) "share8"; done;; (* CODEPOINTER *) let raw_value x = let result = Obj.dup (Obj.repr 0L) in let foo = (Obj.obj result : Int64.t) in Obj.set_field result 1 (Obj.repr x); foo ;; let value_raw x = Obj.field (Obj.repr x) 1;; let x = fun x -> (x + 1);; let v = (wr x : int -> int);; check (v 0 = 1) "code1";; let x = let a = 1 in let b = 2 in fun x -> (x + a, x + b) ;; let v = (wr x : int -> int * int);; check (fst (v 10) = 11) "code2";; check (snd (v 10) = 12) "code3";; (* INFIXPOINTER *) let rec f x = if x = 0 then g x else x + 10 and g x = if x <> 0 then f x else x + 20 ;; let v = (wr f : int -> int);; check (v 0 = 20) "infix0";; check (v 5 = 15) "infix1";; let w = (wr g : int -> int);; check (w 0 = 20) "infix2";; check (w 5 = 15) "infix3";; (* CUSTOM *) test 0l;; test 1l;; test 0x7FFFFFFFl;; test 0x80000000l;; test 0L;; test (-1L);; test 0x7fffffffffffffffL;; test 0x8000000000000000L;; test 0n;; test 1n;; test 10n;; test 0x7fffffffn;; test 0x80000000n;; open Num;; ignore Unmarshal_nums.t_num;; let test v = incr counter; check (string_of_num (wr (num_of_string v)) = v) (sprintf "num%d" !counter); ;; test "0";; test "1";; test "-1";; test "100000000000000000000000000000000";; test "77777777777777777777777777777/2222222222222222222222";; test "-314159265358979/2718281828";; (* 2. Testing with transformation functions. *) let v = [1; 2; 3; 4; 5; 12847];; let double x = let x = (Obj.obj x : int) in Obj.repr (x + x);; let t_list2 = t_list (Transform (t_int, double));; let test v = incr counter; let w = wrt v t_list2 in let f x y = check (x + x = y) (sprintf "list2-%d" !counter) in List.iter2 f v w; ;; test v;; let t_list3 = t_list (Return (t_int, fun () -> (Obj.repr 1)));; let test v ty = incr counter; let w = wrt v ty in let f x y = check (1 = y) (sprintf "list3-%d" !counter) in List.iter2 f v w; ;; test v t_list3;; let t_list4 = Dynamic (fun () -> t_list3);; test v t_list4;; (* 3. Testing multi-allocated constructors. *) type t = A of int * int | B of int let l = [ A (3, 4); B 5 ] let t_l = t_list (Structure (Sum [| [| Abstract; Abstract |]; [| Abstract |] |]));; let test v ty = incr counter; let w = wrt v ty in check (v = w) (sprintf "list3-%d" !counter) ;; test l t_l;; (* 4. Conclusion. *) printf "All tests passed.\n";; ����������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/external/unmarshal_nums.mli�����������������������������������������������0000644�0001750�0001750�00000006350�12155630367�021372� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* Copyright (C) 2009-2012 INRIA *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* * Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* * Redistributions in binary form must reproduce the above *) (* copyright notice, this list of conditions and the following *) (* disclaimer in the documentation and/or other materials provided *) (* with the distribution. *) (* * Neither the name of the <organization> nor the names of its *) (* contributors may be used to endorse or promote products derived *) (* from this software without specific prior written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY <INRIA> ''AS IS'' AND ANY *) (* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE *) (* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE *) (* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR *) (* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT *) (* OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR *) (* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT *) (* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE *) (* USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *) (* DAMAGE. *) (* *) (**************************************************************************) (* caml_unmarshal by Ineffable Casters *) (* Version 3.11.1.8 *) (** Extends {!Unmarshal} to deal with the data types of the [Nums] library. You must make sure that this module is linked with your program, by using one of the values declared below. If you don't need them in your program (for example because you are using [Unmarshal.Abstract] for all your BigNums), you should add the following line to one of your source files. - [ignore Unmarshal_nums.t_num;;] *) val t_nat : Unmarshal.t;; val t_big_int : Unmarshal.t;; val t_ratio : Unmarshal.t;; val t_num : Unmarshal.t;; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/external/unmarshal.ml�����������������������������������������������������0000644�0001750�0001750�00000054040�12155630367�020156� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* Copyright (C) 2009-2012 INRIA *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* * Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* * Redistributions in binary form must reproduce the above *) (* copyright notice, this list of conditions and the following *) (* disclaimer in the documentation and/or other materials provided *) (* with the distribution. *) (* * Neither the name of the <organization> nor the names of its *) (* contributors may be used to endorse or promote products derived *) (* from this software without specific prior written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY <INRIA> ''AS IS'' AND ANY *) (* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE *) (* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE *) (* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR *) (* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT *) (* OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR *) (* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT *) (* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE *) (* USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *) (* DAMAGE. *) (* *) (**************************************************************************) (* caml_unmarshal by Ineffable Casters *) (* Version 3.11.2.0 *) (* Warning: If you are new to OCaml, don't take this as an example of good code. *) type t = | Abstract | Structure of structure | Transform of t * (Obj.t -> Obj.t) | Return of t * (unit -> Obj.t) | Dynamic of (unit -> t) and structure = | Sum of t array array | Dependent_pair of t * (Obj.t -> t) | Array of t ;; let arch_sixtyfour = Sys.word_size = 64;; let arch_bigendian = (Obj.magic [| 0x00002600 |] : string).[1] <> 'L';; let arch_float_endianness = (Obj.magic 1.23530711838574823e-307 : string).[1];; let intext_magic_number = "\x84\x95\xA6\xBE";; let ill_formed () = failwith "input_value: ill-formed message" let zeroword = Obj.field (Obj.repr 0L) 0;; let null = zeroword;; let id x = x;; (* Functions for deserializers. *) let getword ch = let c3 = Char.code (input_char ch) in let c2 = Char.code (input_char ch) in let c1 = Char.code (input_char ch) in let c0 = Char.code (input_char ch) in Int32.logor (Int32.shift_left (Int32.of_int c3) 24) (Int32.of_int ((c2 lsl 16) lor (c1 lsl 8) lor c0)) ;; let read8s ch = let c = Char.code (input_char ch) in if c < 128 then c else c lor (-1 lsl 8) ;; let read16s ch = let c1 = Char.code (input_char ch) in let c0 = Char.code (input_char ch) in let c1x = if c1 < 128 then c1 else c1 lor (-1 lsl 8) in (c1x lsl 8) lor c0 ;; let read32s ch = let c3 = Char.code (input_char ch) in let c2 = Char.code (input_char ch) in let c1 = Char.code (input_char ch) in let c0 = Char.code (input_char ch) in let c3x = if c3 < 128 then c3 else c3 lor (-1 lsl 8) in (c3x lsl 24) lor (c2 lsl 16) lor (c1 lsl 8) lor c0 ;; let read64s = if arch_sixtyfour then begin fun ch -> let c7 = Char.code (input_char ch) in let c6 = Char.code (input_char ch) in let c5 = Char.code (input_char ch) in let c4 = Char.code (input_char ch) in let c3 = Char.code (input_char ch) in let c2 = Char.code (input_char ch) in let c1 = Char.code (input_char ch) in let c0 = Char.code (input_char ch) in (c7 lsl 56) lor (c6 lsl 48) lor (c5 lsl 40) lor (c4 lsl 32) lor (c3 lsl 24) lor (c2 lsl 16) lor (c1 lsl 8) lor c0 end else begin fun _ -> failwith "input_value: integer too large" end ;; let read8u ch = Char.code (input_char ch);; let read16u ch = let c1 = Char.code (input_char ch) in let c0 = Char.code (input_char ch) in (c1 lsl 8) lor c0 ;; let read32u ch = let c3 = Char.code (input_char ch) in let c2 = Char.code (input_char ch) in let c1 = Char.code (input_char ch) in let c0 = Char.code (input_char ch) in (c3 lsl 24) lor (c2 lsl 16) lor (c1 lsl 8) lor c0 ;; let read64u = read64s;; let readheader32 ch = let c3 = Char.code (input_char ch) in let c2 = Char.code (input_char ch) in let c1 = Char.code (input_char ch) in let c0 = Char.code (input_char ch) in (c0, (c1 lsr 2) lor (c2 lsl 6) lor (c3 lsl 14)) ;; let readheader64 = if arch_sixtyfour then begin fun ch -> let c7 = Char.code (input_char ch) in let c6 = Char.code (input_char ch) in let c5 = Char.code (input_char ch) in let c4 = Char.code (input_char ch) in let c3 = Char.code (input_char ch) in let c2 = Char.code (input_char ch) in let c1 = Char.code (input_char ch) in let c0 = Char.code (input_char ch) in (c0, (c1 lsr 2) lor (c2 lsr 6) lor (c3 lsr 14) lor (c4 lsr 22) lor (c5 lsr 30) lor (c6 lsr 38) lor (c7 lsr 46)) end else begin fun _ -> failwith "input_value: data block too large" end ;; let readblock ch dest ofs len = unsafe_really_input ch (Obj.obj dest : string) ofs len ;; let readblock_rev ch dest ofs len = for i = len - 1 + ofs downto ofs do String.unsafe_set (Obj.obj dest : string) i (input_char ch); done ;; (* Auxiliary functions for handling floats. *) let readfloat_same ch v i = readblock ch v (i * 8) 8;; let readfloat_reverse ch v i = readblock_rev ch v (i * 8) 8;; let readfloat_little = match arch_float_endianness with | '1' -> readfloat_same | '6' -> readfloat_reverse | '5' -> begin fun ch v i -> readblock ch v (i * 8 + 4) 4; readblock ch v (i * 8) 4; end | _ -> fun _ch _v _i -> failwith "input_value: non-standard floats" ;; let readfloat_big = match arch_float_endianness with | '1' -> readfloat_reverse | '6' -> readfloat_same | '5' -> begin fun ch v i -> readblock_rev ch v (i * 8) 4; readblock_rev ch v (i * 8 + 4) 4; end | _ -> fun _ch _v _i -> failwith "input_value: non-standard floats" ;; (* Auxiliary functions for handling closures. *) let (code_area_start, cksum) = let s = Marshal.to_string id [Marshal.Closures] in let cksum = String.sub s 0x1E 16 in let c0 = Char.code s.[0x1D] in let c1 = Char.code s.[0x1C] in let c2 = Char.code s.[0x1B] in let c3 = Char.code s.[0x1A] in let ofs = Int32.logor (Int32.shift_left (Int32.of_int c3) 24) (Int32.of_int ((c2 lsl 16) lor (c1 lsl 8) lor c0)) in let start = Obj.add_offset (Obj.field (Obj.repr id) 0) (Int32.neg ofs) in (start, cksum) ;; let check_const ch s msg = for i = 0 to String.length s - 1 do if input_char ch <> s.[i] then failwith msg; done ;; (* Auxiliary functions for handling Custom blocks. *) let buflen = 100;; let buf = String.create buflen;; let bufs = ref [];; let read_customident ch = let rec loop i = let c = input_char ch in if c = '\000' then begin if !bufs = [] then String.sub buf 0 i else begin let res = String.concat "" (List.rev (String.sub buf 0 i :: !bufs)) in bufs := []; res end end else if i >= buflen then begin assert (i = buflen); bufs := String.copy buf :: !bufs; loop 0 end else begin buf.[i] <- c; loop (i + 1) end in loop 0 ;; let custom_table = (Hashtbl.create 13 : (string, in_channel -> Obj.t) Hashtbl.t) ;; let register_custom id f = Hashtbl.add custom_table id f;; let read_custom ch id = try (Hashtbl.find custom_table id) ch with Not_found -> failwith ("input_value: unknown custom data type: " ^ id) ;; (* Large arrays. *) (* Wish there were a way to do it conditionally on Sys.word_size *) module LA = struct type 'a t = 'a array array;; let inner_sz_log = 21;; let inner_sz = 1 lsl inner_sz_log;; let mask = inner_sz - 1;; let make size init : _ t = let outer_sz = size / inner_sz + 1 in let res = Array.make outer_sz [| |] in let rec loop sz i = if sz > inner_sz then begin res.(i) <- Array.make inner_sz init; loop (sz - inner_sz) (i + 1); end else begin res.(i) <- Array.make sz init; end in loop size 0; res ;; let get a i = a.(i asr inner_sz_log).(i land mask);; let set a i v = a.(i asr inner_sz_log).(i land mask) <- v;; end (* Main function. *) type frame = { st_ty : t; st_ctr : int; st_constr : int; mutable st_cur : int; st_obj : Obj.t; };; let rec get_field_type t tag i prev = match t with | Abstract -> Abstract | Structure (Sum a) -> a.(tag).(i) | Structure (Dependent_pair(a, _f)) when i = 0 -> a | Structure (Dependent_pair(_a, f)) when i = 1 -> f prev | Structure (Dependent_pair(_a, _f)) -> assert false | Structure (Array a) -> a | Transform (t1, _) -> get_field_type t1 tag i prev | Return (t1, _) -> get_field_type t1 tag i prev | Dynamic _ -> assert false ;; let rec do_transform t v = match t with | Abstract | Structure _ -> v | Transform (t1, f) -> f (do_transform t1 v) | Return (t1, f) -> ignore (do_transform t1 v); f () | Dynamic _ -> assert false ;; let rec get_structure t context = match t with | Abstract | Structure _ -> (t, context) | Transform (t1, _) -> get_structure t1 true | Return (t1, _) -> get_structure t1 false | Dynamic _ -> assert false ;; let input_val ch t = set_binary_mode_in ch true; check_const ch intext_magic_number "input_value: bad object"; let _block_len = getword ch in let num_objects = read32u ch in let _size_32 = getword ch in let _size_64 = getword ch in let tbl = LA.make num_objects null in let patch = LA.make num_objects [] in let ctr = ref 0 in let rec intern_rec stk t = let read_ch () = let code = read8u ch in match code with | 0x00 (* CODE_INT8 *) -> let v = Obj.repr (read8s ch) in return stk (do_transform t v) | 0x01 (* CODE_INT16 *) -> let v = Obj.repr (read16s ch) in return stk (do_transform t v) | 0x02 (* CODE_INT32 *) -> let v = Obj.repr (read32s ch) in return stk (do_transform t v) | 0x03 (* CODE_INT64 *) -> if arch_sixtyfour then begin let v = Obj.repr (read64s ch) in return stk (do_transform t v) end else begin failwith "input_value: integer too large" end | 0x04 (* CODE_SHARED8 *) -> let ofs = read8u ch in read_shared stk ofs | 0x05 (* CODE_SHARED16 *) -> let ofs = read16u ch in read_shared stk ofs | 0x06 (* CODE_SHARED32 *) -> let ofs = read32u ch in read_shared stk ofs | 0x08 (* CODE_BLOCK32 *) -> let (tag, size) = readheader32 ch in read_block stk t tag size | 0x13 (* CODE_BLOCK64 *) -> let (tag, size) = readheader64 ch in read_block stk t tag size | 0x09 (* CODE_STRING8 *) -> let len = read8u ch in read_string stk t len | 0x0A (* CODE_STRING32 *) -> let len = read32u ch in read_string stk t len | 0x0C (* CODE_DOUBLE_LITTLE *) -> read_double stk t readfloat_little | 0x0B (* CODE_DOUBLE_BIG *) -> read_double stk t readfloat_big | 0x0E (* CODE_DOUBLE_ARRAY8_LITTLE *) -> let len = read8u ch in read_double_array stk t len readfloat_little | 0x0D (* CODE_DOUBLE_ARRAY8_BIG *) -> let len = read8u ch in read_double_array stk t len readfloat_big | 0x07 (* CODE_DOUBLE_ARRAY32_LITTLE *) -> let len = read32u ch in read_double_array stk t len readfloat_little | 0x0F (* CODE_DOUBLE_ARRAY32_BIG *) -> let len = read32u ch in read_double_array stk t len readfloat_big | 0x10 (* CODE_CODEPOINTER *) -> let ofs = getword ch in check_const ch cksum "input_value: code mismatch"; let offset_pointer = Obj.add_offset code_area_start ofs in return stk (do_transform t offset_pointer) | 0x11 (* CODE_INFIXPOINTER *) -> let ofs = getword ch in let clos = intern_rec [] t in return stk (Obj.add_offset (Obj.repr clos) ofs) | 0x12 (* CODE_CUSTOM *) -> let id = read_customident ch in let v = read_custom ch id in let dest = !ctr in ctr := dest + 1; return_block stk t v dest | _ when code >= 0x80 (* PREFIX_SMALL_BLOCK *) -> let tag = code land 0xF in let size = (code lsr 4) land 0x7 in read_block stk t tag size | _ when code >= 0x40 (* PREFIX_SMALL_INT *) -> let v = Obj.repr (code land 0x3F) in return stk (do_transform t v) | _ when code >= 0x20 (* PREFIX_SMALL_STRING *) -> let len = code land 0x1F in read_string stk t len | _ -> (* Format.printf "code %x@." code;*) ill_formed () in match t with | Dynamic f -> intern_rec stk (f ()) | Abstract | Structure (Array _ | Sum _ | Dependent_pair _) | Transform _ | Return _ -> read_ch () and read_block stk t tag size = (* read one block of the given tag and size *) let (t1, alloc) = get_structure t true in begin match t1 with | Abstract -> () | Structure (Dependent_pair(_, _)) -> if tag >= 1 || size != 2 then begin (* Format.printf "dep couple@.";*) ill_formed () end | Structure (Sum a) -> if tag >= Array.length a || size != Array.length a.(tag) then begin (*structure sum tag=0 size=2 len=1 len-tag=1*) (* Format.printf "structure sum tag=%d size=%d len=%d len-tag=%d@." tag size (Array.length a) (Array.length a.(tag));*) ill_formed () end | Structure (Array _) -> () | _ -> assert false end; let v = if alloc then Obj.new_block tag size else Obj.repr size in if size > 0 then begin let fr = { st_ty = t; st_ctr = !ctr; st_constr = tag; st_cur = 0; st_obj = v; } in let t2 = get_field_type t tag 0 (Obj.repr 0) in ctr := !ctr + 1; intern_rec (fr :: stk) t2 end else begin return stk (do_transform t v) end and read_string stk t len = let v = Obj.repr (String.create len) in readblock ch v 0 len; let dest = !ctr in ctr := dest + 1; return_block stk t v dest and read_double stk t readfloat = let v = Obj.dup (Obj.repr 1.0) in readfloat ch v 0; let dest = !ctr in ctr := dest + 1; return_block stk t v dest and read_double_array stk t len readfloat = let v = Obj.repr (Array.make len 0.0) in for i = 0 to len - 1 do readfloat ch v i done; let dest = !ctr in ctr := dest + 1; return_block stk t v dest and read_shared stk ofs = if ofs <= 0 || ofs > !ctr then begin (*Format.printf "shared@.";*) ill_formed () end; let v = LA.get tbl (!ctr - ofs) in if v == null then begin match stk with | [] -> assert false | f :: _ -> let p = LA.get patch (!ctr - ofs) in LA.set patch (!ctr - ofs) ((f.st_ctr, f.st_cur) :: p); return stk null end else begin return stk v end and return stk v = match stk with | [] -> Obj.obj v | f :: stk1 -> let sz = if Obj.is_int f.st_obj then (Obj.obj f.st_obj : int) else begin Obj.set_field f.st_obj f.st_cur v; Obj.size f.st_obj end in f.st_cur <- f.st_cur + 1; if f.st_cur >= sz then return_block stk1 f.st_ty f.st_obj f.st_ctr else intern_rec stk (get_field_type f.st_ty f.st_constr f.st_cur v) and return_block stk t v dest = (* call alloc, patch, and return *) let res = do_transform t v in LA.set tbl dest res; let f (ix, ofs) = Obj.set_field (LA.get tbl ix) ofs res in List.iter f (LA.get patch dest); LA.set patch dest []; return stk res in intern_rec [] t ;; (* Functions for handling Int32, Int64, and Nativeint custom blocks. *) let readint64_little32 ch = let result = Obj.dup (Obj.repr 0L) in readblock_rev ch result 4 8; result ;; let readint64_big32 ch = let result = Obj.dup (Obj.repr 0L) in readblock ch result 4 8; result ;; let readint64_little64 ch = let result = Obj.dup (Obj.repr 0L) in readblock_rev ch result 8 8; result ;; let readint64_big64 ch = let result = Obj.dup (Obj.repr 0L) in readblock ch result 8 8; result ;; register_custom "_j" (if arch_bigendian then if arch_sixtyfour then readint64_big64 else readint64_big32 else if arch_sixtyfour then readint64_little64 else readint64_little32 ) ;; let readint32_little32 ch = let result = Obj.dup (Obj.repr 0l) in readblock_rev ch result 4 4; result ;; let readint32_big32 ch = let result = Obj.dup (Obj.repr 0l) in readblock ch result 4 4; result ;; let readint32_little64 ch = let result = Obj.dup (Obj.repr 0l) in readblock_rev ch result 8 4; result ;; let readint32_big64 ch = let result = Obj.dup (Obj.repr 0l) in readblock ch result 8 4; result ;; register_custom "_i" (if arch_bigendian then if arch_sixtyfour then readint32_big64 else readint32_big32 else if arch_sixtyfour then readint32_little64 else readint32_little32 ) ;; let readnativeint_little32 ch = let code = read8u ch in let result = Obj.dup (Obj.repr 0n) in if code = 1 then (readblock_rev ch result 4 4; result) else if code = 2 then failwith "input_value: native integer value too large" else failwith "input_value: ill-formed native integer" ;; let readnativeint_big32 ch = let code = read8u ch in let result = Obj.dup (Obj.repr 0n) in if code = 1 then (readblock ch result 4 4; result) else if code = 2 then failwith "input_value: native integer value too large" else failwith "input_value: ill-formed native integer" ;; let readnativeint_little64 ch = let code = read8u ch in let result = Obj.dup (Obj.repr 0n) in if code = 1 then (readblock_rev ch result 8 4; result) else if code = 2 then (readblock_rev ch result 8 8; result) else failwith "input_value: ill-formed native integer" ;; let readnativeint_big64 ch = let code = read8u ch in let result = Obj.dup (Obj.repr 0n) in if code = 1 then (readblock ch result 12 4; result) else if code = 2 then (readblock ch result 8 8; result) else failwith "input_value: ill-formed native integer" ;; register_custom "_n" (if arch_bigendian then if arch_sixtyfour then readnativeint_big64 else readnativeint_big32 else if arch_sixtyfour then readnativeint_little64 else readnativeint_little32 ) ;; let t_unit = Abstract;; let t_int = Abstract;; let t_string = Abstract;; let t_float = Abstract;; let t_bool = Abstract;; let t_int32 = Abstract;; let t_int64 = Abstract;; let t_nativeint = Abstract;; let t_record args = Structure (Sum [| args |]);; let t_tuple = t_record;; let t_list a = let rec x = Structure (Sum [| [| a; x |] |]) in x;; let t_ref a = t_record [| a |];; let t_option = t_ref;; let t_array a = Structure (Array a) let t_queue a = t_record [| t_int; t_list a |] (**** Hash tables ****) type ('a, 'b) _caml_hashtable = { mutable size: int; (* number of elements *) mutable data: ('a, 'b) _bucketlist array } (* the buckets *) and ('a, 'b) _caml_hashtable_4_ = { mutable _size: int; (* number of entries *) mutable _data: ('a, 'b) _bucketlist array; (* the buckets *) mutable _seed: int; (* for randomization *) _initial_size: int; (* initial array size *) } and ('a, 'b) _bucketlist = Empty | Cons of 'a * 'b * ('a, 'b) _bucketlist let ge_ocaml_4 = let major, _minor = Scanf.sscanf Sys.ocaml_version "%d.%d" (fun ma mi -> ma, mi) in major >= 4 let t_hashtbl bucket = if not (ge_ocaml_4) then t_record [| Abstract ; t_array bucket |] else t_record [| Abstract ; t_array bucket; Abstract; Abstract |] (* version 1: loading keys do not change their hash value *) let t_hashtbl_unchangedhashs key value = let rec bucket = Structure (Sum [| [| key; value; bucket |] |]) in t_hashtbl bucket (* version 2: keys change hash value in the unmarshalling+transformation *) let t_hashtbl_changedhashs create add key value = Dynamic (fun () -> let new_hashtbl = create 27 in let return_new_hashtbl () = Obj.repr new_hashtbl in let rec bucket = Transform (Structure (Sum [| [| key; value; bucket |] |]), fun cell -> ( match Obj.obj cell with Empty -> () | Cons (k, v, _) -> add new_hashtbl k v); Obj.repr Empty ) in Return (t_hashtbl bucket, return_new_hashtbl)) (**** Sets ****) type elt type _caml_set = Empty | Node of _caml_set * elt * _caml_set * int let t_set_unchangedcompares t_elt = let rec t_set = Structure (Sum [| [| t_set; t_elt; t_set; Abstract |] |] ) in t_set (**** Maps ****) type key type 'a _caml_map = Empty | Node of 'a _caml_map * key * 'a * 'a _caml_map * int let t_map_unchangedcompares t_key t_elt = let rec t_map = Structure (Sum [| [| t_map; t_key; t_elt; t_map; Abstract |] |] ) in t_map ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/external/unz.mli����������������������������������������������������������0000644�0001750�0001750�00000003122�12155630367�017144� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/external/sysutil.ml�������������������������������������������������������0000644�0001750�0001750�00000013010�12155630367�017670� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2013 -- INRIA - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives). *) (* *) (**************************************************************************) (** One modification have been done in relativize_filename for removing useless parent_dir_name ( ../ ) *) let backup_file f = if Sys.file_exists f then begin let fb = f ^ ".bak" in if Sys.file_exists fb then Sys.remove fb; Sys.rename f fb end let channel_contents_fmt cin fmt = let buff = String.make 1024 ' ' in let n = ref 0 in while n := input cin buff 0 1024; !n <> 0 do Format.pp_print_string fmt (if !n = 1024 then buff else String.sub buff 0 !n) done let channel_contents_buf cin = let buf = Buffer.create 1024 and buff = String.make 1024 ' ' in let n = ref 0 in while n := input cin buff 0 1024; !n <> 0 do Buffer.add_substring buf buff 0 !n done; buf let channel_contents cin = Buffer.contents (channel_contents_buf cin) let rec fold_channel f acc cin = try fold_channel f (f acc (input_line cin)) cin with End_of_file -> acc let file_contents_fmt f fmt = try let cin = open_in f in channel_contents_fmt cin fmt; close_in cin with _ -> invalid_arg (Printf.sprintf "(cannot open %s)" f) let file_contents_buf f = try let cin = open_in f in let buf = channel_contents_buf cin in close_in cin; buf with _ -> invalid_arg (Printf.sprintf "(cannot open %s)" f) let file_contents f = Buffer.contents (file_contents_buf f) let open_temp_file ?(debug=false) filesuffix usefile = let file,cout = Filename.open_temp_file "why" filesuffix in try let res = usefile file cout in if not debug then Sys.remove file; close_out cout; res with | e -> if not debug then Sys.remove file; close_out cout; raise e let copy_file from to_ = let cin = open_in from in let cout = open_out to_ in let buff = String.make 1024 ' ' in let n = ref 0 in while n := input cin buff 0 1024; !n <> 0 do output cout buff 0 !n done let rec copy_dir from to_ = if not (Sys.file_exists to_) then Unix.mkdir to_ 0o755; let files = Sys.readdir from in let copy fname = let src = Filename.concat from fname in let dst = Filename.concat to_ fname in if Sys.is_directory src then copy_dir src dst else copy_file src dst in Array.iter copy files (* return the absolute path of a given file name. this code has been designed to be architecture-independant so be very careful if you modify this *) let path_of_file f = let rec aux acc f = (* Format.printf "aux %s@." f; let _ = read_line () in *) let d = Filename.dirname f in if d = Filename.current_dir_name then (* f is relative to the current dir *) let b = Filename.basename f in aux (b::acc) (Sys.getcwd ()) else if f=d then (* we are at the root *) acc else let b = Filename.basename f in if f=b then b::acc else aux (b::acc) d in aux [] f (* let test x = (Filename.dirname x, Filename.basename x) let _ = test "file" let _ = test "/file" let _ = test "/" let _ = test "f1/f2" let _ = test "/f1/f2" let p1 = path_of_file "/bin/bash" let p1 = path_of_file "../src/f.why" *) let relativize_filename base f = let rec aux ab af = match ab,af with | x::rb, y::rf when x=y -> aux rb rf | _ -> let rec aux2 acc p = match p with | [] -> acc | _::rb -> aux2 (Filename.parent_dir_name::acc) rb in aux2 af ab in let rec remove_parent_dir pre post = match pre,post with | _,[] -> List.rev pre | d::pre, parent::post when d <> Filename.parent_dir_name && parent = Filename.parent_dir_name -> remove_parent_dir pre post | pre,x::post -> remove_parent_dir (x::pre) post in let rec rebuild l = match l with | [] -> "" | [x] -> x | x::l -> Filename.concat x (rebuild l) in let path = aux (path_of_file base) (path_of_file f) in let path = remove_parent_dir [] path in rebuild path let absolutize_filename dirname f = if Filename.is_relative f then Filename.concat dirname f else f (* let p1 = relativize_filename "/bin/bash" "src/f.why" let p1 = relativize_filename "test" "/home/cmarche/recherche/why3/src/ide/f.why" *) let uniquify file = (* Uniquify the filename if it exists on disk *) let i = try String.rindex file '.' with _ -> String.length file in let name = String.sub file 0 i in let ext = String.sub file i (String.length file - i) in let i = ref 1 in while Sys.file_exists (name ^ "_" ^ (string_of_int !i) ^ ext) do incr i done; let file = name ^ "_" ^ (string_of_int !i) ^ ext in file ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/external/sysutil.mli������������������������������������������������������0000644�0001750�0001750�00000006136�12155630367�020054� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2013 -- INRIA - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (* File modified by CEA (Commissariat l'nergie atomique et aux *) (* nergies alternatives). *) (* *) (**************************************************************************) (** System utilities (filename management, etc). *) val backup_file : string -> unit (** Create a backup copy of a file if it exists. Do nothing otherwise. *) val channel_contents : in_channel -> string (** @return the content of an in-channel. *) val channel_contents_buf : in_channel -> Buffer.t (** @return the content of an in_channel in a buffer. *) val channel_contents_fmt : in_channel -> Format.formatter -> unit (** Put the content of an in_channel in a formatter *) val fold_channel : ('a -> string -> 'a) -> 'a -> in_channel -> 'a (** Fold on the line of a file. *) val file_contents : string -> string (** @return the content of a file. *) val file_contents_buf : string -> Buffer.t (** @return the content of a file in a buffer *) val file_contents_fmt : string -> Format.formatter -> unit (** Put the content of a file in a formatter. *) val open_temp_file : ?debug:bool -> string -> (string -> out_channel -> 'a) -> 'a (** [open_temp_file debug suffix usefile] creates a temporary file with suffix [suffix], and call [usefile] on this file (filename and open_out). [usefile] can close the file. If [debug] is [true] (default is [false]), don't remove the file. *) val copy_file : string -> string -> unit (** [copy_file from to] copy the file from [from] to [to]. *) val copy_dir : string -> string -> unit (** [copy_dir from to] copy the directory recursively from [from] to [to], currently the directory must contains only directories and common files. *) val path_of_file : string -> string list (** @return the absolute path of the given filename. *) val relativize_filename : string -> string -> string (** [relativize_filename base filename] relativizes the filename [filename] according to [base]. *) val absolutize_filename : string -> string -> string (** [absolutize_filename base filename] absolutizes the filename [filename] according to [base]. *) val uniquify : string -> string (** Find filename that doesn't exists based on the given filename. Be careful the file can be taken after the return of this function. *) (* Local Variables: compile-command: "make -C .." End: *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/external/unz.ml�����������������������������������������������������������0000644�0001750�0001750�00000005224�12155630367�017000� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Unmarshal;; let readz ch = let sign = read8u ch in let charlen = read32u ch in let str = String.create charlen in readblock ch (Obj.repr str) 0 charlen; (* My beautiful string reversing code; now useless :( let max = pred charlen in for i = 0 to (pred max) / 2 do let c = str.[i] in str.[i] <- str.[max - i] ; str.[max - i] <- c done; *) let n = Z.of_bits str in let z = if sign = 0 then n else Z.neg n in Obj.repr z ;; register_custom "_z" readz;; (* #load "zarith.cma" ;; let f = open_out "test" ;; let i = ref (-10000000000000000L) ;; while !i <= 10000000000000000L do output_value f (Z.of_int64 (!i)) ; i := Int64.add !i 100000000000L ; done ;; ocamlc -custom zarith.cma unmarshal.ml unz.ml *) (* let f = open_in "test" ;; let i = ref (-10000000000000000L) ;; while !i <= 10000000000000000L do let z = input_val f Abstract in let r = Z.to_int64 z in if (r <> !i) then begin Format.printf "read: %Ld expected: %Ld@." r !i; assert false end; i := Int64.add !i 100000000000L ; done ;; *) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/external/unmarshal_nums.ml������������������������������������������������0000644�0001750�0001750�00000007775�12155630367�021235� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* Copyright (C) 2009-2012 INRIA *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* * Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* * Redistributions in binary form must reproduce the above *) (* copyright notice, this list of conditions and the following *) (* disclaimer in the documentation and/or other materials provided *) (* with the distribution. *) (* * Neither the name of the <organization> nor the names of its *) (* contributors may be used to endorse or promote products derived *) (* from this software without specific prior written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY <INRIA> ''AS IS'' AND ANY *) (* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE *) (* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE *) (* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR *) (* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT *) (* OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR *) (* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT *) (* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE *) (* USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *) (* DAMAGE. *) (* *) (**************************************************************************) (* caml_unmarshal by Ineffable Casters *) (* Version 3.11.1.8 *) (* Warning: If you are new to OCaml, don't take this as an example of good code. *) open Unmarshal;; let readnat_big32 ch = let len = read32u ch in let v = Obj.repr (Nat.create_nat len) in readblock ch v 4 (len * 4); v ;; let readnat_little32 ch = let len = read32u ch in let v = Obj.repr (Nat.create_nat len) in for i = 1 to len do readblock_rev ch v (i * 4) 4 done; v ;; let readnat_little64 ch = let len = read32u ch in let size = (len + 1) / 2 in let v = Nat.create_nat size in Nat.set_digit_nat v (size - 1) 0; let v = Obj.repr v in for i = 2 to len + 1 do readblock_rev ch v (i * 4) 4 done; v ;; let readnat_big64 ch = let len = read32u ch in let size = (len + 1) / 2 in let v = Nat.create_nat size in Nat.set_digit_nat v (size - 1) 0; let v = Obj.repr v in let rec loop i = if i < len then begin readblock ch v (12 + i * 4) 4; if i + 1 < len then begin readblock ch v (8 + i * 4) 4; loop (i + 2); end end in loop 0; v ;; let readnat = if arch_sixtyfour then if arch_bigendian then readnat_big64 else readnat_little64 else if arch_bigendian then readnat_big32 else readnat_little32 ;; register_custom "_nat" readnat;; let t_nat = Abstract;; let t_big_int = Abstract;; let t_ratio = Abstract;; let t_num = Abstract;; ���frama-c-Fluorine-20130601/external/unmarshal.mli����������������������������������������������������0000644�0001750�0001750�00000017306�12155630367�020333� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* Copyright (C) 2009-2012 INRIA *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* * Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* * Redistributions in binary form must reproduce the above *) (* copyright notice, this list of conditions and the following *) (* disclaimer in the documentation and/or other materials provided *) (* with the distribution. *) (* * Neither the name of the <organization> nor the names of its *) (* contributors may be used to endorse or promote products derived *) (* from this software without specific prior written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY <INRIA> ''AS IS'' AND ANY *) (* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE *) (* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE *) (* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR *) (* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT *) (* OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR *) (* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT *) (* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE *) (* USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *) (* DAMAGE. *) (* *) (**************************************************************************) (* caml_unmarshal by Ineffable Casters *) (* Version 3.11.2.0 *) (** Provides a function [input_val], similar in functionality to the standard library function [Marshal.from_channel]. The main difference with [Marshal.from_channel] is that [input_val] is able to apply transformation functions on the values on the fly as they are read from the input channel. Because it has an abstract representation of the type, [input_val] is able to catch some inconsistencies that [Marshal.from_channel] cannot. It is therefore "more" type-safe, but only if it is always used in conditions where the static type attributed to the result by the type-checker agrees with the representation of the type passed as second argument to [input_val]. No such verification is done by this module (this would require changes to the compiler). The sanity checks are not the primary purpose of [input_val], and it is possible for a bug where the representation of a value of the wrong type is passed to [input_val] to go undetected, just as this can happen with [Marshal.from_channel]. *) type t = | Abstract | Structure of structure | Transform of t * (Obj.t -> Obj.t) | Return of t * (unit -> Obj.t) | Dynamic of (unit -> t) and structure = | Sum of t array array | Dependent_pair of t * (Obj.t -> t) | Array of t ;; (** Type [t] is used to describe the type of the data to be read and the transformations to be applied to the data. [Abstract] is used to input a value without any checking or transformation (as [Marshal.from_channel] does). In this case, you don't need to provide a precise description of the representation of the data. [Structure a] is used to provide a description of the representation of the data, along with optional transformation functions for parts of the data. [a] can be: - [Array(t)], indicating that the data is an array of values of the same type, each value being described by [t]. - [Sum(c)] for describing a non-array type where [c] is an array describing the non-constant constructors of the type being described (in the order of their declarations in that type). Each element of this latter array is an array of [t] that describes (in order) the fields of the corresponding constructor. - [Dependent_pair(e,f)] for instructing the unmarshaler to reconstruct the first component of a pair first, using [e] as its description, and to apply function [f] to this value in order to get the description of the pair's second component. The shape of [a] must match the shape of the representation of the type of the data being imported, or [input_val] may report an error when the data doesn't match the description. [Transform (u, f)] is used to specify a transformation function on the data described by [u]. [input_val] will read and rebuild the data as described by [u], then call [f] on that data and return the result returned by [f]. [Return (u, f)] is the same as [Transform], except that the data is not rebuilt, and [()] is passed to [f] instead of the data. This is to be used when the transformation functions of [u] rebuild the data by side effects and the version rebuilt by [input_val] is irrelevant. [Dynamic f] is used to build a new description on the fly when a new data of the current type is encountered. *) val input_val : in_channel -> t -> 'a;; (** [input_val c t] Read a value from the input channel [c], applying the transformations described by [t]. *) val null : Obj.t;; (** recursive values cannot be completely formed at the time they are passed to their transformation function. When traversing a recursive value, the transformation function must check the fields for physical equality to [null] (with the function [==]) and avoid using any field that is equal to [null]. *) val id : Obj.t -> Obj.t;; (** Use this function when you don't want to change the value unmarshaled by input_val. You can also use your own identity function, but using this one is more efficient. *) (** Convenience functions for describing transformations. *) val t_unit : t;; val t_int : t;; val t_string : t;; val t_float : t;; val t_bool : t;; val t_int32 : t;; val t_int64 : t;; val t_nativeint : t;; val t_record : t array -> t;; val t_tuple : t array -> t;; val t_list : t -> t;; val t_ref : t -> t;; val t_option : t -> t;; val t_array : t -> t;; val t_queue: t -> t;; val t_hashtbl_unchangedhashs :t -> t -> t val t_hashtbl_changedhashs : (int -> 'table) -> ('table -> 'key -> 'value -> unit) -> t -> t -> t val t_set_unchangedcompares : t -> t val t_map_unchangedcompares : t -> t -> t (** Functions for writing deserializers. *) val register_custom : string -> (in_channel -> Obj.t) -> unit;; val arch_sixtyfour : bool;; val arch_bigendian : bool;; val getword : in_channel -> Int32.t;; val read8s : in_channel -> int;; val read16s : in_channel -> int;; val read32s : in_channel -> int;; val read64s : in_channel -> int;; val read8u : in_channel -> int;; val read16u : in_channel -> int;; val read32u : in_channel -> int;; val read64u : in_channel -> int;; val readblock : in_channel -> Obj.t -> int -> int -> unit;; val readblock_rev : in_channel -> Obj.t -> int -> int -> unit;; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/external/unmarshal_hashtbl_test.ml����������������������������������������0000644�0001750�0001750�00000011566�12155630367�022730� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* Copyright (C) 2009-2012 INRIA *) (* INRIA (Institut National de Recherche en Informatique et en *) (* Automatique) *) (* *) (* All rights reserved. *) (* *) (* Redistribution and use in source and binary forms, with or without *) (* modification, are permitted provided that the following conditions *) (* are met: *) (* * Redistributions of source code must retain the above copyright *) (* notice, this list of conditions and the following disclaimer. *) (* * Redistributions in binary form must reproduce the above *) (* copyright notice, this list of conditions and the following *) (* disclaimer in the documentation and/or other materials provided *) (* with the distribution. *) (* * Neither the name of the <organization> nor the names of its *) (* contributors may be used to endorse or promote products derived *) (* from this software without specific prior written permission. *) (* *) (* THIS SOFTWARE IS PROVIDED BY <INRIA> ''AS IS'' AND ANY *) (* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE *) (* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *) (* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE *) (* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR *) (* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT *) (* OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR *) (* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *) (* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT *) (* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE *) (* USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *) (* DAMAGE. *) (* *) (**************************************************************************) open Unmarshal let l = [ 512; 35; 62; 512; 42; 62; 17 ] let t_renumber_int = let tbl = Hashtbl.create 42 in let count = ref 0 in let f x = match ((Obj.magic x) : int ) with | x -> let result = try Hashtbl.find tbl x with Not_found -> let c = !count in count := succ c; Hashtbl.add tbl x c; c in Obj.repr (result : int ) in Transform (t_option t_int, f) let t_l = t_list t_renumber_int let () = let oc = open_out_bin "test-file" in Marshal.to_channel oc l []; close_out oc; let ic = open_in_bin "test-file" in let result = input_val ic t_l in close_in ic; List.iter (print_int ) result; print_endline "fin test1" let l = [ Some 512; Some 35; Some 62; Some 512; Some 42; Some 62; Some 17 ] let t_renumber_intopt = let tbl = Hashtbl.create 42 in let count = ref 0 in let f x = match ((Obj.magic x) : int option) with None -> assert false | Some x -> let result = try Hashtbl.find tbl x with Not_found -> let c = !count in count := succ c; Hashtbl.add tbl x c; c in Obj.repr (Some(result) : int option) in Transform (t_option t_int, f) let t_l = t_list t_renumber_intopt let () = let oc = open_out_bin "test-file" in Marshal.to_channel oc l []; close_out oc; let ic = open_in_bin "test-file" in let result = input_val ic t_l in close_in ic; List.iter (function None -> () | (Some(i)) -> print_int i) result; print_endline "fin test2" let h = Hashtbl.create 12;; let () = Hashtbl.add h 34 "s34"; Hashtbl.add h 63 "s63" let t_h1 = t_hashtbl_changedhashs Hashtbl.create Hashtbl.add t_renumber_int Abstract let () = let oc = open_out_bin "test-file" in Marshal.to_channel oc h []; close_out oc; let ic = open_in_bin "test-file" in let result = input_val ic t_h1 in close_in ic; Hashtbl.iter (fun k v -> Format.printf "%d %s@." k v) result; print_endline "fin test3" let t_h2 = t_hashtbl_unchangedhashs t_int Abstract let () = let oc = open_out_bin "test-file" in Marshal.to_channel oc h []; close_out oc; let ic = open_in_bin "test-file" in let result = input_val ic t_h2 in close_in ic; Hashtbl.iter (fun k v -> Format.printf "%d %s@." k v) result; print_endline "fin test4" ������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/ptests/�������������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�015317� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/ptests/ptests.ml����������������������������������������������������������0000644�0001750�0001750�00000123427�12155630164�017207� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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). *) (* *) (**************************************************************************) (** the options to launch the toplevel with if the test file is not annotated with test options *) let default_options = "-val -out -input -deps -journal-disable" let system = if Sys.os_type = "Win32" then fun f -> Unix.system (Format.sprintf "bash -c %S" f) else fun f -> Unix.system f module Filename = struct include Filename let concat = if Sys.os_type = "Win32" then fun a b -> a ^ "/" ^ b else concat let cygpath r = let cmd = Format.sprintf "bash -c \"cygpath -m %s\"" (String.escaped (String.escaped r)) in let in_channel = Unix.open_process_in cmd in let result = input_line in_channel in ignore(Unix.close_process_in in_channel); result let temp_file = if Sys.os_type = "Win32" then fun a b -> let r = temp_file a b in cygpath r else fun a b -> temp_file a b end let default_env = ref [] let add_default_env x y = default_env:=(x,y)::!default_env let add_env var value = add_default_env var value; Unix.putenv var value let print_default_env fmt = match !default_env with [] -> () | l -> Format.fprintf fmt "@[Env:@\n"; List.iter (fun (x,y) -> Format.fprintf fmt "%s = \"%s\"@\n" x y) l; Format.fprintf fmt "@]" let default_env var value = try ignore (Unix.getenv var) with Not_found -> add_env var value let test_paths = [ "tests"; "../../tests" ] exception Path of string let test_path = try List.iter (fun p -> if Sys.file_exists p && Sys.is_directory p then raise (Path p)) test_paths; Format.eprintf "No test path found@."; exit 1 with Path p -> p (** the name of the directory-wide configuration file*) let dir_config_file = "test_config" (** the files in [suites] whose name matches the pattern [test_file_regexp] will be considered as test files *) let test_file_regexp = ".*\\.\\(c\\|i\\)$" (** the pattern that ends the parsing of options in a test file *) let end_comment = Str.regexp ".*\\*/" let regex_opt = Str.regexp ("\\([^/]+\\)[.]opt\\($\\|[ \t]\\)") let regex_cmxs = Str.regexp ("\\([^/]+\\)[.]cmxs\\($\\|[ \t]\\)") let opt_to_byte toplevel = if toplevel = "frama-c" then "frama-c.byte" else Str.global_replace regex_opt "\\1.byte\\2" toplevel let opt_to_byte_options options = Str.global_replace regex_cmxs "\\1.cmo\\2" options let needs_byte = let load_something = Str.regexp ".*-load-\\(\\(script\\)\\|\\(module\\)\\)" in fun options -> Ptests_config.no_native_dynlink && (Str.string_match load_something options 0) let execnow_needs_byte = let make_cmxs = Str.regexp ".*make.*[.]cmxs" in fun cmd -> Ptests_config.no_native_dynlink && Str.string_match make_cmxs cmd 0 let execnow_opt_to_byte cmd = let cmd = opt_to_byte cmd in opt_to_byte_options cmd let base_path = Filename.current_dir_name (* (Filename.concat (Filename.dirname Sys.executable_name) Filename.parent_dir_name) *) let ptests_config = "ptests_local_config.cmo" (** Command-line flags *) type behavior = Examine | Update | Run | Show let behavior = ref Run let verbosity = ref 0 let use_byte = ref false let use_diff_as_cmp = ref (Sys.os_type = "Win32") let do_diffs = ref (if Sys.os_type = "Win32" then "diff --strip-trailing-cr -u" else "diff -u") let do_cmp = ref (if Sys.os_type="Win32" then !do_diffs else "cmp -s") let do_make = ref "make" let n = ref 4 (* the level of parallelism *) let suites = ref [] (** options given to toplevel for all tests *) let additional_options = ref "" (** special configuration, with associated oracles *) let special_config = ref "" let do_error_code = ref false let exclude_suites = ref [] let exclude s = exclude_suites := s :: !exclude_suites let xunit = ref false let io_mutex = Mutex.create () let lock_fprintf f = Mutex.lock io_mutex; Format.kfprintf (fun _ -> Mutex.unlock io_mutex) f let lock_printf s = lock_fprintf Format.std_formatter s let lock_eprintf s = lock_fprintf Format.err_formatter s let make_test_suite s = suites := s :: !suites let () = if Sys.file_exists ptests_config then try Dynlink.loadfile ptests_config with Dynlink.Error e -> Format.eprintf "Could not load dynamic configuration %s: %s@." ptests_config (Dynlink.error_message e) ;; let () = default_env "FRAMAC_SHARE" !Ptests_config.framac_share; default_env "FRAMAC_PLUGIN" !Ptests_config.framac_plugin; default_env "FRAMAC_LIB" !Ptests_config.framac_lib; default_env "FRAMAC_PLUGIN_GUI" !Ptests_config.framac_plugin_gui; default_env "OCAMLRUNPARAM" ""; default_env "FRAMAC_OPT" !Ptests_config.toplevel_path; default_env "FRAMAC_BYTE" (opt_to_byte !Ptests_config.toplevel_path); Unix.putenv "LC_ALL" "C" (* some oracles, especially in Jessie, depend on the locale *) ;; let example_msg = Format.sprintf "@.@[<v 0>\ A test suite can be the name of a directory in ./tests or \ the path to a file.@ @ \ @[<v 1>\ Examples:@ \ ptests@ \ ptests -diff \"echo diff\" -examine \ # see again the list of tests that failed@ \ ptests misc \ # for a single test suite@ \ ptests tests/misc/alias.c \ # for a single test@ \ ptests -examine tests/misc/alias.c \ # to see the differences again@ \ ptests -v -j 1 \ # to check the time taken by each test\ @]@ @]" ;; let umsg = "Usage: ptests [options] [names of test suites]";; let rec argspec = [ "-examine", Arg.Unit (fun () -> behavior := Examine) , " Examine the logs that are different from oracles."; "-update", Arg.Unit (fun () -> behavior := Update) , " Take the current logs as oracles."; "-show", Arg.Unit (fun () -> behavior := Show; use_byte := true) , " Show the results of the tests. Sets -byte."; "-run", Arg.Unit (fun () -> behavior := Run) , " (default) Delete logs, run tests, then examine logs different from \ oracles."; "-v", Arg.Unit (fun () -> incr verbosity), " Increase verbosity (up to twice)" ; "-diff", Arg.String (fun s -> do_diffs := s; if !use_diff_as_cmp then do_cmp := s), "<command> Use command for diffs" ; "-cmp", Arg.String (fun s -> do_cmp:=s), "<command> Use command for comparison"; "-make", Arg.String (fun s -> do_make := s;), "<command> Use command instead of make"; "-use-diff-as-cmp", Arg.Unit (fun () -> use_diff_as_cmp:=true; do_cmp:=!do_diffs), " Use the diff command for performing comparisons"; "-j", Arg.Int (fun i -> if i>=0 then n := i else ( lock_printf "Option -j requires nonnegative argument@."; exit (-1))), "<n> Use nonnegative integer n for level of parallelism" ; "-byte", Arg.Set use_byte, " Use bytecode toplevel"; "-opt", Arg.Clear use_byte, " Use native toplevel (default)"; "-config", Arg.Set_string special_config, " Use special configuration and oracles"; "-add-options", Arg.Set_string additional_options, " Add additional options to be passed to the toplevels that will be launched"; "-exclude", Arg.String exclude, " Exclude a test or a suite from the run"; "-xunit", Arg.Set xunit, " Create a xUnit file named xunit.xml collecting results"; "-error-code", Arg.Set do_error_code, " Exit with error code 1 if tests failed (useful for scripts"; ] and help_msg () = Arg.usage (Arg.align argspec) umsg;; let () = Arg.parse ((Arg.align (List.sort (fun (optname1, _, _) (optname2, _, _) -> Pervasives.compare optname1 optname2 ) argspec) ) @ ["", Arg.Unit (fun () -> ()), example_msg;]) make_test_suite umsg ;; (* redefine config file if special configuration expected *) let dir_config_file = if !special_config = "" then dir_config_file else dir_config_file ^ "_" ^ !special_config let make_toplevel_path exec = exec (* if Filename.is_relative exec then Filename.concat (Filename.concat base_path "bin") exec else exec *) (* redefine oracle directory if special configuration expected *) let oracle_dirname = if !special_config = "" then "oracle" else "oracle_" ^ !special_config (* redefine result directory if special configuration expected *) let result_dirname = if !special_config = "" then "result" else "result_" ^ !special_config let gen_make_file s dir file = Filename.concat (Filename.concat dir s) file let make_result_file = gen_make_file result_dirname let make_oracle_file = gen_make_file oracle_dirname let toplevel_regex = Str.regexp "\\(.*\\)@frama-c@\\(.*\\)" type execnow = { ex_cmd: string; (** command to launch *) ex_log: string list; (** log files *) ex_bin: string list; (** bin files *) ex_dir: string; (** directory of test suite *) } (** configuration of a directory/test. *) type config = { dc_test_regexp: string; (** regexp of test files. *) dc_execnow : execnow list; (** command to be launched before the toplevel(s) *) dc_default_toplevel : string; (** full path of the default toplevel. *) dc_filter : string option; (** optional filter to apply to standard output *) dc_toplevels : (string * string) list; (** toplevel full path and options to launch the toplevel on *) dc_dont_run : bool; dc_is_explicit_test: bool (** set to true for single test files that are explicitly mentioned on the command line. Overrides dc_dont_run. *) } let default_config = { dc_test_regexp = test_file_regexp ; dc_execnow = []; dc_filter = None ; dc_default_toplevel = !Ptests_config.toplevel_path; dc_toplevels = [ !Ptests_config.toplevel_path, default_options ]; dc_dont_run = false; dc_is_explicit_test = false } let launch command_string = let result = system command_string in match result with | Unix.WEXITED 127 -> lock_printf "%% Couldn't execute command. Retrying once.@."; Thread.delay 0.125; ( match system command_string with Unix.WEXITED r when r <> 127 -> r | _ -> lock_printf "%% Retry failed with command:@\n%s@\nStopping@." command_string ; exit 1 ) | Unix.WEXITED r -> r | Unix.WSIGNALED s -> lock_printf "%% SIGNAL %d received while executing command:@\n%s@\nStopping@." s command_string ; exit 1 | Unix.WSTOPPED s -> lock_printf "%% STOP %d received while executing command:@\n%s@\nStopping@." s command_string; exit 1 let replace_toplevel s = if Str.string_match toplevel_regex s 0 then Str.replace_matched ("\\1" ^ !Ptests_config.toplevel_path ^ "\\2") s else s let scan_execnow dir (s:string) = let rec aux (s:execnow) = try Scanf.sscanf s.ex_cmd "%_[ ]LOG%_[ ]%[A-Za-z0-9_',+=:.\\-]%_[ ]%s@\n" (fun name cmd -> let cmd = replace_toplevel cmd in aux { s with ex_cmd = cmd; ex_log = name :: s.ex_log }) with Scanf.Scan_failure _ -> try Scanf.sscanf s.ex_cmd "%_[ ]BIN%_[ ]%[A-Za-z0-9_.\\-]%_[ ]%s@\n" (fun name cmd -> let cmd = replace_toplevel cmd in aux { s with ex_cmd = cmd; ex_bin = name :: s.ex_bin }) with Scanf.Scan_failure _ -> try Scanf.sscanf s.ex_cmd "%_[ ]make%_[ ]%s@\n" (fun cmd -> let cmd = replace_toplevel cmd in let s = aux ({ s with ex_cmd = cmd; }) in { s with ex_cmd = !do_make^" "^cmd; } ) with Scanf.Scan_failure _ -> s in aux { ex_cmd = s; ex_log = []; ex_bin = []; ex_dir = dir } (* the default toplevel for the current level of options. *) let current_default_toplevel = ref !Ptests_config.toplevel_path let current_default_cmds = ref [!Ptests_config.toplevel_path,default_options] let make_custom_opts = let space = Str.regexp " " in fun stdopts s -> let rec aux opts s = try Scanf.sscanf s "%_[ ]%1[+#\\-]%_[ ]%S%_[ ]%s@\n" (fun c opt rem -> let opt = replace_toplevel opt in match c with | "+" -> aux (opt :: opts) rem | "#" -> aux (opts @ [ opt ]) rem | "-" -> aux (List.filter (fun x -> x <> opt) opts) rem | _ -> assert false (* format of scanned string disallow it *)) with | Scanf.Scan_failure _ -> if s <> "" then lock_eprintf "unknown STDOPT configuration string: %s\n%!" s; opts | End_of_file -> opts in (* NB: current settings does not allow to remove a multiple-argument option (e.g. -verbose 2). *) (* revert the initial list, as it will be reverted back in the end. *) let opts = aux (List.rev (Str.split space stdopts)) s in (* preserve options ordering *) List.fold_right (fun x s -> s ^ " " ^ x) opts "" (* how to process options *) let config_options = [ "CMD", (fun _ s current -> let toplevel = if Str.string_match toplevel_regex s 0 then Str.replace_matched ("\\1" ^ !Ptests_config.toplevel_path ^ "\\2") s else make_toplevel_path s in { current with dc_default_toplevel = toplevel}); "OPT", (fun _ s current -> let t = current.dc_default_toplevel, s in { current with (* dc_default_toplevel = !current_default_toplevel;*) dc_toplevels = t :: current.dc_toplevels }); "STDOPT", (fun _ s current -> let new_top = List.map (fun (cmd,opts) -> cmd, make_custom_opts opts s) !current_default_cmds in { current with dc_toplevels = List.rev_append new_top current.dc_toplevels}); "FILEREG", (fun _ s current -> { current with dc_test_regexp = s }); "FILTER", (fun _ s current -> { current with dc_filter = Some s }); "GCC", (fun _ _ acc -> acc); "COMMENT", (fun _ _ acc -> acc); "DONTRUN", (fun _ s current -> if current.dc_is_explicit_test then current else { current with dc_dont_run = true }); "EXECNOW", (fun dir s current -> let execnow = scan_execnow dir s in { current with dc_execnow = execnow::current.dc_execnow }); ] let scan_options dir scan_buffer default = let r = ref { default with dc_toplevels = [] } in current_default_toplevel := default.dc_default_toplevel; current_default_cmds := List.rev default.dc_toplevels; let treat_line s = try Scanf.sscanf s "%[ *]%[A-Za-z0-9]:%s@\n" (fun _ name opt -> try r := (List.assoc name config_options) dir opt !r with Not_found -> lock_eprintf "@[unknown configuration option: %s@\n%!@]" name) with Scanf.Scan_failure _ -> if Str.string_match end_comment s 0 then raise End_of_file else () in try while true do Scanf.bscanf scan_buffer "%s@\n" treat_line done; assert false with End_of_file -> (match !r.dc_toplevels with | [] -> { !r with dc_toplevels = default.dc_toplevels } | l -> { !r with dc_toplevels = List.rev l }) let scan_test_file default dir f = let f = Filename.concat dir f in let exists_as_file = try (Unix.lstat f).Unix.st_kind = Unix.S_REG with Unix.Unix_error _ | Sys_error _ -> false in if exists_as_file then begin let scan_buffer = Scanf.Scanning.open_in f in let rec scan_config () = (* space in format string matches any number of whitespace *) Scanf.bscanf scan_buffer " /* run.config%s " (fun name -> if not (!special_config = "" && name = "" || name = "_" ^ !special_config) then (ignore (scan_options dir scan_buffer default); scan_config ())) in try scan_config (); let options = scan_options dir scan_buffer default in Scanf.Scanning.close_in scan_buffer; options with End_of_file | Scanf.Scan_failure _ -> Scanf.Scanning.close_in scan_buffer; default end else (* if the file has disappeared, don't try to run it... *) { default with dc_dont_run = true } type toplevel_command = { file : string ; options : string ; toplevel: string ; filter : string option ; directory : string ; n : int } type command = | Toplevel of toplevel_command | Target of execnow * command Queue.t type log = Err | Res type diff = | Command_error of toplevel_command * log | Target_error of execnow | Log_error of string (** directory *) * string (** file *) type cmps = | Cmp_Toplevel of toplevel_command | Cmp_Log of string (** directory *) * string (** file *) type shared = { lock : Mutex.t ; mutable building_target : bool ; target_queue : command Queue.t ; commands_empty : Condition.t ; work_available : Condition.t ; diff_available : Condition.t ; mutable commands : command Queue.t ; (* file, options, number *) cmps : cmps Queue.t ; (* command that has finished its execution *) diffs : diff Queue.t ; (* cmp that showed some difference *) mutable commands_finished : bool ; mutable cmp_finished : bool ; mutable summary_time : float ; mutable summary_run : int ; mutable summary_ok : int ; mutable summary_log : int; } let shared = { lock = Mutex.create () ; building_target = false ; target_queue = Queue.create () ; commands_empty = Condition.create () ; work_available = Condition.create () ; diff_available = Condition.create () ; commands = Queue.create () ; cmps = Queue.create () ; diffs = Queue.create () ; commands_finished = false ; cmp_finished = false ; summary_time = (Unix.times()).Unix.tms_cutime ; summary_run = 0 ; summary_ok = 0 ; summary_log = 0 } let unlock () = Mutex.unlock shared.lock let lock () = Mutex.lock shared.lock let catenate_number prefix n = if n > 0 then prefix ^ "." ^ (string_of_int n) else prefix let name_without_extension command = try (Filename.chop_extension command.file) with Invalid_argument _ -> failwith ("This test file does not have any extension: " ^ command.file) let gen_prefix s cmd = let prefix = gen_make_file s cmd.directory (name_without_extension cmd) in catenate_number prefix cmd.n let log_prefix = gen_prefix result_dirname let oracle_prefix = gen_prefix oracle_dirname let basic_command_string = let ptest_file_token = "@PTEST_FILE@" in let ptest_file_rexp = Str.regexp ptest_file_token in let contains_ptest_file = Str.regexp (".*" ^ ptest_file_token ^ ".*") in let contains_toplevel_or_frama_c = Str.regexp ".*\\(\\(toplevel\\)\\|\\(frama-c\\)\\).*" in let ptest_name_rexp = Str.regexp "@PTEST_NAME@" in let ptest_number_rexp = Str.regexp "@PTEST_NUMBER@" in fun command -> let ptest_file = Filename.concat command.directory command.file in let basic_command = let make_command s = Printf.sprintf "%s %s %s" command.toplevel s command.options in let basic_command = make_command "" in if Str.string_match contains_ptest_file basic_command 0 then (* At least one occurence for the test file is specified. *) Str.global_replace ptest_file_rexp ptest_file basic_command else (* Using default position for the test file (between CMD: and OPT:). *) make_command ptest_file in let basic_command = (* Additional options... *) let is_framac_toplevel = Str.string_match contains_toplevel_or_frama_c command.toplevel 0 in basic_command ^ (if is_framac_toplevel then " " ^ (Str.global_replace ptest_file_rexp ptest_file !additional_options) else "") in let basic_command = let ptest_name = let ptest_name = Filename.basename command.file in try Filename.chop_extension ptest_name with _ -> ptest_name in Str.global_replace ptest_name_rexp ptest_name basic_command in Str.global_replace ptest_number_rexp (string_of_int command.n) basic_command let command_string command = let log_prefix = log_prefix command in let errlog = log_prefix ^ ".err.log" in let stderr = match command.filter with None -> errlog | Some _ -> let stderr = Filename.temp_file (Filename.basename log_prefix) ".err.log" in at_exit (fun () -> try Unix.unlink stderr with Unix.Unix_error _ -> ()); stderr in let filter = match command.filter with | None -> None | Some filter -> let len = String.length filter in let rec split_filter i = if i < len && filter.[i] = ' ' then split_filter (i+1) else try let idx = String.index_from filter i ' ' in String.sub filter i idx, String.sub filter idx (len - idx) with Not_found -> String.sub filter i (len - i), "" in let exec_name, params = split_filter 0 in let exec_name = if Sys.file_exists exec_name || not (Filename.is_relative exec_name) then exec_name else Filename.concat (Filename.dirname (Filename.dirname log_prefix)) (Filename.basename exec_name) in Some (exec_name ^ params) in let command_string = basic_command_string command in let command_string = command_string ^ " 2>" ^ stderr in let command_string = match filter with | None -> command_string | Some filter -> command_string ^ " | " ^ filter in let command_string = command_string ^ " >" ^ log_prefix ^ ".res.log" in let command_string = match filter with | None -> command_string | Some filter -> Printf.sprintf "%s && %s < %s > %s && rm -f %s" command_string filter stderr errlog stderr in command_string let update_toplevel_command command = let log_prefix = log_prefix command in let oracle_prefix = oracle_prefix command in let command_string = "mv " ^ log_prefix ^ ".res.log " ^ oracle_prefix ^ ".res.oracle" in ignore (launch command_string); let command_string = "mv " ^ log_prefix ^ ".err.log " ^ oracle_prefix ^ ".err.oracle" in ignore (launch command_string) let update_log_files dir file = let command_string = "mv " ^ make_result_file dir file ^ " " ^ make_oracle_file dir file in ignore (launch command_string) let rec update_command = function Toplevel cmd -> update_toplevel_command cmd | Target (execnow,cmds) -> List.iter (update_log_files execnow.ex_dir) execnow.ex_log; Queue.iter update_command cmds let remove_execnow_results execnow = List.iter (fun f -> try Unix.unlink (make_result_file execnow.ex_dir f) with Unix.Unix_error _ -> ()) (execnow.ex_bin @ execnow.ex_log) module Make_Report(M:sig type t end)=struct module H=Hashtbl.Make (struct type t = toplevel_command let project cmd = (cmd.directory,cmd.file,cmd.n) let compare c1 c2 = Pervasives.compare (project c1) (project c2) let equal c1 c2 = (project c1)=(project c2) let hash c = Hashtbl.hash (project c) end) let tbl = H.create 774 let m = Mutex.create () let record cmd (v:M.t) = if !xunit then begin Mutex.lock m; H.add tbl cmd v; Mutex.unlock m end let iter f = Mutex.lock m; H.iter f tbl; Mutex.unlock m let find k = H.find tbl k let remove k = H.remove tbl k end module Report_run=Make_Report(struct type t=int*float (* At some point will contain the running time*) end) let report_run cmp r = Report_run.record cmp r module Report_cmp=Make_Report(struct type t=int*int end) let report_cmp = Report_cmp.record let pretty_report fmt = Report_run.iter (fun test (_run_result,time_result) -> Format.fprintf fmt "<testcase classname=%S name=%S time=\"%f\">%s</testcase>@." (Filename.basename test.directory) test.file time_result (let res,err = Report_cmp.find test in Report_cmp.remove test; (if res=0 && err=0 then "" else Format.sprintf "<failure type=\"Regression\">%s</failure>" (if res=1 then "Stdout oracle difference" else if res=2 then "Stdout System Error (missing oracle?)" else if err=1 then "Stderr oracle difference" else if err=2 then "Stderr System Error (missing oracle?)" else "Unexpected errror")))); (* Test that were compared but not runned *) Report_cmp.iter (fun test (res,err) -> Format.fprintf fmt "<testcase classname=%S name=%S>%s</testcase>@." (Filename.basename test.directory) test.file (if res=0 && err=0 then "" else Format.sprintf "<failure type=\"Regression\">%s</failure>" (if res=1 then "Stdout oracle difference" else if res=2 then "Stdout System Error (missing oracle?)" else if err=1 then "Stderr oracle difference" else if err=2 then "Stderr System Error (missing oracle?)" else "Unexpected errror"))) let xunit_report () = if !xunit then begin let out = open_out_bin "xunit.xml" in let fmt = Format.formatter_of_out_channel out in Format.fprintf fmt "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>\ @\n<testsuite errors=\"0\" failures=\"%d\" name=\"%s\" tests=\"%d\" time=\"%f\" timestamp=\"%f\">\ @\n%t</testsuite>@." (shared.summary_log-shared.summary_ok) "Frama-C" shared.summary_log ((Unix.times()).Unix.tms_cutime -. shared.summary_time) (Unix.gettimeofday ()) pretty_report; close_out out; end let do_command command = match command with | Toplevel command -> (* Update : copy the logs. Do not enqueue any cmp Run | Show: launch the command, then enqueue the cmp Examine : just enqueue the cmp *) if !behavior = Update then update_toplevel_command command else begin (* Run, Show or Examine *) if !behavior <> Examine then begin let command_string = command_string command in if !verbosity >= 1 then lock_printf "%% launch %s@." command_string ; let launch_result = launch command_string in let time = 0. (* Individual time is difficult to compute correctly for now, and currently unused *) in report_run command (launch_result, time) end; lock (); shared.summary_run <- succ shared.summary_run ; shared.summary_log <- shared.summary_log + 2 ; Queue.push (Cmp_Toplevel command) shared.cmps; unlock () end | Target (execnow, cmds) -> let continue res = lock(); shared.summary_log <- succ shared.summary_log; if res = 0 then begin shared.summary_ok <- succ shared.summary_ok; Queue.transfer shared.commands cmds; shared.commands <- cmds; shared.building_target <- false; Condition.broadcast shared.work_available; if !behavior = Examine || !behavior = Run then begin List.iter (fun f -> Queue.push (Cmp_Log(execnow.ex_dir, f)) shared.cmps) execnow.ex_log end end else begin let rec treat_cmd = function Toplevel cmd -> shared.summary_run <- shared.summary_run + 1; let log_prefix = log_prefix cmd in begin try Unix.unlink (log_prefix ^ ".res.log ") with Unix.Unix_error _ -> () end; | Target (execnow,cmds) -> shared.summary_run <- succ shared.summary_run; remove_execnow_results execnow; Queue.iter treat_cmd cmds in Queue.iter treat_cmd cmds; Queue.push (Target_error execnow) shared.diffs; shared.building_target <- false; Condition.signal shared.diff_available end; unlock() in if !behavior = Update then begin update_command command; lock (); shared.building_target <- false; Condition.signal shared.work_available; unlock (); end else begin if !behavior <> Examine then begin remove_execnow_results execnow; let cmd = if !use_byte || execnow_needs_byte execnow.ex_cmd then execnow_opt_to_byte execnow.ex_cmd else execnow.ex_cmd in let r = launch cmd in continue r end else continue 0 end let log_ext = function Res -> ".res" | Err -> ".err" let compare_one_file cmp log_prefix oracle_prefix log_kind = if !behavior = Show then begin lock(); Queue.push (Command_error(cmp,log_kind)) shared.diffs; Condition.signal shared.diff_available; unlock(); -1 end else let ext = log_ext log_kind in let log_file = log_prefix ^ ext ^ ".log " in let oracle_file = oracle_prefix ^ ext ^ ".oracle" in let cmp_string = !do_cmp ^ " " ^ log_file ^ oracle_file ^ " > /dev/null 2> /dev/null" in if !verbosity >= 2 then lock_printf "%% cmp%s (%d) :%s@." ext cmp.n cmp_string; match launch cmp_string with 0 -> lock(); shared.summary_ok <- shared.summary_ok + 1; unlock(); 0 | 1 -> lock(); Queue.push (Command_error (cmp,log_kind)) shared.diffs; Condition.signal shared.diff_available; unlock(); 1 | 2 -> lock_printf "%% System error while comparing. Maybe one of the files is missing...@\n%s or %s@." log_file oracle_file; 2 | n -> lock_printf "%% Comparison function exited with code %d for files %s and %s. \ Allowed exit codes are 0 (no diff), 1 (diff found) and \ 2 (system error). This is a fatal error.@." n log_file oracle_file; exit 2 let compare_one_log_file dir file = if !behavior = Show then begin lock(); Queue.push (Log_error(dir,file)) shared.diffs; Condition.signal shared.diff_available; unlock() end else let log_file = make_result_file dir file in let oracle_file = make_oracle_file dir file in let cmp_string = !do_cmp ^ " " ^ log_file ^ " " ^ oracle_file ^ " > /dev/null 2> /dev/null" in if !verbosity >= 2 then lock_printf "%% cmplog: %s / %s@." dir file; shared.summary_log <- succ shared.summary_log; match launch cmp_string with 0 -> lock(); shared.summary_ok <- shared.summary_ok + 1; unlock() | 1 -> lock(); Queue.push (Log_error (dir,file)) shared.diffs; Condition.signal shared.diff_available; unlock() | 2 -> lock_printf "%% System error while comparing. Maybe one of the files is missing...@\n%s or %s@." log_file oracle_file; | n -> lock_printf "%% Diff function exited with code %d for files %s and %s. \ Allowed exit codes are 0 (no diff), 1 (diff found) and \ 2 (system error). This is a fatal error.@." n log_file oracle_file; exit 2 let do_cmp = function | Cmp_Toplevel cmp -> let log_prefix = log_prefix cmp in let oracle_prefix = oracle_prefix cmp in let res = compare_one_file cmp log_prefix oracle_prefix Res in let err = compare_one_file cmp log_prefix oracle_prefix Err in report_cmp cmp (res,err) | Cmp_Log(dir, f) -> ignore (compare_one_log_file dir f) let worker_thread () = while true do lock () ; if (Queue.length shared.commands) + (Queue.length shared.cmps) < !n then Condition.signal shared.commands_empty; try let cmp = Queue.pop shared.cmps in unlock () ; do_cmp cmp with Queue.Empty -> try let rec real_command () = let command = try if shared.building_target then raise Queue.Empty; Queue.pop shared.target_queue with Queue.Empty -> Queue.pop shared.commands in match command with Target _ -> if shared.building_target then begin Queue.push command shared.target_queue; real_command() end else begin shared.building_target <- true; command end | _ -> command in let command = real_command() in unlock () ; do_command command with Queue.Empty -> if shared.commands_finished && Queue.is_empty shared.target_queue && not shared.building_target (* a target being built would mean work can still appear *) then (unlock () ; Thread.exit ()); Condition.signal shared.commands_empty; (* we still have the lock at this point *) Condition.wait shared.work_available shared.lock; (* this atomically releases the lock and suspends the thread on the condition work_available *) unlock (); done let do_diff = function | Command_error (diff, kind) -> let log_prefix = log_prefix diff in let log_ext = log_ext kind in let command_string = command_string diff in lock_printf "%tCommand:@\n%s@." print_default_env command_string; if !behavior = Show then ignore (launch ("cat " ^ log_prefix ^ log_ext ^ ".log")) else let oracle_prefix = oracle_prefix diff in let diff_string = !do_diffs ^ " " ^ oracle_prefix ^ log_ext ^ ".oracle " ^ log_prefix ^ log_ext ^ ".log" in ignore (launch diff_string) | Target_error execnow -> lock_printf "Custom command failed: %s@\n" execnow.ex_cmd | Log_error(dir, file) -> let result_file = make_result_file dir file in lock_printf "Log of %s:@." result_file; if !behavior = Show then ignore (launch ("cat " ^ result_file)) else let diff_string = !do_diffs ^ " " ^ make_oracle_file dir file ^ " " ^ result_file in ignore (launch diff_string) let diff_thread () = lock () ; while true do try let diff = Queue.pop shared.diffs in unlock (); do_diff diff; lock () with Queue.Empty -> if shared.cmp_finished then (unlock () ; Thread.exit ()); Condition.wait shared.diff_available shared.lock (* this atomically releases the lock and suspends the thread on the condition cmp_available *) done let test_pattern config = let regexp = Str.regexp config.dc_test_regexp in fun file -> Str.string_match regexp file 0 let files = Queue.create () (* test for a possible toplevel configuration. *) let default_config = let general_config_file = Filename.concat test_path dir_config_file in if Sys.file_exists general_config_file then begin let scan_buffer = Scanf.Scanning.from_file general_config_file in scan_options Filename.current_dir_name scan_buffer default_config end else default_config let () = (* enqueue the test files *) let suites = match !suites with [] -> let priority = "idct" in let default = !Ptests_config.default_suites in if List.mem priority default then priority :: (List.filter (fun name -> name <> priority) default) else default | l -> List.rev l in let interpret_as_file suite = try let ext = Filename.chop_extension suite in ext <> "" with Invalid_argument _ -> false in let exclude_suite, exclude_file = List.fold_left (fun (suite,test) x -> if interpret_as_file x then (suite,x::test) else (x::suite,test)) ([],[]) !exclude_suites in List.iter (fun suite -> if !verbosity >= 2 then lock_printf "%% producer now treating test %s\n%!" suite; (* the "suite" may be a directory in [test_path] or a single file *) let interpret_as_file = interpret_as_file suite in let directory = if interpret_as_file then Filename.dirname suite else Filename.concat test_path suite in let config = Filename.concat directory dir_config_file in let dir_config = if Sys.file_exists config then begin let scan_buffer = Scanf.Scanning.from_file config in scan_options directory scan_buffer default_config end else default_config in if interpret_as_file then begin if not (List.mem suite exclude_file) then Queue.push (Filename.basename suite, directory, { dir_config with dc_is_explicit_test = true}) files end else begin if not (List.mem suite exclude_suite) then begin let dir_files = Sys.readdir directory in for i = 0 to pred (Array.length dir_files) do let file = dir_files.(i) in assert (Filename.is_relative file); if test_pattern dir_config file && (not (List.mem (Filename.concat directory file) exclude_file)) then Queue.push (file, directory, dir_config) files; done end end) suites let dispatcher () = try while true do lock (); while (Queue.length shared.commands) + (Queue.length shared.cmps) >= !n do Condition.wait shared.commands_empty shared.lock; done; (* we have the lock *) let file, directory, config = Queue.pop files in let config = scan_test_file config directory file in let i = ref 0 in let make_toplevel_cmd (toplevel, options) = let toplevel, options = if !use_byte || needs_byte options then opt_to_byte toplevel, opt_to_byte_options options else toplevel,options in {file=file; options = options; toplevel = toplevel; n = !i; directory = directory; filter = config.dc_filter} in let treat_option q option = Queue.push (Toplevel (make_toplevel_cmd option)) q; incr i in if not config.dc_dont_run then begin (match config.dc_execnow with | hd :: tl -> let subworkqueue = Queue.create () in List.iter (treat_option subworkqueue) config.dc_toplevels; let target = List.fold_left (fun current_target execnow -> let subworkqueue = Queue.create () in Queue.add current_target subworkqueue; Target(execnow,subworkqueue)) (Target(hd,subworkqueue)) tl in Queue.push target shared.commands | [] -> List.iter (treat_option shared.commands) config.dc_toplevels); Condition.broadcast shared.work_available; end; unlock () ; done with Queue.Empty -> shared.commands_finished <- true; unlock () let () = let worker_ids = Array.init !n (fun _ -> Thread.create worker_thread ()) in let diff_id = Thread.create diff_thread () in dispatcher (); if !behavior = Run then lock_printf "%% Dispatch finished, waiting for workers to complete@."; ignore (Thread.create (fun () -> while true do Condition.broadcast shared.work_available; Thread.delay 0.5; done) ()); Array.iter Thread.join worker_ids; if !behavior = Run then lock_printf "%% Comparisons finished, waiting for diffs to complete@."; lock(); shared.cmp_finished <- true; unlock(); ignore (Thread.create (fun () -> while true do Condition.broadcast shared.diff_available; Thread.delay 0.5; done) ()); Thread.join diff_id; if !behavior = Run then lock_printf "%% Diffs finished. Summary:@\nRun = %d@\nOk = %d of %d@\nTime = %f s.@." shared.summary_run shared.summary_ok shared.summary_log ((Unix.times()).Unix.tms_cutime -. shared.summary_time); xunit_report (); let error_code = if !do_error_code && shared.summary_log <> shared.summary_ok then 1 else 0 in exit error_code (* Local Variables: compile-command: "LC_ALL=C make -C .. ptests" End: *) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/ptests/mmap.ml������������������������������������������������������������0000644�0001750�0001750�00000004747�12155630164�016622� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(**************************************************************************) (* *) (* This file is part of Frama-C. *) (* *) (* Copyright (C) 2007-2013 *) (* 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 Bigarray open Unix let compare_files f f' = let fd = Unix.openfile f [Unix.O_RDONLY] 0o000 in let fd' = Unix.openfile f' [Unix.O_RDONLY] 0o000 in let size_byte = (Unix.fstat fd).st_size in let size_byte' = (Unix.fstat fd').st_size in if size_byte' <> size_byte then false else (try let initial_padding = size_byte mod 8 in for i = 1 to initial_padding do let s = "_" in let s' = "_" in assert (Unix.read fd s 0 1=1); assert (Unix.read fd' s' 0 1=1); if s <> s' then raise Not_found done; let size_bigarray = size_byte / 8 in let mapped = Array1.map_file fd int64 c_layout false size_bigarray in let mapped' = Array1.map_file fd' int64 c_layout false size_bigarray in mapped = mapped' with Not_found -> false) let () = Format.printf "GOT:%b@." (compare_files "/tmp/big.mmap" "/tmp/big.mmap") �������������������������frama-c-Fluorine-20130601/lib/����������������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�014543� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/lib/plugins/��������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�016224� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/lib/gui/������������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�015327� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/Makefile������������������������������������������������������������������0000644�0001750�0001750�00000225132�12155630370�015444� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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). # # # ########################################################################## # This file is the main makefile of Frama-C. FRAMAC_SRC=. MAKECONFIG_DIR=share include share/Makefile.common ################### # Frama-C Version # ################### VERSION=$(shell $(SED) -e 's/\\(.*\\)/\\1/' VERSION) ifeq ($(findstring +dev,$(VERSION)),+dev) DEVELOPMENT=yes else DEVELOPMENT=no endif ########################### # Global plugin variables # ########################### # the directory where compiled plugin files are stored PLUGIN_LIB_DIR = lib/plugins PLUGIN_GUI_LIB_DIR= lib/plugins/gui # the directory where the other Makefiles are FRAMAC_SHARE = share # set it to yes to tell Makefile.dynamic than we come from here FRAMAC_MAKE =yes # Shared lists between Makefile.plugin and Makefile : # initialized them as "simply extended variables" (with :=) # for a correct behavior of += (see section 6.6 of GNU Make manual) PLUGIN_LIST := PLUGIN_DYN_EXISTS:="no" PLUGIN_DYN_LIST := PLUGIN_CMO_LIST := PLUGIN_CMX_LIST := PLUGIN_DYN_CMO_LIST := PLUGIN_DYN_CMX_LIST := PLUGIN_INTERNAL_CMO_LIST:= PLUGIN_INTERNAL_CMX_LIST:= PLUGIN_DEP_GUI_CMO_LIST:= PLUGIN_DEP_GUI_CMX_LIST:= PLUGIN_GUI_CMO_LIST:= PLUGIN_GUI_CMX_LIST:= PLUGIN_DYN_DEP_GUI_CMO_LIST:= PLUGIN_DYN_DEP_GUI_CMX_LIST:= PLUGIN_DYN_GUI_CMO_LIST := PLUGIN_DYN_GUI_CMX_LIST := PLUGIN_TYPES_CMO_LIST := PLUGIN_TYPES_CMX_LIST := PLUGIN_DEP_LIST:= PLUGIN_DOC_LIST := PLUGIN_DOC_DIRS := PLUGIN_DISTRIBUTED_LIST:= PLUGIN_DIST_TARGET_LIST:= PLUGIN_DIST_DOC_LIST:= PLUGIN_BIN_DOC_LIST:= PLUGIN_DIST_EXTERNAL_LIST:= PLUGIN_TESTS_LIST:= PLUGIN_DISTRIBUTED_NAME_LIST:= CEA_WP:= ############################### # Additional global variables # ############################### # put here any config option for the binary distribution outside of # plugins CONFIG_DISTRIB_BIN:= # additional compilation targets for 'make all'. # cannot be delayed after 'make all' EXTRAS = ptests # Directories containing some source code SRC_DIRS= ptests $(PLUGIN_LIB_DIR) # Directory containing source code documentation DOC_DIR = doc/code # Source files to document MODULES_TODOC= # Directories containing some source code SRC_DIRS+= $(FRAMAC_SRC_DIRS) # Directories to include when compiling INCLUDES=$(addprefix -I , $(FRAMAC_SRC_DIRS)) -I $(PLUGIN_LIB_DIR) -I lib # Directories to include for ocamldep # Remove -I +.* and -I C:/absolute/win/path INCLUDES_FOR_OCAMLDEP= $(shell echo $(INCLUDES) $(GUI_INCLUDES) | $(SED) -e "s/-I *.:[^ ]*//g" -e "s/-I *+[^ ]*//g" -e "s|-I *$(LABLGTK_PATH)[^ ]*||g") # Ocamldep flags DEP_FLAGS= $(INCLUDES_FOR_OCAMLDEP) # Files for which dependencies are computed FILES_FOR_OCAMLDEP+=$(PLUGIN_LIB_DIR)/*.mli \ $(addsuffix /*.mli, $(UNPACKED_DIRS)) \ $(addsuffix /*.ml, $(UNPACKED_DIRS)) # Flags to use by ocamlc and ocamlopt ifeq ($(DEVELOPMENT),yes) ifeq ($(HAS_OCAML312),yes) ifeq ($(WARN_ERROR_ALL),yes) DEV_FLAGS=$(FLAGS) -warn-error +a else DEV_FLAGS=$(FLAGS) -warn-error +a-32-33-34-35-36-37-38-39 endif #WARN_ERROR_ALL else DEV_FLAGS=$(FLAGS) -warn-error A endif #HAS_OCAML312 else DEV_FLAGS=$(FLAGS) endif #DEVELOPMENT BFLAGS = $(DEV_FLAGS) $(DEBUG) $(INCLUDES) $(COVERAGE_COMPILER_BYTE) \ $(OCAMLVIZ_COMPILER_BYTE) $(OUNIT_COMPILER_BYTE) OFLAGS = $(DEV_FLAGS) $(DEBUG) $(INCLUDES) $(COVERAGE_COMPILER_OPT) \ $(GPROFOPT) $(OCAMLVIZ_COMPILER_OPT) $(OUNIT_COMPILER_OPT) -compact BLINKFLAGS += $(BFLAGS) -linkall -custom OLINKFLAGS += $(OFLAGS) -linkall DOC_FLAGS= -colorize-code -stars -inv-merge-ml-mli -m A -hide-warnings \ $(INCLUDES) $(GUI_INCLUDES) # Libraries generated by Frama-C GEN_BYTE_LIBS= GEN_OPT_LIBS= # Libraries used in Frama-C EXTRA_OPT_LIBS:= BYTE_LIBS = nums.cma unix.cma bigarray.cma str.cma dynlink.cma \ $(GEN_BYTE_LIBS) OPT_LIBS = nums.cmxa unix.cmxa bigarray.cmxa str.cmxa $(EXTRA_OPT_LIBS) ifeq ("$(NATIVE_DYNLINK)","yes") OPT_LIBS+= dynlink.cmxa endif OPT_LIBS+= $(GEN_OPT_LIBS) ICONS:= $(addprefix share/, \ frama-c.ico frama-c.gif unmark.png ) FEEDBACK_ICONS:= $(addprefix share/feedback/, \ never_tried.png \ unknown.png \ surely_valid.png \ surely_invalid.png \ considered_valid.png \ valid_under_hyp.png \ invalid_under_hyp.png \ invalid_but_dead.png \ unknown_but_dead.png \ valid_but_dead.png \ inconsistent.png \ switch-on.png \ switch-off.png ) ROOT_LIBC_DIR:= share/libc LIBC_SUBDIRS:= . sys netinet linux net arpa LIBC_DIR:= $(addprefix $(ROOT_LIBC_DIR)/, $(LIBC_SUBDIRS)) FREE_LIBC:= \ share/*.h share/*.c \ $(addsuffix /*.h, $(LIBC_DIR)) \ $(ROOT_LIBC_DIR)/./__fc_builtin_for_normalization.i \ NONFREE_LIBC:= $(addsuffix /*.[ci], $(LIBC_DIR)) # Kernel files to be included in the distribution. # Plug-ins should use PLUGIN_DISTRIB_EXTERNAL if they export something else # than *.ml* files in their directory. # NB: configure for the distribution is generated in the distrib directory # itself, rather than copied: otherwise, it could include references to # non-distributed plug-ins. DISTRIB_FILES:= cil/*/*.ml* cil/*/*.in \ $(filter-out cil/src/frontc/cparser.ml cil/src/frontc/cparser.mli \ cil/src/logic/logic_lexer.ml cil/src/logic/logic_parser.mli \ cil/src/logic/logic_parser.ml cil/src/frontc/clexer.ml \ cil/src/logic/logic_preprocess.ml, \ $(wildcard cil/src/*/*.ml*)) \ bin/oxygen2fluorine.sh \ share/frama-c.WIN32.rc share/frama-c.Unix.rc \ $(ICONS) $(FEEDBACK_ICONS) \ man/frama-c.1 doc/manuals/*.pdf doc/README \ doc/code/docgen_*.ml \ doc/code/*.css doc/code/intro_plugin.txt \ doc/code/intro_plugin_D_and_S.txt \ doc/code/intro_plugin_default.txt \ doc/code/intro_kernel_plugin.txt doc/code/intro_occurrence.txt \ doc/code/intro_pdg.txt doc/code/intro_scope.txt \ doc/code/intro_slicing.txt doc/code/intro_sparecode.txt \ doc/code/intro_wp.txt doc/code/toc_head.htm \ doc/code/toc_tail.htm \ doc/code/print_api/*.ml* doc/code/print_api/Makefile \ tests/*/*.c tests/*/*.i tests/*/*.h tests/*/*.ml \ $(filter-out ptests/ptests_config.ml, $(wildcard ptests/*.ml*)) \ configure.in Makefile \ share/Makefile.plugin share/Makefile.dynamic \ share/Makefile.dynamic_config.internal \ share/Makefile.dynamic_config.external Changelog config.h.in \ VERSION licenses/* \ $(FREE_LIBC) \ share/acsl.el share/configure.ac \ share/Makefile.config.in share/Makefile.common \ share/Makefile.plugin share/Makefile.dynamic \ share/Makefile.dynamic_config.external \ share/Makefile.dynamic_config.internal \ $(filter-out src/kernel/config.ml, $(wildcard src/kernel/*.ml*)) \ external/hptmap.ml* external/unmarshal*.ml* external/unz.ml* \ external/sysutil.ml* \ src/ai/*.ml* src/buckx/*.ml* \ src/buckx/*.c src/gui/*.ml* src/logic/*.ml* \ $(filter-out src/lib/integer.ml \ src/lib/dynlink_common_interface.ml, \ $(wildcard src/lib/*.ml*)) \ src/memory_state/*.ml* src/misc/*.ml* src/project/*.ml* \ src/printer/*.ml* src/toplevel/toplevel_config.ml src/type/*.ml* \ bin/sed_get_make_major bin/sed_get_make_minor \ INSTALL INSTALL_WITH_WHY .make-clean \ .make-clean-stamp .make-ocamlgraph-stamp .force-reconfigure # files that are needed to compile API documentation of external plugins DOC_GEN_FILES:=$(addprefix doc/code/, \ *.css intro_plugin.txt intro_kernel_plugin.txt \ intro_plugin_default.txt intro_plugin_D_and_S \ kernel-doc.ocamldoc \ docgen_*.ml docgen.cm* *.htm) ################ # Main targets # ################ ifneq ($(ENABLE_GUI),no) ifeq ($(HAS_LABLGTK),yes) EXTRAS += gui endif endif all:: byte $(OCAMLBEST) $(EXTRAS) .PHONY: top opt byte dist bdist archclean rebuild top: bin/toplevel.top$(EXE) $(MAKE) install-kernel-byte FRAMAC_LIBDIR=lib/fc byte:: bin/toplevel.byte$(EXE) \ share/Makefile.dynamic_config share/Makefile.kernel $(MAKE) install-kernel-byte FRAMAC_LIBDIR=lib/fc opt:: bin/toplevel.opt$(EXE) \ share/Makefile.dynamic_config share/Makefile.kernel $(MAKE) install-kernel-opt FRAMAC_LIBDIR=lib/fc dist: clean $(QUIET_MAKE) OPTIM="-unsafe -noassert" DEBUG="" all bdist: clean $(QUIET_MAKE) OPTIM="-unsafe -noassert" DEBUG="" byte ifneq ("$(OCAMLGRAPH_LOCAL)","") archclean: clean $(MAKE) -C $(OCAMLGRAPH_LOCAL) distclean cd $(OCAMLGRAPH_LOCAL) ; ./configure rebuild: archclean $(MAKE) -C $(OCAMLGRAPH_LOCAL) $(QUIET_MAKE) all else archclean: clean rebuild: archclean $(QUIET_MAKE) all endif ############ # Coverage # ############ USE_COVERAGE_TOOL=no ifeq ($(USE_COVERAGE_TOOL),yes) COVERAGE_PATH=. COVERAGE_PREPRO=camlp4o -no_quot -filter $(COVERAGE_PATH)/coverage_filter.cmo COVERAGE_COMPILER_BYTE=-I $(COVERAGE_PATH) -pp "$(COVERAGE_PREPRO)" COVERAGE_COMPILER_OPT=-I $(COVERAGE_PATH) -pp "$(COVERAGE_PREPRO)" COVERAGE_LIB_BYTE=coverage.cma COVERAGE_LIB_OPT=coverage.cmxa endif INCLUDES+=$(COVERAGE_COMPILER_BYTE) GEN_BYTE_LIBS+=$(COVERAGE_LIB_BYTE) GEN_OPT_LIBS+=$(COVERAGE_LIB_OPT) SRC_DIRS+=$(COVERAGE_PATH) ######################## # Ocamlviz (profiling) # ######################## # To use OCamlviz you need to fix its makefile :-( # In $(OCAMLVIZ_PATH)/Makefile.in change the line # OCAMLVIZCMO = $(PROTOCOLCMO) src/monitor_impl.cmo src/ocamlviz.cmo src/ocamlviz_threads.cmo # into # OCAMLVIZCMO = $(PROTOCOLCMO) src/monitor_impl.cmo src/ocamlviz.cmo # and # cp -f src/ocamlviz.mli src/ocamlviz.cmi src/ocamlviz_threads.cmi $(OCAMLLIB) # into # cp -f src/ocamlviz.mli src/ocamlviz.cmi $(OCAMLLIB) # # Then run "./configure && make && make install" in $(OCAMLVIZ_PATH) # Only one instance of Frama-C can be launched at a time when Ocamlviz is on. USE_OCAMLVIZ_TOOL=no ifeq ($(USE_OCAMLVIZ_TOOL),yes) OCAMLVIZ_PATH=~/src/ocamlviz OCAMLVIZ_COMPILER_BYTE=-I $(OCAMLVIZ_PATH)/src # -pp "camlp4 pa_o.cmo str.cma $(OCAMLVIZ_PATH)/camlp4/pa_ocamlviz.cmo pr_o.cmo" # Seems really broken and generates fatal warnings OCAMLVIZ_COMPILER_OPT=-I $(OCAMLVIZ_PATH)/src OCAMLVIZ_LIB_BYTE=~/lib/ocaml/libocamlviz.cma OCAMLVIZ_LIB_OPT=~/lib/ocaml/libocamlviz.cmxa endif BYTE_LIBS+=$(OCAMLVIZ_LIB_BYTE) OPT_LIBS+=$(OCAMLVIZ_LIB_OPT) ######### # OUnit # ######### USE_OUNIT_TOOL=no ifeq ($(USE_OUNIT_TOOL),yes) OCAML_LIBDIR :=$(shell ocamlc -where) OUNIT_PATH=$(OCAML_LIBDIR)/../pkg-lib/oUnit OUNIT_COMPILER_BYTE=-I $(OUNIT_PATH) OUNIT_COMPILER_OPT=-I $(OUNIT_PATH) OUNIT_LIB_BYTE=$(OUNIT_PATH)/oUnit.cma OUNIT_LIB_OPT=$(OUNIT_PATH)/oUnit.cmxa endif BYTE_LIBS+=$(OUNIT_LIB_BYTE) OPT_LIBS+=$(OUNIT_LIB_OPT) ############## # Ocamlgraph # ############## ifneq ("$(OCAMLGRAPH_LOCAL)","") lib/graph.cmi: .make-ocamlgraph $(wildcard $(OCAMLGRAPH_LOCAL)/src/*.ml*) \ $(OCAMLGRAPH_LOCAL)/Makefile $(PRINT_BUILD) ocamlgraph $(MAKE) -C $(OCAMLGRAPH_LOCAL) $(PRINT_CP) $@ $(CP) $(patsubst lib/%,$(OCAMLGRAPH_LOCAL)/%,$@) $@ lib/graph.cmo: lib/graph.cmi $(PRINT_CP) $@ $(CP) $(patsubst lib/%,$(OCAMLGRAPH_LOCAL)/%,$@) $@ lib/graph.cmx: lib/graph.cmi $(PRINT_CP) $@ $(CP) $(patsubst lib/%,$(OCAMLGRAPH_LOCAL)/%,$@) $@ lib/graph.o: lib/graph.cmi $(PRINT_CP) $@ $(CP) $(patsubst lib/%,$(OCAMLGRAPH_LOCAL)/%,$@) $@ GRAPH_LIB+= lib/graph.cmo lib/graph.cmi ifneq ($(OCAMLOPT),no) GRAPH_LIB+= lib/graph.cmx lib/graph.o endif GRAPH_BYTE_LIBS=lib/graph.cmo GRAPH_OPT_LIBS=lib/graph.cmx GEN_BYTE_LIBS+=$(GRAPH_BYTE_LIBS) GEN_OPT_LIBS+=$(GRAPH_OPT_LIBS) .PRECIOUS: .cmo .cmi .cmx .o .cmxa .cma # dgraph (included in ocamlgraph) ifeq ($(HAS_GNOMECANVAS),yes) ifneq ($(ENABLE_GUI),no) lib/dgraph.cmi: lib/graph.cmi $(PRINT_CP) $@ $(CP) $(patsubst lib/%,$(OCAMLGRAPH_LOCAL)/dgraph/%,$@) $@ lib/dgraph.cmo: lib/graph.cmi $(PRINT_CP) $@ $(CP) $(patsubst lib/%,$(OCAMLGRAPH_LOCAL)/dgraph/%,$@) $@ lib/dgraph.cmx: lib/graph.cmi $(PRINT_CP) $@ $(CP) $(patsubst lib/%,$(OCAMLGRAPH_LOCAL)/dgraph/%,$@) $@ lib/dgraph.o: lib/graph.cmi $(PRINT_CP) $@ $(CP) $(patsubst lib/%,$(OCAMLGRAPH_LOCAL)/dgraph/%,$@) $@ GRAPH_GUICMO= lib/dgraph.cmo GRAPH_GUICMI= $(GRAPH_GUICMO:.cmo=.cmi) GRAPH_GUICMX= $(GRAPH_GUICMO:.cmo=.cmx) GRAPH_GUIO= $(GRAPH_GUICMO:.cmo=.o) GRAPH_LIB+= $(GRAPH_GUICMI) $(GRAPH_GUICMO) ifneq ($(OCAMLOPT),no) GRAPH_LIB+= $(GRAPH_GUICMX) $(GRAPH_GUIO) endif GEN_BYTE_GUI_LIBS+=$(GRAPH_GUICMO) GEN_OPT_GUI_LIBS+=$(GRAPH_GUICMX) HAS_DGRAPH=yes else # enable_gui is no: disable dgraph HAS_DGRAPH=no endif else # gnome_canvas is not yes: disable dgraph HAS_DGRAPH=no endif else # does not use ocamlgraph local version INCLUDES+=$(OCAMLGRAPH_INCLUDE) BYTE_LIBS+= graph.cma OPT_LIBS+= graph.cmxa # and dgraph (included in ocamlgraph) ifeq ($(HAS_GNOMECANVAS),yes) ifneq ($(ENABLE_GUI),no) GRAPH_GUICMO_BASE= dgraph.cmo GRAPH_GUICMO=$(GRAPH_GUICMO_BASE:%=$(OCAMLGRAPH_HOME)/%) GRAPH_GUICMX= $(GRAPH_GUICMO:.cmo=.cmx) GRAPH_GUIO= $(GRAPH_GUICMO:.cmo=.o) HAS_DGRAPH=yes else # enable_gui is no: disable dgraph HAS_DGRAPH=no endif else # gnome_canvas is not yes: disable dgraph HAS_DGRAPH=no endif endif # testing ocamlgraph is local GENERATED+=$(GRAPH_LIB) # Redoing ocamlgraph on need ############################ # If 'make untar-ocamlgraph' have to be performed after 'svn update': # change '.make-ocamlgraph-stamp' before 'cvs commit' .make-ocamlgraph: .make-ocamlgraph-stamp $(TOUCH) $@ ifneq ("$(OCAMLGRAPH_LOCAL)","") # Inline the rules of "untar-ocamlgraph" here # because calling a recursive make does not work $(PRINT_UNTAR) ocamlgraph $(RM) -r $(OCAMLGRAPH_LOCAL) $(TAR) xzf ocamlgraph.tar.gz cd $(OCAMLGRAPH_LOCAL) && ./configure $(MAKE) clean endif include .make-ocamlgraph DISTRIB_FILES += .make-ocamlgraph # force "make untar-ocamlgraph" to be executed for all SVN users force-ocamlgraph: expr `$(CAT) .make-ocamlgraph-stamp` + 1 > .make-ocamlgraph-stamp .PHONY: untar-ocamlgraph untar-ocamlgraph: $(PRINT_UNTAR) $@ $(RM) -r $(OCAMLGRAPH_LOCAL) $(TAR) xzf ocamlgraph.tar.gz cd $(OCAMLGRAPH_LOCAL) && ./configure $(MAKE) clean ########## # Zarith # ########## ifeq ($(HAS_ZARITH),yes) BYTE_LIBS+= zarith.cma OPT_LIBS+= zarith.cmxa INCLUDES+= -I $(ZARITH_PATH) src/lib/integer.ml: src/lib/integer.ml.zarith \ share/Makefile.config.in Makefile $(PRINT_CP) $@ $(CP) $< $@ $(CHMOD_RO) $@ else src/lib/integer.ml: src/lib/integer.ml.bigint \ share/Makefile.config.in Makefile $(PRINT_CP) $@ $(CP) $< $@ $(CHMOD_RO) $@ endif GENERATED += src/lib/integer.ml DISTRIB_FILES+= src/lib/integer.ml.zarith src/lib/integer.ml.bigint ################## # Frama-C Kernel # ################## # Dynlink library ################# GENERATED += src/lib/dynlink_common_interface.ml ifeq ($(USABLE_NATIVE_DYNLINK),yes) # native dynlink works src/lib/dynlink_common_interface.ml: src/lib/dynlink_311_or_higher.ml \ share/Makefile.config Makefile $(PRINT_MAKING) $@ $(CP) $< $@ $(CHMOD_RO) $@ else # native dynlink doesn't work ifeq ($(NATIVE_DYNLINK),yes) # native dynlink does exist but doesn't work src/lib/dynlink_common_interface.ml: src/lib/bad_dynlink_311_or_higher.ml \ share/Makefile.config Makefile $(PRINT_MAKING) $@ $(CP) $< $@ $(CHMOD_RO) $@ else # no dynlink at all (for instance no native compiler) # Just for ocamldep src/lib/dynlink_common_interface.ml: src/lib/dynlink_311_or_higher.ml \ share/Makefile.config Makefile $(PRINT_MAKING) $@ $(CP) $< $@ $(CHMOD_RO) $@ # Add two different rules for bytecode and native since # the file dynlink_common_interface.ml does not provide from the same file # in these cases. src/lib/dynlink_common_interface.cmo: src/lib/dynlink_311_or_higher.ml \ share/Makefile.config Makefile $(PRINT_MAKING) src/lib/dynlink_common_interface.ml $(CP) $< src/lib/dynlink_common_interface.ml $(CHMOD_RO) src/lib/dynlink_common_interface.ml $(PRINT_OCAMLC) $@ $(OCAMLC) -c $(BFLAGS) src/lib/dynlink_common_interface.ml src/lib/dynlink_common_interface.cmx: src/lib/no_dynlink_opt.ml \ share/Makefile.config \ Makefile $(PRINT_MAKING) src/lib/dynlink_common_interface.ml $(CP) $< src/lib/dynlink_common_interface.ml $(CHMOD_RO) src/lib/dynlink_common_interface.ml $(PRINT_OCAMLOPT) $@ $(OCAMLOPT) -c $(OFLAGS) src/lib/dynlink_common_interface.ml # force dependency order between these two files in order to not generate them # in parallel since each of them generates the same .ml file src/lib/dynlink_common_interface.cmx: src/lib/dynlink_common_interface.cmo src/lib/dynlink_common_interface.o: src/lib/dynlink_common_interface.cmx endif endif # Libraries which could be compiled fully independently ####################################################### EXTERNAL_LIB_CMO = unmarshal unmarshal_nums sysutil # Zarith ifeq ($(HAS_ZARITH),yes) EXTERNAL_LIB_CMO+= unz MODULES_NODOC+=external/unz.mli endif EXTERNAL_LIB_CMO:= $(patsubst %, external/%.cmo, $(EXTERNAL_LIB_CMO)) CMO += $(EXTERNAL_LIB_CMO) LIB_CMO = \ src/lib/dynlink_common_interface \ src/type/structural_descr \ src/type/type \ src/type/descr \ src/lib/hashtbl_common_interface \ src/lib/extlib \ src/lib/pretty_utils \ src/lib/hook \ src/lib/bag \ src/lib/indexer \ src/lib/bitvector \ src/lib/qstack \ src/lib/integer \ src/lib/filepath LIB_CMO:= $(addsuffix .cmo, $(LIB_CMO)) CMO += $(LIB_CMO) # Very first files to be linked (most modules use them) ############################### FIRST_CMO= src/kernel/config \ src/kernel/gui_init \ src/kernel/log \ src/kernel/cmdline \ src/project/project_skeleton \ src/type/datatype \ src/kernel/journal \ src/kernel/parameter \ src/project/state \ src/kernel/dynamic \ src/printer/printer_builder \ src/lib/rangemap # project_skeleton requires log # datatype requires project_skeleton # rangemap requires datatype FIRST_CMO:= $(addsuffix .cmo, $(FIRST_CMO)) CMO += $(FIRST_CMO) #Project (Project_skeleton must be linked before Journal) PROJECT_CMO= \ state_dependency_graph \ state_topological \ state_selection \ project \ state_builder PROJECT_CMO:= $(patsubst %, src/project/%.cmo, $(PROJECT_CMO)) CMO += $(PROJECT_CMO) # Kernel files usable by Cil PRE_KERNEL_CMO= \ src/kernel/plugin \ src/kernel/kernel \ src/lib/floating_point \ src/kernel/emitter \ src/lib/binary_cache \ external/hptmap \ src/lib/hptset \ PRE_KERNEL_CMO:= $(patsubst %, %.cmo, $(PRE_KERNEL_CMO)) CMO += $(PRE_KERNEL_CMO) # Cil ##### ifeq ("$(LOCAL_MACHDEP)","yes") # Create the machine dependency module # If the cl command cannot be run then the MSVC part will be identical to GCC .PHONY : machdep $(CIL_PATH)/local_machdep.ml machdep: $(CIL_PATH)/local_machdep.ml bin/machdep.exe: machdep $(CIL_PATH)/local_machdep.ml : cil/src/machdep.c configure.in Makefile $(PRINT_MAKING) $@ $(RM) $@ $(ECHO) "(* This module was generated automatically by code in Makefile and machdep.c *)" >$@ # Now generate the type definition $(ECHO) "open Cil_types" >> $@ if gcc -D_GNUCC $< -o bin/machdep.exe ;then \ $(ECHO) "machdep.exe created succesfully."; \ else \ $(RM) $@; exit 1; \ fi $(ECHO) "let gcc = {" >>$@ ./bin/machdep.exe >>$@ $(ECHO) " underscore_name = $(UNDERSCORE_NAME) ;" >> $@ $(ECHO) "}" >>$@ if cl /D_MSVC $< /Febin/machdep.exe /Fobin/machdep.obj ;then \ $(ECHO) "let hasMSVC = true" >>$@; \ else \ $(ECHO) "let hasMSVC = false" >>$@; \ fi $(ECHO) "let msvc = {" >>$@ ./bin/machdep.exe >>$@ $(ECHO) " underscore_name = true ;" >> $@ $(ECHO) "}" >>$@ $(ECHO) \ "let gccHas__builtin_va_list = $(HAVE_BUILTIN_VA_LIST)" >>$@ $(ECHO) "let __thread_is_keyword = $(THREAD_IS_KEYWORD)" >>$@ $(ECHO) \ "$@ generated. You may have this file merged into Frama-C by developers." $(CHMOD_RO) $@ endif # .cmo files of cil CIL_CMO = cil/src/cilmsg.cmo cil/ocamlutil/alpha.cmo \ cil/ocamlutil/cilconfig.cmo \ $(addprefix $(CIL_PATH)/, \ cil_datatype.cmo \ cil_state_builder.cmo \ logic/utf8_logic.cmo \ machdep_x86_16.cmo machdep_x86_32.cmo \ machdep_x86_64.cmo machdep_ppc_32.cmo \ cil_const.cmo \ logic/logic_env.cmo escape.cmo \ logic/logic_const.cmo cil.cmo) \ src/printer/cil_printer.cmo \ src/printer/cil_descriptive_printer.cmo \ $(addprefix $(CIL_PATH)/, \ frontc/errorloc.cmo \ frontc/cabs.cmo ext/expcompare.cmo \ frontc/cabshelper.cmo \ logic/logic_utils.cmo logic/logic_builtin.cmo \ logic/logic_print.cmo logic/logic_parser.cmo \ logic/logic_lexer.cmo frontc/lexerhack.cmo \ mergecil.cmo rmtmps.cmo logic/logic_typing.cmo \ frontc/cprint.cmo frontc/cabscond.cmo \ frontc/cabsvisit.cmo frontc/cabs2cil.cmo \ frontc/clexer.cmo frontc/cparser.cmo \ logic/logic_preprocess.cmo \ frontc/frontc.cmo ext/obfuscate.cmo \ ext/callgraph.cmo \ ext/dataflow.cmo ext/dominators.cmo ext/oneret.cmo \ ext/cfg.cmo ext/usedef.cmo ext/liveness.cmo \ ext/reachingdefs.cmo ext/availexpslv.cmo \ ext/rmciltmps.cmo ext/deadcodeelim.cmo) \ # end of addprefix CMO += $(CIL_CMO) MLI_ONLY+= $(CIL_PATH)/cil_types.mli $(CIL_PATH)/logic/logic_ptree.mli \ src/printer/printer_api.mli \ src/memory_state/offsetmap_sig.mli src/memory_state/lmap_sig.mli NO_MLI+= \ cil/src/machdep_ppc_32.mli \ cil/src/machdep_x86_16.mli \ cil/src/machdep_x86_32.mli \ cil/src/machdep_x86_64.mli \ cil/src/frontc/cabs.mli \ cil/src/ext/expcompare.mli \ cil/src/logic/logic_lexer.mli \ cil/src/frontc/lexerhack.mli \ cil/src/ext/usedef.mli \ cil/src/ext/liveness.mli \ cil/src/ext/reachingdefs.mli \ cil/src/ext/availexpslv.mli \ cil/src/ext/rmciltmps.mli MODULES_NODOC+= cil/src/machdep_ppc_32.ml \ cil/src/machdep_x86_16.ml \ cil/src/machdep_x86_32.ml \ cil/src/machdep_x86_64.ml \ GENERATED += $(addprefix $(CIL_PATH)/, \ frontc/clexer.ml frontc/cparser.ml frontc/cparser.mli \ logic/logic_lexer.ml logic/logic_parser.ml \ logic/logic_parser.mli logic/logic_preprocess.ml) .PHONY: check-logic-parser-wildcard check-logic-parser-wildcard: cd $(CIL_PATH)/logic && ocaml check_logic_parser.ml # Buckx ####### CMO += src/buckx/buckx.cmo GEN_BUCKX=src/buckx/mybigarray.o src/buckx/buckx_c.o GEN_BYTE_LIBS+= $(GEN_BUCKX) GEN_OPT_LIBS+= $(GEN_BUCKX) src/buckx/buckx_c.o: src/buckx/buckx_c.c $(PRINT_OCAMLC) $@ $(OCAMLC) $(BFLAGS) -ccopt "-O3 -fno-pic -fomit-frame-pointer -o $@" $< # Main part of the kernel ######################### # cannot use $(CONFIG_CMO) here :-( KERNEL_CMO= \ src/kernel/ast_info.cmo \ src/kernel/ast.cmo \ src/kernel/globals.cmo \ src/kernel/kernel_function.cmo \ src/logic/property.cmo \ src/logic/property_status.cmo \ src/logic/annotations.cmo \ src/printer/printer.cmo \ src/logic/description.cmo \ src/logic/statuses_by_call.cmo \ src/kernel/alarms.cmo \ src/kernel/messages.cmo \ src/ai/abstract_interp.cmo \ src/ai/int_Base.cmo \ src/kernel/unicode.cmo \ src/misc/bit_utils.cmo \ src/ai/lattice_Interval_Set.cmo \ src/misc/subst.cmo \ src/misc/service_graph.cmo \ src/lib/setWithNearest.cmo \ src/ai/ival.cmo \ src/ai/base.cmo \ src/ai/origin.cmo \ src/ai/map_Lattice.cmo \ src/memory_state/locations.cmo \ src/kernel/cilE.cmo \ src/memory_state/int_Interv.cmo \ src/memory_state/int_Interv_Map.cmo \ src/memory_state/tr_offset.cmo \ src/memory_state/offsetmap.cmo \ src/memory_state/offsetmap_bitwise.cmo \ src/memory_state/lmap.cmo \ src/memory_state/lmap_bitwise.cmo \ src/memory_state/function_Froms.cmo \ src/memory_state/cvalue.cmo \ src/memory_state/widen_type.cmo \ src/kernel/stmts_graph.cmo \ src/kernel/visitor.cmo \ cil/src/frontc/cabsbranches.cmo \ src/kernel/loop.cmo \ $(PLUGIN_TYPES_CMO_LIST) \ src/memory_state/value_types.cmo \ src/kernel/db.cmo \ src/kernel/unroll_loops.cmo \ src/kernel/command.cmo \ src/kernel/task.cmo \ src/logic/translate_lightweight.cmo \ src/kernel/file.cmo \ src/misc/filter.cmo \ src/kernel/special_hooks.cmo \ src/logic/logic_interp.cmo \ src/logic/infer_annotations.cmo \ src/logic/allocates.cmo CMO += $(KERNEL_CMO) NO_MLI+= src/ai/map_Lattice.mli \ src/memory_state/int_Interv_Map.mli # Common startup module # All link command should add it as last linked module and depend on it. ######################################################################## STARTUP_CMO=src/kernel/boot.cmo STARTUP_CMX=$(STARTUP_CMO:.cmo=.cmx) # GUI modules # See below for GUI compilation ############################################################################## SINGLE_GUI_CMO:= gui_parameters \ gtk_helper gtk_form toolbox \ source_viewer pretty_source source_manager book_manager \ warning_manager \ filetree \ launcher \ menu_manager \ history \ design \ analyses_manager file_manager project_manager debug_manager \ help_manager \ property_navigator SINGLE_GUI_CMO:= $(patsubst %, src/gui/%.cmo, $(SINGLE_GUI_CMO)) ############################################################################### # # #################### # # Plug-in sections # # #################### # # # # For 'internal' developpers: # # you can add your own plug-in here, # # but it is better to have your own separated Makefile # ############################################################################### ########### # Metrics # ########### PLUGIN_ENABLE:=$(ENABLE_METRICS) PLUGIN_NAME:=Metrics PLUGIN_DISTRIBUTED:=yes PLUGIN_HAS_MLI:=yes PLUGIN_DIR:=src/metrics PLUGIN_CMO:= metrics_parameters css_html metrics_base \ metrics_cabs metrics_cilast metrics_coverage \ register PLUGIN_GUI_CMO:= metrics_gui register_gui PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ####################### # Syntactic callgraph # ####################### # Extension of the GUI for syntactic callgraph is compilable # only if dgraph is available ifeq ($(HAS_DGRAPH),yes) PLUGIN_GUI_CMO:=cg_viewer else PLUGIN_UNDOC:=cg_viewer.ml endif PLUGIN_ENABLE:=$(ENABLE_SYNTACTIC_CALLGRAPH) PLUGIN_NAME:=Syntactic_callgraph PLUGIN_DISTRIBUTED:=yes PLUGIN_HAS_MLI:=yes PLUGIN_DIR:=src/syntactic_callgraph PLUGIN_CMO:= options register PLUGIN_NO_TEST:=yes PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ################## # Value analysis # ################## PLUGIN_ENABLE:=$(ENABLE_VALUE_ANALYSIS) PLUGIN_NAME:=Value PLUGIN_DIR:=src/value PLUGIN_CMO:= kf_state value_parameters stop_at_nth value_util \ library_functions mark_noresults separate \ state_set state_imp value_results current_table widen warn \ eval_op eval_exprs non_linear initial_state \ locals_scoping c_assert builtins \ eval_terms eval_annots mem_exec function_args \ split_return local_slevel_types local_slevel eval_stmt eval_slevel \ $(patsubst src/value/%.ml,%,\ $(wildcard src/value/builtins_nonfree*.ml)) \ local_slevel_compute eval_funs register PLUGIN_GUI_CMO:=register_gui PLUGIN_HAS_MLI:=yes PLUGIN_NO_TEST:=yes PLUGIN_DISTRIBUTED:=yes include share/Makefile.plugin ################## # Occurrence # ################## PLUGIN_ENABLE:=$(ENABLE_OCCURRENCE) PLUGIN_NAME:=Occurrence PLUGIN_DISTRIBUTED:=yes PLUGIN_HAS_MLI:=yes PLUGIN_DIR:=src/occurrence PLUGIN_CMO:= options register PLUGIN_GUI_CMO:=register_gui PLUGIN_INTRO:=doc/code/intro_occurrence.txt PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ################################################ # Runtime Error Annotation Generation analysis # ################################################ PLUGIN_ENABLE:=$(ENABLE_RTE_ANNOTATION) PLUGIN_NAME:=RteGen PLUGIN_DIR:=src/rte PLUGIN_CMO:= options generator rte visit register PLUGIN_HAS_MLI:=yes PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ################# # From analysis # ################# PLUGIN_ENABLE:=$(ENABLE_FROM_ANALYSIS) PLUGIN_NAME:=From PLUGIN_DIR:=src/from PLUGIN_CMO:= from_parameters from_compute \ functionwise callwise path_dependencies mem_dependencies from_register PLUGIN_GUI_CMO:=from_register_gui PLUGIN_HAS_MLI:=yes PLUGIN_TESTS_DIRS:=idct test float PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ################## # Users analysis # ################## PLUGIN_ENABLE:=$(ENABLE_USERS) PLUGIN_NAME:=Users PLUGIN_DIR:=src/users PLUGIN_CMO:= users_register PLUGIN_HAS_MLI:=yes PLUGIN_NO_TEST:=yes PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ######################## # Constant propagation # ######################## PLUGIN_ENABLE:=$(ENABLE_SEMANTIC_CONSTANT_FOLDING) PLUGIN_NAME:=Constant_Propagation PLUGIN_DIR:=src/constant_propagation PLUGIN_CMO:= propagationParameters \ register PLUGIN_HAS_MLI:=yes PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ################### # Post-dominators # ################### PLUGIN_ENABLE:=$(ENABLE_POSTDOMINATORS) PLUGIN_NAME:=Postdominators PLUGIN_DIR:=src/postdominators PLUGIN_CMO:= postdominators_parameters print compute PLUGIN_HAS_MLI:=yes PLUGIN_NO_TEST:=yes PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ######### # inout # ######### PLUGIN_ENABLE:=$(ENABLE_INOUT) PLUGIN_NAME:=Inout PLUGIN_DIR:=src/inout PLUGIN_CMO:= inout_parameters cumulative_analysis \ operational_inputs outputs inputs derefs access_path register PLUGIN_TYPES_CMO:=src/memory_state/inout_type PLUGIN_HAS_MLI:=yes PLUGIN_NO_TEST:=yes PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ###################### # Semantic callgraph # ###################### PLUGIN_ENABLE:=$(ENABLE_SEMANTIC_CALLGRAPH) PLUGIN_NAME:=Semantic_callgraph PLUGIN_DIR:=src/semantic_callgraph PLUGIN_CMO:= options register PLUGIN_HAS_MLI:=yes PLUGIN_NO_TEST:=yes PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ################### # Impact analysis # ################### PLUGIN_ENABLE:=$(ENABLE_IMPACT) PLUGIN_NAME:=Impact PLUGIN_DIR:=src/impact PLUGIN_CMO:= options pdg_aux reason_graph compute_impact register PLUGIN_GUI_CMO:= register_gui PLUGIN_HAS_MLI:=yes PLUGIN_DISTRIBUTED:=yes # PLUGIN_UNDOC:=impact_gui.ml PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ################################## # PDG : program dependence graph # ################################## PLUGIN_ENABLE:=$(ENABLE_PDG) PLUGIN_NAME:=Pdg PLUGIN_DIR:=src/pdg PLUGIN_HAS_MLI:=yes PLUGIN_CMO:= pdg_parameters \ ctrlDpds \ pdg_state \ build \ sets \ annot \ marks \ register PDG_TYPES:=pdgIndex pdgTypes pdgMarks PDG_TYPES:=$(addprefix src/pdg_types/, $(PDG_TYPES)) PLUGIN_TYPES_CMO:=$(PDG_TYPES) PLUGIN_INTRO:=doc/code/intro_pdg.txt PLUGIN_TYPES_TODOC:=$(addsuffix .mli, $(PDG_TYPES)) PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ################################################ # Scope : show different kinds of dependencies # ################################################ PLUGIN_ENABLE:=$(ENABLE_SCOPE) PLUGIN_NAME:=Scope PLUGIN_DIR:=src/scope PLUGIN_CMO:= datascope zones defs PLUGIN_HAS_MLI:=yes PLUGIN_GUI_CMO:=dpds_gui PLUGIN_INTRO:=doc/code/intro_scope.txt PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ##################################### # Sparecode : unused code detection # ##################################### PLUGIN_ENABLE:=$(ENABLE_SPARECODE) PLUGIN_NAME:=Sparecode PLUGIN_DIR:=src/sparecode PLUGIN_CMO:= sparecode_params globs marks transform register PLUGIN_HAS_MLI:=yes PLUGIN_DEPENDS:=Pdg PLUGIN_INTRO:=doc/code/intro_sparecode.txt PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin ########### # Slicing # ########### PLUGIN_ENABLE:=$(ENABLE_SLICING) PLUGIN_NAME:=Slicing PLUGIN_DIR:=src/slicing PLUGIN_CMO:= slicingParameters \ slicingMacros \ slicingMarks \ slicingActions \ fct_slice \ printSlice \ slicingProject \ slicingTransform \ slicingCmds \ register SLICING_TYPES:=slicingInternals slicingTypes SLICING_TYPES:=$(addprefix src/slicing_types/, $(SLICING_TYPES)) PLUGIN_TYPES_CMO:=$(SLICING_TYPES) PLUGIN_GUI_CMO:=register_gui PLUGIN_INTRO:=doc/code/intro_slicing.txt PLUGIN_TYPES_TODOC:= $(addsuffix .ml, $(SLICING_TYPES)) PLUGIN_UNDOC:=register.ml # slicing_gui.ml PLUGIN_TESTS_DIRS:= slicing slicing2 #PLUGIN_TESTS_DIRS_DEFAULT:=slicing PLUGIN_TESTS_LIB:= tests/slicing/libSelect tests/slicing/libAnim PLUGIN_DEPENDS:=Pdg PLUGIN_DISTRIBUTED:=yes PLUGIN_INTERNAL_TEST:=yes include share/Makefile.plugin FILES_FOR_OCAMLDEP+=$(TEST_SLICING_ML) ##################### # External plug-ins # ##################### define INCLUDE_PLUGIN FRAMAC_INTERNAL:=yes FRAMAC_MAKE:=yes FRAMAC_SHARE:=./share FRAMAC_PLUGIN:=lib/plugins FRAMAC_PLUGIN_GUI:=lib/plugins/gui PLUGIN_DIR:=$(1) FRAMAC_LIB:=lib/fc include $(1)/Makefile endef $(foreach p, $(EXTERNAL_PLUGINS), $(eval $(call INCLUDE_PLUGIN,$p))) ############################################################################### # # ########################### # # End of plug-in sections # # ########################### # # # ############################################################################### ##################### # Generic variables # ##################### CMX = $(CMO:.cmo=.cmx) CMI = $(CMO:.cmo=.cmi) ALL_CMO = $(CMO) $(PLUGIN_CMO_LIST) $(STARTUP_CMO) ALL_CMX = $(CMX) $(PLUGIN_CMX_LIST) $(STARTUP_CMX) FILES_FOR_OCAMLDEP+= $(addsuffix /*.mli, $(FRAMAC_SRC_DIRS)) \ $(addsuffix /*.ml, $(FRAMAC_SRC_DIRS)) MODULES_TODOC+=$(filter-out $(MODULES_NODOC), \ $(MLI_ONLY) $(NO_MLI:.mli=.ml) \ $(filter-out $(NO_MLI), \ $(filter-out $(PLUGIN_TYPES_CMO_LIST:.cmo=.mli), $(CMO:.cmo=.mli)))) ############ # Toplevel # ############ ALL_BATCH_CMO= $(filter-out src/kernel/gui_init.cmo, $(ALL_CMO)) # ALL_BATCH_CMX is not a translation of ALL_BATCH_CMO with cmo -> cmx # in case native dynlink is not available: dynamic plugin are linked # dynamically in bytecode and statically in native code... ALL_BATCH_CMX= $(filter-out src/kernel/gui_init.cmx, $(ALL_CMX)) bin/toplevel.byte$(EXE): $(ALL_BATCH_CMO) $(GEN_BYTE_LIBS) \ $(PLUGIN_DYN_CMO_LIST) $(PRINT_LINKING) $@ $(OCAMLC) $(BLINKFLAGS) -o $@ $(BYTE_LIBS) $(ALL_BATCH_CMO) bin/toplevel.prof$(EXE): $(ALL_BATCH_CMO) $(GEN_BYTE_LIBS) \ $(PLUGIN_DYN_CMO_LIST) $(PRINT_OCAMLCP) $@ $(OCAMLCP) $(BFLAGS) -o $@ $(BYTE_LIBS) $(ALL_BATCH_CMO) src/toplevel/toplevel_boot.ml: src/toplevel/toplevel_config.ml \ src/kernel/boot.ml cat $^ > $@ GENERATED+= src/toplevel/toplevel_boot.ml bin/toplevel.top$(EXE): $(filter-out src/kernel/boot.ml, $(ALL_BATCH_CMO)) \ src/toplevel/toplevel_boot.cmo \ $(GEN_BYTE_LIBS) $(PLUGIN_DYN_CMO_LIST) $(PRINT_OCAMLMKTOP) $@ $(OCAMLMKTOP) $(BFLAGS) -custom -o $@ $(BYTE_LIBS) \ $(patsubst src/kernel/boot.cmo, src/toplevel/toplevel_boot.cmo, \ $(ALL_BATCH_CMO)) bin/toplevel.opt$(EXE): $(ALL_BATCH_CMX) $(GEN_OPT_LIBS) \ $(PLUGIN_DYN_CMX_LIST) $(PRINT_LINKING) $@ $(OCAMLOPT) $(OLINKFLAGS) -o $@ $(OPT_LIBS) $(ALL_BATCH_CMX) share/Makefile.kernel: Makefile share/Makefile.config share/Makefile.common $(PRINT_MAKING) $@ $(RM) $@ $(ECHO) "# This makefile was automatically generated." > $@ $(ECHO) "# Do not modify." >> $@ $(ECHO) "ifeq (\$$(FRAMAC_INTERNAL),yes)" >> $@ $(ECHO) "DYN_BLINKFLAGS=$(filter-out $(INCLUDES), $(BLINKFLAGS)) $(foreach d, $(INCLUDES:-I%=%), -I $(FRAMAC_TOP_SRCDIR)/$(d))" >> $@ $(ECHO) "DYN_GEN_BYTE_LIBS=$(addprefix $(FRAMAC_TOP_SRCDIR)/, $(GEN_BYTE_LIBS))" >> $@ $(ECHO) "DYN_BYTE_LIBS=$(filter-out $(GEN_BYTE_LIBS), $(BYTE_LIBS))" >> $@ $(ECHO) "DYN_ALL_BATCH_CMO=$(addprefix $(FRAMAC_TOP_SRCDIR)/, $(notdir $(ALL_BATCH_CMO)))" >> $@ $(ECHO) "DYN_OLINKFLAGS=$(filter-out $(INCLUDES), $(OLINKFLAGS)) $(foreach d, $(INCLUDES:-I%=%), -I $(FRAMAC_TOP_SRCDIR)/$(d))" >> $@ $(ECHO) "DYN_GEN_OPT_LIBS=$(addprefix $(FRAMAC_TOP_SRCDIR)/, $(GEN_OPT_LIBS))" >> $@ $(ECHO) "DYN_OPT_LIBS=$(filter-out $(GEN_OPT_LIBS), $(OPT_LIBS))" >> $@ $(ECHO) "DYN_ALL_BATCH_CMX=$(addprefix $(FRAMAC_TOP_SRCDIR)/, $(ALL_BATCH_CMX))" >> $@ $(ECHO) "else" >> $@ $(ECHO) "DYN_BLINKFLAGS=$(filter-out $(INCLUDES), $(BLINKFLAGS)) $(addprefix -I ,$(filter +%,$(INCLUDES)))" >> $@ $(ECHO) "DYN_GEN_BYTE_LIBS=$(addprefix $(FRAMAC_LIBDIR)/, $(notdir $(GEN_BYTE_LIBS)))" >> $@ $(ECHO) "DYN_BYTE_LIBS=$(filter-out $(GEN_BYTE_LIBS), $(BYTE_LIBS))" >> $@ $(ECHO) "DYN_ALL_BATCH_CMO=$(addprefix $(FRAMAC_LIBDIR)/, $(notdir $(ALL_BATCH_CMO)))" >> $@ $(ECHO) "DYN_OLINKFLAGS=$(filter-out $(INCLUDES), $(OLINKFLAGS)) $(addprefix -I ,$(filter +%,$(INCLUDES)))" >> $@ $(ECHO) "DYN_GEN_OPT_LIBS=$(addprefix $(FRAMAC_LIBDIR)/, $(notdir $(GEN_OPT_LIBS)))" >> $@ $(ECHO) "DYN_OPT_LIBS=$(filter-out $(GEN_OPT_LIBS), $(OPT_LIBS))" >> $@ $(ECHO) "DYN_ALL_BATCH_CMX=$(addprefix $(FRAMAC_LIBDIR)/, $(notdir $(ALL_BATCH_CMX)))" >> $@ $(ECHO) "endif" >> $@ $(CHMOD_RO) $@ ####### # GUI # ####### ifneq ($(ENABLE_GUI),no) GUI_INCLUDES = -I src/gui -I $(LABLGTK_PATH) BYTE_GUI_LIBS+= lablgtk.cma OPT_GUI_LIBS += lablgtk.cmxa FILES_FOR_OCAMLDEP+= src/gui/*.ml src/gui/*.mli ifeq ("$(OCAMLGRAPH_LOCAL)","") GUI_INCLUDES += $(OCAMLGRAPH) endif ifeq ($(HAS_GNOMECANVAS),yes) BYTE_GUI_LIBS += lablgnomecanvas.cma OPT_GUI_LIBS += lablgnomecanvas.cmxa endif ifeq ($(HAS_LABLGTK),yes) EXTRAS += gui endif ifeq ($(HAS_GTKSOURCEVIEW),yes) ifeq ($(HAS_LEGACY_GTKSOURCEVIEW),yes) GUI_INCLUDES += -I $(LABLGTK_PATH)/lablgtksourceview endif BYTE_GUI_LIBS += lablgtksourceview2.cma OPT_GUI_LIBS += lablgtksourceview2.cmxa endif # NEW dynamic GUI ifeq (no,yes) PLUGIN_ENABLE:=$(ENABLE_GUI) PLUGIN_NAME:=Gui PLUGIN_DISTRIBUTED:=yes # PLUGIN_HAS_MLI:=yes PLUGIN_DIR:=src/gui #PLUGIN_CMO:= PLUGIN_CMO:= \ gtk_helper gtk_form toolbox \ source_viewer pretty_source source_manager \ warning_manager \ filetree \ launcher \ menu_manager \ history \ design \ project_manager \ debug_manager \ about_dialog \ property_navigator \ po_navigator PLUGIN_BFLAGS:=-I $(LABLGTK_PATH) PLUGIN_OFLAGS:=-I $(LABLGTK_PATH) PLUGIN_LINK_BFLAGS:=-I $(LABLGTK_PATH) PLUGIN_EXTRA_BYTE:=lablgtk.cma lablgtksourceview.cma PLUGIN_EXTRA_OPT:=lablgtk.cmxa PLUGIN_DYNAMIC:=yes lablgtk.cma lablgtksourceview.cma: lablgtk.cmxa: include share/Makefile.plugin gui:: lib/plugins/Gui.cmo else SINGLE_GUI_CMI = $(SINGLE_GUI_CMO:.cmo=.cmi) SINGLE_GUI_CMX = $(SINGLE_GUI_CMO:.cmo=.cmx) GUICMO += $(SINGLE_GUI_CMO) $(PLUGIN_GUI_CMO_LIST) MODULES_TODOC+= $(filter-out src/gui/book_manager.mli, \ $(SINGLE_GUI_CMO:.cmo=.mli)) GUICMI = $(GUICMO:.cmo=.cmi) GUICMX = $(SINGLE_GUI_CMX) $(PLUGIN_GUI_CMX_LIST) $(GUICMI) $(GUICMO) bin/viewer.byte$(EXE): BFLAGS+= $(GUI_INCLUDES) $(GUICMX) bin/viewer.opt$(EXE): OFLAGS+= $(GUI_INCLUDES) $(PLUGIN_DEP_GUI_CMO_LIST) $(PLUGIN_DYN_DEP_GUI_CMO_LIST): BFLAGS+= $(GUI_INCLUDES) $(PLUGIN_DEP_GUI_CMX_LIST) $(PLUGIN_DYN_DEP_GUI_CMX_LIST): OFLAGS+= $(GUI_INCLUDES) .PHONY:gui gui:: bin/viewer.byte$(EXE) share/Makefile.dynamic_config share/Makefile.kernel $(MAKE) install-gui-byte FRAMAC_LIBDIR=lib/fc ifeq ($(OCAMLBEST),opt) gui:: bin/viewer.opt$(EXE) $(MAKE) install-gui-opt FRAMAC_LIBDIR=lib/fc endif ALL_GUI_CMO= $(ALL_CMO) $(GRAPH_GUICMO) $(GUICMO) ALL_GUI_CMX= $(patsubst %.cma, %.cmxa, $(ALL_GUI_CMO:.cmo=.cmx)) bin/viewer.byte$(EXE): BYTE_LIBS+=$(BYTE_GUI_LIBS) $(GRAPH_GUICMO) # recompile ocamlgraph on need iff we use its local version ifneq ("$(OCAMLGRAPH_LOCAL)","") bin/viewer.byte$(EXE): $(GRAPH_GUICMO) endif bin/viewer.byte$(EXE): $(filter-out $(GRAPH_GUICMO), $(ALL_GUI_CMO)) \ $(GEN_BYTE_LIBS) \ $(PLUGIN_DYN_CMO_LIST) $(PLUGIN_DYN_GUI_CMO_LIST) $(PRINT_LINKING) $@ $(OCAMLC) $(BLINKFLAGS) -o $@ $(BYTE_LIBS) \ $(CMO) \ $(filter-out \ $(patsubst $(PLUGIN_GUI_LIB_DIR)/%, $(PLUGIN_LIB_DIR)/%, \ $(PLUGIN_GUI_CMO_LIST)), \ $(PLUGIN_CMO_LIST)) \ $(GUICMO) $(STARTUP_CMO) bin/viewer.opt$(EXE): OPT_LIBS+= $(OPT_GUI_LIBS) $(GRAPH_GUICMX) # recompile ocamlgraph on need iff we use its local version ifneq ("$(OCAMLGRAPH_LOCAL)","") bin/viewer.opt$(EXE): $(GRAPH_GUICMX) $(GRAPH_GUIO) endif bin/viewer.opt$(EXE): $(filter-out $(GRAPH_GUICMX), $(ALL_GUI_CMX)) \ $(GEN_OPT_LIBS) \ $(PLUGIN_DYN_CMX_LIST) $(PLUGIN_DYN_GUI_CMX_LIST) \ $(PLUGIN_CMX_LIST) $(PLUGIN_GUI_CMX_LIST) $(PRINT_LINKING) $@ $(OCAMLOPT) $(OLINKFLAGS) -o $@ $(OPT_LIBS) \ $(CMX) \ $(filter-out \ $(patsubst $(PLUGIN_GUI_LIB_DIR)/%, $(PLUGIN_LIB_DIR)/%, \ $(PLUGIN_GUI_CMX_LIST)), \ $(PLUGIN_CMX_LIST)) \ $(GUICMX) $(STARTUP_CMX) endif endif ######################### # Standalone obfuscator # ######################### obfuscator: bin/obfuscator.$(OCAMLBEST) bin/obfuscator.byte$(EXE): $(ACMO) $(KERNEL_CMO) $(STARTUP_CMO) $(GEN_BYTE_LIBS) $(PRINT_LINKING) $@ $(OCAMLC) $(BLINKFLAGS) -o $@ $(BYTE_LIBS) $^ bin/obfuscator.opt$(EXE): $(ACMX) $(KERNEL_CMX) $(STARTUP_CMX) $(GEN_OPT_LIBS) $(PRINT_LINKING) $@ $(OCAMLOPT) $(OLINKFLAGS) -o $@ $(OPT_LIBS) $^ ##################### # Config Ocaml File # ##################### CONFIG_DIR=src/kernel CONFIG_FILE=$(CONFIG_DIR)/config.ml CONFIG_CMO=$(CONFIG_DIR)/config.cmo GENERATED +=$(CONFIG_FILE) empty:= space:=$(empty) $(empty) $(CONFIG_FILE): VERSION share/Makefile.config Makefile $(PRINT_MAKING) $@ $(RM) $@ $(ECHO) "(* This file is generated by Makefile. Do not modify. *)" \ > $@ $(ECHO) "let version = \""$(VERSION)"\"" >> $@ $(ECHO) "let date = \""`LC_ALL=C date`"\"" >> $@ $(ECHO) "let is_gui = ref false" >> $@ $(ECHO) "let ocamlc = \""$(OCAMLC)"\"" >> $@ $(ECHO) "let ocamlopt = \""$(OCAMLOPT)"\"" >> $@ $(ECHO) "let datadir = try Sys.getenv \"FRAMAC_SHARE\" with Not_found -> \"$(FRAMAC_DATADIR)\"" >> $@ $(ECHO) "let libdir = try Sys.getenv \"FRAMAC_LIB\" with Not_found -> \"$(FRAMAC_LIBDIR)\"" >> $@ $(ECHO) "let plugin_dir = try Sys.getenv \"FRAMAC_PLUGIN\" with Not_found -> try (Sys.getenv \"FRAMAC_LIB\") ^ \"/plugins\" with Not_found -> \"$(FRAMAC_PLUGINDIR)\"" >> $@ $(ECHO) "let preprocessor = try Sys.getenv \"CPP\" with Not_found -> \"$(FRAMAC_DEFAULT_CPP)\"" >> $@ $(ECHO) "let static_plugins = [" \ $(subst $(space),"; ",$(foreach p,$(PLUGIN_LIST),\"$(notdir $p)\")) \ "]" >> $@ $(ECHO) "let static_gui_plugins = [" \ $(subst $(space),"; ",$(foreach p,$(PLUGIN_GUI_CMO_LIST),\"$(notdir $(patsubst %.cmo,%,$p))\")) \ "]" >> $@ $(ECHO) "let compilation_unit_names = [" \ $(subst $(space),"; ",$(foreach p,$(ALL_GUI_CMO),\"$(notdir $(patsubst %.cmo,%,$p))\")) \ "]" >> $@ ifeq ($(HAS_DOT),yes) $(ECHO) "let dot = Some \"$(DOT)\"" >> $@ else $(ECHO) "let dot = None" >> $@ endif $(CHMOD_RO) $@ ######### # Tests # ######### .PHONY: tests oracles btests tests_dist tests:: byte opt ptests $(PRINT_EXEC) ptests time -p ./bin/ptests.byte$(EXE) $(PTESTS_OPTS) \ -make "$(MAKE)" $(PLUGIN_TESTS_LIST) $(MAKE) external_tests external_tests: byte opt ptests for plugin in $(EXTERNAL_PLUGINS); do \ if $(call external_make,$$plugin,run_tests) 2> /dev/null; \ then \ $(call external_make,$$plugin,tests); \ fi \ done oracles: byte opt ptests $(PRINT_MAKING) oracles ./bin/ptests.byte$(EXE) -make "$(MAKE)" $(PLUGIN_TESTS_LIST) > /dev/null 2>&1 ./bin/ptests.byte$(EXE) -make "$(MAKE)" -update $(PLUGIN_TESTS_LIST) btests: byte ptests $(PRINT_EXEC) ptests -byte time -p ./bin/ptests.byte$(EXE) -make "$(MAKE)" -byte $(PLUGIN_TESTS_LIST) tests_dist: dist ptests $(PRINT_EXEC) ptests time -p ./bin/ptests.byte$(EXE) -make "$(MAKE)" $(PLUGIN_TESTS_LIST) # test only one test suite : make suite_tests %_tests: opt ptests $(PRINT_EXEC) ptests ./bin/ptests.byte$(EXE) -make "$(MAKE)" $($*_TESTS_OPTS) $* # full test suite wp_TESTS_OPTS=-j 1 fulltests: tests wp_tests acsl_tests: byte $(PRINT_EXEC) acsl_tests find doc/speclang -name \*.c -exec ./bin/toplevel.byte$(EXE) {} \; > /dev/null # Non-plugin test directories containing some ML files to compile TEST_DIRS_AS_PLUGIN=dynamic dynamic_plugin journal saveload spec misc syntax PLUGIN_TESTS_LIST += $(TEST_DIRS_AS_PLUGIN) $(foreach d,$(TEST_DIRS_AS_PLUGIN),$(eval $(call COMPILE_TESTS_ML_FILES,$d,,))) # Testing of dynamic plug-ins ############################# tests/dynamic/.cmi tests/dynamic/empty.cmifoo:tests/dynamic/empty.cmi $(CP) $< $@ tests/dynamic/.cmo tests/dynamic/empty.cmofoo:tests/dynamic/empty.cmo \ tests/dynamic/.cmi tests/dynamic/empty.cmifoo $(CP) $< $@ tests/dynamic/Register_mod1.cmo:tests/dynamic_plugin/register_mod1.cmo $(OCAMLC) -o $@ -pack $^ tests/dynamic/Register_mod2.cmo:tests/dynamic_plugin/register_mod2.cmo $(OCAMLC) -o $@ -pack $^ tests/dynamic/Apply.cmo:tests/dynamic_plugin/apply.cmo $(OCAMLC) -o $@ -pack $^ DYNAMIC_TESTS_TARGETS=tests/dynamic/empty.cmo tests/dynamic/empty_gui.cmo \ tests/dynamic/.cmo tests/dynamic/empty.cmofoo \ tests/dynamic/Register_mod1.cmo tests/dynamic/Register_mod2.cmo \ tests/dynamic/Apply.cmo \ tests/dynamic/abstract.cmo tests/dynamic/abstract2.cmo .PHONY:tests/dynamic/all tests/dynamic/all: $(QUIET_MAKE) $(DYNAMIC_TESTS_TARGETS) ############## # Emacs tags # ############## .PHONY: tags # otags gives a better tagging of ocaml files than etags ifdef OTAGS tags: $(OTAGS) -r external src lib cil vtags: $(OTAGS) -vi -r external src lib cil else tags: find . -name "*.ml[ily]" -o -name "*.ml" | sort -r | xargs \ etags "--regex=/[ \t]*let[ \t]+\([^ \t]+\)/\1/" \ "--regex=/[ \t]*let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ "--regex=/[ \t]*and[ \t]+\([^ \t]+\)/\1/" \ "--regex=/[ \t]*type[ \t]+\([^ \t]+\)/\1/" \ "--regex=/[ \t]*exception[ \t]+\([^ \t]+\)/\1/" \ "--regex=/[ \t]*val[ \t]+\([^ \t]+\)/\1/" \ "--regex=/[ \t]*module[ \t]+\([^ \t]+\)/\1/" endif ################# # Documentation # ################# .PHONY: wc doc doc-distrib wc: ocamlwc -p external/*.ml* cil/*/*.ml cil/*/*.ml[ily] cil/src/*/*.ml[ily] cil/src/*/*.ml[ly] src/*/*.ml src/*/*.ml[iyl] # private targets, useful for recompiling the doc without dependencies # (too long!) .PHONY: doc-kernel doc-index plugins-doc doc-update doc-tgz DOC_DEPEND=$(MODULES_TODOC) bin/toplevel.byte$(EXE) $(DOC_PLUGIN) ifneq ($(ENABLE_GUI),no) DOC_DEPEND+=bin/viewer.byte$(EXE) endif GENERATED+=$(DOC_DIR)/docgen.ml ifeq ($(HAS_OCAML400),yes) $(DOC_DIR)/docgen.ml: $(DOC_DIR)/docgen_ge400.ml share/Makefile.config Makefile $(RM) $@ $(CP) $< $@ $(CHMOD_RO) $@ else $(DOC_DIR)/docgen.ml: $(DOC_DIR)/docgen_lt400.ml share/Makefile.config Makefile $(RM) $@ $(CP) $< $@ $(CHMOD_RO) $@ endif $(DOC_DIR)/docgen.cmo: $(DOC_DIR)/docgen.ml $(PRINT_OCAMLC) $@ $(OCAMLC) -c -I +ocamldoc -I $(CONFIG_DIR) $(DOC_DIR)/docgen.ml $(DOC_DIR)/docgen.cmxs: $(DOC_DIR)/docgen.ml $(PRINT_PACKING) $@ $(OCAMLOPT) -o $@ -shared -I +ocamldoc -I $(CONFIG_DIR) \ $(DOC_DIR)/docgen.ml clean-doc:: $(PRINT_RM) "documentation generator" $(RM) $(DOC_DIR)/docgen.cm* $(DOC_DIR)/docgen.ml DOC_NOT_FOR_DISTRIB=yes plugins-doc: $(QUIET_MAKE) \ $(if $(DOC_NOT_FOR_DISTRIB), $(PLUGIN_DOC_LIST), \ $(filter \ $(addsuffix _DOC, $(PLUGIN_DISTRIBUTED_NAME_LIST)), \ $(PLUGIN_DOC_LIST))) # to make the documentation for one plugin only, # the name of the plugin should begin with a capital letter : # Example for the pdg doc : make Pdg_DOC # While working on the documentation of a plugin, it can also be useful # to use : make -o doc/code/kernel-doc.ocamldoc Plugin_DOC # to avoid redoing the global documentation each time. STDLIB_FILES:=\ array \ big_int \ buffer \ char \ format \ hashtbl \ int64 \ list \ map \ marshal \ obj \ pervasives \ printf \ queue \ scanf \ set \ stack \ string \ sys STDLIB_FILES:=$(patsubst %, $(OCAMLLIB)/%.mli, $(STDLIB_FILES)) .PHONY: doc-kernel doc-kernel: $(DOC_DIR)/kernel-doc.ocamldoc $(DOC_DIR)/kernel-doc.ocamldoc: $(DOC_DEPEND) $(PRINT_DOC) Kernel Documentation $(MKDIR) $(DOC_DIR)/html $(RM) $(DOC_DIR)/html/*.html $(OCAMLDOC) $(DOC_FLAGS) -I $(OCAMLLIB) \ $(addprefix -stdlib , $(STDLIB_FILES)) \ -t "Frama-C Kernel" \ -sort -css-style ../style.css \ -g $(DOC_PLUGIN) \ -d $(DOC_DIR)/html -dump $(DOC_DIR)/kernel-doc.ocamldoc \ $(MODULES_TODOC) DYN_MLI_DIR := doc/code/print_api .PHONY: doc-dynamic doc-dynamic: doc-kernel $(RM) $(DYN_MLI_DIR)/dynamic_plugins.mli $(MAKE) -C $(DYN_MLI_DIR) PLUGIN_LIB_DIR=. clean $(MAKE) -C $(DYN_MLI_DIR) \ FRAMAC_SHARE=../../../share \ FRAMAC_LIBDIR=../../../lib/fc \ PLUGIN_LIB_DIR=. \ FRAMAC_SRC=../../.. \ depend byte FRAMAC_PLUGIN=lib/plugins FRAMAC_LIB=lib/fc FRAMAC_SHARE=share \ ./bin/toplevel.byte -load-module $(DYN_MLI_DIR)/Print_api \ -print_api `pwd`/$(DYN_MLI_DIR) $(PRINT_DOC) Dynamically registered plugins Documentation $(MKDIR) $(DOC_DIR)/dynamic_plugins $(RM) $(DOC_DIR)/dynamic_plugins/*.html $(OCAMLDOC) $(DOC_FLAGS) -I $(FRAMAC_LIB) -I $(OCAMLLIB) \ -docpath $(DOC_DIR)/html \ -sort -css-style ../style.css \ -load $(DOC_DIR)/kernel-doc.ocamldoc \ -t " Dynamically registered plugins" \ -g $(DOC_PLUGIN) \ -d $(DOC_DIR)/dynamic_plugins \ $(DYN_MLI_DIR)/dynamic_plugins.mli $(ECHO) '<li><a href="dynamic_plugins/Dynamic_plugins.html">Dynamically registered plugins</a </li>' > $(DOC_DIR)/dynamic_plugins.toc doc-index: #dependencies in doc target $(PRINT_MAKING) doc/code/index.html $(CAT) $(DOC_DIR)/toc_head.htm $(DOC_DIR)/*.toc \ $(DOC_DIR)/toc_tail.htm > $(DOC_DIR)/index.html doc-update: doc-kernel doc-dynamic plugins-doc doc-index doc:: $(DOC_DEPEND) $(QUIET_MAKE) doc-kernel doc-dynamic plugins-doc doc-index doc-tgz: $(PRINT_MAKING) frama-c-api.tar.gz cd $(DOC_DIR); \ $(TAR) zcf tmp.tgz index.html *.txt \ $(notdir $(wildcard $(DOC_DIR)/*.css $(DOC_DIR)/*.png \ $(DOC_DIR)/dynamic_plugins*)) \ html \ $(foreach p, $(PLUGIN_DISTRIBUTED_NAME_LIST), \ $(notdir $($(p)_DOC_DIR))) $(MKDIR) frama-c-api $(RM) -r frama-c-api/* cd frama-c-api; $(TAR) zxf ../$(DOC_DIR)/tmp.tgz $(TAR) zcf frama-c-api.tar.gz frama-c-api $(RM) -r frama-c-api $(DOC_DIR)/tmp.tgz doc-distrib: $(QUIET_MAKE) clean-doc $(QUIET_MAKE) doc DOC_NOT_FOR_DISTRIB= $(QUIET_MAKE) doc-tgz doc/db/db.tex: src/kernel/db.mli $(PRINT_DOC) $@ $(MKDIR) $(dir $@) $(OCAMLDOC) $(INCLUDES) -I $(OCAMLLIB) \ -latex -noindex -latextitle 3,paragraph -notoc -noheader -notrailer \ -o $@ $< # Could be optimized .PHONY: db_doc db_doc doc/db/db.pdf: doc/db/main.tex doc/db/main.bib doc/db/db.tex $(PRINT_MAKING) doc/db/db.pdf cd $(dir $@); \ pdflatex $(notdir $<); bibtex main; \ pdflatex $(notdir $<); pdflatex $(notdir $<); \ mv main.pdf $(notdir $@) #find src -name "*.ml[i]" -o -name "*.ml" -maxdepth 3 | sort -r | xargs dots: $(ALL_CMO) $(PRINT_DOC) callgraph $(OCAMLDOC) $(INCLUDES) -o doc/call_graph.dot \ -dot -dot-include-all -dot-reduce $(MODULES_TODOC) $(QUIET_MAKE) doc/call_graph.svg $(QUIET_MAKE) doc/call_graph.ps datatype_dependencies.dot computation_dependencies.dot: ./bin/toplevel.byte$(EXE) $(PRINT_MAKING) $@ ./bin/toplevel.byte$(EXE) -project-debug -dump \ > /dev/null 2> /dev/null .PHONY:display_dependencies display_dependencies: datatype_dependencies.svg computation_dependencies.svg inkscape datatype_dependencies.svg computation_dependencies.svg & # Checking consistency with the current implementation ###################################################### DOC_DEV_DIR = doc/developer CHECK_API_DIR=$(DOC_DEV_DIR)/check_api $(CHECK_API_DIR)/check_code.cmo: $(CHECK_API_DIR)/check_code.ml $(PRINT_OCAMLC) $@ $(OCAMLC) -c -I +ocamldoc str.cma $(CHECK_API_DIR)/check_code.ml $(CHECK_API_DIR)/check_code.cmxs: $(CHECK_API_DIR)/check_code.ml $(PRINT_PACKING) $@ $(OCAMLOPT) -o $@ -shared -I +ocamldoc \ str.cmxa $(CHECK_API_DIR)/check_code.ml ifeq ("$(OCAMLDOC)","ocamldoc.opt") CHECK_CODE=$(CHECK_API_DIR)/check_code.cmxs else CHECK_CODE=$(CHECK_API_DIR)/check_code.cmo endif .PHONY: check-devguide check-devguide: $(CHECK_CODE) $(DOC_DEPEND) $(DOC_DIR)/kernel-doc.ocamldoc \ $(CHECK_API_DIR)/main.idx $(PRINT) 'Checking developer guide consistency' $(MKDIR) $(CHECK_API_DIR)/html $(OCAMLDOC) $(DOC_FLAGS) -I $(OCAMLLIB) \ -docdevpath `pwd`/$(CHECK_API_DIR) \ -load $(DOC_DIR)/kernel-doc.ocamldoc \ -g $(CHECK_CODE) \ -d $(CHECK_API_DIR)/html $(RM) -r $(CHECK_API_DIR)/html $(MAKE) --silent -C $(CHECK_API_DIR) main.idx $(MAKE) --silent -C $(CHECK_API_DIR) >$(CHECK_API_DIR)/summary.txt $(ECHO) see all the information displayed here \ in $(CHECK_API_DIR)/summary.txt $(RM) code_file # Oug (M. Guesdon's tool: could probably be deleted) ##### oug: echo $(ALL_CMX) $(STARTUP_CMX) > cmx.files rpl ".cmx" ".ml" cmx.files cp cmx.files ml0.files rpl ".ml" ".mli" cmx.files cat cmx.files >> ml0.files (ls -U `cat ml0.files` | grep -v sparecode > ml.files | true) cp ml.files files oug.x --debug 0 -I `ocamlc -where` $(INCLUDES) -I src/value -I src/pdg -I src/slicing -I src/security_slicing -I $(LABLGTK_PATH) --no-reduce --dump dump.oug `cat files` oug.x --load dump.oug --no-reduce --useless-elements useless.txt --aliases-used --print-loc --progress oug.x --load dump.oug --useless-elements useless-reduced.txt --aliases-used --print-loc --progress metrics: $(PRINT) Computing metrics ocamlmetrics -max-mi 75 -worst-modules 10 -worst-functions 25 \ $(filter-out $(GENERATED), $(patsubst cil/%,, $(patsubst lib/%,,$(ALL_CMO:.cmo=.ml)))) \ > doc/metrics.html ################ # Installation # ################ FILTER_INTERFACE_DIRS:=lib/plugins src/gui ifeq ("$(OCAMLGRAPH_LOCAL)","") FILTER_INTERFACE_DIRS+= +ocamlgraph endif .PHONY: install-kernel-byte install-kernel-opt install-gui-byte install-gui-opt install-kernel-byte: $(PRINT_CP) bytecode kernel API $(MKDIR) $(FRAMAC_LIBDIR) # line below does not work if INCLUDES contains twice the same directory # Do not attempt to copy gui interfaces if gui is disabled $(CP) $(wildcard $(foreach d,$(filter-out $(FILTER_INTERFACE_DIRS),$(INCLUDES:-I%=%)), $(d)/*.cmi)) $(FRAMAC_LIBDIR) $(CP) $(ALL_BATCH_CMO) $(filter-out %.o, $(GEN_BYTE_LIBS:.cmo=.cmi)) \ $(GEN_BYTE_LIBS) $(FRAMAC_LIBDIR) install-kernel-opt: $(PRINT_CP) native kernel API $(CP) $(ALL_BATCH_CMX) \ $(filter %.a,$(ALL_BATCH_CMX:.cmxa=.a)) \ $(filter %.o,$(ALL_BATCH_CMX:.cmx=.o)) \ $(FRAMAC_LIBDIR) $(CP) $(filter-out %.o, $(GEN_OPT_LIBS)) \ $(filter %.o,$(GEN_OPT_LIBS:.cmx=.o)) $(FRAMAC_LIBDIR) install-gui-byte: $(PRINT_CP) bytecode gui API $(MKDIR) $(FRAMAC_LIBDIR) if [ "$(ENABLE_GUI)" != "no" ]; then \ $(CP) $(SINGLE_GUI_CMI) $(SINGLE_GUI_CMO) $(FRAMAC_LIBDIR); \ fi install-gui-opt: $(PRINT_CP) native gui API $(MKDIR) $(FRAMAC_LIBDIR) if [ "$(ENABLE_GUI)" != "no" -a "$(OCAMLBEST)" = "opt" ]; then \ $(CP) $(SINGLE_GUI_CMX) $(SINGLE_GUI_CMX:.cmx=.o) $(FRAMAC_LIBDIR); \ fi install-doc-code: $(PRINT_CP) API documentation $(MKDIR) $(FRAMAC_DATADIR)/doc/code (cd doc ; tar cf - --exclude='.svn' --exclude='*.toc' \ --exclude='*.htm' --exclude='*.txt' code \ | (cd $(FRAMAC_DATADIR)/doc/code ; tar xf -)) .PHONY: install install:: $(PRINT_MAKING) destination directories $(MKDIR) $(BINDIR) $(MKDIR) $(MANDIR)/man1 $(MKDIR) $(FRAMAC_PLUGINDIR)/gui $(MKDIR) $(FRAMAC_DATADIR)/feedback $(MKDIR) $(FRAMAC_DATADIR)/libc/sys $(MKDIR) $(FRAMAC_DATADIR)/libc/netinet $(MKDIR) $(FRAMAC_DATADIR)/libc/linux $(MKDIR) $(FRAMAC_DATADIR)/libc/net $(MKDIR) $(FRAMAC_DATADIR)/libc/arpa $(PRINT_CP) shared files $(CP) \ $(wildcard share/*.c share/*.h) share/acsl.el \ share/Makefile.dynamic share/Makefile.plugin share/Makefile.kernel \ share/Makefile.config share/Makefile.common share/configure.ac \ $(FRAMAC_DATADIR) $(CP) share/frama-c.rc $(ICONS) $(FRAMAC_DATADIR) $(CP) $(FEEDBACK_ICONS) $(FRAMAC_DATADIR)/feedback if [ -d $(EMACS_DATADIR) ]; then \ $(CP) share/acsl.el $(EMACS_DATADIR); \ fi $(CP) share/Makefile.dynamic_config.external \ $(FRAMAC_DATADIR)/Makefile.dynamic_config $(PRINT_CP) C standard library $(CP) $(wildcard share/libc/*.c share/libc/*.i share/libc/*.h) \ $(FRAMAC_DATADIR)/libc $(CP) share/libc/sys/*.[ch] $(FRAMAC_DATADIR)/libc/sys $(CP) share/libc/arpa/*.[ch] $(FRAMAC_DATADIR)/libc/arpa $(CP) share/libc/net/*.[ch] $(FRAMAC_DATADIR)/libc/net $(CP) share/libc/netinet/*.[ch] $(FRAMAC_DATADIR)/libc/netinet $(CP) share/libc/linux/*.[ch] $(FRAMAC_DATADIR)/libc/linux $(PRINT_CP) binaries $(CP) bin/toplevel.$(OCAMLBEST) $(BINDIR)/frama-c$(EXE) $(CP) bin/toplevel.byte$(EXE) $(BINDIR)/frama-c.byte$(EXE) if [ -x bin/toplevel.top ] ; then \ $(CP) bin/toplevel.top $(BINDIR)/frama-c.toplevel$(EXE); \ fi if [ -x bin/viewer.$(OCAMLBEST) ] ; then \ $(CP) bin/viewer.$(OCAMLBEST) $(BINDIR)/frama-c-gui$(EXE);\ fi if [ -x bin/viewer.byte$(EXE) ] ; then \ $(CP) bin/viewer.byte$(EXE) $(BINDIR)/frama-c-gui.byte$(EXE); \ fi $(CP) bin/ptests.byte$(EXE) $(BINDIR)/ptests.byte$(EXE) $(PRINT_CP) config files $(CP) ptests/ptests_config.cmi $(FRAMAC_LIBDIR) $(PRINT_CP) manuals if [ -d doc/manuals ]; then \ $(MKDIR) $(FRAMAC_DATADIR)/manuals ; \ $(CP) doc/manuals/*.pdf $(FRAMAC_DATADIR)/manuals ; \ fi $(PRINT_CP) API documentation $(MKDIR) $(FRAMAC_DATADIR)/doc/code $(CP) $(wildcard $(DOC_GEN_FILES)) $(FRAMAC_DATADIR)/doc/code $(PRINT_CP) dynamic plug-ins if [ -d "$(FRAMAC_PLUGIN)" -a "$(PLUGIN_DYN_EXISTS)" = "yes" ]; then \ $(CP) $(patsubst %.cma,%.cmi,$(PLUGIN_DYN_CMO_LIST:%.cmo=%.cmi)) \ $(PLUGIN_DYN_CMO_LIST) $(PLUGIN_DYN_CMX_LIST) \ $(FRAMAC_PLUGINDIR); \ fi $(PRINT_CP) dynamic gui plug-ins if [ -d "$(FRAMAC_PLUGIN_GUI)" -a "$(PLUGIN_DYN_GUI_EXISTS)" = "yes" ]; \ then \ $(CP) $(patsubst %.cma,%.cmi,$(PLUGIN_DYN_GUI_CMO_LIST:.cmo=.cmi)) \ $(PLUGIN_DYN_GUI_CMO_LIST) $(PLUGIN_DYN_GUI_CMX_LIST) \ $(FRAMAC_PLUGINDIR)/gui; \ fi $(MAKE) install-kernel-byte $(MAKE) install-gui-byte if [ "$(OCAMLBEST)" = "opt" ]; then \ $(MAKE) install-kernel-opt install-gui-opt; \ fi $(PRINT_CP) man pages $(CP) man/frama-c.1 $(MANDIR)/man1/frama-c.1 $(CP) man/frama-c.1 $(MANDIR)/man1/frama-c-gui.1 .PHONY: uninstall uninstall:: $(PRINT_RM) installed binaries $(RM) $(BINDIR)/frama-c* $(BINDIR)/ptests.byte$(EXE) $(PRINT_RM) installed shared files $(RM) -R $(FRAMAC_DATADIR) $(PRINT_RM) installed libraries $(RM) -R $(FRAMAC_LIBDIR) $(FRAMAC_PLUGINDIR) $(PRINT_RM) installed man files $(RM) $(MANDIR)/man1/frama-c.1 $(MANDIR)/man1/frama-c-gui.1 ################################ # File headers: license policy # ################################ # Modify this variable if you add a new header HEADERS:= MODIFIED_OCAMLGRAPH MODIFIED_MENHIR CEA_LGPL CEA_PROPRIETARY \ CEA_LGPL_UTF8 CEA_PROPRIETARY_UTF8 CEA_INRIA_LGPL INRIA_LGPL \ MODIFIED_OCAML CIL MODIFIED_CAMLLIB INSA_INRIA_LGPL INRIA_BSD ACSL_EL \ JCF_LGPL OCAML_STDLIB AORAI_LGPL CEA_WP MODIFIED_WHY3 # Kernel licences ################# CIL = cil/ocamlutil/*.ml* \ cil/src/*.ml* \ cil/src/ext/*.ml* \ cil/src/frontc/*.ml* CEA_INRIA_LGPL = configure.in cil/src/logic/*.ml* JCF_LGPL= MODIFIED_OCAML=src/lib/setWithNearest.ml src/lib/setWithNearest.mli MODIFIED_WHY3=external/sysutil.ml* MODIFIED_OCAMLGRAPH=src/project/state_topological.ml* MODIFIED_MENHIR=external/hptmap.ml* OCAML_STDLIB=src/lib/rangemap.ml src/lib/rangemap.mli INRIA_LGPL= INRIA_BSD= external/unmarshal*.ml* INSA_INRIA_LGPL= CEA_LGPL= Makefile \ share/Makefile.config.in share/Makefile.common \ share/Makefile.plugin share/Makefile.dynamic \ share/Makefile.dynamic_config.internal \ share/Makefile.dynamic_config.external \ share/configure.ac configure.ml \ config.h.in \ src/report/*.ml* src/report/configure.ac src/report/Makefile.in \ share/frama-c.WIN32.rc share/frama-c.Unix.rc \ external/unz.ml* \ src/ai/*.ml* \ src/buckx/*.ml* src/buckx/*.[cS] \ src/constant_propagation/*.ml* \ src/from/*.ml* \ src/gui/*.ml* \ src/inout/*.ml* \ src/pdg_types/*.ml* src/pdg/*.ml* doc/code/intro_pdg.txt \ src/slicing_types/*.ml* src/slicing/*.ml* doc/code/intro_slicing.txt \ src/scope/*.ml* doc/code/intro_scope.txt \ src/sparecode/*.ml* doc/code/intro_sparecode.txt \ src/impact/*.ml* \ src/kernel/*.ml* \ src/printer/*.ml* \ src/lib/*.ml* \ src/logic/*.ml* \ src/memory_state/*.ml* \ src/metrics/*.ml* \ src/misc/*.ml* \ src/obfuscator/*.ml* src/obfuscator/configure.ac \ src/obfuscator/Makefile.in \ src/occurrence/*.ml* doc/code/intro_occurrence.txt \ src/postdominators/*.ml* \ $(patsubst %.cmo, %.ml*, \ $(filter-out src/project/state_topological.cmo, $(PROJECT_CMO))) \ src/project/project_skeleton.ml* \ src/project/state.ml* \ src/security_slicing/*.ml* \ src/security_slicing/configure.ac src/security_slicing/Makefile.in \ src/semantic_callgraph/*.ml* \ src/syntactic_callgraph/*.ml* \ src/toplevel/*.ml* \ src/type/*.ml* \ src/users/*.ml* \ src/value/*.ml* \ src/dummy/*/*.ml* \ src/dummy/*/Makefile \ src/rte/*.ml* \ src/report/*.ml* \ ptests/*.ml* \ doc/code/docgen_*.ml \ doc/code/style.css \ doc/code/intro_plugin.txt \ doc/code/intro_plugin_default.txt \ doc/code/intro_plugin_D_and_S.txt \ doc/code/intro_kernel_plugin.txt \ doc/code/toc_head.htm doc/code/toc_tail.htm \ doc/code/print_api/*.ml* doc/code/print_api/Makefile \ man/frama-c.1 \ bin/lithium2beryllium.sh bin/boron2carbon.sh bin/carbon2nitrogen.sh \ bin/nitrogen2oxygen.sh bin/oxygen2fluorine.sh CEA_LGPL_UTF8= \ $(FREE_LIBC) CEA_PROPRIETARY:= src/modular_dependencies/*.ml* \ share/miel-mode.el \ src/value/builtins_nonfree*.ml* \ src/finder/*.ml* src/finder/configure.ac src/finder/Makefile.in \ CEA_PROPRIETARY_UTF8= \ $(filter-out $(wildcard $(FREE_LIBC)), $(wildcard $(NONFREE_LIBC))) ACSL_EL := share/acsl.el # Plug-in specific licences ########################### AORAI_LGPL:= src/aorai/*.ml* src/aorai/Makefile.in src/aorai/configure.ac CEA_WP+=doc/code/intro_wp.txt # Generating headers #################### .PHONY: headers show_headers $(add_prefix show_,$(HEADERS)) headers:: $(GENERATED) @echo "Applying Headers..." $(foreach l,$(HEADERS),\ $(foreach f,$(wildcard $($l)),$(shell if test -f $f; then \ LC_ALL=C $(HEADACHE) -h headers/$l $f; fi))) show_headers: $(patsubst %,show_%,$(HEADERS)) show_%: @echo "files under $(patsubst show_%,%,$@) licence:" @echo $($(patsubst show_%,%,$@)) headers:: $(MKDIR) aorai-example-tmp-dir cd aorai-example-tmp-dir; $(TAR) xzf ../doc/manuals/aorai-example.tgz $(CP) headers/INSA_INRIA_LGPL aorai-example-tmp-dir/example/LICENSE $(ISED) -e 's/This file is/Files in this archive are/' \ aorai-example-tmp-dir/example/LICENSE $(RM) doc/manuals/aorai-example.tgz cd aorai-example-tmp-dir; \ $(TAR) czf ../doc/manuals/aorai-example.tgz example/ $(RM) -r aorai-example-tmp-dir NO_CHECK_HEADERS=tests/*/* doc/manuals/*.pdf doc/manuals/aorai-example.tgz \ doc/README cil/LICENSE cil/CHANGES Changelog .make* \ .force-reconfigure \ licenses/* VERSION INSTALL bin/sed* \ share/Makefile.kernel $(ICONS) $(FEEDBACK_ICONS) \ INSTALL_WITH_WHY doc/manuals/aorai-example.tgz .PHONY: check-headers check-headers-xunit check-headers: $(GENERATED) @echo "Checking Headers..." EXIT_VALUE=0; \ $(foreach f,$(wildcard $(DISTRIB_FILES)),\ $(if $(findstring $(f),\ $(wildcard $(NO_CHECK_HEADERS)) \ $(foreach l,$(HEADERS),$(wildcard $($l)))),,\ EXIT_VALUE=1; \ echo "file $(f) does not have a proper license";)) \ exit $$EXIT_VALUE check-headers-xunit: $(GENERATED) @echo '<?xml version="1.0" encoding="UTF-8"?>' > check-headers-xunit.xml @echo '<testsuites>' >> check-headers-xunit.xml @TIME=`date +%Y-%m-%dT%T`; \ echo "<testsuite name=\"headers\" package=\"headers\" " \ >> check-headers-xunit.xml; \ echo "id=\"0\" timestamp=\"$$TIME\" hostname=\"`hostname`\" " \ >> check-headers-xunit.xml; \ echo "time=\"0\" errors=\"0\" skipped=\"0\" SUMMARY>" \ >> check-headers-xunit.xml; \ NB_HEADERS=0; NB_NO_LICENSE=0; \ for f in $(wildcard $(DISTRIB_FILES)); do \ NB_HEADERS=$$(($$NB_HEADERS + 1)); \ echo "<testcase name=\"$$f\" classname=\"header\" time=\"0\"" \ >> check-headers-xunit.xml; \ if echo "$(wildcard $(NO_CHECK_HEADERS)) \ $(foreach l,$(HEADERS),$(wildcard $($l)))" | \ grep -q -e $$f; then \ echo '/>' >> check-headers-xunit.xml; \ else \ NB_NO_LICENSE=$$(($$NB_NO_LICENSE + 1)); \ echo '>' >> check-headers-xunit.xml; \ echo '<failure message="file has no header" type="header"/>' \ >> check-headers-xunit.xml; \ fi; \ done; \ $(ISED) -e \ "s/SUMMARY/tests=\"$$NB_HEADERS\" failures=\"$$NB_NO_LICENSE\"/" \ check-headers-xunit.xml; \ echo "</testsuite>" >> check-headers-xunit.xml; \ echo "</testsuites>" >> check-headers-xunit.xml ######################################################################## # Makefile is rebuilt whenever Makefile.in or configure.in is modified # ######################################################################## share/Makefile.config: share/Makefile.config.in config.status $(PRINT_MAKING) $@ ./config.status share/Makefile.dynamic_config: share/Makefile.dynamic_config.internal $(PRINT_MAKING) $@ $(RM) $@ $(CP) $< $@ $(CHMOD_RO) $@ config.status: configure $(PRINT_MAKING) $@ ./config.status --recheck configure: configure.in .force-reconfigure $(PRINT_MAKING) $@ rm -fr autom4te.conf autoconf touch configure # If 'make clean' has to be performed after 'svn update': # change '.make-clean-stamp' before 'svn commit' .make-clean: .make-clean-stamp $(TOUCH) $@ $(QUIET_MAKE) clean include .make-clean # force "make clean" to be executed for all users of SVN force-clean: expr `$(CAT) .make-clean-stamp` + 1 > .make-clean-stamp # force a reconfiguration for all svn users force-reconfigure: expr `$(CAT) .force-reconfigure` + 1 > .force-reconfigure ############ # cleaning # ############ clean-journal: $(PRINT_RM) journal $(RM) frama_c_journal* clean-tests: $(PRINT_RM) tests $(RM) tests/*/*.byte$(EXE) tests/*/*.opt$(EXE) tests/*/*.cm* \ tests/dynamic/.cm* tests/*/*~ tests/*/#* $(RM) tests/*/result/*.* clean-doc:: $(PLUGIN_LIST:=_CLEAN_DOC) $(PRINT_RM) documentation $(RM) -r $(DOC_DIR)/html $(RM) $(DOC_DIR)/docgen.cm* $(DOC_DIR)/*~ $(RM) doc/db/*~ doc/db/ocamldoc.sty doc/db/db.tex $(RM) doc/training/*/*.cm* $(MAKE) --silent -C $(DYN_MLI_DIR) clean if [ -f doc/developer/Makefile ]; then \ $(MAKE) --silent -C doc/developer clean; \ fi if [ -f doc/architecture/Makefile ]; then \ $(MAKE) --silent -C doc/architecture clean; \ fi if [ -f doc/speclang/Makefile ]; then \ $(MAKE) --silent -C doc/speclang clean; \ fi if [ -f doc/www/src/Makefile ]; then \ $(MAKE) --silent -C doc/www/src clean; \ fi clean-gui:: $(PRINT_RM) gui $(RM) src/*/*_gui.cm* src/*/*_gui.o src/gui/*.cm* src/gui/*.o clean:: $(PLUGIN_LIST:=_CLEAN) $(PLUGIN_DYN_LIST:=_CLEAN) \ clean-tests clean-journal $(PRINT_RM) $(PLUGIN_LIB_DIR) $(RM) $(PLUGIN_LIB_DIR)/*.mli $(PLUGIN_LIB_DIR)/*.cm* \ $(PLUGIN_LIB_DIR)/*.o $(RM) $(PLUGIN_GUI_LIB_DIR)/*.mli $(PLUGIN_GUI_LIB_DIR)/*.cm* \ $(PLUGIN_GUI_LIB_DIR)/*.o $(PRINT_RM) local installation $(RM) lib/*.cm* lib/*.o lib/fc/*.cm* lib/fc/*.o lib/gui/*.cm* lib/*.cm* $(PRINT_RM) other sources for d in . $(SRC_DIRS) src/gui share; do \ $(RM) $$d/*.cm* $$d/*.o $$d/*.a $$d/*.annot $$d/*~ $$d/*.output \ $$d/*.annot $$d/\#*; \ done $(PRINT_RM) generated files $(RM) $(GENERATED) $(RM) ptests_config.* # temporary clean-up of svn version $(PRINT_RM) binaries $(RM) bin/*.byte$(EXE) bin/*.opt$(EXE) bin/*.top$(EXE) distclean-ocamlgraph: $(PRINT_RM) ocamlgraph if [ -f ocamlgraph/Makefile ]; then \ $(MAKE) --silent -C ocamlgraph distclean; \ cd ocamlgraph; ./configure; \ fi # Do NOT use :: for this rule: it is mandatory to remove share/Makefile.config # as the very last step performed by make (who'll otherwise try to regenerate # it in the middle of cleaning) dist-clean distclean: clean clean-doc distclean-ocamlgraph distclean-mcpp \ $(PLUGIN_LIST:=_DIST_CLEAN) \ $(PLUGIN_DYN_LIST:=_DIST_CLEAN) $(PRINT_RM) config $(RM) share/Makefile.config $(RM) config.cache config.log config.h $(RM) -r autom4te.cache $(RM) src/lib/dynlink_common_interface.ml \ $(DOC_DIR)/docgen.ml $(PRINT_RM) dummy plug-ins $(RM) src/dummy/*/*.cm* src/dummy/*/*.o src/dummy/*/*.a \ src/dummy/*/*.annot src/dummy/*/*~ src/dummy/*/*.output \ src/dummy/*/*.annot src/dummy/*/\#* ifeq ($(OCAMLWIN32),yes) # Use Win32 typical ressources share/frama-c.rc: share/frama-c.WIN32.rc $(PRINT_MAKING) $@ $(CP) $^ $@ else # Use Unix typical ressources share/frama-c.rc: share/frama-c.Unix.rc $(PRINT_MAKING) $@ $(CP) $^ $@ endif GENERATED+=share/frama-c.rc ########## # Depend # ########## GENERATED+=ptests/ptests_config.ml PLUGIN_DEP_LIST:=$(PLUGIN_LIST) $(PLUGIN_DYN_LIST) .PHONY: depend depend:: $(PLUGIN_DEP_LIST:%=%_DEP_REDO) $(ALL_CMO:.cmo=.cmi) $(ALL_CMO) $(ALL_CMX): $(GRAPH_LIB) | .depend GENERATED_FOR_OCAMLDEP:= $(filter-out $(GRAPH_LIB), $(GENERATED)) .depend depend:: $(GENERATED_FOR_OCAMLDEP) \ share/Makefile.dynamic_config share/Makefile.kernel \ $(PLUGIN_DEP_LIST:%=%_DEP) $(PRINT_MAKING) .depend $(CHMOD_RW) .depend if test "$(PLUGIN_DEP_LIST)" != " "; then \ $(CAT) $(foreach d, $(PLUGIN_DEP_LIST), $(dir $d).depend) \ > .depend; \ else \ $(TOUCH) .depend; \ fi $(OCAMLDEP) $(DEP_FLAGS) $(FILES_FOR_OCAMLDEP) >> .depend $(CHMOD_RO) .depend include .depend ##################### # ptest development # ##################### .PHONY: ptests # Because Ocaml on MacOS X has issues with native threads ptests: bin/ptests.byte$(EXE) PTESTS_SRC=ptests/ptests_config.ml ptests/ptests.ml ifeq ($(OCAMLWIN32),yes) # OCaml on Win32 does not support vmthreads, use native ones. THREAD=-thread else THREAD=-vmthread endif bin/ptests.byte$(EXE): $(PTESTS_SRC) $(PRINT_LINKING) $@ $(OCAMLC) -I ptests -dtypes $(THREAD) -g -o $@ \ unix.cma threads.cma str.cma dynlink.cma $^ #bin/ptests.opt$(EXE): $(PTESTS_SRC) # $(PRINT_LINKING) $@ # $(OCAMLOPT) -I ptests -dtypes -thread -o $@ \ # unix.cmxa threads.cmxa str.cmxa dynlink.cmxa $^ # "let default_suites = ref [" $(PLUGIN_TESTS_LIST:%='"%";') "];;" >> $@ ptests/ptests_config.ml: Makefile share/Makefile.config $(PRINT_MAKING) $@ $(RM) $@ $(TOUCH) $@; $(ECHO) \ "let default_suites : string list ref = ref [" $(PLUGIN_TESTS_LIST:%='"%";') "];;" >> $@ $(ECHO) \ "let no_native_dynlink = " \ $(subst yes,false,$(subst no,true,$(USABLE_NATIVE_DYNLINK))) ";;" \ >> $@ $(ECHO) \ "let toplevel_path = ref \"bin/toplevel.$(OCAMLBEST)$(EXE)\";;" >> $@ $(ECHO) \ "let framac_share = ref (Filename.concat Filename.current_dir_name \ \"share\");;" >> $@ $(ECHO) \ "let framac_plugin = ref \ (Filename.concat (Filename.concat Filename.current_dir_name \"lib\")\ \"plugins\");;" >> $@ $(ECHO) \ "let framac_plugin_gui = ref \ (Filename.concat !framac_plugin \"gui\");;" >> $@ $(ECHO) \ "let framac_lib = ref \ (Filename.concat (Filename.concat Filename.current_dir_name \"lib\")\ \"fc\");;" >> $@ $(CHMOD_RO) $@ GENERATED+=ptests/ptests_config.ml ####################### # Source distribution # ####################### STANDALONE_PLUGINS_FILES = \ $(addprefix src/dummy/hello_world/, hello_world.ml Makefile) \ $(addprefix src/dummy/untyped_metrics/, count_for.ml Makefile) DISTRIB_FILES += $(PLUGIN_DISTRIBUTED_LIST) $(PLUGIN_DIST_EXTERNAL_LIST) \ $(PLUGIN_DIST_DOC_LIST) $(STANDALONE_PLUGINS_FILES) EXPORT=frama-c-$(VERSION) NONFREE=no ifeq ($(NONFREE),no) DISTRIB_FILES := $(filter-out src/value/builtins_nonfree%, \ $(wildcard $(DISTRIB_FILES))) else DISTRIB_FILES:=$(DISTRIB_FILES) $(NONFREE_LIBC) endif src-distrib: src-distrib-ocamlgraph $(MAKE) clean $(PRINT_TAR) tmp-distrib $(TAR) cf tmp.tar $(wildcard $(DISTRIB_FILES)) $(PRINT_MAKING) export directories $(MKDIR) $(EXPORT)/bin $(MKDIR) $(EXPORT)/lib/plugins $(MKDIR) $(EXPORT)/lib/gui $(MKDIR) $(EXPORT)/external $(PRINT_UNTAR) tmp-distrib cd $(EXPORT); $(TAR) xf ../tmp.tar; autoconf; \ rm -rf autom4te.cache src/*/autom4te.cache $(PRINT_RM) tmp-distrib $(RM) tmp.tar $(PRINT_MAKING) test directories for dir in $(EXPORT)/tests/*; do \ $(MKDIR) $$dir/result; \ $(MKDIR) $$dir/oracle; \ done $(PRINT_MAKING) archive $(TAR) czf frama-c-src.tar.gz $(EXPORT) $(PRINT) Cleaning $(RM) -fr $(EXPORT) bin-distrib: depend configure Makefile $(PRINT_MAKING) bin-distrib $(RM) -r $(VERSION) ./configure $(CONFIG_DISTRIB_BIN) $(QUIET_MAKE) DESTDIR=$(FRAMAC_SRC)/$(VERSION) install $(CP) README $(VERSION) clean-distrib: dist-clean $(PRINT_RM) distrib $(RM) -r $(EXPORT) $(EXPORT).tar.gz ifeq ($(OCAMLGRAPH_LOCAL),"") src-distrib-ocamlgraph: $(PRINT_MAKING) distrib-ocamlgraph @ $(ECHO) "Cannot make distrib tar ball without local ocamlgraph installation" @ exit 2 else src-distrib-ocamlgraph: $(PRINT_MAKING) distrib-ocamlgraph $(MKDIR) $(EXPORT) $(CP) ocamlgraph.tar.gz $(EXPORT) endif # Compiling Frama-C's mcpp # force "make mcpp" to be executed for all SVN users force-mcpp: expr `$(CAT) .make-mcpp-stamp` + 1 > .make-mcpp-stamp bin/frama-c-mcpp$(EXE): .make-mcpp-stamp $(PRINT_MAKING) Frama-C\'s mcpp $(QUIET_MAKE) -C mcpp $(CP) mcpp/src/mcpp$(EXE) $@ distclean-mcpp: if test -f mcpp/Makefile ; then $(QUIET_MAKE) -C mcpp clean ; fi ifneq ($(FC_MCPP),no) all:: bin/frama-c-mcpp$(EXE) install:: $(MKDIR) $(BINDIR) $(PRINT_CP) frama-c-mcpp$(EXE) $(CP) bin/frama-c-mcpp$(EXE) $(BINDIR) uninstall:: $(PRINT_RM) frama-c-mcpp$(EXE) $(RM) $(BINDIR)/frama-c-mcpp$(EXE) endif ############################################################################### # Local Variables: # compile-command: "LC_ALL=C make" # End: ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/configure.in��������������������������������������������������������������0000644�0001750�0001750�00000073020�12155630370�016312� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������########################################################################## # # # This file is part of Frama-C. # # # # Copyright (C) 2007-2013 # # 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 2.1 # # for more details (enclosed in the file licenses/LGPLv2.1). # # # ########################################################################## # autoconf input for Objective Caml programs # Copyright (C) 2001 Jean-Christophe Fillitre # from a first script by Georges Mariano # the script generated by autoconf from this input will set the following # variables: # OCAMLC "ocamlc" if present in the path, or a failure # or "ocamlc.opt" if present with same version number as ocamlc # OCAMLOPT "ocamlopt" (or "ocamlopt.opt" if present), or "no" # OCAMLBEST either "byte" if no native compiler was found, # or "opt" otherwise # OCAMLDEP "ocamldep" # OCAMLLEX "ocamllex" (or "ocamllex.opt" if present) # OCAMLYACC "ocamlyacc" # OCAMLLIB the path to the ocaml standard library # OCAMLVERSION the ocaml version number # OCAMLWIN32 "yes"/"no" depending on Sys.os_type = "Win32" # EXE ".exe" if OCAMLWIN32=yes, "" otherwise AC_INIT(src/kernel) define([FRAMAC_MAIN_AUTOCONF]) m4_include(share/configure.ac) AC_SUBST([FRAMAC_VERSION],[`cat VERSION`]) # export CYGWIN=nobinmode ########################## # Check for Make version # ########################## new_section "configure make" AC_CHECK_PROG(MAKE,make,make,) MAKE_DISTRIB=`sh -c "$MAKE -v | sed -n -e 's/\(.*\) Make.*$/\1/p'"` MAKE_MAJOR=`sh -c "$MAKE -v | sed -n -f bin/sed_get_make_major"` MAKE_MINOR=`sh -c "$MAKE -v | sed -n -f bin/sed_get_make_minor"` echo $ECHO_N "make version is $MAKE_DISTRIB Make $MAKE_MAJOR.$MAKE_MINOR: $ECHO_C" if test "$MAKE_DISTRIB" != GNU -o "$MAKE_MAJOR" -lt 3 -o "$MAKE_MINOR" -lt 81; then echo "${ECHO_T}" AC_MSG_ERROR([unsupported version; GNU Make version 3.81 or higher is required.]); else echo "${ECHO_T}Good!" fi # verbosemake feature AC_ARG_ENABLE( verbosemake, [ --enable-verbosemake verbose makefile commands], VERBOSEMAKE=$enableval, VERBOSEMAKE=no ) if test "$VERBOSEMAKE" = yes ; then AC_MSG_RESULT(Make will be verbose.) fi ############################# # Check for Ocaml compilers # ############################# # Specifically allow 3.10.0 UNSUPPORTED_OCAML=no AC_ARG_ENABLE( unsupported-ocaml, [ --enable-unsupported-ocaml attempt to compile even against unsupported ocaml version], UNSUPPORTED_OCAML=$enableval, UNSUPPORTED_OCAML=no) new_section "configure ocaml compilers" # we first look for ocamlc in the path; if not present, we fail AC_CHECK_PROG(OCAMLC,ocamlc,ocamlc,no) if test "$OCAMLC" = no ; then AC_MSG_ERROR(Cannot find ocamlc.) fi OCAML_ANNOT_OPTION="-dtypes" # Let user shoot himself in the foot if he so wishes warn_or_die () { if test "$UNSUPPORTED_OCAML" = "yes"; then echo "Compile at your own risks"; else echo "If you want to compile Frama-C with this version, use the \ --enable-unsupported-ocaml option of configure"; exit 2; fi } # we extract Ocaml version number and library path # "sed -n" is the posix version of "sed --quiet" OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` echo $ECHO_N "OCaml version is $OCAMLVERSION: $ECHO_C" case $OCAMLVERSION in 3.12.1*) echo "${ECHO_T}good!"; OCAML_ANNOT_OPTION="-annot";; 3.0*) echo "${ECHO_T}Incompatible version! Use at least OCaml 3.12.1."; exit 2;; 3.10*) echo "${ECHO_T}Incompatible version! Use at least OCaml 3.12.1."; exit 2;; 3.11*) echo "${ECHO_T}Incompatible version! Use at least OCaml 3.12.1."; exit 2;; 3.12.0*) echo "${ECHO_T}Incompatible version! Use at least OCaml 3.12.1."; exit 2;; 4.*) echo "${ECHO_T}good!"; OCAML_ANNOT_OPTION="-annot";; *) echo "${ECHO_T}Incompatible version!"; exit 2;; esac # Ocaml library path OCAMLLIB=`$OCAMLC -where | tr -d '\\r'` echo "ocaml library path is $OCAMLLIB" # then we look for ocamlopt; if not present, we issue a warning # if the version or the stdlib directory is not the same, we also discard it # we set OCAMLBEST to "opt" or "byte", whether ocamlopt is available or not AC_CHECK_PROG(OCAMLOPT,ocamlopt,ocamlopt,no) OCAMLBEST=byte if test "$OCAMLOPT" = no ; then AC_MSG_WARN(Cannot find ocamlopt; bytecode compilation only.) else AC_MSG_CHECKING(ocamlopt version and standard library) TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p'` if test "$TMPVERSION" != "$OCAMLVERSION" \ -o `$OCAMLOPT -where | tr -d '\\r'` != "$OCAMLLIB"; then AC_MSG_RESULT(differs from ocamlc; ocamlopt discarded.) OCAMLOPT=no else AC_MSG_RESULT(ok) OCAMLBEST=opt fi fi if test "$OCAMLBEST" = "opt"; then LIB_SUFFIX=cmxa OBJ_SUFFIX=cmx; else LIB_SUFFIX=cma OBJ_SUFFIX=cmo; fi # checking for ocamlc.opt AC_CHECK_PROG(OCAMLCDOTOPT,ocamlc.opt,ocamlc.opt,no) if test "$OCAMLCDOTOPT" != no ; then AC_MSG_CHECKING(ocamlc.opt version and standard library) TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVERSION" != "$OCAMLVERSION" \ -o `$OCAMLCDOTOPT -where | tr -d '\\r'` != "$OCAMLLIB"; then AC_MSG_RESULT(differs from ocamlc; ocamlc.opt discarded.) else AC_MSG_RESULT(ok) OCAMLC=$OCAMLCDOTOPT fi fi # checking for ocamlopt.opt if test "$OCAMLOPT" != no ; then AC_CHECK_PROG(OCAMLOPTDOTOPT,ocamlopt.opt,ocamlopt.opt,no) if test "$OCAMLOPTDOTOPT" != no ; then AC_MSG_CHECKING(ocamlc.opt version and standard library) TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVER" != "$OCAMLVERSION" \ -o `$OCAMLOPTDOTOPT -where | tr -d '\\r'` != "$OCAMLLIB"; then AC_MSG_RESULT(differs from ocamlc; ocamlopt.opt discarded.) else AC_MSG_RESULT(ok) OCAMLOPT=$OCAMLOPTDOTOPT fi fi fi ############################################## # Check for other mandatory tools/libraries # ############################################## new_section "configure mandatory tools and libraries" # ocamldep AC_CHECK_PROG(OCAMLDEP,ocamldep,ocamldep,no) if test "$OCAMLDEP" = no ; then AC_MSG_ERROR(Cannot find ocamldep.) else AC_CHECK_PROG(OCAMLDEPDOTOPT,ocamldep.opt,ocamldep.opt,no) if test "$OCAMLDEPDOTOPT" != no ; then OCAMLDEP=$OCAMLDEPDOTOPT fi fi # ocamllex AC_CHECK_PROG(OCAMLLEX,ocamllex,ocamllex,no) if test "$OCAMLLEX" = no ; then AC_MSG_ERROR(Cannot find ocamllex.) else AC_CHECK_PROG(OCAMLLEXDOTOPT,ocamllex.opt,ocamllex.opt,no) if test "$OCAMLLEXDOTOPT" != no ; then OCAMLLEX=$OCAMLLEXDOTOPT fi fi # ocamlyacc AC_CHECK_PROG(OCAMLYACC,ocamlyacc,ocamlyacc,no) if test "$OCAMLYACC" = no ; then AC_MSG_ERROR(Cannot find ocamlyacc.) fi ############## # ocamlgraph # ############## OCAMLGRAPH_LOCAL="" OCAMLGRAPH_HOME=$OCAMLLIB/ocamlgraph OCAMLGRAPH_EXISTS=no OCAMLGRAPH_INCLUDE= # check if any ocamlgraph is installed in the right place AC_CHECK_FILE($OCAMLGRAPH_HOME/graph.$OBJ_SUFFIX, OCAMLGRAPH_EXISTS="yes" OCAMLGRAPH_INCLUDE="-I +ocamlgraph") ocamlgraph_error() { AC_MSG_NOTICE([OcamlGraph $OCAMLGRAPH_VERSION is incompatible with Frama-C.]) OCAMLGRAPH_EXISTS=no OCAMLGRAPH_INCLUDE= } # if any, check if it is a compatible version if test "$OCAMLGRAPH_EXISTS" = "yes"; then test_ocamlgraph_version='print_string Graph.Version.version;;' echo $test_ocamlgraph_version > test_ocamlgraph.ml if ocamlc -o test_ocamlgraph $OCAMLGRAPH_INCLUDE graph.cmo \ test_ocamlgraph.ml 2> /dev/null; \ then OCAMLGRAPH_VERSION=`./test_ocamlgraph` case $OCAMLGRAPH_VERSION in 1.8.1) ocamlgraph_error;; 1.8.2) ocamlgraph_error;; 1.8.3) AC_MSG_NOTICE([OcamlGraph $OCAMLGRAPH_VERSION found: great!]);; 1.8.*) AC_MSG_NOTICE([OcamlGraph $OCAMLGRAPH_VERSION > 1.8.2 found: should be compatible!]);; *) ocamlgraph_error;; esac else ocamlgraph_error fi rm -f test_ocamlgraph test_ocamlgraph.ml test_ocamlgraph.cm* fi # revert back to local version of ocamlgraph if test "$OCAMLGRAPH_EXISTS" = "no"; then AC_MSG_NOTICE([switching to OcamlGraph provided by Frama-C]) OCAMLGRAPH_LOCAL=ocamlgraph OCAMLGRAPH_HOME= AC_CHECK_FILE($OCAMLGRAPH_LOCAL,OCAMLGRAPH_EXISTS=yes) if test "$OCAMLGRAPH_EXISTS" = "no"; then AC_CHECK_FILE(ocamlgraph.tar.gz,OCAMLGRAPH_EXISTS=yes) if test "$OCAMLGRAPH_EXISTS" = "yes"; then # ocamlgraph.tar.gz exists, but no directory ocamlgraph AC_MSG_NOTICE([unarchiving ocamlgraph.tar.gz]) tar zxf ocamlgraph.tar.gz else # neither directory ocamlgraph, nor ocamlgraph.tar.gz exists # broken distrib indeed AC_MSG_ERROR([cannot find OcamlGraph in the current directory. Quite strange: would your Frama-C distribution be corrupted? Anyway: 1. download the latest version from http://ocamlgraph.lri.fr/download 2. install it by './configure && make && make install' 3. rerun ./configure here]) fi else AC_CHECK_FILE(ocamlgraph.tar.gz,OCAMLGRAPH_TAR=yes) if test "$OCAMLGRAPH_TAR" = "yes"; then # both directory ocamlgraph and ocamlgraph.tar.gz exist at the same time # untar only if the tar is newer than the directory if test ocamlgraph.tar.gz -nt ocamlgraph; then AC_MSG_NOTICE([find a newer OcamlGraph version: OcamlGraph updated!]) rm -rf ocamlgraph tar zxf ocamlgraph.tar.gz fi fi fi # Anyway reconfigure OcamlGraph while reconfiguring Frama-C AC_MSG_NOTICE([configuring ocamlgraph...]) (cd $OCAMLGRAPH_LOCAL && ./configure > /dev/null) fi ################################################# # Check for other (optional) tools/libraries # ################################################# new_section "configure optional tools and libraries" AC_CHECK_PROG(OCAMLDOC,ocamldoc,ocamldoc,no) if test "$OCAMLDOC" = no ; then AC_MSG_RESULT(ocamldoc discarded not present) else AC_CHECK_PROG(OCAMLDOCOPT,ocamldoc.opt,ocamldoc.opt,no) # Strange quantic segfault with native ocamldoc in version 4.00.0 if test "$OCAMLDOCOPT" != no -a "$OCAMLVERSION" != 4.00.0; then OCAMLDOC=$OCAMLDOCOPT; fi fi AC_CHECK_PROG(OCAMLMKTOP,ocamlmktop,ocamlmktop,no) if test "$OCAMLMKTOP" = no ; then AC_MSG_RESULT(Cannot find ocamlmktop: toplevels cannot be built.) fi # ocamlcp AC_CHECK_PROG(OCAMLCP,ocamlcp,ocamlcp,no) if test "$OCAMLCP" = no ; then AC_MSG_ERROR(Cannot find ocamlcp.) fi AC_CHECK_PROG(OTAGS,otags,otags,) AC_CHECK_PROG(OCAMLFIND,ocamlfind,ocamlfind,no) if test "$OCAMLFIND" = "no" ; then echo "No ocamlfind detected" else OCAMLLIB_BY_FINDLIB=`ocamlfind query stdlib | tr -d '\\r'` if test "$OCAMLLIB_BY_FINDLIB" = "$OCAMLLIB" ; then echo "OCamlfind detected and enabled" else echo "OCamlfind detected but disabled. Standard libraries differ." OCAMLFIND=no fi fi # zarith ######## AC_ARG_ENABLE( zarith, [ --enable-zarith=<dir> use ZArith library], ZARITH_PATH=$enableval,) if test -z "$ZARITH_PATH"; then # standard installation procedure of zarith diverges according to # ocamlfind installation (see zarith's README) if test "$OCAMLFIND" = no ; then ZARITH_PATH=$OCAMLLIB else ZARITH_PATH=`ocamlfind printconf destdir | tr -d '\\r\\n'`/zarith fi AC_CHECK_FILE($ZARITH_PATH/zarith.$LIB_SUFFIX,HAS_ZARITH=yes,HAS_ZARITH=no) if test "$HAS_ZARITH" = "no"; then AC_MSG_WARN(Zarith not found: will use the default less efficient library instead) fi else AC_CHECK_FILE($ZARITH_PATH/zarith.$LIB_SUFFIX,HAS_ZARITH=yes,HAS_ZARITH=no) if test "$HAS_ZARITH" = "no"; then AC_MSG_ERROR(Zarith: file $ZARITH_PATH/zarith.$LIB_SUFFIX not found.) fi fi ############ # Platform # ############ new_section "configure platform" AC_MSG_CHECKING(platform) if echo "let _ = Sys.os_type;;" | ocaml | grep -q Win32; then AC_MSG_RESULT(Win32) OCAMLWIN32=yes EXE=.exe else OCAMLWIN32=no if echo "let _ = Sys.os_type;;" | ocaml | grep -q Cygwin; then AC_MSG_RESULT(Cygwin) EXE=.exe else AC_MSG_RESULT(Unix) EXE= fi fi # Local machdep feature (to generate new platforms) if test "$LOCAL_MACHDEP" = yes ; then AC_CONFIG_HEADER(config.h) AC_CHECK_HEADERS(stdlib.h) AC_CHECK_HEADERS(wchar.h) # Find out the true definitions of some integer types # checkIntegerype(size_t) will echo "int" or "long" checkIntegerType() { fn="testtype.c" fo="testtype.o" for t in "int" "unsigned int" "long" "unsigned long" "short" "unsigned short" "char" "unsigned char" ;do echo "#include <stddef.h>" >$fn echo "#include <wchar.h>" >>$fn # We define a prototype with one type and the function with # another type. This will result in compilation error # unless the types are really identical echo "$t foo($t x);" >>$fn echo "$1 foo($1 x) { return x;}" >>$fn if gcc -c $fn 2>/dev/null ;then # Found it echo $t rm -f $fn $fo return fi done rm -f $fn $fo } AC_MSG_CHECKING([definition of size_t]) TYPE_SIZE_T=`checkIntegerType "size_t"` if test "x$TYPE_SIZE_T" = "x" ;then AC_MSG_ERROR([Cannot find definition of size_t]) fi AC_DEFINE_UNQUOTED(TYPE_SIZE_T, "$TYPE_SIZE_T") AC_MSG_RESULT([$TYPE_SIZE_T]) AC_MSG_CHECKING([definition of wchar_t]) TYPE_WCHAR_T=`checkIntegerType "wchar_t"` if test "x$TYPE_WCHAR_T" = "x" ;then AC_MSG_ERROR([Cannot find definition of wchar_t]) fi AC_DEFINE_UNQUOTED(TYPE_WCHAR_T, "$TYPE_WCHAR_T") AC_MSG_RESULT([$TYPE_WCHAR_T]) AC_MSG_CHECKING([definition of ptrdiff_t]) TYPE_PTRDIFF_T=`checkIntegerType "ptrdiff_t"` if test "x$TYPE_PTRDIFF_T" = "x" ;then AC_MSG_ERROR([Cannot find definition of ptrdiff_t]) fi AC_DEFINE_UNQUOTED(TYPE_PTRDIFF_T, "$TYPE_PTRDIFF_T") AC_MSG_RESULT([$TYPE_PTRDIFF_T]) AC_MSG_CHECKING([for gcc version]) AC_CHECK_TYPE(__builtin_va_list, HAVE_BUILTIN_VA_LIST=true, HAVE_BUILTIN_VA_LIST=false) AC_MSG_CHECKING([if __thread is a keyword]) AC_COMPILE_IFELSE([int main(int __thread) { return 0; }], THREAD_IS_KEYWORD=false, THREAD_IS_KEYWORD=true) AC_MSG_RESULT($THREAD_IS_KEYWORD) # Does gcc add underscores to identifiers to make assembly labels? # (I think MSVC always does) AC_MSG_CHECKING([if gcc adds underscores to assembly labels.]) AC_LINK_IFELSE([int main() { __asm__("jmp _main"); }], UNDERSCORE_NAME=true, UNDERSCORE_NAME=false) AC_MSG_RESULT($UNDERSCORE_NAME) fi # local machdep configuration ########################## # Frama-C's mcpp support # ########################## AC_ARG_ENABLE( mcpp, [ --enable-mcpp use Frama-C's mcpp], #' making emacs mode happy FC_MCPP=$enableval, FC_MCPP=no) if test "$FC_MCPP" = no ; then FRAMAC_DEFAULT_CPP="gcc -C -E -I." ; else new_section "configure Frama-C-mcpp" (cd mcpp ; ./configure --prefix=$prefix --datarootdir=$datarootdir \ --exec_prefix=$exec_prefix --bindir=$bindir --libdir=$datadir/frama-c \ --host=$host --build=$build --mandir=$mandir > /dev/null \ || \ AC_MSG_ERROR([cannot configure Frama-C-mcpp])) FRAMAC_DEFAULT_CPP="frama-c-mcpp$EXE -C -I- -I$datadir/frama-c/libc -I." fi # Specific preprocessor support AC_ARG_WITH( cpp, [ --with-cpp customize defaut preprocessor for Frama-C], [FRAMAC_DEFAULT_CPP=$withval], []) AC_MSG_RESULT(Default preprocessor is $FRAMAC_DEFAULT_CPP.) ################# # Plugin wished # ################# new_section "wished frama-c plug-ins" # Option -with-all-static ####################### define([ALL_STATIC_HELP], AC_HELP_STRING([--with-all-static], [link all plug-ins statically (default: no)])) AC_ARG_WITH(all-static,ALL_STATIC_HELP,IS_ALL_STATIC=$withval) # Option -with-no-plugin ####################### define([NO_PLUGIN_HELP], AC_HELP_STRING([--with-no-plugin], [disable all plug-ins (default: no)])) AC_ARG_WITH(no-plugin,NO_PLUGIN_HELP,[ONLY_KERNEL=$withval],[ONLY_KERNEL=no]) # library declarations ###################### # REQUIRE_LIBRARY: library *must* be present in order to build plugins # USE_LIBRARY: better for plugins if library is present, but not required # HAS_LIBRARY: is the library available? REQUIRE_LABLGTK= USE_LABLGTK= HAS_LABLGTK= REQUIRE_NATIVE_DYNLINK= USE_NATIVE_DYNLINK= HAS_NATIVE_DYNLINK=uncheck # Tool declarations #################### DOT= REQUIRE_DOT= USE_DOT= HAS_DOT= ### Now plugin declarations PLUGINS_FORCE_LIST= ############################################################################### # # #################### # # Plug-in sections # # #################### # # # # For 'internal' developpers: # # Add your own plug-in here # # # ############################################################################### # constant propagation ###################### check_plugin(semantic_constant_folding, src/constant_propagation, [support for constant propagation plugin], yes, no) plugin_require(semantic_constant_folding,value_analysis) # from ###### check_plugin(from_analysis,src/from,[support for from analysis],yes,no) plugin_require(from_analysis,value_analysis) plugin_require(from_analysis,semantic_callgraph) # gui ##### check_plugin(gui,src/gui,[support for gui],yes,no) plugin_require_external(gui,lablgtk) plugin_require_external(gui,gnomecanvas) plugin_use_external(gui,dot) # impact ######## check_plugin(impact,src/impact,[support for impact plugin],yes,no) plugin_use(impact,gui) plugin_use(impact,slicing) plugin_require(impact,pdg) plugin_require(impact,value_analysis) plugin_require(impact,inout) # inout ####### check_plugin(inout,src/inout,[support for inout analysis],yes,no) plugin_require(inout,from_analysis) plugin_require(inout,value_analysis) plugin_require(inout,semantic_callgraph) # metrics ######### check_plugin(metrics,src/metrics,[support for metrics analysis],yes,no) plugin_use(metrics,value_analysis) plugin_use(metrics,gui) # occurrence ############ check_plugin(occurrence,src/occurrence,[support for occurrence analysis],yes,no) plugin_use(occurrence,gui) plugin_require(occurrence,value_analysis) # pdg ##### check_plugin(pdg,src/pdg,[support for pdg plugin],yes,no,pdg_types) plugin_require(pdg,from_analysis) plugin_require(pdg,value_analysis) # postdominators ################ check_plugin(postdominators,src/postdominators, [support for postdominators plugin],yes,no) # rte ##### check_plugin(rte_annotation,src/rte, [support for runtime error annotation],yes,no) # scope ############ check_plugin(scope,src/scope,[support for scope plugin],yes,no) plugin_require(scope,postdominators) plugin_require(scope,value_analysis) plugin_require(scope,from_analysis) plugin_require(scope,pdg) plugin_use(scope,gui) # semantic callgraph #################### check_plugin(semantic_callgraph,src/semantic_callgraph, [support for semantic callgraph],yes,no) plugin_require(semantic_callgraph,value_analysis) plugin_require(semantic_callgraph,users) # slicing ######### check_plugin(slicing,src/slicing,[support for slicing plugin],yes,no, src/slicing_types) plugin_require(slicing,from_analysis) plugin_require(slicing,pdg) plugin_require(slicing,value_analysis) plugin_use(slicing,gui) # spare code ############ check_plugin(sparecode,src/sparecode,[support for sparecode plugin],yes,no) plugin_require(sparecode,pdg) plugin_require(sparecode,value_analysis) # syntactic callgraph ##################### check_plugin(syntactic_callgraph, src/syntactic_callgraph, [support for callgraph plugin], yes, no) plugin_use_external(syntactic_callgraph,dot) plugin_use(syntactic_callgraph,gui) # users ####### check_plugin(users,src/users,[support for users analysis],yes,no) plugin_require(users,value_analysis) # value ####### check_plugin(value_analysis,src/value,[support for value analysis],yes,no, [src/ai src/buckx]) plugin_use(value_analysis,gui) plugin_use(value_analysis,scope) #################### # External plugins # #################### EXTRA_EXTERNAL_PLUGINS= AC_ARG_ENABLE(external, [[ --enable-external=plugin allows to compile directly from Frama-C kernel some external plug-ins.]], [ if test -d $enableval; then AC_MSG_NOTICE([external plug-in $enableval found.]) EXTRA_EXTERNAL_PLUGINS="$EXTRA_EXTERNAL_PLUGINS $enableval" olddir=`pwd` cd $enableval; if test -x ./configure; then new_section "configure plug-in $enableval" ./configure --prefix=$prefix --datarootdir=$datarootdir \ --exec_prefix=$exec_prefix --bindir=$bindir --libdir=$datadir/frama-c \ --host=$host --build=$build --mandir=$mandir \ || \ AC_MSG_ERROR([cannot configure requested external plugin in $enableval]) fi; cd $olddir else AC_MSG_ERROR([--enable-external expects an existing directory as argument.]) fi ]) define([KNOWN_SRC_DIRS], KNOWN_SRC_DIRS src/kernel src/project src/logic src/dummy src/toplevel \ src/lib src/misc src/qed src/type) AC_FOREACH([__plugin],m4_esyscmd([ls src]), [ m4_if(m4_index(KNOWN_SRC_DIRS,__plugin),[-1], [ m4_syscmd(test -r src/__plugin/configure.in) m4_define([is_configure_in],m4_sysval) m4_syscmd(test -r src/__plugin/configure.ac) m4_define([is_configure_ac],m4_sysval) m4_define([config_file], [m4_if(is_configure_in,0,src/__plugin/configure.in, m4_if(is_configure_ac,0,src/__plugin/configure.ac,no))]) m4_if(config_file,[no], [ m4_syscmd(test -r src/__plugin/Makefile) m4_if(m4_sysval,[0], [ check_plugin(__plugin,src/__plugin, [support for __plugin plug-in],yes,yes) if test "$[ENABLE_]tovarname(__plugin)" != "no"; then EXTERNAL_PLUGINS="$EXTERNAL_PLUGINS src/__plugin"; fi])], [ m4_define([plugin_prefix],src/__plugin) m4_include(config_file) m4_syscmd(cd src/__plugin && [FRAMAC_SHARE]=../../share autoconf) ]) ]) ]) ##################################################### # Check for tools/libraries requirements of plugins # ##################################################### new_section "configure tools and libraries used by some plug-ins" # lablgtk2 ########## REQUIRE_LABLGTK="$REQUIRE_LABLGTK$REQUIRE_GNOMECANVAS" USE_LABLGTK="$USE_LABLGTK$USE_GNOMECANVAS" if test "$OCAMLFIND" = "no" ; then echo "No Ocamlfind. Using +lablgtk2." LABLGTK_PATH=+lablgtk2 LABLGTKPATH_FOR_CONFIGURE=$OCAMLLIB/lablgtk2 else LABLGTK_PATH=`ocamlfind query lablgtk2 | tr -d '\\r\\n'` if test "$LABLGTK_PATH" = "" -o "$LABLGTK_PATH" -ef "$OCAMLLIB/lablgtk2" ; then echo "Ocamlfind -> using +lablgtk2.($LABLGTK_PATH,$OCAMLLIB/lablgtk2)" LABLGTK_PATH=+lablgtk2 LABLGTKPATH_FOR_CONFIGURE=$OCAMLLIB/lablgtk2 else echo "Ocamlfind -> using $LABLGTK_PATH" LABLGTKPATH_FOR_CONFIGURE=$LABLGTK_PATH fi fi configure_library([LABLGTK],[$LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX], [$LABLGTKPATH_FOR_CONFIGURE/lablgtk.$LIB_SUFFIX not found.],no) if test "$HAS_LABLGTK" = "yes"; then # Gtksourceview ############### REQUIRE_GTKSOURCEVIEW= USE_GTKSOURCEVIEW= HAS_GTKSOURCEVIEW= FORCE_GTKSOURCEVIEW="yes" if test "$FORCE_GTKSOURCEVIEW" = "yes"; then REQUIRE_GTKSOURCEVIEW="$REQUIRE_LABLGTK" USE_GTKSOURCEVIEW="$USE_LABLGTK" else if test "$has" = "yes"; then USE_GTKSOURCEVIEW="$REQUIRE_LABLGTK$USE_LABLGTK" fi fi configure_library([GTKSOURCEVIEW], [$LABLGTKPATH_FOR_CONFIGURE/lablgtksourceview2.$LIB_SUFFIX], [lablgtksourceview2.$LIB_SUFFIX not found], no) # Gnomecanvas ############# configure_library([GNOMECANVAS],[$LABLGTKPATH_FOR_CONFIGURE/lablgnomecanvas.$LIB_SUFFIX], [lablgnomecanvas.$LIB_SUFFIX not found], no) fi # $HAS_LABLGTK=yes # dot and xdot tools #################### configure_tool([DOT],[dot],[dot not found: you should install GraphViz],no) # Native dynlink ################ define([force_static_plugins], [# compile statically all dynamic plug-ins # except contrary instructions [USE_NATIVE_DYNLINK]=""; for plugin in m4_flatten(PLUGINS_LIST); do n=NAME_$plugin d=DYNAMIC_$plugin s=STATIC_$plugin eval np=\$$n eval dp=\$$d eval sp=\$$s if test "$dp" = "yes"; then if test "$sp" = "no"; then # force to be dynamic USE_NATIVE_DYNLINK="${USE_NATIVE_DYNLINK} $np"; else eval STATIC_$plugin=yes; eval DYNAMIC_$plugin=no; fi fi done]) configure_library([NATIVE_DYNLINK], [$OCAMLLIB/dynlink.cmxa], [native dynlink unavailable (ocaml 3.11 or higher required)], yes, [force_static_plugins]) # Checking some other things which cannot be done too early ########################################################### # Usable native dynlink # Checking internal invariant if test "$HAS_NATIVE_DYNLINK" = "uncheck"; then AC_MSG_ERROR([Internal error with check of native dynlink. Please report.]) fi HAS_USABLE_NATIVE_DYNLINK=no if test "$HAS_NATIVE_DYNLINK" != "no" ; then echo "let f x y = Dynlink.loadfile \"foo\"; ignore (Dynlink.is_native); abs_float (x -. y)" > test_dynlink.ml if ($OCAMLOPT -shared -linkall -o test_dynlink.cmxs test_dynlink.ml) \ 2> /dev/null ; \ then HAS_USABLE_NATIVE_DYNLINK=yes AC_MSG_RESULT([native dynlink works fine. Great.]) else REQUIRE_USABLE_NATIVE_DYNLINK=$REQUIRE_NATIVE_DYNLINK USE_USABLE_NATIVE_DYNLINK=$USE_NATIVE_DYNLINK HAS_USABLE_NATIVE_DYNLINK=no # we know that dynlink does not work: # configure a dummy library "dynlink" in order to # configure plug-ins depending on dynlink in a proper way configure_library([USABLE_NATIVE_DYNLINK], [dynlink], [native dynlink unsupported on this platform], yes, [force_static_plugins]) fi rm -f test_dynlink.* fi ######################## # Plug-in dependencies # ######################## new_section "checking for plug-in dependencies" check_frama_c_dependencies ############################ # Substitutions to perform # ############################ EXTERNAL_PLUGINS="${EXTERNAL_PLUGINS} ${EXTRA_EXTERNAL_PLUGINS}" AC_SUBST(VERBOSEMAKE) AC_SUBST(DOT) AC_SUBST(HAS_DOT) AC_SUBST(HAS_ZARITH) AC_SUBST(ZARITH_PATH) AC_SUBST(OCAMLGRAPH_INCLUDE) AC_SUBST(OCAMLGRAPH_LOCAL) AC_SUBST(OCAMLGRAPH_HOME) AC_SUBST(OCAMLBEST) AC_SUBST(OCAMLVERSION) AC_SUBST(OCAMLLIB) AC_SUBST(OCAMLWIN32) AC_SUBST(OCAML_ANNOT_OPTION) AC_SUBST(EXE) AC_SUBST(HAVE_STDLIB_H) AC_SUBST(HAVE_WCHAR_H) AC_SUBST(HAVE_PTRDIFF_H) AC_SUBST(HAVE_BUILTIN_VA_LIST) AC_SUBST(THREAD_IS_KEYWORD) AC_SUBST(UNDERSCORE_NAME) AC_SUBST(CYCLES_PER_USEC) AC_SUBST(LOCAL_MACHDEP) AC_SUBST(datarootdir) AC_SUBST(FRAMAC_DEFAULT_CPP) AC_SUBST(FC_MCPP) AC_SUBST(EXTERNAL_PLUGINS) AC_SUBST(HAS_USABLE_NATIVE_DYNLINK) AC_SUBST(LABLGTK_PATH) # m4_foreach_w is not supported in some old autoconf versions. # Sadly AC_FOREACH is deprecated now... AC_FOREACH([p],PLUGINS_LIST, [AC_SUBST([ENABLE_]p) AC_SUBST([DYNAMIC_]p) ]) ################################################ # Finally create the Makefile from Makefile.in # ################################################ new_section "creating makefile" AC_CONFIG_FILES([share/Makefile.config], [chmod a-w share/Makefile.config]) AC_OUTPUT() ########### # Summary # ########### new_section "summary: plug-ins available" for plugin in m4_flatten(PLUGINS_LIST); do n=NAME_$plugin e=ENABLE_$plugin d=DYNAMIC_$plugin s=STATIC_$plugin i=INFO_$plugin eval nv=\$$n eval ev=\$$e eval dv=\$$d eval sv=\$$s eval iv=\$$i if test "$ev" = "no"; then res=$ev; elif test "$dv" = "yes"; then res="$ev, dynamic"; elif test "$sv" = "yes"; then res="$ev, static"; else res=$ev; fi AC_MSG_NOTICE([$nv: $res$iv]) done if test "$EXTRA_EXTERNAL_PLUGINS" != ""; then new_section "summary: requested external plugins" fi for plugin in $EXTRA_EXTERNAL_PLUGINS; do AC_MSG_NOTICE([$plugin]) done ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/Changelog�����������������������������������������������������������������0000644�0001750�0001750�00000370042�12155630370�015617� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������############################################################################### # Preliminary notes: # # ------------------ # # Mark "-": change with an impact for users (and possibly developers). # # Mark "o": change with an impact for developers only. # # Mark "+": change for Frama-C-commits audience (not in html version) # # Mark "*": bug fixed. # # Mark "!": change that can break compatibility with existing development. # # '#nnn' : BTS entry #nnn # # '#!nnn' : BTS private entry #nnn # # For compatibility with old change log formats: # # '#?nnn' : OLD-BTS entry #nnn # ############################################################################### ##################################### Open Source Release Fluorine-20130601 ##################################### -* Value [2013/06/11] Add missing C library files. ##################################### Open Source Release Fluorine-20130501 ##################################### - Value [2013/05/22] Better precision for ^ (bitwise xor) operator when applied on intervals of positive integers -* RTE [2013/05/22] Fix off-by-one error in alarms on overflowing unsigned unary minuses. -* Value [2013/05/21] Catch evaluation errors when selecting a logic l-value in the GUI. o* Kernel [2013/05/06] Fixed Type.pp_ml_name for polymorphic types with 3 and 4 type variables (bug #1127). -* Makefile [2013/05/06] Fixed installation directory of the doc in plug-in's Makefile (bug #1278). ##################################### Open Source Release Fluorine-20130401 ##################################### o! Cil [2013/04/11] Remove Cil pretty-printer. Use module Printer instead. The script bin/oxygen2fluorine.sh may be used to automatically convert your code. - Cil [2013/04/09] Handles interpretation of linemarker ending by // and cleanup file paths. - Value [2013/03/26] Highlight non-terminating calls. - Value [2013/03/26] The location in which the result of a call is stored is now evaluated before the call. A warning is emitted if this location has changed after the call. - Logic [2013/03/26] Improved merge strategy for assigns and report in presence of different assigns clauses between two files. - Value [2013/03/23] Better precision for postconditions in functions with multiple return analyzed without slevel. -* Value [2013/03/20] Fix incorrect interpretation of \valid{L}(P) when L is not Here label. -! Value [2013/03/20] The first element of a -lib-entry allocated array, or of an array passed as an argument to main, is now valid regardless of option -valid-context-pointers. -* Slicing [2013/03/18] Fix incorrectness in presence of assertions involving \initialized predicate. User predicates are no longer treated. -* Value [2013/03/15] Fix incorrectness of option -remove-redundant-alarms in presence of '\initialized(...)' alarms. - Value [2013/03/15] Optionally warn against unsigned overflows according to option -warn-unsigned-overflow. - Cil [2013/03/14] The type of fields that are bit-fields now carry an informative attribute FRAMA_C_BITFIELD_SIZE. -* Value [2013/03/09] Fixed misleading "after statement" state on statements followed by an assertion. -* Value [2013/03/09] Option -memexec is now correct in presence of RTE alarms. -! Value [2013/03/09] Consolidated states are now stored before 'assert' clauses are evaluatued. -* Slicing [2013/03/03] Fix options -slice-assert and -slice-threat (-threat did nothing, -assert selected all alarms). -! Sparecode [2013/03/03] Alarms are now ignored during the analysis. -* Value [2013/03/03] Fix incorrect reduction in integers containing pointers address when option -warn-signed-overflow is set. -! Value [2013/03/03] Signed overflows now cause an alarm. Option -no-warn-signed-overflow can be used to get 2's complement. -! Kernel [2013/03/03] Signed overflow alarms are now emitted by default. -! Kernel [2013/03/03] Signed downcast alarms are no longer emitted by default. Use option -warn-signed-downcast to activate them. - Kernel [2013/03/02] Print signed downcast alarms as 'signed_downcast' -! Value [2013/03/02] Removed option -val-signed-overflow-alarms. Use -warn-signed-overflow instead. -! Rte [2013/03/02] Removed options -rte-signed, rte-unsigned-ov, -rte-downcast and -rte-unsigned-downcast. They are replaced by -warn-signed-overflow, -warn-unsigned-overflow, -warn-signed-downcast and -warn-unsigned-downcast respectively. -* Rte [2013/03/02] Added missing alarm for casts from overly large floating-point numbers to integer. Fixes #!1318. - Cil [2013/03/02] 'do {...} while(0);' are now translated as '{...}'. -* Value [2013/02/28] Initial state of Value does not depend on -main option, but depends on -context-<...>. - Value [2013/02/27] Emit proper alarms for completely imprecise floating-point values, and for casts from float to int. -* Impact [2013/02/23] Prevent crash when a caller or callee function has been imprecisely analyzed. - PDG [2013/02/23] Ignore inline asm statements (previous behavior was to generate Top Pdgs). -* Value [2013/02/23] In -lib-entry mode, void* fields or pointers now point to something potentially valid. - Value [2013/02/22] Option -val-ignore-recursive-calls now uses the assigns clauses of the recursive function to treat the call. - Value [2013/02/17] Improved support for va_arg variadic macro. -! Value [2013/02/17] Renamed options -initialized-padding-globals and -no-no-results into -uninitialized-padding-globals and -val-store-results respectively. -* Value [2013/02/17] Improved again support for abstract structs. o! Value [2013/02/15] Generic types of Value are now in Value_types (previously Value_aux). Implies a signature change for Db.Value.register_builtin. Value_aux.accept_base is now in Db.Semantic_Callgraph. - Value [2013/02/13] Offsets in misaligned values that repeat themselves are now always printed relatively to the beginning of the binding. - Value [2013/02/12] Suppress superfluous warning when passing as argument a struct that contains pointers. -* Metrics [2013/02/12] Global variables both declared and defined were counted twice. -* Metrics [2013/02/11] Option -value-metrics now report a correct location for function referenced by an initializer. Fixes #!1361. o! Value [2013/02/08] Renamed Locations.valid_enumerate_bits into Locations.enumerate_valid_bits. o*! Kernel [2013/02/08] Must register keywords introducing new clauses of ACSL contracts. Fixes issue #!1358. o! Kernel [2013/02/08] redesign of message categories. See detailed changelog for more information. o! Cil [2013/02/07] Clean up registering of new machdeps. Some machdep options have been integrated into Cil_types.mach, or removed from Cil.theMachine (as they were already in Cil_types.mach). - Value [2013/02/06] Improve reduction by conditions that involve '&' and '|' operators. -* Value [2013/02/06] Fix validities of degenerate variables that were too big considering the size of the memory. -* Impact [2013/02/06] Prevent crash when considering a function with an unreachable first statement. o! Logic [2013/02/04] Change Property_status.Consolidation_graph.dump now takes a formatter instead of a file name. - Value [2013/02/02] Improved support for abstract structs. o! Value [2013/02/02] Removed Base.All validity. Use big validities with unknown flag instead. Improved signature of Base.Unknown. o! Cil [2013/02/02] Renamed function Cil.alignOf_int into bytesAlignOf. o! Cil [2013/02/02] Remove unused 'alignof_char_array' machdep field. -* Value [2013/02/01] Fix erroneous casting operating when interpreting logic casts. -* Kernel [2013/02/01] Ghost status is appropriately propagated in statements (instead of only instructions) and pretty-printed accordingly. Fixes issue #1328. - Value [2013/02/01] Value more agressive evaluation of construct '//@ for b: assert p' when b is guaranteed to be active. Harmonize behaviors-related messages. - Kernel [2013/01/29] The level of verbose is at least the level of debug. -* Value [2013/01/28] Ignore 'const' qualifier on extern globals in lib-entry mode (previously, those globals were initialized to 0). - Obfuscator [2013/01/28] Hide variables that do not appear in the output from the dictionary. -* From [2013/01/28] Fix rare bug in presence of involved control-flow graphs and non-terminating calls. o! Slicing [2013/01/21] Remove no longer used ~ai argument. -!*Value [2013/01/21] Various changes in the way undefined functions returning pointers are handled. - Value [2013/01/20] Alarms emitted by Value are no longer evaluated during analysis (unlike user assertions). - Value [2013/01/20] More aggressive reduction in presence of write through partially invalid pointers. Warn if the pointer is completely invalid. -* Value [2013/01/20] Option -absolute-valid-range can now be changed between two executions of Value. -! Slicing [2013/01/19] Alarms are now removed in the generated project (regardless of option -slicing-keep-annotations). -! Sparecode [2013/01/19] RTE or Value-generated alarms are now removed in the generated project. o! Value [2013/01/17] Builtins must now warn if their results should not be cached (signature change in Db.Value.builtin_result). o* Kernel [2013/01/16] Visitor no longer crashes when a non-function global is replaced by a list containing at least one function or prototype (fixes bug #!1349). !* Kernel [2013/01/10] Add lv_kind field to trace origin of logic variables Cil_const.make_logic_var is deprecated in favor of specialized. -* Kernel [2013/01/10] Fixed bug #!1347 about accessing to a consolidated status of a property which depends on removed hypotheses. o! Kernel [2013/01/10] Remove method is_annot_before from visitors (it was returning only true). -* Makefile [2013/01/08] Compile OcamlGraph less often: fixes issue #1343. - Value [2013/01/08] More agressive analysis of statements with improperly sequenced accesses when option -unspecified-access is used. o Kernel [2013/01/04] New methods videntified_term and videntified_predicate for the visitor. -* Kernel [2013/01/04] Fixed discrepancy between compare_type and hash_type. Added new datatype TypNoUnroll. o Kernel [2013/01/03] Added pp_field and pp_model_field in Printer_api. o Kernel [2013/01/03] Added type modules Cil_datatype.Wide_string and Datatype.List_with_collections. -* Logic [2013/01/03] Fixes various type-checking issues in presence of polymorphism and implicit conversions (including #1146). o! Kernel [2012/12/21] Module Cilutil has been removed. Previously used list functions can now be found in Extlib (use script oxygen2fluorine.sh for migration). Functions related to configuration files are now Cilconfig. o! Impact [2012/12/21] Function Db.Impact.compute_pragmas now returns a list of statements. -* From [2012/12/21] Fix absence of effect of option -calldeps after a save/load cycle. -* Inout [2012/12/21] Fix absence of effect option -inout-callwise after a save/load cycle. o! Kernel [2012/12/13] Reorganize AST's pretty-printers. You must now use module Printer. Use the script oxygen2fluorine.sh to upgrade your plug-in. o! Kernel [2012/12/13] Remove Cilutil's pretty printing helpers. Use Pretty_utils' ones instead. - Inout [2012/12/12] Indirect reads (for example 'p' for '*p') are now automatically added to inputs when evaluating assigns. - Value [2012/12/12] Evaluation of assigns now include indirect reads (ie 'assigns *p' depends on p) automatically. - Value [2012/12/07] Improve handling of conditionals when option -val-ilevel is used. - PDG [2012/11/28] InCtrl nodes are no longer displayed in Dot graphs. o! Kernel [2012/11/24] Various types whose names started by t_ in PDG/slicing related modules are now unprefixed. o Rte [2012/11/23] Export function "exp_annotations" to get RTEs of a C expression as annotations. o*!Kernel [2012/11/23] Added TLogic_coerce constructor to mark explicitely a conversion from a C type to a logical one (in particular floating point -> real and integral -> integer). Fixes issue #1309. o! Kernel [2012/11/22] Remove unintuitive ?prj argument from Cil visitors, and first argument of Visitor.generic_frama_c_visitor. Information is now stored inside the type Cil.visitor_behavior. -* Value [2012/11/20] Fix evaluation of logic constant characters above 127. -* Value [2012/11/20] Fix soundness bugs for comparisons with logic constants that are not representable as 64 bits double. o! Kernel [2012/11/20] Signature change for constructor LReal. - Rte [2012/11/16] Generate Value-compatible alarms and annotations. - Kernel [2012/11/16] Syntactic constant folding is done once by AST (fixed bug #!1306). - Value [2012/11/13] More precise line numbers for statuses of assertions and loop invariants. - Value [2012/11/09] New option -val-callstack-results to record and display in GUI the results splitted by callstacks. o Kernel [2012/11/08] New function Annotations.model_fields. -! Rte [2012/11/06] Remove option -rte-print. Use -print instead. -* Kernel [2012/11/06] Do not print help of negative options when the positive one is invisible (fixed #1295). o! Kernel [2012/11/05] Get rid of useless rooted_code_annotation datatype. -* Aorai [2012/10/31] Adds locations modified by Aorai to existing loop assigns (fixes issue #1290). o Kernel [2012/10/31] Renamed Kernel_function.self to Kernel_function.auxiliary_kf_stmt_state to avoid confusion. o Kernel [2012/10/31] New function 'get' for projectified counters. - Kernel [2012/10/29] Better frama-c.top (fixed issue #1287). -* Kernel [2012/10/26] Do not attempt to merge unrelated anonymous enum that have been given the same name by Cil (fixes #1283). - Logic [2012/10/26] Extended syntax for naming terms and predicates ("string":pred and "string":term are now allowed). o! Kernel [2012/10/18] New API for module Alarm's. - Kernel [2012/10/18] When printing the AST, display the emitter name of generated annotations and also the origin of annotations corresponding to an alarm. o* Kernel [2012/10/18] Fixes incorrect visitor behavior with JustCopy (issue #1282). - Value [2012/10/16] Reduce more agressively on accesses *p where p is imprecise but contains only one valid value. -* Value [2012/10/16] Correct potentially incorrect reduction on l-values of the form *(p+off) or *(p-off). -* Kernel [2012/10/16] Fixed bug with Type.pp_ml_name for pairs, triples and quadruples which can lead to incorrect journal generation (new occurrence of bts #1127). o Kernel [2012/10/12] Optional argument 'reorder' to File.* functions creating an AST in a new project from a visitor. -* Value [2012/10/12] A bug causing the number of superposed states to be slightly underestimated has been fixed. As a result, it may be necessary to up the -slevel argument a little bit for existing proof scripts. - Kernel [2012/10/11] Option -enums for choosing representation of enums. -* Scope [2012/10/10] Prevent crash in defs computation when a lvalue is a formal. o* Makefile [2012/10/01] Fix installation directory of API documentation (fixed bts #1278). - Kernel [2012/10/01] Assumptions and axioms now get consilodated status "Considered valid" instead of "Valid". -* Value [2012/10/01] Fix "Semantic level unrolling superposing up to" messages. The number displayed was sometimes lower than the actual number of superposed states. -* Gui [2012/10/01] In some cases, after a crash of an analyzer, the GUI was not fully restored, became inconsistent and could crash. o! Value [2012/09/30] Remove various instances of Top_Param, which were all equal to Base.SetLattice. o Pdg [2012/09/30] Fix display for control dependencies in PDG graphs. o Kernel [2012/09/20] Provide Datatype.triple and Datatype.quadruple (bts wish #1277). o* Kernel [2012/09/20] Fixed consistency check of descriptor when building polymorphic datatypes (fixed bts #1277). ################################### Open Source Release Oxygen-20120901 ################################### -! Kernel [2012/09/17] Remove useless negative options -no-help, -no-version, -no-print-share-path, -no-print-lib-path and -no-print-plugin-path. - Kernel [2012/09/13] All globals with attribute FC_BUILTIN are preserved even if unused. - Value [2012/09/13] Print misaligned values in a simpler way. Fixes wish #!1271. o!* Cil [2012/09/12] Split constants of logic and C (fixes bts #745). o! Cil [2012/09/12] Remove type Cil_type.typeSig. Use the functions in Cil_datatype.Typ and Cil_datatype.Logic_typ to compare types. -* Kernel [2012/09/07] Identical messages emitted in two different projects will now be visible in both projects. Fix bug #1104. o Kernel [2012/09/07] Improve signature of State_builder.Set_ref. o* Kernel [2012/09/07] Correct hash function for Sets created by Datatype.Make_with_collections or Datatype.With_collections. o* Kernel [2012/09/06] Datatype with structural comparison for exp and lval fixes bts #1263. -* Kernel [2012/09/06] Fine tuning AST dependencies. See developer guide. -* Kernel [2012/09/05] Fixed missing undefined behavior for multiple write accesses (fixes bts #1059). -* Metrics [2012/09/05] Fixes count of pointer accesses. - Value [2012/09/05] Clarified message about completely indeterminate memory. -* Kernel [2012/09/03] Do not accept spurious '}'. Fixes bts #1273. o! Kernel [2012/09/03] Remove obsolete constructors Cabs.TRANSFORMER and Cabs.EXPRTRANSFORMER and related parsing rules. - Value [2012/09/02] Warn when 'assigns *p' points to a completely invalid location. - Value [2012/09/01] Assertions such as \valid(p) now evaluate to Invalid when p is not initialized or an escaping address. -* Value [2012/08/30] Fix crash when evaluating *((int*)0+x)=v when the NULL base is invalid. -* Kernel [2012/08/29] Fixed #!1267 (adds explicit casts for default argument promotions). o! Value [2012/08/29] Signature change for function Db.Value.register_builtin: builtins can now return multiple states. o! Value [2012/08/20] Rename Db.Value.assigns_to_zone_inputs_state to Db.Value.assigns_inputs_to_zone. Add new functions Db.Value.assigns_outputs_to_zone and Db.Value.assigns_inputs_to_locations. -* Kernel [2012/08/21] Fixed bug with save/load: loading a file <f>, then quitting Frama-C can no longer modify <f> (bts #!1269). +* Logic [2012/08/08] Fixed bts #!1262 about logic preprocessing and string escapes. - Value [2012/08/02] Statutes 'Invalid' are now positioned on 'for behav:' assertions even when 'behav' is not the only active behavior. o* Cil [2012/08/02] Fixed bts #1254: incorrect documentation of Cil.d_plaininit. -* Logic [2012/08/01] Fixed bts #!1253: IndexPI and PlusPI are equivalent. o* Kernel [2012/08/01] Fixed bts #!1250: setting formals of visited function is not delayed until fill_global_tables anymore. +* Slicing [2012/07/31] Fixed bts #!1248 about empty slicing request. -* Journal [2012/07/31] Fixed bts #932 about journalization of dynamic plug-ins in some corner cases. o!* Kernel [2012/07/31] Operations that silently mutate AST should now call Ast.mark_as_changed to clear states depending on it (fixes #!1244). o Kernel [2012/07/30] API of dynamic plug-ins is now documented as well as static plug-ins (fixed bts #!171). - Slicing [2012/07/30] No more blank between -slicing-project-name and -slicing-exported-project-postfix (from #!1249 entry). - Gui [2012/07/27] Fixed bugs when the consolidation graph cannot be displayed (fixed bts #1122). - Kernel [2012/07/24] The annotation 'loop pragma UNROLL "completly", n;' unroll 'n' times the annoted loop and then add it a clause 'loop invariant \false;'. The remaining loop should be death code. o Kernel [2012/07/24] Changes in interface of StringHashtbl options. -! Inout [2012/07/22] Option -inout-callwise restarts Value when it is newly set - Impact [2012/07/19] Complete rewrite. Improved precision and computation time. Fixes wishes #!5 and #!6. -* Logic [2012/07/18] Fixes sizeof("string_literal") in logic. - Logic [2012/07/18] Better error messages when parsing logic. - Kernel [2012/07/16] C constant expressions are now allowed as UNROLL level into loop pragmas. o! Cil [2012/07/16] Ast changed: Unrool_level renamed into Unroll_specs and its argument becomes a list for next evolutions. o! Kernel [2012/07/16] Add function [stmt_can_reach] to the arguments of Dataflow.Backwards, which is used to speed up the analysis. See dataflow.mli for good possible values. - Kernel [2012/07/16] linker checks that the ghost status of two merged declaration is the same, and raises an error otherwise. o* Kernel [2012/07/16] -check verifies if vdefined flag is coherent with status of variable in Globals tables and AST. Fixes one of the issues of #!1241. -! Rte [2012/07/16] Rename option -rte-const into -rte-no-trivial-annotations (set by default). -* Value [2012/07/15] Fix crash when an undeclared function returned a pointer to a function that was later called. -* Rte [2012/07/14] Prevent generation of incorrect alarms on statements whose order of execution is not completely specified. - Rte [2012/07/14] Generate simpler assertions for accesses to arrays, and discard trivial ones; improve ordering of assertions. Honor option -unsafe-arrays. o Makefile [2012/07/13] Added variables PTESTS_OPTS and PLUGIN_PTESTS_OPTS to pass options to ptests through make tests. See dev manual. -! Value [2012/07/12] More thorough checks for calls through a function pointer: warn when the function type and the pointer are not compatible, and stop when they cannot be reconciled. -! Kernel [2012/07/12] A negative value given to -ulevel option hides all UNROLL_LOOP pragmas. - Report [2012/07/10] Display unreachable properties in a special way; identify unreachable statement more clearly. - Gui [2012/07/10] Display all properties in 'Properties' panel, including generated ones without location. +! Kernel [2012/07/10] Change semantics of 'reachable' properties for functions. Use intrinsic notion instead of accessibility of first statement. o Kernel [2012/07/04] Hook for handling for loop components in Cabs. o Makefile [2012/07/04] plugin is distributed iff PLUGIN_DISTRIBUTED and PLUGIN_ENABLE are not 'no' (instead of PLUGIN_DISTRIBUTED == yes). -* Kernel [2012/07/03] Fixes bug #840 (inaccurate position in presence of -pp-annot). o+ Kernel [2012/06/29] New functions Annotations.remove_* and .fold_* for each component of a contract and other small API changes. Better compatibility between Visitor and Annotations. - Kernel [2012/06/26] New option -keep-unused-specified-functions. o! Kernel [2012/06/25] Correct (albeit slow) hash function for terms and term lvalues. -* Cil [2012/06/25] Better propagatation of volatile, const and restrict type qualifiers through typedefs on arrays -* Cil [2012/06/25] Preserve typedefs on global variables with an initializer -! Kernel [2012/06/22] improve 'reachable' properties. o! Kernel [2012/06/19] Remove module Inthash. Use Datatype.Int.Hashtbl instead, or directly carbon2nitrogen.sh migration script. o! Value [2012/06/18] Made type Ival.tt private. - Kernel [2012/06/16] Consolidation from call-site preconditions to original precondition now handle calls through function pointers - Value [2012/06/16] Position call-site statuses for function preconditions, instead of the previous global status. - Cil [2012/06/13] New option -warn-undeclared-callee for calls to functions that have not been previously declared. - From [2012/06/12] Better precision for code of the form 'if (c) stop(); else y = x+1;', where stop does not terminate - Pdg [2012/06/12] Improve precision in presence of provably dead code branches. Fixes issue #1194. o Makefile [2012/06/12] Use ocamldoc.opt whenever possible. - Rte [2012/06/11] Reuse behaviors names when -rte-precond is used on fonctions with multiple behaviors. o! Kernel [2012/06/11] New API for Annotations which merges old Annotations, Globals.Annotations and operations of Kernel_function over function contracts. - Scope [2012/06/08] Improved computation of defs. Statements are categorized between direct and indirect accesses. -! Pdg [2012/06/08] Rename option -dot-pdg into -pdg-dot - Logic [2012/06/07] Cleaner generated assertions in presence of multiple pointer casts. o! Kernel [2012/05/30] Kernel.Functions.get does not silently create a kernel function if it does not already exist. This behavior is kept for Cil builtins. -* Kernel [2012/05/29] Fix graph of consolidation statuses when several properties get the same name. -* Value [2012/05/19] Calls (*p)() where p resolves to both valid functions and invalid addresses are now properly handled. - Value [2012/05/19] Add bzero builtin. A precise destination and size are required (wish #915). -* Value [2012/05/19] In lib-entry mode, honor 'const' attributes that appear deep inside the type (bts #759). -* Value [2012/05/19] Better time and space complexity for initialization of big arrays in -lib-entry mode (bts #1026). o* Kernel [2012/05/16] Fix implementation of Datatype.Triple and Datatype.Quadruple (bts #!1133). -* Value [2012/05/15] Re-emit alarms when Value options are changed and an analysis is restarted. - Value [2012/04/29] New option -val-ilevel, to change the frontier between sets of integers and intervals. - Kernel [2012/04/27] when printing help, display the name of the opposite boolean option (bts #1085). -* Kernel [2012/04/26] Fixed bug with Type.pp_ml_name for generic sets which can lead to incorrect journal generation (bts #1127). o! Kernel [2012/04/26] Plugin.set_optional_help is now deprecated. -* Value [2012/04/26] Fix possible typing bugs when evaluating logic expressions with non-integral types (bts #!1175). - Kernel [2012/04/24] Use Zarith whenever possible (bts #!983). - Value [2012/04/16] Allow comparison of invalid pointers in the logic. - Value [2012/04/15] Old "Evaluate expression" menu in the GUI replaced by "Evaluate ACSL term"; value of term lval is now displayed. Evaluations that may fail are flagged. - Value [2012/04/15] Errors during evaluation in the logic are now reported. *! Kernel [2012/04/14] Introduce more temporaries for a call [lv = f()] if the return type of f and the type of lv do not match. Fix issue #1024. -* Value [2012/04/14] Fix incorrect initialization of volatile fields or globals in presence of initializers (bts #!1112). o* Makefile [2012/04/12] Fix bug #1145 about PLUGIN_LINK_GUI_OFLAGS. -* Kernel [2012/04/12] Strict checking of type compatibility when merging an already called prototype without arg list and a full prototype (fixes issue #728, #!109). - Kernel [2012/04/12] New option -<plugin>-share for plug-ins to customize their specific share directories. - Rte [2012/04/06] Emit \valid_read alarms instead of \valid for read accesses. - Inout [2012/04/05] Better precision for 'if' in which only a side is reachable. - Kernel [2012/04/05] Keep all prototypes with a spec, even if not referenced. - Inout [2012/04/04] Operational inputs are now more precise for function with only an ACSL prototype. -* Kernel [2012/04/04] Fixes issue in loop unrolling and annotations. -* Kernel [2012/04/02] Fixed bug #1135 and bug #1139 about loop unrolling. - Logic [2012/03/29] LoopEntry and LoopCurrent built-in labels. - Value [2012/03/26] Support for \valid_read predicate; evaluation of \at(p,Pre) and \initialized{Pre}(...). o! Kernel [2012/03/26] Kernel.CppExtraArgs now gets type Plugin.String_list and not Plugin.String_set (fixed bts #!1132). - Value [2012/03/24] Improved handling of conditions involving the conversion to int of a floating-point variable. - Journal [2012/03/21] Better journalisation of command line options setting a list of arguments (e.g. -slevel-function): avoid quadratic complexity in the generated code (fixed bts #!1123). - Gui [2012/03/20] Removing 'add assert before' from contextual menu. Uses ACSL_Importer plugin for such a feature. -* Value [2012/03/18] Handle 'assigns *p' where p has a typedef type - Kernel [2012/03/18] Support for model fields -* Kernel [2012/03/12] Initialization of locals is correct for all sizes; uses bzero to 0 + contract (directly validated by Kernel) -* Value [2012/03/12] Fixed bug where user assertions accessing uninitialized variables got the wrong status. - Value [2012/03/12] Improved handling of *(p+i) (or equivalently p[i]) when p is a known pointer and i is unknown. -! Kernel [2012/02/29] Adding some more supports for built-in related to memory blocks. -! Cil [2012/02/24] Functions returning a value cannot let control flow falling through the closing '}' Fixes #685. - Inout [2012/02/24] Option -inout-callwise to compute callsite-wise operational inputs. Improves precision of -inout, of the "Modifies" clause in the gui, and of the slicing. -! Kernel [2012/02/23] Sets generated assigns clauses into the default behavior. - Value [2012/02/22] New message for functions with only a specification. Changed old message for functions with neither code nor specification to "No code nor specification for function ...". - Value [2012/02/21] Evaluation of \separated predicate -* Value [2012/02/21] Fix bug in evaluation of pointers to start of array. -* Cil [2012/02/20] Improve label positions in presence of loop unrolling (bug #1100). -* Value [2012/02/18] Fix crashes and/or missing alarms when evaluating *p=(cast)f() with p invalid (bug #!1097). -* Cil [2012/02/13] Correct sharing bug on widening pragmas. Fixes #!1090. o* Cil [2012/02/11] Fixed off-by-one error in foldLeftCompound ~implicit:true. o* Makefile [2012/02/09] 'make doc' did not work when GUI disabled (bts #1014). -! Kernel [2012/02/08] Adding supports for clause allocates and frees and their version for loops. - Slicing [2012/02/07] More precise slicing when -calldeps is used (fixes wish #107). -* Kernel [2012/02/07] Fixed bug about property statuses and setting parameters after -load (statuses were not cleared when required). -* Value [2012/02/07] Allocate a finite space for malloc builtins; fixes some bugs when a pointer refers to a non-yet allocated space. -* Journal [2012/02/07] Fixed bug #!1080: better generated journal in case of missing internal data preventing it of being runable. o* Makefile [2012/02/07] Fixed bug #1082 about wrong link in generated code documentation. - Scope [2012/02/04] Improve precision of Defs computation (wish #1079). - Value [2012/02/02] Assertions of the form \valid(p+i) and \valid(&p->f) are now used to reduce p whenever possible. - Value [2012/01/30] Improve precision for code with pointer casts (fixes bug #1074). -* Syntactic_callgraph [2012/01/27] Fix bug #989 about difference of display between GUI and dot output. -* Syntactic_callgraph [2012/01/27] Fix tricky bug while computing services when a cycle depends on another cycle (most part of the fix is actually in OcamlGraph itself). -* Value [2012/01/27] Evaluate ACSL && and || when they appear as terms (fixes bug #1072). - From [2012/01/25] More sharing between identical values when printing results. - Pdg [2012/01/25] Improve performance, typically on arrays of structs. - Logic [2012/01/23] Better label inference in axiomatics (see bts #1068). - Cil [2012/01/20] In debug mode, pretty-print numerical constants instead of displaying the source file strings. - GUI [2012/01/19] Add filters for properties' consolidated statuses. - Value [2012/01/19] Aesthetic fix: do not display {{ &NULL }} and {{ &"foo" + {2} }} but rather {{ NULL }} and {{ "foo" + {2} }}. - Occurrence [2012/01/10] Results can be filtered to display only occurrences in read or write positions. - Value [2012/01/09] FRAMA_C_MALLOC_INDIVIDUAL modelization now properly treats allocated blocks as uninitialized. - Value [2012/01/07] Reduce more aggressively invalid pointers: { p->f1 = v1; p->f2 = v2 } will usually raise at most one alarm. - Value [2012/01/03] During evaluation, reduce indexes that are detected as out-of_bounds. - Value [2012/01/03] In index out-of-bounds alarms, do not generate 'assert 0 <= i' part when 'i' is always greater than 0. o Kernel [2011/12/19] Added Property.location function. o* Value [2011/12/05] Fix option -absolute-valid-range being reset by project copies. -* Value [2011/12/05] Fix wrong hash function, which could cause memory overuse and worse. o Value [2011/12/02] Lmap.paste_offsetmap now handles imprecise destinations. o! Value [2011/12/02] Moved contents of memory_state/Abstract_value into ai/Lattice_Interval_Set. Use bin/nitrogen2oxygen for automatic migration. - Project [2011/11/28] Accept to load inconsistent project by setting to default the inconsistent states and their dependencies. - Value [2011/11/26] Minor improvements related to single-precision floating-point handling. -* Pdg [2011/11/24] Option -pdg did nothing if -pdg-print was not set. - Value [2011/11/22] After emitted an alarm \initialized(lv), the value analysis tries to remember that lv is initialized. This suppresses redundant alarms that were emitted further on. -* Value [2011/11/22] Fixed soundness bugs involving lval = lval; assignments targeting literal strings and automatically created S_... memory zones. - Value [2011/11/22] Suppressed confusing message "all target addresses were invalid. This path is assumed to be dead.". -* Value [2011/11/21] Prevent potentially incorrect assertions from being emitted when the result a call must be cast. Fixes #997 and #1024. o Kernel [2011/11/21] New File.init_from_project function. - Value [2011/11/20] New builtin Frama_C_assert. Take advantage of existing assertions with "#define assert Frama_C_assert". -* Occurrence [2011/11/19] Fix bug where some occurrences were silently ignored in big asts; improve performance. -* Cil [2011/11/18] Go to new line more often when printing sequence of statements. Fixes issues #1021. - Value [2011/11/17] Better evaluation of \initialized predicate when only some parts of the location are initialized. - Value [2011/11/17] New option -no-val-left-shift-negative-alarms to treat left shift of negative integers as defined. -* Cil [2011/11/14] Fail when encountering a lvalue of type void (#1013). - Value [2011/11/10] Evaluate more precisely statements of the form if (*p == 1) {...} when *p is reused within the if block. This also improves the handling of switches. -* Kernel [2011/11/09] keep track of local variables even in presence of annotation + do not silently lose statement contract. Fixes issue #1009. -*! Kernel [2011/11/07] empty list in complete/disjoint is expanded by logic type-checker to the list of behavior name of current contract. Fixes issue #1006. See bts comments for the differences that can appear in the treatment of specs. - Aorai [2011/11/07] Aorai gets a real Dataflow analysis for contract generation + various logic simplifications. - Gui [2011/11/04] Display global annotations in the filetree. o! Cil [2011/11/04] Add method pFile in printers. Signature change for Cil.d_file (but you should use !Ast_printer.d_file). - Inout [2011/11/03] Major precision improvements when evaluating library functions whose assigns contains ranges. - From [2011/11/03] Major precision improvements when evaluating library functions whose assigns contains ranges. -* Logic [2011/10/30] Fixes issue #1005 (earlier detection of duplicated axiom name avoids Kernel.fatal). o Kernel [2011/10/27] Plugin.Register defines a new option -plugin-debug-category that allows to enable debugging for sub-categories of messages (See Log.set_debug_keys for more info). -* Value [2011/10/27] Fixed #1001: do not warn for unsigned shifts, do not end propagation on signed left shift of an address. o Value [2011/10/27] shift_left and shift_right functions now take an optional signedness boolean in addition to the optional size. -* Value [2011/10/26] Generate correct assertions when using memcpy builtin. Fix #1000. - Value [2011/10/25] Improve interpretation of ACSL annotations in presence of typedefs. -* Value [2011/10/24] Improve warnings and evaluation in presence of possibly infinite floats (fixes #997). -* From [2011/10/21] The interpretation of explicit assigns clauses for library function "assigns *p \from x;" was wrong: every possible location was assumed to have been overwritten. -* Kernel [2011/10/20] Link error aborts Frama-C (fixes #990). -* Kernel [2011/10/20] Better linking behavior (fixes #672). o! Kernel [2011/10/18] Logic_preprocess.file takes an additional parameter, as gcc pre-processor treats differently .c and .cxx files, and this must be reflected in annotation pre-processing. - Value [2011/10/18] Improve evaluation of logic when option -val-signed-overflow-alarms is active. -* Value [2011/10/17] Fixed crash when a library function is called in a state where the function's precondition cannot be true. -* Value [2011/10/10] Fixed spurious alarm \valid(p) in *p = e; when e is completely invalid. Soundness was not affected (the alarm for whatever made e invalid was present). ##################################### Open Source Release Nitrogen-20111001 ##################################### - Rte [2011/10/07] No longer position 'Don't know' statuses - Value [2011/10/07] New alarm for left shift of negative values. Minor other changes related to shift operation alarms. o*! Rte [2011/10/06] Correct plug-in name for dynamically registered RTE functions. -* Kernel [2011/10/06] Warn when the plug-in specified by -load-module or -load-script is not found (used to remain silent) -!* Kernel [2011/10/06] Do not normalize Pre in Old, especially where Old is not allowed. - Value [2011/10/01] Do not continue evaluating successive 'requires' or 'ensures' clauses if one of them is false. - Kernel [2011/10/01] New kind of command-line parameter, for commands that do heavy output. Used for Value, Pdg and Metrics. -* Cil [2011/09/30] Correctly handle casts in switch. Fixes #961. -! Rte [2011/09/30] Option -rte-precond is not entailed by -rte-all anymore (precontion annotations must now be required explicitly). -* Aorai [2011/09/30] Generation of loop invariant for intermediate counter + fixes various issues -! Slicing [2011/09/30] Option -slice-print is now deprecated: use instead <normal slicing command> -then-on 'Slicing export' -print - From [2011/09/29] Display results function by function, instead of as one big block (may lower memory consumption considerably). - Value [2011/09/27] New option -remove-redundant-alarms for removing redundant alarms. This was previously done by default. Use this option if you are going to inspect alarms emitted by Value. -* Kernel [2011/09/26] Treat long bitfields the same way as gcc and clang. Fixes #!959. -* Kernel [2011/09/26] New exception for Ast.UntypedFiles.get when no untyped AST is available. Fixes #954. - Value [2011/09/23] New alarm, for programs that do not respect C99 6.5.16.1:3 (overlapping assignment from lvalue to lvalue). Partially supported (not emitted in some cases). -* Kernel [2011/09/23] Fixes various performance issues when parsing very large functions. Fixes #!965. - Value [2011/09/23] Improved precision of if (x!=c) when the value set of x is an interval of 9 elements. -* Slicing [2011/09/23] Use correct function during generation of sliced project. Fixes #!950. o* Kernel [2011/09/22] Copy visitor creates new kf before visiting a function, allowing to use it for creating Property.t items in the new project during visit (fixes #!942). -* Value [2011/09/22] Much more clever when interpreting logic terms, including those containing \old (eg. formals in postconditions) - Value [2011/09/21] Raised cut-off limit between sets and intervals from 7 to 8 elements. - Value [2011/09/21] New informative message when not using. -val-signed-overflow-alarms "2's complement assumed for overflow" o! Value [2011/09/18] Changed the representation of Ival.t. If an external plug-in matches "Ival.Set s", a simple fix is to add "let s = Ival.set_of_array s in" as first line of that case. - Value [2011/09/16] Improved precision of &. - Value [2011/09/16] Improved precision when using -all-rounding-modes. o Kernel [2011/09/09] Map_common_interface to have a merge function for Ocaml < 3.12. o Kernel [2011/09/09] Quadruple datatype. - Value [2011/09/09] Better message when interpretation stops for a function argument. - Pdg [2011/09/06] Pdg can now be saved on disk. -* Logic [2011/04/20] Fix bug #!501: volatile clauses relative to partially volatile lvalues are handled by the kernel. - Pdg [2011/09/03] Improved time and space complexity on big functions. - Cil [2011/09/02] Add support for GCC specific cast from field of union to union -* Cil [2011/09/02] Fix merging bug (#!948). -* Slicing [2011/09/02] Fix incorrect simplification of single-statement block in presence of label. - Value [2011/09/02] Wide strings more supported. - Kernel [2011/09/02] Improve space complexity of function stmt_can_reach. - Semantic Constant Folding [2011/09/02] All options are prefixed by "scf". Use -scf-help for the details. Fixed #!946. Compatibility is preserved thanks to option aliases. - Value [2011/08/30] Remove non-relevant variables from the 'Modifies' clauses of the GUI. o! Kernel [2011/08/30] Add parameter ~with_locals to Db.accept_base (prior this, ~with_locals was implicitly false) o! Value [2011/08/30] Signature change in CilE: plugins that want to emit Value analysis alarms must define their own emitters. o! Value [2011/08/30] Add some missing ~with_alarms arguments, notably to offsetmaps copy and paste. o! Kernel [2011/08/29] Export datatype Varinfo.Hptset. Signature change in functor Abstract_interp.Make_Hashconsed_Lattice_Set. - Metrics [2011/08/26] New command-line options to compute the functions potentially called from a given function, and the percentage of functions analyzed by the value analysis. - Value [2011/08/25] Improve handling of assigns in library functions. - Occurrence [2011/08/25] Better pretty-printing: do not display internal ids anymore. -! Value [2011/08/24] Improve behavior in presence of errors during the computation of the initial state. Allow non ISO global initializers using the value of constant globals defined earlier. o! Kernel [2011/08/23] Getters of Dynamic.Parameter now get an extra argument of type unit. May improve efficiency a lot. -* Kernel [2011/08/23] Fixes visitor bug + properly refresh ids of properties in code transformation (in particular loop unrolling). -* Kernel [2011/08/15] Add parameter ~declarations to Globals.FileIndex.get_functions. Prevent duplication bug in properties navigator of the GUI. - Inout [2011/08/12] Operational inputs and outputs are now more precise for library functions: assigns clause are evaluated at each call. o! Inout [2011/08/12] Interface change. Non_contextual renamed to Cumulative_analysis. -* Cil [2011/08/10] Fix conversion bug for f(i++) or f(++i) when i has size less than int, and f expects an int (bug #911). - Value [2011/08/10] Loop invariants are now used to improve analysis. - Value [2011/08/09] Uses "complete behaviors" information. - Scope [2011/08/09] "Show Defs" is now an interprocedural analysis. o! Value [2011/08/09] Module Cvalue_type renamed to Cvalue. Module Relations_type removed. Use Cvalue instead. - Value [2011/08/04] Postconditions containing \old are now handled. - Kernel [2011/08/04] Current pragmas no longer give rise to code annotations (as they do not contain anything that can be proven). -! Gui [2011/08/04] Improve labels under the icons of the toolbar. Smart constructors in Menu_manager now require a label and a tooltip. o Kernel [2011/08/04] Add Kernel.Unicode.without_unicode, which applies a function without upsetting the Unicode option in the gui. -* Impact [2011/08/04] Correct a journalisation bug in gui mode. - Value [2011/08/01] More precise when an alarm is emited in a loop. o! Kernel [2011/08/01] Signature of Plugin renamed for consistency. Use carbon2nitrogen for automatic translation. o! Kernel [2011/08/01] Annotations.replace and Globals.Annotations.replace_all are removed. o! Kernel [2011/08/01] Add IPLemma, IPNotacsl and IPConjunction as new constructors of Property.t; remove IPBehavior. - Kernel [2011/08/01] Better pretty printing of lists of any elements o! Kernel [2011/08/01] Properties_status is now called Property_status. Fully new interface. o! Cil [2011/08/01] Removing types about validity status from the AST. Use module Property_status instead. o Kernel [2011/07/25] Adding option ~dkey to Log.debug functions. See Log.Messages for details. o! Kernel [2011/07/22] Modification of Log.print_on_console. No more based on Format.kfprintf to avoid deadlock when error are raised by plugin pretty printers. -* Logic [2011/07/22] Fixes bug #885 (wrong insertion of cast). -* Logic [2011/07/21] Fixes bug #!887 (merging logic constants). o* Kernel [2011/07/20] Ensures that a unique kf is generated per function in each project, avoid using kf for project A in project B. -! Kernel [2011/07/18] Better handling of comments with -keep-comments and new API. See Cabshelper.Comments and Globals.get_comments_* o! Aorai [2011/07/12] Redefinition of internal structures before enabling Ya extensions for sequences o! Value [2011/07/11] Add argument "exact" to Lmap.paste_offsetmap (which was preciously supposed to be always true). -* Cil [2011/07/06] Correct obscure Cil bug linked to the removal of trivial unspecified sequences or blocks. Fixes bug #882. - Value [2011/07/05] Option -val-builtin: experimental support for builtins that can fail (by calling a fallback C function). - Value [2011/07/04] New builtin Frama_C_dump_each_file, which dumps the entire memory state into successive files. o* Logic [2011/06/29] Fixes bug #751 (Cil.lconstant now returns terms of type integer and not int). - Metrics [2011/06/27] Improves efficiency of metrics computation. o! Cil [2011/06/24] Improve performances of Cil_datatype.Typ.{compare, equal, hash}. - Cil [2011/06/22] Cache results of offsets computations. -* Logic [2011/06/22] Fixed issue #!866 (merging specs included twice) o Kernel [2011/06/16] Exporting Property_status.self state o! Kernel [2011/06/16] Dynamic.load_module searches in plugin path as advertised in its documentation o*! Cil [2011/06/14] Support for large constants in programs. My_bigint is now used instead of Int64.t in the AST. Fixes #!858. o* Kernel [2011/06/10] Fix dynamic access to function [is_default] of parameters. o! Kernel [2011/06/10] New way for handling abstract type in the type library. -* Value [2011/06/09] Remove some uneeded warnings when comparing function pointers with NULL. Fixes bug #!855. -* Kernel [2011/06/09] Correct syntactic loop unrolling in presence of switch. Fixes bug #861. o! Kernel [2011/06/09] Remove function CilE.update_gotos. o! Kernel [2011/06/09] new function Kernel_function.set_spec which must be called whenever the spec of a kf is modified. o! Kernel [2011/06/08] Remove Kernel_datatype (merge with Cil_datatatype). o! Kernel [2011/06/07] Most types of module Property are now private. Use smart constructors instead. o Kernel [2011/06/07] New function Dynamic.is_plugin_present. -* Cil [2011/06/07] Fixes bug #857 (problem with some C enum value and Ocaml 32 bits 3.11.0). -* Logic [2011/06/06] Normalization of assigns clause: \result and \exit_status only appear if a \from is specified. Fixes #!557, #!845 o! Kernel [2011/06/06] Structural_descr.pack is now a private type. Use smart constructors instead. - Value [2011/06/04] Emit \pointer_comparable alarm for unspecified. equality test between literal strings such as "foo" == "foo". - GUI [2011/06/03] Double-clicking on a warning now displays the pretty-printed source location o! Value [2011/06/03] Functions valid_* now take an argument ~for_writing Pass true when the lvalue being considered is used for writing in the program. Pass false when unsure. - Value [2011/06/03] Literal strings are now read-only. - Value [2011/06/03] More agressive state reduction when emiting pointer_comparable assertions. Use option -undefined-pointer-comparison-propagate-all if you liked the old behavior better. o GUI [2011/06/02] Menu_manager now support check menus and toggle buttons - Value [2011/06/02] New option -no-val-show-progress - Cil [2011/06/02] Pretty-printing lval and term_lval the same way - Cil [2011/06/01] Normalization of lval: T+1 ==> &T[1] when T is in fact an array (implies *(T+1) ==> T[1]) -* Logic [2011/05/31] can have a local binding for a predicate (even a constant one) without spurious warnings from typechecker. (fixes #!848) + Ptests [2011/05/31] Add -xunit option to support JUnit like output. o Kernel [2011/05/31] Cil_datatype.LogicLabel implemented o Kernel [2011/05/31] New function File.new_machdep in order to register a new machdep dynamically. - Dominators,Postdominators [2011/05/31] No feedback by default. Use -dominators-verbose 2 or -postdominators-verbose 2 if you need it. -* Project [2011/05/31] Fix sharing bug when copying project. - Value [2011/05/31] Alarms may pretty print the abstract value culprit for the potential violation. This is particularly informative for certain alarms. - Cil [2011/05/30] Support for &"constant_string" in parser. -* Kernel [2011/05/29] Fixed macros in limit.h. - GUI [2011/05/28] Support to display the state of the absolute memory. o! Kernel [2011/05/26] Module Parameters is dead. Each module corresponding to a parameters is moved to Kernel. Module Parameters.Dynamic is now Dynamic.Parameter while Parameters.get_selection_context is now Plugin.get_selection_context. You can use the script bin/carbon2nitrogen to perform the translation (almost) automatically. - Value [2011/05/24] Option -val-after-results to control the recording of post-statement states. Active by default in the GUI. -* Cil [2011/05/24] Fixes bug #832 (spurious warning for read/write accesses in undefined order) o! Logic [2011/05/24] Add possibility to cast integer to C integral type when type-checking (Changes parameter of Logic_typing.Make) o! Kernel [2011/05/24] Kernel_function.find_return may now raise exception Kernel_function.No_Statement. -* Cil [2011/05/17] Fixes bug #771 (spurious warning for read/write accesses in undefined order). -* Kernel [2011/05/13] Support GCC like typing of enums. - GUI [2011/05/13] Add history for navigating source code. o! GUI [2011/05/13] Signature change for Filetree#add_select_function, Filetree#select_global and Menu_manager.entry. Deprecate Design.apply_on_selected. -* Kernel [2011/05/12] Fixed typing of bitfields whose size is equal to the size of int (bugs #823, #817). -* Value [2011/05/11] Fixed undocumented builtin is_base_aligned. -* Value [2011/05/11] Fixed bug when bitfield receives the result of a function call (bug #819). - GUI [2011/05/10] Menu to configure what is displayed in the filetree. -* Logic [2011/05/08] Fixed overloading resolution (fixes bug #655). -* Logic [2011/05/06] Fixed issue with -pp-annot (fix bug #691 and #812). o Kernel [2011/05/05] Kernel now accepts declarations as main entry point. - Aorai [2011/05/04] Automaton is handled by contract of leaf functions. o Cil [2011/05/04] Various smart constructors and ast helper functions. -* Cil [2011/05/04] Fixes wrong precedence of not in predicate when pretty-printing. - GUI [2011/05/04] Automatically show the main function at launch. - GUI [2011/05/04] Hide empty plugins columns in the filetree. Add support for hiding globals entirely. o! GUI [2011/05/04] Signature change for Filetree#append_pixbuf_column. o! Kernel [2011/05/03] Remove Db_types module. All types are now in Cil_types. Moved type Alarms.t to Cil_types.alarm. -* Kernel [2011/05/02] Support for GCC packed and aligned attributes and for GCC pack pragmas. Fixes #719. -* Configure [2011/05/02] Fix bug #!262: --disable-plugin works for external plugins compiled from within Frama-C kernel. - Dataflow [2011/04/29] Improve precision of backwards dataflow algorithm and of postdominators on 'if' with a missing branch -* Pdg [2011/04/28] Better precision in the dependencies. Fix bug #787, #789 and #802 : infinite loops creation in slicing. o Value [2011/04/28] Changed representation of bases for literal strings in preparation of related checks. o Postdominators [2011/04/27] Add Db.PostdominatorsValue: postdominators taking into account value analysis results -* Value [2011/04/24] Fixed crash for high values of -subdivide-float-var - Value [2011/04/24] Improved results for operation % by zero. Removed message about binary operators raising exceptions. o Value [2011/04/24] Defunctorized Lattice_Interval_Set. -* Logic [2011/04/20] Fix bug #761: adding \old in ensures clause for parameters does not capture terms in associated offset. -* Logic [2011/04/20] Fix bug #!501: volatile clauses are handled by the kernel. -* Slicing [2011/04/20] Fix bug #799: missing label in sliced program. -* Value [2011/04/17] Fix bug #798: calls to functions that return a value with latent conversion. -* Cil [2011/04/15] Fix bug #785: promotion between long long and an unsigned same-sized type. -* Cil [2011/04/14] Fix bugs #780 and #791: use ids unique between projects for varinfos, statements and expressions. o*! Cil [2011/04/14] Remove incorrect Cil_const.Build_Counter; use State_builder.SharedCounter instead. -! Value [2011/04/14] Use hash-consed sets of statements, making many analyses faster and leaner for large functions or idioms that make functions large at normalization (e.g. large initialized local arrays). -* Kernel [2011/04/14] Fix 'make clean' of plug-ins. -* Kernel [2011/04/13] Fix bug #769: merging issue for declared struct. o* Kernel [2011/04/13] Fix bug #790: AST integrity checker issue. -* Pdg [2011/04/13] Fix bug #787 but leads to less precise dependencies. -* Slicing [2011/04/02] Fix bug #786: missing label in sliced program. -* Value [2011/04/12] Correctly emit \pointer_comparable(...) alarms. -* From [2011/04/11] Fix #781: handling of function calls with an implict cast for the assignment of the result. o Makefile [2011/04/08] Add target to launch the tests of a specific dynamic internal plugin from Frama-C's main Makefile. -* Aorai [2011/04/08] Existing assigns are augmented with the locations corresponding to the instrumentation of the automaton. - Value [2011/04/05] Each precondition can get a specific validity status. -* Kernel [2011/04/01] Fixed bug #770 and #769, part 1. Fixed typo in anonFieldName (was annonFieldName). -* Kernel [2011/04/1] Fixed bug #775. Large octal and hexadecimal constants are now correctly typed. -* Occurrence [2011/04/01] Fixed bug when journalising. -* Slicing [2011/04/01] Fixed bug #774: journalisation works again. o Kernel [2011/03/30] Removed type Log.source. From now on all locations have type Lexing.position. - Kernel [2011/03/30] Some messages may be printed several time for the same line if they refer to different columns. -* Value [2011/03/30] Fixed bug #689. Each postcondition can get a specific validity status. -* Impact [2011/03/30] Bug fixed when plug-in `Security_slicing' cannot be loaded or is incompatible with Impact. -* Impact [2011/03/30] Bug fixed with '-impact-pragma f' on an unknown function f. -* Security_slicing [2011/03/30] Fixed bug #768 about exception raised when analysing variadic functions. A warning is now emitted: the function is ignored by the analyzer, thus the result is potentially incorrect. o! Kernel [2011/03/29] Alternative signature for dataflow initial state. A few IntHash replaced by Stmt.Hashtbl. - Users [2011/03/28] Calls to this plug-in are now written in the journal. -* Value [2011/03/26] Some floating-point alarms could be printed several times. Fixed. o! Kernel [2011/03/25] get rid of bin/sed_inplace (use ISED from share/Makefile.common where needed, which was the recommended way from the beginning). o* Kernel [2011/03/25] Makefile.plugin and .dynamic more robust wrt external plugins (can make doc clean depend more easily; fixes bug #754, improves bug #742). -* Logic [2011/03/24] \at(t,L) when t is a C array is now a logic array whose content is the one of t at L, not the address of the first element of t (which stays the same between L and Here anyway). partial fix of bug #761. - Kernel [2011/03/24] \at(p,Old) is pretty-printed as \old(p). o! Cil [2011/03/24] AST changed: removing Told and Pold constructs. o! Kernel [2011/03/11] Following items are now deprecated: function Kernel_function.pretty_name: use Kernel_function.pretty module UseUnicode: use module Unicode. o! Kernel [2011/03/11] Remove several kernel functions: Ast_info.pretty_vname: use Cil_datatype.Varinfo.pretty_vname Cil.print_utf8: use module Parameters.UseUnicode- Clexer.keep_comment: use module Parameters.PrintComments Cabshelper.continue_annot_error_set: Cabshelper.continue_annot_error_set: use Parameters.ContinueOnAnnotError.off all Cil, Cilmsg and CilE functions for pretty printing: use Kernel ones instead. - From [2011/03/11] Display name of called function when displaying results of option -calldeps. o!* Logic [2011/03/11] Implementation of statement contracts for function behaviors. -* Value [2011/03/11] Fixed crash with ACSL assertions involving floating-point variables (bug #752). -* Logic [2011/03/10] Fixed bug #744 (comparison between arithmetic types is done in the smallest possible type). -* Kernel [2011/03/10] Bug fixed in File.create_project_from_visitor potentially impacted programs transformation. -* Kernel [2011/03/10] Bug fixed in pretty printer. (incorrect precedences leading to missing parenthesis). - Kernel [2011/03/09] Big integers can now be displayed using hexadecimal notation. - Value [2011/03/06] Improved option -subdivide-float-var when used without -all-rounding-modes. Improvement marginal for double computations and significant for float ones. o! Cil [2011/03/04] AST changed: 'a before_after type is deleted. All annotations are now attached before. -* Value [2011/03/04] Fixed correctness bug when bitfield initializer exceeds range (bug #721) (jrrt). o! Value [2011/03/02] Minor interface changes in Value. Replace some meaningless kinstr by stmt, and make the callbacks lazy. o! From [2011/03/02] Minor interface changes in From. Replace some meaningless kinstr by stmt, and make the callbacks lazy. -! Cil [2011/03/02] Fixed #720 (incorrect simplification of switch). - Kernel [2011/03/02] Better error message when plug-in crashes on loading (bts #737). o Kernel [2011/03/02] New function File.create_rebuilt_project_from_visitor - Cil [2011/02/24] Implement precise dataflow on switch constructs. As side effect, improve precision of value analysis. o* Kernel [2011/02/24] Fixed bug #727 (visiting a GFun spec in frama-c visitor was not done in the appropriate context). o* Ptests [2011/02/24] Ptests adds filename of current test before the options given to frama-c (see #736). - Aorai [2011/02/24] Deterministic automata. -* Aorai [2011/02/24] Fix issue in translation of guards + better error messages. o! Inout [2011/02/23] Db.InOutContext becomes Db.Operational_inputs. - Inout [2011/02/23] Correctness in presence of recursive calls. See issue #733. - Value [2011/02/23] Improved informative messages about addresses of locals escaping their scope. o! Kernel [2011/02/22] Change semantics of ChangeDoChildrenPost for vstmt_aux. See developer's manual for more precision. - Value [2011/02/22] Take Flush-To-Zero possibility into account for single-precision floats. - Kernel [2011/02/22] Exit status on unknown error is now 125. 127 and 126 are reserved for the shell by POSIX. o!* Kernel [2011/02/21] Extlib.temp_file_cleanup_at_exit and Extlib.temp_dir_cleanup_at_exit may now raise exception Temp_file_error. They may raise an unspecified exception before. -* Value [2011/02/20] Fixed bug #732: Synthetic results were partial when -slevel was set not high enough to unroll loops completely. - Inout [2011/02/20] Improved messages in presence of recursive calls o! Kernel [2011/02/18] Bts #729: calling function Plugin.is_visible (resp. Plugin.is_invisible) forces to display (resp. prevents from displaying) the corresponding parameters in an help message. o! Kernel [2011/02/18] module Service_graph: function entry_point in input and output of functor Make now returns an option type. - Syntactic Callgraph [2011/02/18] Fixed issue #723: syntactic callgraph does not require an entry point anymore. If no entry point, services are less precise yet. -* Cil [2011/02/17] Fixed bug #725 (type-checking && operator). - Inout [2011/02/17] Improved precision of the computation of operational inputs in presence of function calls. -* Logic [2011/02/17] Fixed bug #714 about lexing ACSL characters and strings. o Cil/Logic [2011/02/16] New functions Clexer.is_c_keyword and Logic_lexer.is_acsl_keyword. -! Cil [2011/02/16] Enumerated constants are kept in the AST. -* Aorai [2011/02/16] State names used as enum constant are checked to be admissible fresh C identifiers. -* Value [2011/02/15] Fixed bug when passing struct as argument to function with a big-endian target architecture. - Value [2011/02/15] Uniformized message displayed when no information is available for a function. - Logic [2011/02/14] Added support for bitwise operators --> and <--> into ACSL formula. -* Slicing [2011/04/02] Fixed bug #709: missing statements in sliced program. -* Value [2011/02/14] Fixed bug when passing bitfield as argument to function. (jrrt) -* Value [2011/02/12] Fixed forgotten warning when passing completely undefined lvalue as argument to function. (jrrt) -* Value [2011/02/12] Fixed correctness bug involving nested structs (jrrt). -* Value [2011/02/12] Fixed crash when passing invalid argument to function, found by John Regehr using random testing (jrrt). -* Value [2011/02/09] Fixed representation of unknown single-precision floats in initial context (it used to be the same as for an unknown double). -* Value [2011/02/09] Changes related to 0., +0., -0., sort of thing. Unwarranted loss of precision fixed. ################################### Open Source Release Carbon-20110201 ################################### - WP [2011/02/07] Plug-in WP removed from kernel-releases (now an independent plug-in). - Logic [2011/02/04] Mentioning a formal on the left-hand side of an assigns clause is now an error when type-checking logic annotations. o! Logic [2011/02/04] Refactoring of assigns and from AST representation and of Property.identified_property. - Value [2011/02/04] Changes in Frama_C_memcpy built-in. Still not perfect. - Value [2011/02/04] Is is now possible to call Frama_C_show_each without ..._x. - Value [2011/02/04] Generate independent assertions for signed overflow and signed underflow. In many cases only one is generated (win!). o! Value [2011/02/02] Renamed copy to copy_offsmap in Offsetmaps. The name "copy" clashed with Datatypes. o Kernel [2011/02/01] New syntactic context for memory accesses with user-supplied validity range. + WP [2011/01/31] Option -wp-warnings to display additional informations for 'Stronger' and 'Degenerated' goals. + WP [2011/01/24] Option -wp-split-dim <n> to limit spliting up to 2**n sub-goals (see -wp-split option). -! Kernel [2011/01/27] Handle errors better when they occur when exiting Frama-C. Slight semantic changes for exit code: - old code 5 is now 127; - code 5 is now: error raised when exiting Frama-C normally; - code 6: error raised when exiting Frama-C abnormally. - Kernel [2011/01/27] Improve performance on platform with dynami.c loading. Mainly impact value analysis (for developers: improve efficiency of Dynamic.get). - Value [2011/01/25] Change in initial states generated by -lib-entry Much smaller. Perhaps more representative. + WP [2011/01/24] When -rte-precond is not used, wp generates a separate proof obligation for each call site. -! Configure [2011/01/24] Frama-C does not require Apron anymore (Why does for Jessie). Thus fix bug #647. - Value [2011/01/22] More aggressive handling of if(x>e) where x has type double. o* Kernel [2011/01/20] Fix bug #677. As a side-effect, function Plugin.add_alias is now deprecated and replaced by Plugin.add_aliases. o Kernel [2011/01/21] New function in API: Kernel_function.find_syntactic_callsites. + WP [2011/01/20] Options -wp-status-xxx to refine goal selection. o Report [2011/01/20] Option -report no longer survive after -then. + WP [2011/01/19] Clarification of -save/-then effect on WP. * Slicing [2011/01/19] Fixed bug #673. - Value [2011/01/19] Various minor speed improvements. -* Value [2011/01/19] Fixed correctness bug involving pointers to signed integer pointing to memory locations containing unsigned integers or vice versa. -* Kernel [2011/01/19] Fixed bug if an empty string is given on the command line while an option name is expected. There is now a proper error message. - Logic [2011/01/16] Fix priority bug in parser. - Slicing [2011/01/14] New options added for fixing bug #668. o Sparecode [2011/01/14] API modified for fixing #668. o GUI [2011/01/13] Added support for icons in Gtk_helper.Icon. -* GUI [2011/01/12] Fixed bug #666. Do not display misleading "After statement". - Value [2011/01/12] Improve performance of callbacks. - GUI [2011/01/11] Display more precise state after statement (http://blog.frama-c.com/index.php?post/2011/01/11/Seven-errors-game). -o Value [2011/01/11] New callback for recording the state after a statement. +* WP [2011/01/10] Fixed incorrect status refresh problem in the GUI. -* Kernel [2011/01/10] Fixed #!313. Entry point with a specification is no longer wiped out. -* GUI [2011/01/10] Fixed 100% cpu load while external command are launched. - Value [2011/01/09] Disabled incorrect interpretation of ACSL statement contracts. - Value [2011/01/07] Interpretation of ==> in ACSL annotations. -* Value [2011/01/07] Fixed obscure crash that could happen during very imprecise analyses. -* Makefile [2011/01/06] Fixed bug #!660 related to a default Frama-C-compatible ocamlgraph installation under Cygwin (i.e. in a Win32 path containing the ':' character). - Value [2011/01/06] Improved precision of & operator. - Value [2011/01/05] Added check that denormals work correctly on host computer (correction would be affected otherwise). o! Kernel [2011/01/05] Remove Messages.disable_echo (can be done using Log module) and Messages.depend (can be done using Messages.self). - Value [2011/01/05] New alarm for float -> int cast overflows. - Value [2011/01/04] Improved precision of | operator. +* WP [2011/01/04] Fixed bug #702 on Coq output with large integers. -* Inout [2010/12/22] Return statement dependencies were forgotten in operational input computations. Fixed. o! Kernel [2010/12/21] Remove API function Messages.enable_collect: please let the kernel do the job. - GUI [2010/12/21] Implement feature #635: display messages in the messages panel while loading a batch session in the GUI. The batch session must have been previously executed with the new option -collect-messages. -* Makefile [2010/12/21] Fixed bug #637: "make install -n" did wrongly create directories. -! GUI [2010/12/21] Gui options start by -gui and not -GUI - Makefile [2010/12/21] Fixed bug #!638. By default, warnings are no more errors when compiling a public Frama-C distribution and plug-ins. SVN versions of Frama-C are still compiled with "-warn-error A". o* Cil [2010/12/20] Fixed bug #645. Ast_info.constant_expr, Cil.[zero,one,new_exp,makeZeroInit,mone,kinteger64_repr, kinteger64,kinteger,integer,constFoldBinOp,mkAddrOf, mkAddrOrStartOf,mkString,parseInt,sizeOf] no longer use an optional argument ?loc. It is now a non optional labeled argument. Previous default value of loc was ~loc:Cil_datatype.Location.unkown which is most of the time not accurate. ################################### Open Source Release Carbon-20101202 ################################### -* WP [2010/12/16] Fixed bug #639: no more Coq compilation to shared directory. - WP [2010/12/16] Accessibility of all provers from gui. ################################### Open Source Release Carbon-20101201 ################################### -! Kernel [2010/12/13] Fixed bug #548: limit.h now syntactically correct. Architectures other than x86_32 still unsupported. - Value [2010/12/12] New option -float-normal (undocumented) - Value [2010/12/12] Removed undocumented option -float-digits - Value [2010/12/10] New option named -undefined-pointer-comparison-propagate-all -* Configure [2010/12/10] Always configure OcamlGraph local version (if used) when configuring Frama-C. -* Value [2010/12/09] Fixed bug that could happen in programs casting address of floating-point type to address of integer type o! Kernel [2010/12/07] Remove function Globals.has_entry_point. Use Globals.entry_point instead. -* Syntactic callgraph [2010/12/07] Fixed bug #!587: proper error message when the entry point is invalid. -* Value [2010/12/06] Do not evaluate annotations right after propagation is stopped. - Inout [2010/12/03] Improve printing of -out -input -deps - Value [2010/12/03] Preliminary support for interpreting C type float as IEEE 754 single-precision. -* Value [2010/12/02] Emit proper ACSL alarm for overflowing floating-point binary and unary operators. Fixed #259. -* Value [2010/12/02] Emit alarm for overflowing floating-point constants instead of crashing. - Value [2010/12/02] Emit alarm for uninitialized arguments to library functions. - Value [2010/12/01] Improved speed of options -slevel* for arguments in the thousands. Synthetizing results remains slow, so consider options -no-results* if you take advantage of them. - Value [2010/11/24] Do not emit alarm for uninitialized arguments to non-library functions. Necessary for structs. Relevant messages changed a little. -! Cil [2010/11/16] Cil normalization takes care of abrupt clauses o Kernel [2010/11/15] New Task module: a monadic library for calling asynchroneous commands from the toplevel and the gui. o! Kernel [2010/11/05] File.check_file takes a new argument, allowing to describe which AST fails integrity check in case of trouble. -!* Kernel [2010/11/05] Fixed #620 (default assigns generation). o! Cil [2010/11/04] Changed type of doGuard in forward dataflow -* Value [2010/10/29] Disappearance of non termination messages from the log. The messages were inconsistent. -! Cil [2010/10/15] Clean up local variables handling and pretty-printing modified pBlock method interface (unified pBlock and pInnerBlock) o! Cil [2010/10/13] Extending logic label for plugin purpose. -! GUI [2010/10/08] New graph viewer, requires ocamlgraph > 1.5 -* Logic [2010/09/30] Priority is used for pretty printing predicates. o!* Kernel [2010/09/30] Major changes in the kernel. Mainly merge the old modules Datatype and Type into a single most powerful library called Type. The API of these libraries changes. Consequently, some other API changes. By side effect, a lot of functions of module Cilutil has been removed and replaced by their counterpart in module Cil_datatype. The script bin/boron2carbon.sh fixes most changes automatically. Feel free to use it to upgrade your plug-in. In the process, some minor bugs found and fixed in the Frama-C kernel. o! Cil [2010/09/20] Changed ignored pure exp hook + hook for conditional evaluation of side-effects -* Value [2010/09/18] Fixed memory leak. o! Cil [2010/09/14] Cil and Cabs expression have now a location. o Ptests [2010/09/01] Slightly changed semantics of CMD and STDOPT. See developer manual for more info -* Logic [2010/08/31] Fixed #570 (implicit conversion to void*) and fixes issue in overloading resolution -* Value [2010/08/27] Fixed performance bug that could lead to "stack overflow" error during large analyses. -* Logic [2010/08/27] Fixed #549 (Arrays in the logic) -* Cil [2010/08/27] Fixed #542 (now raises parse error when C function call dot not provide correct number of arguments) - Value [2010/08/26] "assert(TODO)", used when a property to check in the analyzed code cannot be expressed as ACSL and the user should read the English explanation (e.g. "accessing uninitialized left-value") instead, could look unprofessional to the superficial onlooker. "assert(Ook)" will now be used instead. - Value [2010/08/23] Lowered memory consumption slightly. o! Value [2010/08/22] Renamed Int.eq into Int.equal. Removed Int.neq -* Configure [2010/08/18] get rid of known_plugins.ac (fix #462) -* Logic [2010/08/18] Better error messages for logic parser and other fix (fix #512, #538, #!553, #!560) -* Kernel [2010/08/17] CL options for cabs2cil flags (fix #506) -* Occurrence [2010/08/17] Fix bug #550: crash when selecting an occurrence if the entry point set by "-main" is incorrect. -* Logic [2010/08/16] ACSL identifiers starting with a \ are not replaced by pre-processing when a macro of the same name exists (fix #541) - Value [2010/07/28] Clean local variables passed by address to callees from results of -val. - Inout [2010/07/28] Clean local variables passed by address to callees from results of -input, -out, -deps -! Value [2010/07/28] Abort analysis when recursion is encountered. -! Value [2010/07/23] Structures passed as function arguments now precisely handled. o! Value [2010/07/21] Function Cvalue_type.V.is_top rebaptized is_imprecise o! Value [2010/07/21] There was one too many function called "find_ival". One was renamed to "project_ival". - Value [2010/07/19] Improved precision of analysis for program short s[]= {0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1};main(){return((int*)s)[u()];} -* Value [2010/07/14] Fixed bug involving typedefs when using option -val-signed-overflow-alarms. -* Kernel [2010/07/12] Tried to fix all permissions on *.{c,h} files -* Makefile [2010/07/05] Fix bug #528 when building a dynamic plug-in in a sandbox. - Configure [2010/07/05] Better detection of native dynlink support. -* GUI [2010/06/30] Fixed parsing of floats in frama-c-gui.config - Cil [2010/06/30] Be less agressive during inline function merge. Alpha equivalent function are now kept separate. - GUI [2010/06/29] One tooltip by parameter in the launcher o! Cil [2010/06/23] Removed function varinfo_from_vid. You can use maps or hashtables indexed by varinfos directly instead. o! Kernel [2010/06/21] New implementation of module Properties_status o! Cil [2010/06/15] global_annotation has location information o Cil [2010/06/11] Cil.makeLocalVar now inserts the variable into one of the function's local blocks. -* Value [2010/06/11] Some "Misaligned" imprecision origins were wrongly classified as "Arithmetic". Fixed. -* Logic [2010/06/11] Fix bug #!498 (behaviors within same scope must now have unique names) o* Logic [2010/06/10] Fix bug #505 (Associate default label for predicates with a single label parameter and no argument) o!* Project [2010/06/08] Reimplementation of the project library (the contents of directory src/project). New API. o! Cil [2010/06/04] Preliminary support for function calls in UnspecifiedSequence o Cil [2010/06/04] Support for custom extension in grammar of behaviors. See Logic_typing.register_behavior_extension. -* Value [2010/06/03] Do not emit an alarm for the comparison of function addresses to NULL. -* Cil [2010/06/02] Fixed bug #440 (remove spurious block generation at parsing time that clashed with label scoping rule in ACSL) -* Value [2010/06/01] Fixed correctness bug involving the comparison of a variable of type float or double. - Inout [2010/06/01] Improved precision for option -inout-with-formals * Cil [2010/05/31] Fixed bugs #451 (break outside of loop/switch) and #452 (spurious 'body of f call falls through' warnings) -* Cil [2010/05/31] Extended grammar of pragma lines. o* Cil [2010/05/28] Fix bug #489: constant literal present in original source are preserved in the AST. NB: this implies that they might be explicitly cast when an integer conversion occur. -* Kernel [2010/05/28] Fixed bug in handling of -cpp-command o! Cil [2010/05/21] Remove deprecated annotation_status of AAssert in the AST o! Kernel [2010/05/20] Added field b_extended in behaviors to support grammar extensions -* Logic [2010/05/19] Checking for loop variant position - Kernel [2010/05/19] Feature #484 about requires into named behaviors -* Inout [2010/05/12] Fixed bug in -inout where operational inputs of called library function were improperly infered from assigns -* Value [2010/05/12] Fixed bug with extern variables of incomplete type -* Logic [2010/05/11] Fixed wrong precedence of <==> - Value [2010/05/11] Improved Frama_C_memcpy built-in. - From [2010/05/11] Improved interpretation of assigns clauses - Inout [2010/05/05] Improve option -inout-with-formals: cleanup local variables that come from out of call tree functions. - GUI [2010/05/07] In expressions 't[v]', allow to select 't' (when it is a variable). To select the entire expression 't[v]', click on the ']' on the right. o Kernel [2010/05/07] Deprecate Globals.Functions.find_englobing_kf. Use Kernel_function.find_englobing_kf which has a much better complexity instead. - Value [2010/05/06] More consistent naming scheme for generating shorter names when using -lib-entry. "star_" becomes "S_". - Value [2010/05/05] Tweak in -slevel* options. A little slower for some programs, much faster for others. - Inout [2010/05/04] New option -inout-with-formals similar to -inout but without locals and with formals - Inout [2010/05/04] Improved precision of -inout with possibly invalid pointers. - Value [2010/05/03] Variables now uninitialized by default. Improves -deps, -input, -output when addresses of local variables are passed as arguments of called functions. o! Logic [2010/04/30] Parameterize search of field in logic typing functor in a similar way to search of other C symbols o!* Kernel [2010/04/30] Fix bug #!441 (keep track of original names in AST) -* Makefile [2010/04/24] Fix bug #461 when installing the GUI on a bytecode-only architecture -* Makefile [2010/04/24] Fix bug #460 when using a non-local ocamlgraph - GUI [2010/04/27] First support for persistent GUI configuration. GtkPaned ratios, main and launcher window dimensions are saved to file frama-c-gui.config in the user's home directory. - Value [2010/04/26] Yet more small improvements in value analysis of large programs. -* GUI [2010/04/26] Fix bug with toolbar button 'duplicate project' - Value [2010/04/26] More optimization of library functions -* Logic [2010/04/23] fix bug #!454 (multiple labels in same statement) - Security_slicing [2010/04/23] Only use the GUI; does not require it anymore o! Kernel [2010/04/22] Ptmap (resp. Ptset) is renamed into Hptmap (Hptset) -! Obfuscator [2010/04/22] Option -obfuscate is now part of a new dynamic plug-in `Obfuscator' (fixed issue #!265). The behaviour of this option is now journalized and may be run by other plug-ins. -* Makefile [2010/04/20] Fixed potential generation of corrupted .o - GUI [2010/04/19] Better graph display. Require ocamlgraph > 1.4 - Value [2010/04/19] Optimization in the handling of library functions -* Slicing [2010/04/16] Fixed bug #!448 about -keep-annotations option -* Configure [2010/04/14] Fixed bug in configuration of external plug-ins + Logic [2010/04/13] #!346 Formals have an \old label when used in post conditions ################################## Open Source Release Boron-20100401 ################################## - Kernel [2010/04/12] Preliminary standard C library in $FRAMAC_SHARE/libc o* Cil [2010/04/12] New hook after Cabs elaboration (fix bug #!446) o! Kernel [2010/04/12] Slight modification of Hook API o* Configure [2010/04/09] Improved dependencies handling (fix #!054) - Value [2010/04/08] Experimental new option -val-signed-overflow-alarms - Value [2010/04/04] Experimental new option -subdivide-float-var - Logic [2010/04/02] Adding "\pi" as built-in symbol -! Configure [2010/03/24] Compiling the GUI now requires LablGnomeCanvas. -* Makefile [2010/03/24] Fix bug for generating .o files through recursive calls to Make in quiet mode (VERBOSEMAKE unset) o! Kernel [2010/03/23] Dynamic.register and Dynamic.get are more robust, but take an extra parameter - Value [2010/03/23] New options -no-results and -no-results-function, improved replacements for undocumented option -klr -+ Kernel [2010/03/23] New saving/loading algorithms. Option -load is faster, and rid of its previous allocation peak -! Logic [2010/03/22] Support for "reads \nothing" -! Logic [2010/03/19] Support for type abbreviation in logic - Value [2010/03/11] Suppressed undocumented option -klr - Value [2010/03/10] New option -slevel-function f:n for fine-tuning semantic unrolling. - Kernel [2010/03/05] New option "-plugin-h" as an alias for option "-plugin-help" - Logic [2010/02/23] If a C typedef integer, real or boolean exists, it takes precedence over corresponding logic type. The logic type remains accessible through its utf-8 denomination. - Value [2010/02/22] Interpreting post-conditions about \result in contracts for functions that have implementations. o! Kernel [2010/02/22] Type changes in Db.Properties.Interp. Use ~result:None to get your plug-in to compile again. o! Kernel [2010/02/22] Kernel_function.Set now implemented with Patricia. o! Value [2010/02/21] Changed type of functions Db.Value.*_to_kernel_function. These functions now return a Kernel_function.Set.t. Use Kernel_function.Set.elements to transform this set into a list. o! Project [2010/02/19] Project.register_todo_on_clear is deprecated and replaced by Project.register_todo_before_clear - Value [2010/02/19] Improved precision when loop index has type char or short. Fixes bug #325 o! Kernel [2010/02/17] Log.protect is replaced by Cmdline.protect -!* Logic [2010/02/17] Arrays and pointers are distinct in the logic, as per ACSL reference. Fixes bug #396 -* Makefile [2010/02/16] Fixed 'make clean' in plug-in directory (bug #!407) o! Kernel [2010/02/15] Major changes in API of module Annotations: add possible dependencies from/to a single annotation of a statement -+ Value [2010/02/14] New options -no-results and -no-results-all, improved replacements for undocumented option -klr -! Value [2010/02/14] Clarified progress messages -* Cil [2010/02/10] Fix crash in parser when double definition of variable in two different files, in some order (fixed bug #213) - Slicing [2010/02/04] Assigns clauses was missing from the sliced program (fixed bug #393) -!* Logic [2010/02/03] Full support for \let (fixed bug #!344) - Kernel [2010/02/03] Backtrace when Frama-C is crashing (only if Frama-C is compiled with caml >= 3.11.0) - Security_slicing [2010/02/01] New experimental and quite undocumented plug-in. Sub-part of the old plug-in security. Only usable through the GUI. -! Security [2010/02/01] No more distributed. -* Cil [2010/02/01] Bug fixed with incompatible declarations of C functions -* Logic [2010/01/29] complete/disjoint behaviors do not accept undefined behaviors anymore (fixed bug #364) -* Logic [2010/01/27] Default label is "Old" inside \old(...) - Value [2010/01/25] New display option -float-relative -* Value [2010/01/25] Fixed uncaught exception that could happen in analysis of programs with floating-point operations. - Value [2010/01/22] Preliminary support of post-conditions for library functions. - Value [2010/01/21] Take into account all known flush-to-zero floating-point variants. No option seems necessary for now. - Value [2010/01/20] Improved precision of floating-point operations +-* Logic [2010/01/18] \let is supported (except \let id = pred; pred) - GUI [2010/01/18] Add a menu entry for setting C source files of the current project -* GUI [2010/01/18] Fixed bug while choosing 'New project' if -cpp-command is set (fixed bug #374) - GUI [2010/01/18] New menu entries for loading ocaml scripts and ocaml object files (fixed issue #!318) -! Inout [2010/01/17] -out and -out-external now obey -inout-verbose option Generated logs re-ordered a little. - GUI [2010/01/15] Plug-in panels can be detached with drag and drop. o! Kernel [2010/01/15] Type.register is more robust but gets a modified interface (fixed issue #!276) -* Kernel [2010/01/15] -load-script did not clean up compiled files after exiting (fixed bug #!371) - Impact [2010/01/15] In the GUI filetree, for each function, a bullet shows if some statements are highlighted - GUI [2010/01/15] Now possible to save/load a single project (fixed issue #!9) o! Kernel [2010/01/14] New implementation of save/load with small changes in the project API. Loading is now rid of its previous allocation peak and faster. - GUI [2010/01/14] View property status in GUI. Fixed a bug on reset with strange reactive zones in default buffer. -* Logic [2010/01/14] More utf-8 identifier accepted (fixes bug #366) -* Value [2010/01/13] Fixed bug #372 - Value [2010/01/08] New option -all-rounding-modes (floating-point) New dependency on C99 functions to control the FPU. o! GUI [2009/12/17] New implementation for the menubar and the toolbar. API fully changed for adding an item in these bars. -! GUI [2009/12/04] Drop gtksourceview 1.x dependency and replace it with gtksourceview 2.x. -* Makefile [2009/12/03] Some GUI library files was not installed o Kernel [2009/11/30] Support for dynamic uses of StringSet parameters -* Kernel [2009/11/30] -kernel-debug and -kernel-verbose did not work as expected (bts #!343). - Configure [2009/11/27] Dynamic plug-ins are now statically linked by default whenever native dynlink is not usable (bts #!301). o! Kernel [2009/11/24] Use of global logic constants is now a TLval (TVar _,TNoOffset) instead of TApp(_,[]) - Value [2009/11/24] Handling of behavior-specific assertions now correct (albeit imprecise). -! Kernel [2009/11/19] The journal is generated only if the GUI is crashing, or if the option -journal-enable is explicitly set (fixed issue #!330). +- Value [2009/11/19] New option -slevel-exclude f for fine-tuning semantic unrolling. - Logic [2009/11/13] ordering of clauses in contracts -* Logic [2009/11/10] Fixed bug #228, #327 (syntax garbage at end of contracts) - GUI [2009/11/09] Now possible to delete the current project. - GUI [2009/11/09] New shortcut buttons. - GUI [2009/11/04] Options *-verbose, *-debug and -quiet are now settable via the launcher dialog box (bts #!317). -* Logic [2009/11/04] Fixed bug #272 (complete behaviors wo name) - Logic [2009/11/03] Better error message when using = in annotations -* Makefile [2009/11/02] Fixed bug #310: improve robustness againts new ocaml warnings. - Kernel [2009/11/02] New option -no-dynlink in order to prevent loading of dynamic plug-ins. -* Makefile [2009/10/28] Fixed bug #305: make did not terminate when all plug-ins were disabled. -* Configure [2009/10/28] Fixed bug with -help. - Kernel [2009/10/28] Better -*-help. - Kernel [2009/10/28] Better error messages when a dynamic plug-in cannot be loaded. - Kernel [2009/10/21] Clarification of the multiple accesses warning. Becomes "undefined multiple accesses in expression". -* Value [2009/10/21] Some "loss of precision" messages were duplicated and failed to be localized. Fixed. o Kernel [2009/10/18] Extlib now contains various functions to replace Sys.command but with portability and efficiency in mind. -*! Logic [2009/10/16] Support for abrupt clauses; Modifies AST - Syntactic_callgraph [2009/10/15] Big speedup for showing the callgraph in the GUI. Require ocamlgraph >= 1.4. o! Kernel [2009/10/13] Module Db.Properties.Status replaced by module Properties_status. o! Kernel [2009/10/13] Function Db.Properties.predicate_on_stmt and Db.Properties.get_user_assert does not exist anymore. -* Value [2009/10/12] Synthetic validity status for assertions. -* Syntactic_callgraph [2009/10/12] Fixed bug in services computation. -* GUI [2009/10/09] Instantaneous actions are no longer cancelable but are as fast as possible now. o! GUI [2009/10/09] Methods protect and full_protect of main_window_extension_points now have an additional arguments. o Kernel [2009/10/08] Add unique id for elements in Db.Properties.Status tables. - Kernel [2009/10/08] Add status for all clauses - Cil [2009/10/08] Extend logic pretty printer to handle all specific clauses -! GUI [2009/10/08] Extend type Pretty_source.localizable o! Cil [2009/09/28] pAssigns now prints directly a whole list of assigns - GUI [2009/09/28] Assigns clauses are now localizable in GUI - Value [2009/09/25] Improved treatment of "assigns p[..]" clauses in -input ###################################### Open Source Release Beryllium-20090902 ###################################### -* Obfuscator [2009/09/23] obfuscator does not lose links between logic and C variables anymore (bts #250). Obfuscator now gives a specific name to formal parameters. - Journal [2009/09/23] Better handling of exceptions. -! Value [2009/09/21] Computed values not displayed on -load. Use -val -load to force display of computed values. Use -val -quiet to compute without printing results. o Cil [2009/09/21] New pIdentifiedPredicate method in pretty-printer -* GUI [2009/09/21] Elimination of repeated messages (bts #237). -! Syntactic callgraph [2009/09/18] Improvement of the GUI of syntactic callgraph. Require ocamlgraph > 1.2. - Kernel [2009/09/18] Slightly less false alarms with -warn-unspecified-order o Cil [2009/09/18] Deprecated Cil.get_status. Use Db.Properties.Status.* instead. o* Makefile [2009/09/18] Fixed bugs with the use of PLUGIN_EXTRA_BYTE and PLUGIN_EXTRA_OPT by plug-ins. - Value [2009/09/15] Stopped displaying temporary variables introduced by normalization of source code, and block-local variables. -!* Makefile [2009/09/14] Fixed bug #236. Require ocamlgraph version > 1.2. - Configure [2009/09/13] Detection of dot if required. - Syntactic_callgraph [2009/09/11] Better implementation for computing the service graph: faster + correctly handle cycles. -! Syntactic_callgraph [2009/09/11] -cg-services-only is not relevant anymore. - Makefile [2009/09/09] Now possible to build custom binaries for plug-ins. Roughly these binaries are frama-c[.byte] + the plug-in statically-linked. The goal is called "static" in the plug-in's makefile. -* Value [2009/09/08] Fixed display bug when logging the call stack introduced in Beryllium. - Value [2009/09/08] Improved treatment of "assigns p[..]" clauses in value analysis. Other plug-ins (outputs,...) have not had the same improvement yet. -* Makefile [2009/09/08] Frama-C compiles even if ocamlopt is not available. -* Project [2009/09/08] Fixed bug involving loading and options previously set while saving. -* GUI [2009/09/08] Release the terminal when the splash window is deleted. - Jessie [2009/09/08] Is no longer built within Frama-C. It becomes part of Why. - Makefile [2009/09/08] Why is no longer a compilation dependency. It is required only at runtime for the experimental WP plugin. -* Makefile [2009/09/07] Fixed compilation error occuring on a platform which does not support native dynlink and with ocaml >= 3.11 (bts #224). ###################################### Open Source Release Beryllium-20090901 ###################################### -! Syntactic_callgraph [2009/08/27] New design of the callgraph in the GUI. Frama-C now requires ocamlgraph 1.2. - Logic "reads" clauses on logic functions and predicates, which disappeared with the introduction of axiomatic blocks, have been resurected. Beware that the semantics is slightly different from before: see ACSL document for details. It is used to automatically generate footprint axioms. - GUI [2009/08/18] Improved display of summary information when selecting a file. - Kernel [2009/08/05] New options -kernel-help, -kernel-verbose and -kernel-debug (bts #!205). - Syntactic_callgraph [2009/08/04] New option -cg-services-only to only computes the graph of services - Value [2009/07/29] Improved treatment of conditions involving char or short variables. - GUI [2009/07/28] Possible to stop the GUI while computing analysis o! Project [2009/07/26] Preliminary support for direct unmarshalling. Datatypes must define value descr. Using Unmarshal.Direct is okay for now. -* Makefile [2009/07/24] Fixed bug with static linking of plug-ins using external libraries (bts #200) - Value [2009/07/22] Improved integer division. Now returns best effort results when 0 is among the possible values for the divisor. -* Project [2009/07] Fixed bug causing delays with -load (bts #180) - GUI [2009/07/08] New message panel -* Journal [2009/07/07] Fix generation of invalid variable name in journal -* Semantic Constant Folding [2009/07/07] Fix bad journalisation - GUI [2009/07/03] Redesign the dialog box for running analysis o! Cil [2009/06/24] Added 2 components to Cil_types.typ to optimize bitsSizeOf. The proper way to get a default value is Cil.empty_size_cache. The added value must not be shared by types. No one should need to read this value directly. - GUI [2009/06/24] Graphical customization now uses Gtk rc files. A default file is loaded from FRAMAC_SHARE/frama-c.rc. The end user can provide its custom FRAMAC_SHARE/frama-c-user.rc to override defaults. -* Project [2009/06/24] Fixed bug with save/load in multi-project contexts (bts #!161) -* Kernel [2009/06/24] Restore compatibility with ocaml 3.10.2 -* Configure [2009/06/24] Fixed bug with --disable-gui in configure.in ###################################### Open Source Release Beryllium-20090601 ###################################### o Value [2009/06/23] New constructor Signed_overflow_alarm for type Alarms.t -! Jessie [2009/06/23] Option for launching jessie is now -jessie, not -jessie-analysis -* Jessie [2009/06/23] Fixed contract for strchr() and strrchr() in string.h -* Jessie [2009/06/23] Support for label Post in assigns clauses. Fixes bug #160 -! Jessie [2009/06/18] GUI mode is now the default, options -jessie-gui and -jessie-goals do not exists anymore -* Jessie [2009/06/18] Full support for loop assigns, including those implictly generated from function's assigns, fixes bug #41 - GUI [2009/06/18] Change the warning to panel to preserve decent performance. This imposes lablgtk 2.12 at least. - Semantic_callgraph [2009/06/15] small change in the computation of services: the roots are now the same as the syntactic callgraph (while there is no function pointer). -! Semantic_callgraph [2009/06/15] new options -scg-dump and -scg-init-func consistent with the options -cg-dump and -cg-init-func of the syntactic callgraph. o Users [2009/06/15] Users are now computed on need while calling !Db.Users.get - Journal [2009/06/15] Journal disabled by default in batch mode -! Kernel [2009/06/10] FRAMAC_DYN_PATH is now called FRAMAC_PLUGIN -* GUI [2009/06/10] Changes having to do with dependencies between computations. Hopefully less problems exist now than before. -* Jessie [2009/06/09] Support for loop assigns, partially fixes bug #41 see tests/jessie/bts0041-bis.c for details o! Kernel [2009/06/09] Db.Main.extend is now of type unit -> unit - Kernel [2009/06/08] By default, Frama-C stops on annotation errors. Option -continue-annotation-error o GUI [2009/06/05] The plug-in GUI is now packed with the core plug-in -* Jessie [2009/06/05] Fix bug #!8, compilation of jessie with Apron -* Configure [2009/06/05] Fixed issues in configure and makefile if lablgtk2 is not enabled. o! Kernel [2009/06/03] Moved lightweigth annotation support from Jessie to Kernel. They are now available for all plugins. Support for lightweight global invariants on globals has been dropped. -* Project [2009/06/03] Fixed bug #!113: loading a session containing a project p referring to another project generated a new incorrect project p. o! Project [2009/06/03] Remove functions Project.save and Project.load: cannot ensure their correctness. - Kernel [2009/05/29] New options -no-type and -no-obj - Kernel [2009/05/29] New environment variable FRAMAC_LIB - Kernel [2009/05/29] When loading a module via -load-module, the dynamically registered options are now recognized on the command line. - Kernel [2009/05/29] New option -load-script to dynamically compile and load an ocaml script. -! Journal [2009/05/29] Option -journal-loader-run does not exist anymore. Use -load-module instead. o! Logic [2009/05/29] Tresult has a type attached to it -* Jessie [2009/05/22] fixed bugs #!63 and #71 (labels and \at) - Slicing [2009/05/20] New option "-slicing-keep-annotations" o Pdg [2009/05/20] The functions that return nodes from an annotations now also return a list of the variables declarations nodes. - Kernel [2009/05/18] Each boolean option now has an opposite. - Kernel [2009/05/15] New alias "-h" and "--help" for "-help" (bug #61). o Kernel [2009/05/15] Possibility to define alias for options. - Kernel [2009/05/14] Better message for errors on the command line. - Kernel [2009/05/14] Syntax "-option-name=value" is now valid on the command line. In such a case, [value] may begin by '-', which is forbidden for the usual syntax "-option-name value". -* Value [2009/05/11] Fixed bug with the interpretation of "==>". - Value [2009/05/04] Improved reduction for (ptr-ptr) expressions. - Value [2009/04/28] Trivially redundant alarms are now automatically discharged. - Value [2009/04/28] Improved results for char ones[] = "11111111"; col_ones = 1 + * (int*) ones; o Configure [2009/04/21] Explicitly require >= OCaml 3.10.0 -! Inout [2009/04/17] -input_with_formals is now called -input-with-formals -! Kernel [2009/04/15] New implementation of command line parsing -* Kernel [2009/04/08] Frama-C has now a very early initialisation step. That's fixed minor issues with -journal-disable (bts #!14 and #!16). o! Kernel [2009/04/07] Cil_state is now called Ast and Cil_state.file is now called Ast.get. -* Sparecode [2009/04/07] Selected an annotation attached to a function call made a wrong propagation in the visibility of the call (bts #!3). -* Sparecode [2009/04/07] The generated project lost some useful parameters like the entry point (bts #!10). o Makefile [2009/04/03] Independent Makefile for dynamic plug-ins. - Configure [2009/04/01] Auto-detection of lablgtk2's custom tree model. -* Configure [2009/04/01] Fixed bug with --disable-* options (except when '*' was a plug-in name). - Logic [2009/03/27] Overloaded logic symbols. -* Jessie [2009/03/27] proper message when \lambda is encountered (bts #?7528). - Configure [2009/03/27] better message when a plug-in isn't enable by default. -* Syntactic_callgraph [2009/03/26] Fixed bug when the callgraph is computed twice -* Logic [2009/03/24] Fixed bugs in type unification. -* Value [2009/03/23] Fixed bug that could appear with assignments like t[5] = t[4]; where t[4] is not a singleton. o* Makefile [2009/03/20] Fixed "dist" and "bdist" targets that had been broken on 02/27. -* Value [2009/03/20] Fixed performance bug. - GUI [2009/03/20] Environment variables FRAMAC_MONOSPACEFONT and FRAMAC_GENERALFONT. o! Cil [2009/03/19] C expressions now have a unique ID. See frama-c-commits for details. -* From [2009/03/17] Improved dependencies + bug fixes -* GUI [2009/03/17] Fixed bug with some utf8 strings. -* Value [2009/03/13] Fixed correctness bug that had a tiny chance to manifest itself when analyzing code that dereferences casted pointers. -* Logic [2009/03/11] Fixed predicate typing of \pointer_comparable. -* Logic [2009/03/11] Changed \result_finite_float into \is_finite_float. Alarm generation is still untyped. -* Logic [2009/03/11] Allow \ as first letter of identifier. o Makefile [2009/02/27] New implementation of (un)verbose mode (bts #?442). -* Value [2009/02/24] Miscellaneous fixes and tuning. -* Cil [2009/02/23] Keep track of variables that have block scope (bts #?218) uninitialize them at the exit of corresponding block. - InOut [2009/02/18] Add -out-external option. -* Cil [2009/02/18] Fixed some localization problems with frontc visitor. o! Logic [2009/02/13] Merge terms and tsets in the AST. - Value [2009/02/09] Adjustments in the appearance of some alarms -* Cil [2009/02/03] Fixed parsing of global initializers like "(3>0)?0:1" when Cil.lowerConstants is false. o GUI [2009/01/29] Add function Design.main_window_extension_points#help_message. o! Kernel [2009/01/28] Dynamic plug-ins have to take care about journalisation. o! Kernel [2009/01/26] Type of Db.register changed in order to be able to say that a function call must never be written in the journal. - Journal [2009/01/23] Operations on projects (bts #?436) and code outputs are journalised. o! Kernel [2009/01/23] File.pretty does not take anymore a formatter as argument. The default output is the one specified by option -ocode. - Journal [2009/01/23] Journalisation of functions with labels is now possible (bts #?427). - Journal [2009/01/21] Journalisation of plug-ins slicing, sparecode, impact and security done. - Value [2009/01/20] Minor changes in floating-point handling. -* Journal [2009/01/19] Fixed bug with -disable-journal and type with no pretty-printer. - Configure [2009/01/19] New option -with-all-static in order to statically link all plug-ins, except those explicitly specified as dynamic (bts #?430). -* Journal [2009/01/19] Fixed bug in journalisation of non-functional values. -* Makefile [2009/01/19] Fixed bug whenever all plug-ins should be static. -* Makefile [2009/01/19] Fixed bug in compilation of dynamic plug-ins with a GUI. -* Logic [2009/01/09] Fixed bug in type-checking of polymorphic functions. - Logic [2009/01/09] Support for concrete type definition. - Aorai [2009/01/08] Aorai is now a dynamic plug-in. - Jessie [2009/01/08] Jessie is now a dynamic plug-in (bts #?419). - Configure [2009/01/08] For each dynamic plug-in P, a new option --with-P-static is added to configure.in for linking P statically with Frama-C. o Configure [2009/01/08] No longer require to modify the end of configure.in when you add a new plug-in. o Kernel [2009/01/06] Dynamic plug-ins can now register their own types (abstract from the outside) and operations on such types (bts #?413). o! Kernel [2009/01/05] Some changes in API of module Type (bts #?410). In particular: 1) module FunTbl no longer exist. Replaced by Type.Tbl 2) Merge of pretty printer registration with type registration. No more in module Journal. Only in module Type. -* GUI [2008/12/22] Reentrancy fix with left panels. -* Impact [2008/12/22] In the GUI, fixed bug while the analysis raised an exception. It is now properly catched and displayed on stderr. - Impact [2008/12/22] In the GUI, highlight the selected statement in cyan. -! Impact [2008/12/22] Do not select anymore the selected statements except if they are effectively impacted themselves (bts #?411). -! GUI [2008/12/21] Code annotation and all globals are now reactive to selections (bts #?359 and #?387). -* Jessie [2008/12/20] Support constant sizeof and alignof in logic terms (bts #?396). -* GUI [2008/12/20] Fix a bug with broken UTF-8 output on stdout (bts #?420). - GUI [2008/12/20] Add 2 separate pages for stdout and stderr redirections . - Syntactic_callgraph [2008/12/20] Separate services are now created for callees of the entry point. - Impact [2008/12/19] Slicing after impact is now possible (bts #?301). -* Impact [2008/12/19] Bug fixed in the GUI (on project switching). - Value [2008/12/18] Improved support for state reduction on a memory read. #################################### Open Source Release Lithium-20081201 #################################### -! GUI [2008/12/09] Improved consistency of some information messages. - Value [2008/12/09] Abstract structs are now supported in conjunction with option -lib-entry, and invalid to access. -! Value [2008/12/09] Removed outdated warning about uninitialized const variables. o! Cil [2008/12/09] Modified typeForInsertedCast hook to take as arguments the expression and its original type in addition to the destination type. o* Makefile [2008/12/02] Fixed various bugs in Makefile.template. - Logic [2008/11/24] Added support for (wide) string constants in ACSL formula. -! Kernel [2008/11/21] Changed the definition of non-determinist functions in builtin.c. These functions no longer rely on a volatile variable. Analysis logs may change slightly as a result. - Value [2008/11/21] Introduced preliminary support for state reductions on a memory read access. This should eliminate some redundant alarms. - Sparecode [2008/11/20] New option -rm-unused-globals to remove unused global variables and types. -! Slicing [2008/11/20] Unused global variables and types are now removed in sparecode analysis and slicing results. o Cil [2008/11/17] New methods current_function and current_kf methods (bts #?406). o! Cil [2008/11/17] enum items now have their own type and are shared between declaration and use. o Cil [2008/11/17] New methods for visiting compinfo, enuminfo, fieldinfo and enumitem (prevents potential misuse of copy visitor for these types). -* Jessie [2008/11/14] Fixed bug with multiple labels in axiomatic definitions. - Jessie [2008/11/14] Added example tests/jessie/minimum_sort.c in Jessie tutorial. -* Jessie [2008/11/10] Fixed problem with array in logical annotations. -* Jessie [2008/11/05] Fixed problem with memory model preventing the proof of some pointer programs. The solution is to require pointers that are compared to belong to the same allocated memory block, which can be expressed in logical annotations using equality of \base_addr constructs. - Impact [2008/11/04] In the GUI, new panel to manage impact analysis actions. o Makefile [2008/11/03] Support for native compilation in Makefile.template (require ocaml >= 3.11). #################################### Open Source Release Lithium-20081002 #################################### -! Value [2008/10/23] Changed behavior of option -context-valid-pointers to make it more like the documentation says it is. -* Value [2008/10/23] Fixed a bug introduced with the "value concatenation" feature where an imprecise value obtained by reading misaligned data would have the origin "Arithmetic" instead of "Misaligned". -* Value [2008/10/14] Fixed huge bug in the computation of the dependencies of an expression. Differences are most visible in the results of options -input and -deps, and of course all she slicing options that make use of these. o! Value [2008/10/14] Removed argument ~skip_base_deps from all functions in Db.Value that had one. This argument did not make sense. - Slicing [2008/10/07] In the GUI, slicing request related to values returned by functions is available from the contextual submenu. - Slicing [2008/10/07] In the GUI, new panel to manage slicing actions. - Semantic_callgraph [2008/09/24] New option -scg-dump to dump a semantic callgraph to stdout. - Logic [2008/09/23] Support for address-of operator (&) in tsets. - Logic [2008/09/18] Basic support for sets as first-class value. - Kernel [2008/09/15] Added option -warn-unspecified-order to display a warning for each unspecified sequence containing writes. o Ptests [2008/09/11] Added config option STDOPT (see developer's manual for details). o! Kernel [2008/09/11] Refined UnspecifiedSequence information. -! Value [2008/09/11] Raise alarm for undefined behavior caused by side-effects in UnspecifiedSequence (except for function calls). - Value [2008/09/11] Added option -no-unspecified-access to disable alarm above. - Logic [2008/09/04] Support for \separated. - Inout [2008/09/04] New option -input_with_formals. - Journal [2008/08/28] New options available -load-journal, -journal-name, -journal-disable for user management of journals. - Journal [2008/08/22] Journalization available (only Cmdline and Occurrence are done yet). -* Logic [2008/08/21] Fixed typing error of pointer lval hidden by typdefs. - Deps [2008/08/01] In the GUI, the "Dependencies" contextual menu provides the old "Scope" and "Show Def" features in addition to the new "Zones" feature. These three actions can be launch together with the "All" button. - Slicing [2008/07/22] In the GUI, implemented feature request related to highlighting when the source function is called, for CAT/AF evaluation. - Project [2008/07/21] Projectification of machdep (bts #?101). -* Logic [2008/07/21] Fixed bug "0 can be seen as pointer to any type" (bts #?338). -* Pdg [2008/07/21] Fixed bugs for CAT/AF evaluation. - GUI [2008/07/18] Lower the bound on maximum number of displayed globals to 20 (bts #?342). - Slicing [2008/07/18] In the GUI, request related to read/write accesses to lvalues is available from the contextual submenu. -* Slicing [2008/07/18] In the GUI, fixed bugs related to enabling/disabling conditions of the slicing submenu. - Kernel [2008/07/17] Dynamic linking of plugin available (experimental). o! Cil [2008/07/17] AST changes for unspecified sequences (experimental). -* Jessie [2008/07/16] Fixed path problems with binary distributions. ################################### Open Source Release Helium-20080701 ################################### - Occurrence [2008/07/11] Occurrences of a variable can be computed from any occurrence of the program (not only from its declaration). - Project [2008/07/11] Loading works even if the configuration while saving is not exactly equal to the one while loading. - Pdg [2008/07/09] Improvement of the precision of interprocedural analysis (bts #?179). -* Impact [2008/07/02] Fixed bug when a function is undefined (bts #?322). - Logic [2008/07/02] Typing of recursive logic functions. - Logic [2008/07/02] Enforce correct return type of logic functions. - Sparecode [2008/07/01] New option -sparecode-no-annot (bts #?331 and #?334). -* Pdg [2008/06/26] Fixed bug in interprocedural analysis (bts #?324). - Slicing [2008/06/24] In the GUI, slicing contextual submenu available. -! Logic [2008/06/24] Merge predicates and logic functions when linking multiple c files. o! Logic [2008/06/24] AST changes for invariants. -! GUI [2008/06/23] Enforce lablgtksourceview dependency and suppressed camlp4 need. - GUI [2008/06/23] First rehighlight support. - Slicing [2008/06/19] Some slicing requests are available from the GUI. - Configure [2008/06/19] ./configure will not emit so many warning when gui is not available (bts #?296). - GUI [2008/06/18] Invalidate display cache on project switching. -! Value [2008/06/18] Do not emit imprecision tracing warning when a lval=lval is optimized. - Value [2008/06/18] New option -context-width for auto-allocated context pointer width. Defaults to 2. - Makefile [2008/06/17] Prefix install directories by the value of DESTDIR (patch contributed by Igor Galic). -! Logic [2008/06/17] \valid* predicates rejects void pointers. -! Value [2008/06/16] Removed last top from merging leaf functions returns. - Value [2008/06/13] Some partial builtin_va_start support - Value [2008/06/13] New implicit context generation with a fixed width of 6 (an option will be available later). -! Value [2008/06/12] Remove remaining TOP in value analysis: WELL at amx-valid-depth and for leaf functions. - GUI [2008/06/10] Improve speed of configuration menu. -! Kernel [2008/06/10] Change -lib-entry option into a boolean. "-lib-entry foo" becomes "-lib-entry -main foo" - Metrics [2008/06/10] Number of syntactic calls by functions and potential entry points. - Metrics [2008/06/10] New option -metrics-dump. -! Constfold [2008/06/09] Semantic constant folding does not introduce casts by default. - Constfold [2008/06/09] New option -cast-from-constant has been added to allows cast introductions. -! Kernel [2008/06/06] Do not remove unused static functions. -! Logic [2008/06/05] Quantification over arrays are interpreted as quantification over pointers to be consistent with predicates and C function calls. - Logic [2008/06/05] Pretty printing of pointer accesses in terms and tsets are now much nicer. For example *(T+(0+i..j)) becomes T[0+i..j]. -! Value [2008/06/05] Separate warnings for uninitialized and addresses escaping their scopes (these used to be grouped together as "unspecified" alarms) -* Makefile [2008/06/04] Fixed bug in "make distclean" (bts #?308). -* Logic [2008/06/03] Correct typing for predicates: no more dangerous promotions. - Logic [2008/06/03] Typing of terms: implement ACSL semantics for integral/real promotions. - Logic [2008/06/03] Better error messages for logic typing errors. -! Logic [2008/06/03] Support for constant predicates and functions (breaks 0-argument old syntax). -* Kernel [2008/06/03] Correct promotion rules from bitfields to integers. -* Kernel [2008/06/02] -machdep was ignored (bts #?309). ##################################### Open Source Release Hydrogen-20080502 ##################################### o* Makefile [2008/05/21] Fixed bug in "make clean-doc" (and "make distclean"). - GUI [2008/05/19] All internal options are available in the GUI preferences pannel. ##################################### Open Source Release Hydrogen-20080501 ##################################### -! Value [2008/04/24] Display a warning whenever an unitialized value causes the death of a branch. - GUI [2008/04/18] Project names are pairwise different in the GUI. -* GUI [2008/04/17] Win32 default fonts fixed. - Value [2008/04/14] In the GUI, function level information displayed in Information panel. - GUI [2008/04/14] Progress added in existing plugins. - GUI [2008/04/10] Buffer memoization for speedup. - GUI [2008/04/10] Persistent position. - GUI [2008/04/10] No file selection on startup. - Scope [2008/04/09] First release of the plug-in (bts #?191). - Impact [2008/04/08] Available from toplevel through -impact-pragma and -impact-print. o Project [2008/04/08] Warnings are project compliant. - GUI [2008/04/07] Large improvements in reactivity -* GUI [2008/04/07] Prefs/Execute bugs fixed. o GUI [2008/04/07] Project management redesigned for older Gtk and for the best. -* Project [2008/04/07] Fixed bug in save/load with duplicated computations. -* Project [2008/04/07] Inconsistent data with multiple projects and while removing projects. -* Kernel [2008/04/01] Various Win32 path fixes. - Kernel [2008/04/01] Option -no-unicode : do not print Unicode chars. ################################ Binary Release Hydrogen-20080302 ################################ - Occurrence [2008/03/17] New option -occurrence. - Occurrence [2008/03/17] First release of the plug-in. -* GUI [2008/03/16] GUI no longer frozen during computations. - GUI [2008/03/16] 'New' menu entry. -* Makefile [2008/03/14] Fixed bug with GUI compilation. -* Project [2008/03/14] Fixed bug with checksum computation during save/load. -* Slicing [2008/02/25] Fixed bug in interprocedural slicing (bts #?201). ########################################### First Open Source Release Hydrogen-20080301 ########################################### - First release ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/��������������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634040�015137� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/libc/���������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016053� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/libc/oracle/��������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017320� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/libc/string.c�������������������������������������������������������0000644�0001750�0001750�00000000435�12155630325�017526� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#include <string.h> void test_strcmp(void) { int res = strcmp("hello", "world"); //@ assert res == 0; } void test_strcat(void) { char string[10]; string[0] = 0; strcat(string, "hello"); } int main(int argc, char **argv) { test_strcmp(); test_strcat(); return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/libc/socket.c�������������������������������������������������������0000644�0001750�0001750�00000005417�12155630325�017515� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-val-builtin memset:Frama_C_memset" STDOPT: +"-val-builtin memset:Frama_C_memset -cpp-extra-args='-D__FRAMA_C_MACHDEP_X86_64'" */ #include <sys/types.h> #include <sys/socket.h> #include <stdio.h> #include <stdlib.h> #include <unistd.h> #include <string.h> #include <sys/uio.h> const char* sent_msg = "World"; #define SIZEOF_SENT_MSG 6 // char send_buffer[SIZEOF_SEND_BUFFER]; /* Contiguous receive buffer. */ #define SIZEOF_RCV_BUFFER 10 char rcv_buffer[SIZEOF_RCV_BUFFER]; /* Scattered receive buffer. Initialized locally so that it is UNINITIALIZED. */ #define DECLARE_SCATTERED_RECEIVE_BUFFER \ char rcv_buffer_scattered1[2]; \ char rcv_buffer_scattered2[5]; \ char rcv_buffer_scattered3[3]; \ const struct iovec rcv_buffer_scattered_iovec[3] = \ {{ &rcv_buffer_scattered1, sizeof(rcv_buffer_scattered1)}, \ { &rcv_buffer_scattered2, sizeof(rcv_buffer_scattered2)}, \ { &rcv_buffer_scattered3, sizeof(rcv_buffer_scattered3)}} int socket_fd[2]; /* In this test, we always send to the same socket and receive through the other. */ #define send_socket socket_fd[0] #define rcv_socket socket_fd[1] /* Clears rcv_buffers and writes data to send_socket. */ void init_reception(void) { memset( rcv_buffer, 0, SIZEOF_RCV_BUFFER); write( send_socket, sent_msg, SIZEOF_SENT_MSG); } void init_sockets(void) { /* Creates a pair of local sockets. */ if( socketpair(AF_LOCAL,SOCK_SEQPACKET,0,socket_fd) != 0) { fprintf( stderr, "Could not create a pair of sockets\n"); exit( EXIT_FAILURE); } //@ assert \initialized(&socket_fd[0..1]); } void test_read(void) { init_reception(); read( rcv_socket, rcv_buffer, SIZEOF_RCV_BUFFER); printf("Hello %s\n", rcv_buffer); } void test_readv(void) { DECLARE_SCATTERED_RECEIVE_BUFFER; init_reception(); readv( rcv_socket, rcv_buffer_scattered_iovec, 3); rcv_buffer_scattered1[0] == 0; /* Reduce to bottom if rcv_buffer_scattered1 is not initialized. */ /* @assert \true; */ printf( "Hello %.2s%.3s\n", rcv_buffer_scattered1, rcv_buffer_scattered2); } void test_recvmsg(void) { DECLARE_SCATTERED_RECEIVE_BUFFER; init_reception(); struct msghdr hdr; hdr.msg_name = NULL; hdr.msg_namelen = 0; hdr.msg_iov = rcv_buffer_scattered_iovec; hdr.msg_iovlen = 3; hdr.msg_control = NULL; hdr.msg_controllen = 0; recvmsg( rcv_socket, &hdr, 0); rcv_buffer_scattered1[0] == 0; /* Reduce to bottom if rcv_buffer_scattered1 is not initialized. */ /* @assert \true; */ printf( "Hello %.2s%.3s\n", rcv_buffer_scattered1, rcv_buffer_scattered2); } int main(int argc, char **argv) { init_sockets(); test_read(); test_readv(); test_recvmsg(); return 0; } /* Local Variables: compile-command: "cd ../.. && ptests.byte -show -config gcc tests/libc/socket.c" End: */ �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/libc/result/��������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017371� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/libc/time.c���������������������������������������������������������0000644�0001750�0001750�00000000577�12155630325�017165� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#include <sys/time.h> void test_gettimeofday(void) { struct timeval tv; gettimeofday(&tv, (void *) 0); /*@ assert( \initialized( &tv.tv_sec)); */ /*@ assert( \initialized( &tv.tv_usec)); */ } int main(int argc, char **argv) { test_gettimeofday(); return 0; } /* Local Variables: compile-command: "cd ../.. && ptests.byte -show -config gcc tests/libc/time.c" End: */ ���������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/��������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016247� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/oracle/�������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017514� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/cte_overflow.i������������������������������������������������0000644�0001750�0001750�00000000447�12155630324�021122� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-warn-decimal-float all" */ int volatile v; int main() { double t=0.0; if (v) { t = 1e500 * 1e500; Frama_C_dump_each(); // does not execute } if (v) { t = 1e80f * 1e500f; Frama_C_dump_each(); // does not execute } return 0; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/some.c��������������������������������������������������������0000644�0001750�0001750�00000000752�12155630324�017360� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -val-show-slevel 10 -slevel 100 -val -cpp-command "gcc -C -E -DFLOAT=double -DN=55 -I. " -float-normal -journal-disable -no-results OPT: -memory-footprint 1 -slevel 100 -val -cpp-command "gcc -C -E -DFLOAT=float -DN=26 -I. " -float-normal -journal-disable -no-results */ FLOAT t[N] = { 1. } ; FLOAT y = 0.5; main(){ int i; for (i=1 ; i<N; i++) { t[i] = t[i-1] + y; y = y / 2.; } Frama_C_dump_each(); return i; } ����������������������frama-c-Fluorine-20130601/tests/float/nonlin.c������������������������������������������������������0000644�0001750�0001750�00000003553�12155630324�017714� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -slevel 30 -val -cpp-command "gcc -C -E -DFLOAT=double -I. " share/builtin.c -float-hex -journal-disable -subdivide-float-var 0 OPT: -memory-footprint 1 -slevel 30 -val -cpp-command "gcc -C -E -DFLOAT=double -I. " share/builtin.c -float-hex -journal-disable -subdivide-float-var 10 OPT: -memory-footprint 1 -slevel 30 -val -cpp-command "gcc -C -E -DFLOAT=float -I. " share/builtin.c -float-hex -journal-disable -subdivide-float-var 0 OPT: -memory-footprint 1 -slevel 30 -val -cpp-command "gcc -C -E -DFLOAT=float -I. " share/builtin.c -float-hex -journal-disable -subdivide-float-var 10 */ #include "share/builtin.h" FLOAT a, b, c, r1, r2, d, i, s, zf, s2, sq, h; int t[10]={1,2,3,4,5,6,7,8,9,10},r,z; void nonlin_f() { a = Frama_C_float_interval(5.0, 7.0); b = Frama_C_float_interval(0.0, 1.0); c = 7.0; d = a; /*@ assert (5.0 <= d) ; */ r1 = a + (b * (c - a)); /*@ assert (5.0 <= a <= 5.125) || (5.125 <= a <= 5.25) || (5.25 <= a <= 5.375) || (5.375 <= a <= 5.5) || (5.5 <= a <= 5.625) || (5.625 <= a <= 5.75) || (5.75 <= a <= 5.875) || (5.875 <= a <= 6.0) || (6.0 <= a <= 6.125) || (6.125 <= a <= 6.25) || (6.25 <= a <= 6.375) || (6.375 <= a <= 6.5) || (6.5 <= a <= 6.625) || (6.625 <= a <= 6.75) || (6.75 <= a <= 6.875) || (6.875 <= a <= 7.0) ; */ r2 = a + (b * (c - a)); Frama_C_show_each_a_r2("a", a, "r2", r2); } unsigned long rbits1; int rbits2; int access_bits(FLOAT X ) { unsigned long x0; x0 = *((unsigned long *)(& X)); if (x0 > 2UL) return 1; rbits1 = x0; return 0; } main() { nonlin_f(); i = Frama_C_float_interval(-133.0,142.0); s = Frama_C_float_interval(-133.0,142.0); r = 1 + t[(int)(i*i+2.0)]; z = (int)(10000.0 * (s - s)); zf = s - s; s2 = s + s; sq = s * s; h = s * (1 - s); rbits2 = access_bits(i); } �����������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/alarms.i������������������������������������������������������0000644�0001750�0001750�00000000564�12155630324�017703� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������union { long long l ; float f ; double d ; } u1, u2; float f; double d, big; unsigned long long ull; double fd(); main (long long l){ u1.l = l; f = u1.f + 1.0; u2.l = l; d = u2.d + 1.0; Frama_C_dump_each(); float vf = fd(); double vd = fd(); long long i = vd; long long j = vf; vd = fd(); double mvd = -vd / 4.; big = 0x1.8p63; ull = big; } ��������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/dr_infinity.i�������������������������������������������������0000644�0001750�0001750�00000000307�12155630324�020735� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-warn-decimal-float all" +"-float-hex" */ void main(void) { float x, y; x = 3.4028235677973366e+38f; Frama_C_show_each(x); y = (float) 3.402823567797366e+38; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/absorb.c������������������������������������������������������0000644�0001750�0001750�00000002112�12155630324�017655� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: BIN absorb.sav LOG absorb_sav.res LOG absorb_sav.err FRAMAC_PLUGIN=tests/.empty @frama-c@ -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 FRAMAC_PLUGIN=tests/.empty @frama-c@ -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, min_f, min_fl, den; void main() { long long b = Frama_C_interval(-2000000001, 2000000001); b = b * b; z = y + 1e-286; while (y != x) { y = x ; x+=1E-286; } t = b; min_f = 1.175494351e-38; min_fl = -1.1754943505e-38; den = min_f / 128.; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/round10d.i����������������������������������������������������0000644�0001750�0001750�00000000647�12155630324�020062� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -val -float-normal -journal-disable -no-results OPT: -memory-footprint 1 -val -float-normal -all-rounding-modes -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; } �����������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/cond.c��������������������������������������������������������0000644�0001750�0001750�00000001011�12155630324�017325� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -val -cpp-command "gcc -C -E -I. " share/builtin.c -journal-disable -float-hex */ #include "share/builtin.h" float x, y, z; double dx, dy, dz, dt; int c1,c2; void main(int c) { x = Frama_C_float_interval(-10.0, 10.0); x = x >= 0.0 ? x : 0.0; dx = Frama_C_float_interval(-10.0, 10.0); dx = dx >= 0.0 ? dx : 0.0; c1 = dx >= 0; /*@ assert ! (0. <= dx <= 1.) ; */ dz = Frama_C_float_interval(-10.0, 10.0); dt = dz < 1.0 ? dz : 0.0; dz = dz > 1.0 ? dz : 2.0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/result/�������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017565� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/parse.i�������������������������������������������������������0000644�0001750�0001750�00000001136�12155630324�017532� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-warn-decimal-float all" +"-float-hex" */ volatile v; int main() { if (v) { double d = 0.0E9999999999999999999; Frama_C_show_each(d, "reached"); } if (v) { double d = 0.0E-9999999999999999999; Frama_C_show_each(d, "reached"); } if (v) { double d1 = 0e500; double d2 = 0.0e500; Frama_C_show_each(d1, d2, "reached"); } if (v) { double d = 0.00000000000000000000000000000000000000001e310; Frama_C_show_each(d, "reached"); } if (v) { double d = 0.0000001E9999999999999999999; Frama_C_show_each("unreached"); } } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/uninit.i������������������������������������������������������0000644�0001750�0001750�00000000054�12155630324�017724� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ main(int c){ float f; if (c) f++; }������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/precise_cos_sin.i���������������������������������������������0000644�0001750�0001750�00000000736�12155630324�021574� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } } ����������������������������������frama-c-Fluorine-20130601/tests/float/init_float.i��������������������������������������������������0000644�0001750�0001750�00000001502�12155630324�020545� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; double Ha[5], THa[5]; /*@ requires -1000.0 <= x <= 1000.0; requires 0.0 <= s.y <= 0.0; */ int main(float x) { Ha[2] = 0.5; Ha[3] = 0x0.8000000000001p0; Ha[4] = 0x0.8000000000002p0; Ha[1] = 0x0.7ffffffffffffp0; Ha[0] = 0x0.7fffffffffffep0; THa[2] = 1.5; THa[3] = 0x1.8000000000001p0; THa[4] = 0x1.8000000000002p0; THa[1] = 0x1.7ffffffffffffp0; THa[0] = 0x1.7fffffffffffep0; 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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/s.i�����������������������������������������������������������0000644�0001750�0001750�00000030631�12155630324�016664� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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);} } �������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/logic.i�������������������������������������������������������0000644�0001750�0001750�00000000465�12155630324�017521� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-warn-decimal-float all" +"-float-hex" */ volatile v; int main() { if (v) { double d = 0.1; //@ assert !(d == 0.1); } if (v) { double d = 0.1; //@ assert d == 0.1f; } if (v) { float f = 0.1; //@ assert !(f == 0.1); } // assert 0.1 == v; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/float_cast_implicite.i����������������������������������������0000644�0001750�0001750�00000000526�12155630324�022600� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/dr.i����������������������������������������������������������0000644�0001750�0001750�00000001146�12155630324�017026� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-val" STDOPT: +"-val -float-hex" */ float big = 100e30f; float big2 = 100.126E30f; float ne1 = -0.1f, ne2 = -.5f, nodigits = 10.f; float smaller = 1e-99999999999999999999999f; // larger = 1e99999999999999999999999f; causes initial state to bottomify float he = 0X1.8p1f; float g1 = 0.1 ; float f1 = 0.1f, f9 = 0.999999999999999999f, ep = 1.25e+10f; float g2 = 1.01161128282547 ; float f2 = 1.01161128282547f; double d2 = 1.01161128282547 ; int e1, e2; int printf(const char *format, ...); main(){ e1 = f1 == g1; e2 = f2 == g2; printf("%d %d\n", e1, e2); return 0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/const.i�������������������������������������������������������0000644�0001750�0001750�00000004203�12155630324�017544� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/float/extract_bits.i������������������������������������������������0000644�0001750�0001750�00000001074�12155630324�021114� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -slevel 10 -big-ints-hex 0 -machdep ppc_32 -float-normal -warn-decimal-float all OPT: -val -slevel 10 -big-ints-hex 0 -machdep x86_32 -float-normal -warn-decimal-float all */ float f = 3.14; double d = 2.71; double stdtod_bug = 1.8254370818746402660437411213933955878019332885742187; /* http://www.exploringbinary.com/a-bug-in-the-bigcomp-function-of-david-gays-strtod/ */ int fr[4]; int dr[8]; void main() { int i; for (i=0; i<4; i++) fr[i] = ((unsigned char*) &f)[i]; for (i=0; i<8; i++) dr[i] = ((unsigned char*) &d)[i]; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/����������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�015711� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/oracle/���������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017156� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/comments.c������������������������������������������������������0000644�0001750�0001750�00000000223�12155630325�017676� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -print -keep-comments */ /* ABC */ void f() {} //ABD/*FOO*/ /*ABC*/ /*ABC */ /*@ requires \true ; // FOO */ void g() {} �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/branch.c��������������������������������������������������������0000644�0001750�0001750�00000000153�12155630325�017310� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT:-print */ int f(int a,int b) { if (a<b) return a++ ; else return b-- ; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/bts892.i��������������������������������������������������������0000644�0001750�0001750�00000000212�12155630325�017110� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int tab[16]; void* main(void) { int i; static const int* t[] = { &tab[1], &tab[3], &tab[4], &i }; return &t; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/cpu_a.c���������������������������������������������������������0000644�0001750�0001750�00000000176�12155630325�017147� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: tests/cil/cpu_b.c -machdep x86_16 -print */ typedef unsigned short DWORD ; DWORD f(void) { return 0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/bts297.c��������������������������������������������������������0000644�0001750�0001750�00000000241�12155630325�017103� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ /* Doc example 2.45 */ int abrupt (int x) { while (x > 0) /*@ requires \true ; ensures x==3; */ {if (x) x++ ;} } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/bts342.c��������������������������������������������������������0000644�0001750�0001750�00000000277�12155630325�017103� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: invalid C file */ typedef struct { int i1; int i2; } s; /*@ requires @ \valid(x + i) && &x[i]->i1 != 0; @*/ int f (s x[], int i) { return 1 / (&x[i])->i1; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/bts882.i��������������������������������������������������������0000644�0001750�0001750�00000000213�12155630325�017110� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT:-print */ void main () { int r; switch(1) { case 2: r = (int) f(1); break; default: break; } } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/annot.c���������������������������������������������������������0000644�0001750�0001750�00000000235�12155630325�017173� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int fact(int n) { int r = 1 ; while ( n > 0 ) { //@ assert n > 0 ; before: r *= n-- ; //@ assert r == \at(r*n,before) ; } return r ; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/issues.c��������������������������������������������������������0000644�0001750�0001750�00000017130�12155630325�017371� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: some issues with Cil parsing and pretty printing */ #include <stdio.h> /*OK: Unspecified statements */ int main() { struct l { struct l** next; } s[4]; struct l* a; struct l* p[4]; struct l* old; p[0] = s; p[0]->next = &p[0]; old = (*p[0]->next); a = ((*p[0]->next) += 1); if (old + 1 != a) printf("bug!\n"); return 0; } /*OK: Correct switch */ int foo(int i) { switch (i) case 0: case 1: ; return 0; } /*KO: Wrong Order of declaration after pretty printing */ extern int base_files[]; const char *const lang_dir_names[] = { "c" }; int base_files[sizeof (lang_dir_names) / sizeof (lang_dir_names[0])]; /*OK: no visible problem. */ struct record { int references; char buffer[1]; }; typedef struct { char * base; } buffer; int bar(int flags ) { return ((flags & (0x0004)) ? __builtin_offsetof (struct record, buffer[0]) : __builtin_offsetof (struct record, references)); } /*OK: $ in identifiers */ static void foo$bar() { } /*OK: typdef void */ typedef void tVoid; int pimInit(void); int pimInit(tVoid) { return 1; } /*KO: conditional intializers */ #if 0 typedef long int time_t; struct time_t_is_integer { char a[(((time_t) 1.5 == 1)) ? 1 : -1]; }; #endif #if 0 /*KO: complex array size */ int mySize(void) {return 1;} int main1(void) { union { int x; char a[mySize() * 2]; } u; u.a[0]++; return 1; } #endif /*OK: packed attribute prettun printing*/ typedef enum { MFT_RECORD_IN_USE = (0x0001), MFT_RECORD_IS_DIRECTORY = (0x0002), MFT_REC_SPACE_FILLER = 0xffff } __attribute__ ((__packed__)) MFT_RECORD_FLAGS; MFT_RECORD_FLAGS foo1; /*OK: packed attribute parsing */ struct __attribute__ ((__packed__)) s; typedef struct { int x1; short x2; short x3; } __attribute__ ((__packed__)) s; s foo2; /*OK: pretty print an unused label */ void foo3(int z) { int i; for (i=0; i<10; i++) { z++; if (z < 5) continue; else break; } } /*OK: local pragma */ void foo4() { #pragma TCS_atomic printf("hello!"); } /* OK: bitfields */ typedef struct { int free : 1; int counter : 3; } __attribute__ ((packed)) tpsn_node_t; typedef struct { tpsn_node_t tpsn_node[7]; } __attribute__ ((packed)) app_state_t; int foo5() { app_state_t s; s.tpsn_node[0].counter--; return 0; } /*OK: constfold attributes */ struct swsusp_info { unsigned long num_physpages; int cpus; unsigned long image_pages; unsigned long pages; unsigned long size; } __attribute__((aligned((1UL << 12)))); struct swsusp_info foo6; /*OK: attribute on label */ int tcf_exts_dump() { goto rtattr_failure; return 0; rtattr_failure: __attribute__ ((unused)) return -1; } /*OK: Empty attribute */ int strnvis(char *, const char *, size_t, int) __attribute__ (()) {return 1;} /*OK: Compound initializer share statements */ struct bars { int x; }; struct foos { struct bars b; int y; }; int rand(void); void foo7(void) { int t = rand(); struct foos f = { .b = { .x = (t?2:3), }, .y = 42 }; return; } /*OK: Missing cast */ #include <stdio.h> #include <stdlib.h> int foo8(void) { char *p; int i; p = malloc(2*sizeof(int)); *(int *)p = 1; *((int *)p + 1) = 2; i = *((int *)p)++; printf("%d\n", i); i = *((int *)p)++; printf("%d\n", i); return 0; } /*OK: tricky assigns with cast */ typedef struct tTestStructX { int x; } tTestStructX; typedef struct tTestStruct { tTestStructX x; int a; int b; struct tTestStruct* ptr; char c; short int x16; int x32; } tTestStruct; typedef struct tTestStruct2 { tTestStructX x; int a; int b; struct tTestStruct2* ptr; char c; short int x16; int x32; } tTestStruct2; void testaccess2(void) { tTestStruct *p = NULL; int z; tTestStruct t2; tTestStruct *p2 = &t2; p = (tTestStruct *) modMalloc(sizeof(tTestStruct), 0); p->ptr = NULL; (tTestStructX*) p2->ptr = (tTestStructX*) p; } /*OK: typeOf problem */ struct foo10 { int x; }; struct foo10 foof(int y) { return (struct foo10) { y } ; } int goo(int z) { __typeof__(foof(3)) a = foof(3); if (a.x == z) return 1; return 0; } /*OK: complexity problem in conditionals */ extern __attribute__((const, noreturn)) int ____ilog2_NaN(void); int __ilog2_u32(int n); int __ilog2_u64(int n); #define ilog2(n) \ ( \ __builtin_constant_p(n) ? ( \ (n) < 1 ? ____ilog2_NaN() : \ (n) & (1ULL << 63) ? 63 : \ (n) & (1ULL << 62) ? 62 : \ (n) & (1ULL << 61) ? 61 : \ (n) & (1ULL << 60) ? 60 : \ (n) & (1ULL << 59) ? 59 : \ (n) & (1ULL << 58) ? 58 : \ (n) & (1ULL << 57) ? 57 : \ (n) & (1ULL << 56) ? 56 : \ (n) & (1ULL << 55) ? 55 : \ (n) & (1ULL << 54) ? 54 : \ (n) & (1ULL << 53) ? 53 : \ (n) & (1ULL << 52) ? 52 : \ (n) & (1ULL << 51) ? 51 : \ (n) & (1ULL << 50) ? 50 : \ (n) & (1ULL << 49) ? 49 : \ (n) & (1ULL << 48) ? 48 : \ (n) & (1ULL << 47) ? 47 : \ (n) & (1ULL << 46) ? 46 : \ (n) & (1ULL << 45) ? 45 : \ (n) & (1ULL << 44) ? 44 : \ (n) & (1ULL << 43) ? 43 : \ (n) & (1ULL << 42) ? 42 : \ (n) & (1ULL << 41) ? 41 : \ (n) & (1ULL << 40) ? 40 : \ (n) & (1ULL << 39) ? 39 : \ (n) & (1ULL << 38) ? 38 : \ (n) & (1ULL << 37) ? 37 : \ (n) & (1ULL << 36) ? 36 : \ (n) & (1ULL << 35) ? 35 : \ (n) & (1ULL << 34) ? 34 : \ (n) & (1ULL << 33) ? 33 : \ (n) & (1ULL << 32) ? 32 : \ (n) & (1ULL << 31) ? 31 : \ (n) & (1ULL << 30) ? 30 : \ (n) & (1ULL << 29) ? 29 : \ (n) & (1ULL << 28) ? 28 : \ (n) & (1ULL << 27) ? 27 : \ (n) & (1ULL << 26) ? 26 : \ (n) & (1ULL << 25) ? 25 : \ (n) & (1ULL << 24) ? 24 : \ (n) & (1ULL << 23) ? 23 : \ (n) & (1ULL << 22) ? 22 : \ (n) & (1ULL << 21) ? 21 : \ (n) & (1ULL << 20) ? 20 : \ (n) & (1ULL << 19) ? 19 : \ (n) & (1ULL << 18) ? 18 : \ (n) & (1ULL << 17) ? 17 : \ (n) & (1ULL << 16) ? 16 : \ (n) & (1ULL << 15) ? 15 : \ (n) & (1ULL << 14) ? 14 : \ (n) & (1ULL << 13) ? 13 : \ (n) & (1ULL << 12) ? 12 : \ (n) & (1ULL << 11) ? 11 : \ (n) & (1ULL << 10) ? 10 : \ (n) & (1ULL << 9) ? 9 : \ (n) & (1ULL << 8) ? 8 : \ (n) & (1ULL << 7) ? 7 : \ (n) & (1ULL << 6) ? 6 : \ (n) & (1ULL << 5) ? 5 : \ (n) & (1ULL << 4) ? 4 : \ (n) & (1ULL << 3) ? 3 : \ (n) & (1ULL << 2) ? 2 : \ (n) & (1ULL << 1) ? 1 : \ (n) & (1ULL << 0) ? 0 : \ ____ilog2_NaN() \ ) : \ (sizeof(n) <= 4) ? \ __ilog2_u32(n) : \ __ilog2_u64(n) \ ) void foo11(int n) { int x = ilog2(20); } #if 0 /*KO: local struct */ int foo12() { { struct B; struct B { double d; }; { struct B; extern void bar(struct B d); struct B { int k; short h; }; struct B p = { 1, 2}; bar(p); } } return 0; } #endif /*OK: Huge constants */ enum { HUGE_BYTES = (18446744073709551615ULL) == (127 * 2 + 1) }; void foo13() { int x = HUGE_BYTES; } /*OK: permutation of typedefs */ typedef volatile int mytype_t; /* line 1 */ typedef int volatile mytype_t; /* line 2 */ mytype_t my; typedef struct ATTR {int len;} attr; typedef attr *pattr; typedef struct TUPLEDESC {pattr *attrs;} *t; int foo14(t desc) { pattr *att = desc->attrs; return att[0]->len; } /*OK: Large constant */ void foo15 (unsigned long long f); int foo16 (int argc, char **argv) { foo15 (0xFFFFFFFFFFFFFFFFULL); // Should be 16 F's return 0; } void foo17 (unsigned long long f) { } /*KO: duplicate labels */ int foo18(int a) { int x = 0, y = 1; (a ? x : y) = ({ 2; goto l ; l: 3;}); return x; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/merge2.c��������������������������������������������������������0000644�0001750�0001750�00000000075�12155630325�017237� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: tests/cil/merge.c -print */ int x =2; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/cpu_b.c���������������������������������������������������������0000644�0001750�0001750�00000000217�12155630325�017144� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: tests/cil/cpu_a.c -machdep x86_16 -print */ typedef unsigned int DWORD ; DWORD f(void); DWORD g(void) { return f(); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/result/���������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017227� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/empty_cond.c����������������������������������������������������0000644�0001750�0001750�00000000064�12155630325�020215� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int y,z; void main(int x) { if(z++) ; return; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/merge.c���������������������������������������������������������0000644�0001750�0001750�00000000072�12155630325�017152� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: tests/cil/merge2.c -print */ int x; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/duplicate-labels.c����������������������������������������������0000644�0001750�0001750�00000000644�12155630325�021272� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -keep-switch -print -check -journal-disable */ int foo18(int a) { int x = 0, y = 1; x = ({ 3; goto l ; l: 3;}); goto l; return x; } void foo(int z) { int i; for (i=0; i<10; i++) { __Cont: z++; if (z < 5) continue; else goto __Cont; } } void f() { int i = 0; while_1_break: while (i < 10) { ++i; } goto while_1_break; } ��������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/ocaml32bits3_11_0.i���������������������������������������������0000644�0001750�0001750�00000000132�12155630325�021003� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������enum { OK=0x1111EEEEu, KO=0x99996666u, // fixed bug of Ocaml 32bits 3.11.0 } v ; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/overlap.c�������������������������������������������������������0000644�0001750�0001750�00000000414�12155630325�017523� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT:-print */ int main() { int n = 8 ; int z[8] ; for (int i=0;i<n;) { first: z[i++] = z[i++]+(i--) ; last: z[i++] = z[i++]+(i--) ; //@ assert \at( 0<=i<n , first ) ; //@ assert \at( 0<=i<n , last ) ; } return z[n-1]; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/cil/union_to_union.i������������������������������������������������0000644�0001750�0001750�00000000153�12155630325�021123� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������union X { int a; short b; }; int main() { union X u,v; v = (union X) u; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/����������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�015734� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/oracle/���������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017201� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/fptr_assert.c���������������������������������������������������0000644�0001750�0001750�00000000537�12155630273�020442� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -rte-precond -print */ typedef int (*fptr)(int); void g() { return; } int f(int x) { return x; } int h(int x) { return x; } int main (int i) { void (*fp1)(); fptr fp2; fptr ma[2] = { &f, &h }; fp1 = &g; fp2 = &f; (*fp1)(); (*fp2)(3); (*ma[1])(5); (*ma[i])(5); return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/memaccess.c�����������������������������������������������������0000644�0001750�0001750�00000000435�12155630273�020043� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -machdep x86_32 */ int main(int x) { int *p,*q; int tab[10]; *p = 3; q = p; *q = *p + 5; tab[3] = *q; tab[x] = *q; p = &tab[2]; p = &tab[x]; *(p+1) = tab[0]; *(p+1) = tab[x]; *q=p[2]; return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/bts1052.c�������������������������������������������������������0000644�0001750�0001750�00000000350�12155630273�017177� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -rte-precond -print -journal-disable */ /*@ assigns \nothing; ensures \let count = d ; \result ==count; */ int op(int d) ; int x,y; void main () { x = op(33); y = op(31) ; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/sizeof.c��������������������������������������������������������0000644�0001750�0001750�00000000323�12155630273�017376� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -rte-precond */ int main() { int x, y,z ; int *p; int tab[10]; x = sizeof(*p); y = sizeof((double) *p); z = sizeof(tab[3]); return 0; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/twofunc.c�������������������������������������������������������0000644�0001750�0001750�00000000634�12155630273�017571� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/rte/my_annot_proxy/my_annot_proxy.ml */ int f(int x, int y) { if (x + y != 0) { if ((x == 2147483647) && (y == 1)) return -1; else return 0; } else return 1; } int main() { int x =1 , y =2; int i; for (i = 0 ; i < 20 ; ++i) { int tmp = x+y; y = x-y; x = tmp; } if ((x > 0) && (y > 0)) return f(x,y); else return 0; } ����������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/shift_unsigned.c������������������������������������������������0000644�0001750�0001750�00000000446�12155630273�021116� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -machdep x86_32 OPT: -rte -warn-signed-overflow -warn-unsigned-overflow -print -machdep x86_32 */ int main () { unsigned int x, y; x= 0x10000000U; y = x << 4; y = 0x10000000U << 4; y = 1U << -3; y = -4 << 2; return y; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/assign6.c�������������������������������������������������������0000644�0001750�0001750�00000000413�12155630273�017451� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -rte-no-all -rte-precond -journal-disable */ int z; /*@ assigns z \from y; assigns \result \from x,y; */ int f(int x, int y); int main() { int a,b; a = f(0,0); a = f(0,b); a = f(b,0); return a; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/tab.c�����������������������������������������������������������0000644�0001750�0001750�00000000571�12155630273�016652� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print */ typedef double typetab[2]; double g4(typetab *t) { double y; y = (*t)[0] + (*t)[1]; return y; } double h4(typetab t) { return t[0] + t[1]; } double i4(double* t) { return t[0] + t[1]; } /*@ assigns \nothing; */ double f4() { double tab[2],r; tab[0]=1.0; tab[1]=2.0; r = g4( &tab ) ; return r + h4(tab); } ���������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/bts621.c��������������������������������������������������������0000644�0001750�0001750�00000000274�12155630273�017125� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -print -then -no-print -rte -warn-signed-overflow -rte-precond -then -print */ //@ assigns *p; float g(float* p); void f(float a) { /*@ ghost float x = g(&a); */ } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/float_to_int.c��������������������������������������������������0000644�0001750�0001750�00000000442�12155630273�020562� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -rte-float-to-int -print -machdep x86_32 -journal-disable */ void main() { float f = 0.; int i = f; long long l = f; unsigned short s = f; int ci1 = 1.5; int ci2 = 1.5e255; char ci3 = 258.; int ci4 = 2147483647.5; int ci5 = -2147483649.5; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/assign4.c�������������������������������������������������������0000644�0001750�0001750�00000000572�12155630273�017455� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -rte-no-all -print -rte-precond -journal-disable */ //@ assigns \result \from min, max; int choose1(int min, int max); /*@ assigns \result \from min, max, min, max; assigns \result \from min, max, min, max; */ int choose2(int min, int max); int main() { int c1 = choose1(5,10); int c2 = choose2(0,c1); return c1+c2; } ��������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/assign7.c�������������������������������������������������������0000644�0001750�0001750�00000001155�12155630273�017456� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -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(); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/precond.c�������������������������������������������������������0000644�0001750�0001750�00000005044�12155630273�017536� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -rte-precond -journal-disable */ int global = 15; typedef struct cell { int val; struct cell* next; } cell; typedef struct other { cell c; } other; /*@ requires x > 0 ; requires (int) (x + y) != 0 ; */ int f(int x, int y, float z) { return x + y - (int) z; } /*@ predicate is_valid_int_range(int* p, int n) = (0 <= n) && \valid_range(p,0,n-1) ; */ /*@ requires is_valid_int_range(p,i); */ int g(int* p, int i) { if (i >= 1) return p[i-1]; else return 0; } /*@ requires \valid(&p[1]+3) ; */ int h(int* p) { return *(p+3); } /*@ requires \valid(p->next); // requires \valid(&p->next); // requires \valid(&p->val); requires \valid(p); */ cell* set(cell* p, int v) { p->val=v; return p->next; } /*@ requires \valid(cIn.next); requires global > 0; */ int next_val(cell cIn) { return cIn.next->val; } typedef struct top { int topv; cell* next; cell* pred; } top; /*@ requires \valid(ptop->next); */ cell* top_set(top* ptop, int v) { return set(ptop->next, v); } /*@ requires \valid(tIn.next); */ int top_next(top tIn) { return next_val(*tIn.next); } /*@ requires \valid(tab_top); requires \valid(&tab_top); requires \valid(tab_top[i]->next); */ cell* tabtop_set(top* tab_top[], int i, int v) { return top_set(tab_top[i], v); } int main() { int a=2,b=3; cell c = { 20 , 0 }; cell* pc; top T; top tabT[2]; top* ptabT[3] = { &T, &T, &T }; top** pptop; other ot = { c }; void* V; int k = 1, l = 1; int z= f(2,3,1.0), y = f(b-a,a,2.0); int w; int tab[4] = { 1, 2, 3, 4 }; int* r; int** rr; z = f(y,a+b,-0.0); w = g(&z,1); w = g(&tab[1],2); w = g(&tab[k],l); r = tab; rr = &r; w = g(r+2,0); w = h(tab); w = h(r); w = h (*rr); // w = h(&tab[1]); // w = h(&tab[k]); pc = &c; c.next = &c; set(pc,15); set(&c,10); set((cell*)(void*)&c,20); V = &c; set((cell*) V, 20); next_val(c); next_val(*pc); next_val(*((cell*) V)); T.pred = &c; T.next = &c; tabT[0] = T; tabT[1] = T; set(T.pred,10); set(tabT[1].next,20); next_val(*T.next); next_val(*tabT[0].pred); set(ptabT[2]->pred,15); set(tabT[1].pred,10); next_val(*(ptabT[1]->next)); top_set(&T, 3); top_set(&tabT[1],2); top_set(ptabT[1],4); top_set((void*) (c.next), 5); top_next(T); top_next(*ptabT[0]); tabtop_set(ptabT, 2, 10); pptop = (void*) ptabT; tabtop_set(pptop,2,15); tabtop_set((void*) ptabT, 1, 20); tabtop_set((void*) pc->next, 1, 10); return z; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/addsub_unsigned_typedef.c���������������������������������������0000644�0001750�0001750�00000000700�12155630273�022754� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -machdep x86_32 OPT: -rte -warn-signed-overflow -warn-unsigned-overflow -print -machdep x86_32 */ typedef unsigned int uint; int main() { uint ux,uy,uz; ux = 0x7FFFFFFFU * 2 ; /* no unsigned ov */ uy = 0x80000000U + 0x80000000U; /* unsigned ov */ uy = 2U * 0x80000000U; /* unsigned ov */ uz = ux + 2; /* unsigned ov but not detected by const folding */ return 0; } ����������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/assign2.c�������������������������������������������������������0000644�0001750�0001750�00000000544�12155630273�017452� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -rte-no-all -print -rte-precond */ int i; int t[10]; //@ ensures 0 <= \result <= 0; int any(); /*@ assigns i, t[\at(i,Post)]; @ ensures t[i] == \old(t[\at(i,Here)]) + 1; @ ensures \let j = i ; t[j] == \old(t[j]) + 1; @*/ void f() { i = any(); t[i]++; } void main() { f(); f(); return 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/addsub_unsigned.c�����������������������������������������������0000644�0001750�0001750�00000000654�12155630273�021244� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -machdep x86_32 OPT: -rte -warn-signed-overflow -warn-unsigned-overflow -print -machdep x86_32 */ int main() { unsigned int ux,uy,uz; ux = 0x7FFFFFFFU * 2 ; /* no unsigned ov */ uy = 0x80000000U + 0x80000000U; /* unsigned ov */ uy = 2U * 0x80000000U; /* unsigned ov */ uz = ux + 2; /* unsigned ov but not detected by const folding */ return 0; } ������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/minus.c���������������������������������������������������������0000644�0001750�0001750�00000001057�12155630273�017237� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -warn-signed-downcast -print -machdep x86_32 */ int main() { int x=0,y=0,z=0; unsigned int ux=0,uy=0,uz=0; short sz=0; z = -x; z = - (-0x7fffffff -1); z = -ux; sz = ((unsigned short) (65535 + 3)) + x; z = -0x80000000 -1; /* this is unsigned and equal to 0x7fffffff */ z = -2147483648 - 1; /* this is unsigned and equal to 0x7fffffff */ z = -2147483647 -1 -1; /* this is signed and overflows */ z = -((int)(-0x7fffffff -1)) -1; /* this is signed and overflows */ return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/assign5.c�������������������������������������������������������0000644�0001750�0001750�00000001176�12155630273�017457� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -rte-no-all -rte-precond -journal-disable */ /* the assigns of f shouldn't parse: in fact both assigns are taken into account */ /*@ assigns *p \from x; assigns *p \from \nothing; */ int f(int *p, int x); /* the assigns of g shouldn't parse: here only assigns \from \nothing is kept */ /*@ assigns *p \from \nothing; assigns *p \from x; */ int g(int *p, int x); int main() { int i,a; int t[10]; i = 0; a = 0; t[0] = f(&i,a); // rte warning: from \nothing + other froms t[1] = g(&i,a); // no rte warning since only assigns from \nothing is kept } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/array_index.c���������������������������������������������������0000644�0001750�0001750�00000001157�12155630273�020412� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -then -rte-trivial-annotations OPT: -rte -warn-signed-overflow -print -unsafe-arrays */ int t[10]; int u[8+3]; int v[16][17]; typedef struct _s { int t[15]; struct { int u[12]; } s; struct _s v[12]; } ts; ts s; unsigned int c[10]; void main(int i, int j, unsigned int k) { t[0] = 0; u[1] = 0; v[2][3] = 0; s.t[1] = 0; s.s.u[2] = 0; s.v[3].t[4] = 0; t[i] = 0; u[i] = 0; v[i][j] = 0; s.t[i] = 0; s.s.u[i] = 0; s.v[i].t[j] = 0; t[k] = 0; u[k] = 0; v[k][c[k]] = 0; s.t[k] = 0; s.s.u[k] = 0; s.v[k].t[c[k]] = 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/addsub.c��������������������������������������������������������0000644�0001750�0001750�00000000754�12155630273�017351� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -machdep x86_32 */ int main() { int x=0,y=0,z=0; z = (int) 0x7fffffff + (int) 0x7fffffff; /* false */ z = - 0x7fffffff - 0x7fffffff; /* false */ z = (- (int) (-0x7fffffff -1)) - 1; /* false */ z = (int) 0x7fffffff + 0; /* true */ z = - (int) 0x7fffffff - 1; /* true */ z = x + y; z = - (int) 0x7ffffffc - y; z = - x - (int) 0x7ffffffc; z = (int) 0x7ffffffc + y; z = x + (int) 0x7ffffffc; return 0; } ��������������������frama-c-Fluorine-20130601/tests/rte/precond2.c������������������������������������������������������0000644�0001750�0001750�00000001002�12155630273�017606� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/rte/compute_annot/compute_annot.ml -journal-disable OPT: -load-script tests/rte/rte_api/rte_api.ml -journal-disable */ int global = 15; typedef struct cell { int val; struct cell* next; } cell; typedef struct other { cell c; } other; /*@ requires x > 0 ; requires (int) (x + y) != 0 ; */ int f(int x, int y, float z) { return x + y - (int) z; } int g(int a, int b) { return a / b ; } int main() { int a=2,b=3; return f(b-a,g(a,b),1.0); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/divmod.c��������������������������������������������������������0000644�0001750�0001750�00000001454�12155630273�017367� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -warn-signed-downcast -print -machdep x86_32 -journal-disable */ #include "share/libc/limits.h" int main() { int x=0,y=0,z=0; unsigned int ux=0,uy=0,uz=0; z = INT_MIN / -1 ; z = INT_MIN % -1 ; uz = 1 / 0; uz = 1 / (0xffffffff + 1); ux = 0x80000000; uy = 0xffffffff; uz = ((int) ux) / ((int) uy); // floating point exception uz = ux / uy; // correct if uy != 0 uz = 0x80000000 / (0xffffffff + 1); uz = ((int) (-0x7fffffff -1)) / ((int) -1); uz = ((int) (-0x7fffffff -1)) / 0xffffffff; uz = 0x80000000 / (int) -1; uz = (int) (0x80000000 / 0xffffffff); z = 1 / (x + y) ; z = x / -1; z = (- 0x7ffffff - 1) / y; z = (-2147483648L) / (-1L) ; z = 0x80000000 / -1; z = 0x80000000 / 0xffffffff; return 0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/result/���������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017252� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/bts0580.i�������������������������������������������������������0000755�0001750�0001750�00000000254�12155630273�017220� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -rte-no-all -rte-mem -print */ struct ArrayStruct { int data[10]; } buff; int main (int i) { return buff.data[i] ; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/assign3.c�������������������������������������������������������0000644�0001750�0001750�00000000362�12155630273�017451� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -rte-no-all -print -rte-precond -journal-disable */ // if f() assigns i there might be a problem //@ assigns \nothing; int f(); int main() { int i; int t[10]; i = 0; t[i] = f(); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/noresult.c������������������������������������������������������0000644�0001750�0001750�00000000460�12155630273�017754� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -rte-precond */ int x ; //@ ensures \result > 0 ; assigns x; int f(void); //@ ensures \result > 0 ; assigns \nothing; int g(); //@ requires p > 0 ; ensures \result > 0 ; assigns \nothing; int h(int p); void job(void) { f(); g(); h(2); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/s64.c�����������������������������������������������������������0000644�0001750�0001750�00000000214�12155630273�016512� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -machdep x86_32 */ int main() { long long z; z = 5LL << 63; return 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/postcond2.c�����������������������������������������������������0000644�0001750�0001750�00000000627�12155630273�020021� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -rte-no-all -print -rte-precond */ /*@ requires \valid(x); requires \valid_range(x, 0, 10); assigns *x \from y; assigns \result \from *x; */ int g(int *x, int y); /*@ requires \valid(&tab[0]); assigns \nothing; */ int f(int* tab) { return 0; } int main() { int tab[2] = { 3, 4 }; int a = f(tab); return g(&tab[3 - tab[0]] + a, a); } ���������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/reqlabl2.c������������������������������������������������������0000644�0001750�0001750�00000000370�12155630273�017605� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -rte-precond */ /*@ requires PROP_SUR_982: x>0; requires PROP_SUR_982: x+1>1; ensures PROP_SUR_982: x>0; ensures PROP_SUR_982: x+1>1; */ int f(int x); void g(int a) { int c; c = f(a); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/mul.c�����������������������������������������������������������0000644�0001750�0001750�00000000705�12155630273�016700� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -warn-signed-downcast -print -machdep x86_32 */ int main() { int x=0,y=0,z=0; unsigned int ux=0,uy=0,uz=0; uz = ux * uy; z = x * y; z = 0x1000 * y; z = x * 0x1000; z = (- 0x1000) * y; z = x * (- 0x1000); z = (int) (-1) * y; z = x * 1; z = 1 * y; z = x * 0xffffffff; z = 0xffff * 0xffff; z = 0xffff * 0x7fff; z = 0xffff * 0x8000; z = 0xffff * 0x8001; return 0; } �����������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/bts0576.c�������������������������������������������������������0000644�0001750�0001750�00000000556�12155630273�017221� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -rte-precond */ typedef double typetab[2]; /*@ requires \valid(t) && \valid_range(&*t,0,0) && \valid_range((double *)t,0,1); */ double g4(typetab *t) { double y; y = (*t)[0] + (*t)[1]; return y; } /*@ assigns \nothing; */ double f4() { double tab[2],r; tab[0]=1.0; tab[1]=2.0; r = g4( &tab ); return r; } ��������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/castoncall.c����������������������������������������������������0000644�0001750�0001750�00000001060�12155630273�020221� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -warn-signed-downcast -rte-precond -print OPT: -rte -warn-signed-overflow -warn-signed-downcast -rte-precond -no-collapse-call-cast -print */ /*@ 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; assigns \nothing; int f(); void g() { char c = f(); return; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/reqlabl.c�������������������������������������������������������0000644�0001750�0001750�00000000255�12155630273�017525� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -rte-precond -journal-disable */ //@ requires PROP_SUR_982: x>0; int f(int x); void g(int a) { int c; c = f(a); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/unspecified_sequence.i������������������������������������������0000644�0001750�0001750�00000000276�12155630273�022302� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������unsigned long long f(int x) { return 0; } int t[10]; //@ requires x < 1 << 30; void main(int x) { unsigned long long v; int y = t[(int)f(x+1)]; int z = t[(int)f(x+1)+(int)f(x)]; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/twofunc3.c������������������������������������������������������0000644�0001750�0001750�00000000703�12155630273�017651� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/rte/rte_api/rte_get_annot.ml -journal-disable */ int f(int x, int y) { if (x + y != 0) { if ((x == 2147483647) && (y == 1)) return -1; return 0; } return 1; } int main() { int x =1 , y =2; int i; //@ assert (y > x); for (i = 0 ; i < 20 ; ++i) { int tmp = x+y; y = x-y; x = tmp; } //@ assert (i > 0); if ((x > 0) && (y > 0)) return f(x,y); return 0; } �������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/shift.c���������������������������������������������������������0000644�0001750�0001750�00000001215�12155630273�017215� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -machdep x86_32 */ int main() { int i=0; int x=0,y=0,z=0; unsigned int ux=0,uy=0,uz=0; long lx=0,ly=0,lz=0; z = 5u << 30; uz = 5 << 30; z = 5 << 30; z = -3 << 2; z = 5 << 30; lz = 5 << 30; lz = 5 << 60; z = 5 << 29; z = 5 << 28; z = 5 << 3; z = 5 << 1; for(i = 0 ; i < 10 ; ++i) { z = 1 << i ; z = i << 1 ; z = i << i ; } z = 3 >> -2; z = 3 >> 5; z = 3 >> 32; z= 3 >> 31; z = -5 >> 1; z = x >> y; uz = ((unsigned int) x) >> y; z = -2 >> 1; uz = ((unsigned int) -2) >> 1; z = 0 << 10; z = 0 >> 10; return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/divmod_typedef.c������������������������������������������������0000644�0001750�0001750�00000001533�12155630273�021105� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -warn-signed-downcast -print -machdep x86_32 -journal-disable */ #include "share/libc/limits.h" typedef int tint; typedef unsigned int tuint; int main() { tint x=0,y=0,z=0; tuint ux=0,uy=0,uz=0; z = INT_MIN / -1 ; z = INT_MIN % -1 ; uz = 1 / 0; uz = 1 / (0xffffffff + 1); ux = 0x80000000; uy = 0xffffffff; uz = ((tint) ux) / ((tint) uy); // floating point exception uz = ux / uy; // correct if uy != 0 uz = 0x80000000 / (0xffffffff + 1); uz = ((tint) (-0x7fffffff -1)) / ((tint) -1); uz = ((tint) (-0x7fffffff -1)) / 0xffffffff; uz = 0x80000000 / (tint) -1; uz = (tint) (0x80000000 / 0xffffffff); z = 1 / (x + y) ; z = x / -1; z = (- 0x7ffffff - 1) / y; z = (-2147483648L) / (-1L) ; z = 0x80000000 / -1; z = 0x80000000 / 0xffffffff; return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/shift_machdep.c�������������������������������������������������0000644�0001750�0001750�00000000322�12155630273�020674� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -machdep x86_32 OPT: -rte -warn-signed-overflow -print -machdep x86_64 */ int main() { int x; long y; x = 5 << 30; y = 5L << 30; return 0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/postcond.c������������������������������������������������������0000644�0001750�0001750�00000001152�12155630273�017731� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -rte-no-all -print -rte-precond */ /*@ ensures \result == -x ; behavior pos: assumes first_bhv:(x >= 0) ; ensures \result <= 0; assigns *y; behavior neg: assumes second_bhv:(x < 0 ); ensures \result > 0; assigns \nothing; complete behaviors pos,neg; disjoint behaviors pos,neg; */ int f(int x, int *y) { if (x >= 0) *y = x; return -x; } /*@ assigns *x; ensures *x == y; */ void g(int y, int* x) { *x = f(y,&y); } int main() { int a = 5; int c; int b = f(a,&c); g(b,&a); b = b + a; return b; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/downcast.c������������������������������������������������������0000644�0001750�0001750�00000001023�12155630273�017717� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -warn-signed-downcast -print -machdep x86_32 OPT: -rte -warn-signed-overflow -rte-no-all -print -warn-signed-overflow -machdep x86_32 OPT: -rte -warn-signed-overflow -rte-no-all -print -warn-signed-downcast -warn-unsigned-downcast -machdep x86_32 */ int main(void) { signed char sx,sy,sz; unsigned char uc; int x; unsigned int ux, uy,uz; unsigned short s; sz = sx + sy; uc = sx + sy; uc = x; x = uy + uz; ux = uy + uz; s = uy + uz; return 0; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/addsub_typedef.c������������������������������������������������0000644�0001750�0001750�00000001011�12155630273�021054� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -machdep x86_32 */ typedef int tint; int main() { tint x=0,y=0,z=0; z = (tint) 0x7fffffff + (tint) 0x7fffffff; /* false */ z = - 0x7fffffff - 0x7fffffff; /* false */ z = (- (tint) (-0x7fffffff -1)) - 1; /* false */ z = (tint) 0x7fffffff + 0; /* true */ z = - (tint) 0x7fffffff - 1; /* true */ z = x + y; z = - (tint) 0x7ffffffc - y; z = - x - (tint) 0x7ffffffc; z = (tint) 0x7ffffffc + y; z = x + (tint) 0x7ffffffc; return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/bts0567.c�������������������������������������������������������0000644�0001750�0001750�00000000235�12155630273�017213� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -rte-precond -print */ int tab [2] ; //@ requires \valid(p+1) ; void f(int *p) ; void g(){ f(tab) ; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/malloc.c��������������������������������������������������������0000644�0001750�0001750�00000000453�12155630273�017352� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -rte-all -print -rte-precond */ /*@ allocates \result; @ ensures \result==\null || \fresh(\result,10); */ char* my_malloc (unsigned int n) ; int main() { //@ requires \true ; char * p = my_malloc (10) ; if (p) return 1; return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/bts0580_2.c�����������������������������������������������������0000644�0001750�0001750�00000000716�12155630273�017433� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -rte-no-all -rte-mem -print */ typedef int (*fptr)(int); struct S { int val; struct S* next; }; struct C { struct S cell[5]; fptr f; }; struct ArrayStruct { struct C data[10]; }; struct ArrayStruct buff ; int main(int i ) { int a, b,d; int c[3]; int* p; fptr f; a = buff.data[i].cell[*p].next->val; b = buff.data[c[2]].f(c[1]); d = f(buff.data[0].cell[0].val); return a > b; } ��������������������������������������������������frama-c-Fluorine-20130601/tests/rte/assign.c��������������������������������������������������������0000644�0001750�0001750�00000001302�12155630273�017361� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -rte-no-all -print -rte-precond -journal-disable */ int global_x, global_y; //@ assigns \nothing; void g(); //@ assigns \nothing; int fnd1(); //@ assigns global_x ; int fnd2(); //@ assigns global_x; assigns global_y; int fnd3(); int fnd4(); /*@ assigns global_x; @ behavior normal : assumes cond; assigns \nothing ; @ behavior other : assumes !cond; assigns global_x ; @*/ int fnd5(int cond); //@ assigns \nothing; int fnd6(); //@ assigns *x \from *y ; int fnd7(int* x, int* y); int rte (int cond) { int a,b; g(); if (fnd1() && fnd2() && fnd3() && fnd4() && fnd5(cond) && fnd6() && fnd7(&a,&b)) return 1; else return 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/valid.c���������������������������������������������������������0000644�0001750�0001750�00000002605�12155630273�017203� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -rte -warn-signed-overflow -print -machdep x86_32 -then -unsafe-arrays */ struct R { int v; }; struct Q { int v; int id[12]; struct P* next; struct R tr[13]; }; struct P { int val; struct P* next; int id[5]; int oth[6][7]; struct P* nexts[8][9]; struct Q q; struct Q tq[10][11]; struct P*** znexts; }; int main() { struct P*** pppp; struct P** ppp; struct P* pp; struct P p, p2; int v; struct Q q; int *i,j; int i0 = 0; int i1 = 1; int i2 = 2; int i3 = 3; int i4 = 4; j=0; i = &j; pp = &p; ppp = &pp; pppp = &ppp; p.next = pp; p.znexts = pppp; p.nexts[i0][i1] = p.nexts[i2][i3] = pp; q.next = pp; q.id[i0] = 0; p.q = q; p.tq[i0][i1] = q; p.id[i1] = p.id[i2]; p.id[i1] = p.id[i3]; struct P np = *(p.next); struct P* npp = p.next; v = p.id[3]; v = pp->id[3]; v = *i; v = pp->val; v = pp->id[3]; struct P* z = pp->nexts[i0][i1]; v = pp->nexts[i0][i1]->val; v = pp->next->val; v = pp->next->next->val; v = p.nexts[i0][i1]->val; v = pp->id[i2]; v = pp ->oth[i0][i1]; v = p.nexts[i1][i2]->nexts[i3][*i]->id[i4]; v = p.q.v; v = p.q.id[i4]; v = p.tq[i3][i1].v; v = p.tq[i1][i2].next->tq[i3][i4].v; v = pp->tq[i3][i1].v; v = p.znexts[i0][i1][i2].val; q = p.tq[i0][i1]; v = p.tq[i0][i1].tr[i2].v; v = pp->val; v = p.val; v = p.tq[i0][i1].v; return v; } ���������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/rte/threefunc.c�����������������������������������������������������0000644�0001750�0001750�00000000715�12155630273�020067� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/rte/my_annotation/my_annotation.ml */ int g(int x, int y) { return x / y ; } int f(int x, int y) { if (x + y != 0) { if ((x == 2147483647) && (y == 1)) return -1; else return 0; } else return 1; } int main() { int x =1 , y =2; int i; for (i = 0 ; i < 20 ; ++i) { int tmp = x+y; y = x-y; x = tmp; } if ((x > 0) && (y > 0)) return f(x,y) + g(x,y); else return 0; } ���������������������������������������������������frama-c-Fluorine-20130601/tests/occurrence/���������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017272� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/occurrence/oracle/��������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020537� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/occurrence/result/��������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020610� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/occurrence/decl_func.i����������������������������������������������0000644�0001750�0001750�00000000343�12155630261�021364� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-occurrence" */ int x,y; /*@ predicate foo{L} = x == y; */ /*@ assigns \nothing; ensures \result == x + 1; */ int f(int x); int main () { int y = 0; int z = f(y); y = f(z); return f(y); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/occurrence/ptr_assert.i���������������������������������������������0000644�0001750�0001750�00000000367�12155630261�021636� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/constant_propagation/�����������������������������������������������0000755�0001750�0001750�00000000000�12155634043�021376� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/constant_propagation/oracle/����������������������������������������0000755�0001750�0001750�00000000000�12155634043�022643� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/constant_propagation/const_propagate.c������������������������������0000644�0001750�0001750�00000002635�12155630321�024733� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -val -deps -out -input -semantic-const-folding -journal-disable OPT: -memory-footprint 1 -semantic-const-folding -cast-from-constant -semantic-const-fold add3 -main init -journal-disable */ int x,y,z; int TAB[10]; struct st { int a, b ; } s1, s2; typedef struct st ST ; void test_struct (void) { ST s = {0,1}; s1 = s ; s1.a++; s2.a = s1.a; s.a++; s2 = s; s.b--; } void test_tab (int v) { TAB[s1.b] = TAB[++s2.b]; int * r = &TAB[4]; *r = v; r[1] = v; char * q = (char *)r; *q = v; q[1] = v; int decal = sizeof(int); q[decal] = v; } int * test_ptr(int v) { int * p = &x ; char *s= (char *)p; *s = v; int decal = 1; s[decal] = v; s = ((char *)p) + decal; *s = v; *p = v; return &x; } int * test_struct_ptr(void) { int * q = &s1.b; return &s1.a ; } int add3 (int v1, int v2, int v3) { return v1 + v2 + v3; } int init (int v) { int zero = 0; int sept = 7; x = v; y = sept; z = add3 (x, y, zero); // TODO: add3(x, 7, 0); z = 12; int z1 = z ; return zero ; } unsigned long long ull; void test_ull () { ull = ull - 1L; } void main(int a) { test_ull (); test_struct () ; test_struct_ptr () ; test_tab (13) ; int b = init(5); // TODO: init(5); b = 0; z = add3 (a, 0, 0); int *p = test_ptr (y); //@ assert *p == 7 ; int *q = a?p:&y; int yy = *q; //@ assert a==0 ==> q==&y ; //@ assert *q == 7 ; } ���������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/constant_propagation/declaration2.c���������������������������������0000644�0001750�0001750�00000000227�12155630321�024105� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -semantic-const-folding -journal-disable */ void f(int *x) { (*x)++; } int main () { int Y = 42; f(&Y); return Y; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/constant_propagation/introduction_of_non_explicit_cast.ml�����������0000644�0001750�0001750�00000000462�12155630321�030717� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ let main _ = let all = Datatype.String.Set.empty in let new_proj = !Db.Constant_Propagation.get all true in Project.set_current new_proj; Kernel.CodeOutput.output (fun fmt -> Format.fprintf fmt "After Constant propagation :@.") ; File.pretty_ast ~prj:new_proj ();; let () = Db.Main.extend main ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/constant_propagation/bts117.c���������������������������������������0000644�0001750�0001750�00000000550�12155630321�022556� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -journal-disable -print OPT: -journal-disable -semantic-const-folding OPT: -journal-disable -sparecode-analysis */ int main1 (void) { int r ; if (1) r = 0; else r = 2; return r; } int main2 (void){ int r = 1; if (r) r = 0; else r = 2; return r; } int main (void) { int x1 = main1(); int x2 = main2(); return x1 + x2; } ��������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/constant_propagation/declaration.c����������������������������������0000644�0001750�0001750�00000000265�12155630321�024025� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: bugfix in progress OPT: -val -semantic-const-folding -journal-disable */ void f(int *x) { (*x)++; } int Y = 42; int main () { f(&Y); return Y; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/constant_propagation/result/����������������������������������������0000755�0001750�0001750�00000000000�12155634043�022714� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/constant_propagation/const_field_return_struct.i��������������������0000644�0001750�0001750�00000000256�12155630321�027042� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/constant_propagation/introduction_of_non_explicit_cast.c������������0000644�0001750�0001750�00000002600�12155630321�030525� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/constant_propagation/introduction_of_non_explicit_cast.opt CMD: tests/constant_propagation/introduction_of_non_explicit_cast.opt OPT: -deps -journal-disable */ int x,y,z; int TAB[10]; struct st { int a, b ; } s1, s2; typedef struct st ST ; void test_struct (void) { ST s = {0,1}; s1 = s ; s1.a++; s2.a = s1.a; s.a++; s2 = s; s.b--; } void test_tab (int v) { TAB[s1.b] = TAB[++s2.b]; int * r = &TAB[4]; *r = v; r[1] = v; char * q = (char *)r; *q = v; q[1] = v; int decal = sizeof(int); q[decal] = v; } int * test_ptr(int v) { int * p = &x ; char *s= (char *)p; *s = v; int decal = 1; s[decal] = v; s = ((char *)p) + decal; *s = v; *p = v; return &x; } int * test_struct_ptr(void) { int * q = &s1.b; return &s1.a ; } int add3 (int v1, int v2, int v3) { return v1 + v2 + v3; } int init (int v) { int zero = 0; int sept = 7; x = v; y = sept; z = add3 (x, y, zero); // TODO: add3(x, 7, 0); z = 12; int z1 = z ; return zero ; } unsigned long long ull; void test_ull () { ull = ull - 1L; } void main(int a) { test_ull (); test_struct () ; test_struct_ptr () ; test_tab (13) ; int b = init(5); // TODO: init(5); b = 0; z = add3 (a, 0, 0); int *p = test_ptr (y); //@ assert *p == 7 ; int *q = a?p:&y; int yy = *q; //@ assert a==0 ==> q==&y ; //@ assert *q == 7 ; } ��������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016572� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/oracle/�����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020037� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts283.c����������������������������������������������������0000644�0001750�0001750�00000001053�12155630261�017760� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -slice-return main -slice-undef-functions -journal-disable -then-on 'Slicing export' -print */ int x,y,z; int X, Y ; /*@ requires a > 0; ensures y == a; */ int f(int a) { y = x; return x; } /*@ requires a > 0; requires b > 0; assigns \result \from a; assigns Y \from b; */ int g (int a, int b); /*@ requires x > 0; ensures X > \old(X); ensures Y == \old(Y) + 1; */ void k(int x) { X += x ; Y ++ ; } int main() { x = 1; y = 2; z = f(x); z += g(1, 2); k(3); return X + z; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/slice_no_body.c���������������������������������������������0000644�0001750�0001750�00000000636�12155630261�021551� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/slicing/slice_no_body.opt CMD: tests/slicing/slice_no_body.opt OPT: -check -deps -lib-entry -main h -journal-disable */ int G; int f (int a); int g (int c) { int x = c+1; int y = c*2; if (c == 0) return f (x); else return y; } int h (void) { int a = f (1); int b = f (2); int c = f (3); G = f (4); if (G > 0) G = g (c); return g; } ��������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/top2.c������������������������������������������������������0000644�0001750�0001750�00000000705�12155630261�017622� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config * 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 */ int tab[2]={0, 7 }; int G, X ; typedef struct {int a; int b; } Ts; Ts S; int f(void) { volatile int i=0; int v; v = tab[i]; G = X; return v; } int main(void) { int x = f(); G += 1 ; //@ slice pragma expr G ; return x; } �����������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/call_accuracy.c���������������������������������������������0000644�0001750�0001750�00000002722�12155630261�021524� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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; ++b; return c ? a : b; } int test_cond (int x, int y, int z) { ++x ; ++y ; // <- best can be done. ++z ; z = f_cond(1, x, y); // <- best can be done. ++y ; // <- best can be done. ++x ; ++z; return f_cond(0, y, z); // <- best can be done. } void f_set (int *p, int v) { *p = v ; } struct st {int a, b ;} S1, S2, S3, S4; int test_set (int x, int y, int z) { int a, b ; struct st s1, s2, s3 = {1, 2} ; int tab [5] ; f_set(&a,x); f_set(&b,y); f_set(&s1.a,x); // <- best++ can be done. f_set(&s1.b,y); f_set(&s2.a,x); f_set(&s2.b,z); f_set(&s3.a,x); f_set(&tab[0],x); // <- best++ can be done. f_set(&tab[1],y); f_set(&tab[2],z); // <- best++ can be done. f_set(&S1.a,x); // <- best++ can be done. f_set(&S1.b,y); f_set(&S2.a,x); // <- best++ can be done. f_set(&S2.b,y); S3.a = 1 ; // <- best++ can be done. S3.b = 2 ; S4.a = 3 ; return b + s1.b + s3.b + tab[1] + S1.b + S2.b; } int test_struct (void) { S1.a = 1 ; // <- best can be done. S1.b = 2 ; S2.a = 3 ; S2 = S1 ; S2.a = 4 ; // <- best can be done. return S2.b ; } int main (int x, int y, int z) { int r1 = test_struct () ; int r2 = test_cond(x, y, z) ; int r3 = test_set (x, y, z) ; return r1 + r2 + r3 + S3.b + S4.b ; } ����������������������������������������������frama-c-Fluorine-20130601/tests/slicing/simple_intra_slice.c����������������������������������������0000644�0001750�0001750�00000003435�12155630261�022606� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/slicing/simple_intra_slice.opt CMD: tests/slicing/simple_intra_slice.opt OPT: -check -deps -slicing-level 2 -no-slice-callers -journal-disable */ int Unknown; int G; /* on slectionne le return. on doit garder juste a (pas G et b) */ int f1 (int x, int y) { int a = 1, b = 2; G = x + a; return y + b; } /* on slectionne le return. pas de rduction intreproc -> b doit tre marqu Spare et recursivement a aussi. */ int f2 (void) { int a = 1, b = a+1, c = 3; return f1 (b, c); } /* avec un IF : slection de la branche then */ int f3 (int c) { int a = 1, b = 2; int x = 0; if (c > Unknown) x = b; else G = a; return x; } /* avec un IF : slection de la branche else */ int f4 (int c) { int a = 1, b = 2; int x = 0; if (c > Unknown) G = a; else x = b; return x; } int f5 (int c) { int x = 0; if (c > Unknown) goto Lsuite; x += 1; Lsuite : if (c < Unknown) goto L2; G++; L2 : x += 1; return x; } int f6 (int n) { int i = 0; while (n < 10) { if (Unknown > 3) { i = 1; break; } if (n%2) continue; n++; } if (i) return 0; else return 10*n; } typedef struct { int a; int b; int c; } Tstr; Tstr S, S1, S2; void f7 (Tstr s0) { int x = S.a; if (x > 0) { S.a += 3; } else { s0.a += 1; S = s0; } } void f8 (Tstr * ps) { ps->a ++; ps->b ++; } int main (void) { int res = 0; /* make Unknown really unknown */ volatile int uninit=0, uninit2=0 ; while(uninit) if (uninit-1) Unknown++; else Unknown--; while(uninit2) if (uninit2-1) S.a++; else S.a--; res += f2 (); res += f3 (1); res += f4 (1); res += f5 (1); res += f6 (Unknown); f7 (S); if (Unknown) f8 (&S1); else f8 (&S2); return res; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/call_demo.c�������������������������������������������������0000644�0001750�0001750�00000000777�12155630261�020666� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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; int call1 (int v); //@ assigns \result \from v; int call2 (int v); void oper (int * s, int * p, int i) { *s = *s + i; *p = *p * i; } void main (int n) { int i; int sum = 0; int product = 1; for(i = 0; i < n; ++i) oper (& sum, & product, i); call1(sum); call2(product); } �frama-c-Fluorine-20130601/tests/slicing/if_many_values.c��������������������������������������������0000644�0001750�0001750�00000000353�12155630261�021736� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -slice-value r -journal-disable -slevel 101 -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; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/sizeof.c����������������������������������������������������0000644�0001750�0001750�00000006251�12155630261�020237� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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 ; unsigned int SizeOf_1 (void) { int x = 1; int i = 2; int *p = &x; int tab[5] = {0,1,2,3,4}; return sizeof(int *) ; } unsigned int SizeOf_2 (void) { int x = 1; int i = 2; int *p = &x; int tab[5] = {0,1,2,3,4}; return sizeof(struct St) ; } unsigned int SizeOfE_pt1 (void) { int x = 1; int i = 2; int *p = &x; int tab[5] = {0,1,2,3,4}; return sizeof(&x) ; } unsigned int SizeOfE_pt2 (void) { int x = 1; int i = 2; int *p = &x; int tab[5] = {0,1,2,3,4}; return sizeof(p) ; } unsigned int SizeOfE_pt3 (void) { int x = 1; int i = 2; int *p = &x; int tab[5] = {0,1,2,3,4}; return sizeof(p+i) ; } unsigned int SizeOfE_pt_deref_1 (void) { int x = 1; int i = 2; int *p = &x; int tab[5] = {0,1,2,3,4}; return sizeof(*(p+i)) ; } unsigned int SizeOfE_tab_1 (void) { int x = 1; int i = 2; int *p = &x; int tab[5] = {0,1,2,3,4}; return sizeof(tab) ; } unsigned int SizeOfE_pt_tab_1 (void) { int x = 1; int i = 2; int *p = &x; int tab[5] = {0,1,2,3,4}; return sizeof(tab+i) ; } unsigned int SizeOfE_pt_tab_2 (void) { int x = 1; int i = 2; int *p = &x; int tab[5] = {0,1,2,3,4}; return sizeof(&(tab[i])) ; } unsigned int SizeOfE_tab_acces_1 (void) { int x = 1; int i = 2; int *p = &x; int tab[5] = {0,1,2,3,4}; return sizeof(tab[i]) ; } int main (void) { int r = 0 ; r += sizeof (struct St); // How to write something like this: assert r == sizeof (st) //@ assert r != 0; r += SizeOf_1 (); r += SizeOf_2 (); r += SizeOfE_pt1 (); r += SizeOfE_pt2 (); r += SizeOfE_pt3 (); r += SizeOfE_pt_deref_1 (); r += SizeOfE_tab_1 (); r += SizeOfE_pt_tab_1 (); r += SizeOfE_pt_tab_2 (); r += SizeOfE_tab_acces_1 (); //@ slice pragma expr r; return r; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/select_return_bis.c�����������������������������������������0000644�0001750�0001750�00000003644�12155630261�022456� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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; int get (int y) ; void send(int x); void send_bis(int x); void k_bis(int ab, int c, int d) { H = c; if (ab) send_bis (d); } int k(int a, int b, int c, int d) { int cond = get (d) ; G = b; k_bis (cond, c, d); return a; } void g(int b, int c) { int r = k(0,0,c,0); f(b); } int f(int y) { k(0,0,0,0); int r = k(0,y,0,0); int z = k(G,0,0,0); //@ slice pragma expr z; send (z); return z; } ��������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/switch.c����������������������������������������������������0000644�0001750�0001750�00000000522�12155630261�020234� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/slicing/switch.opt CMD: tests/slicing/switch.opt OPT: -check -deps -journal-disable */ int main (char choix) { int x = 0, y = 0, z = 0; switch (choix) { case 'a' : x = 1; break; case 'b' : x = 2; y = 1; break; case 'c' : case 'd' : y = 2; break; } z++; return x; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/ex_spec_interproc.ml����������������������������������������0000644�0001750�0001750�00000007354�12155630261�022646� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* ledit bin/toplevel.top -deps tests/slicing/ex_spec_interproc.c #use "tests/slicing/select.ml";; ou #use "tests/slicing/ex_spec_interproc.ml";; *) include LibSelect;; let main _ = (*--------------------------*) (* find the kernel functions *) let _kf_g = Globals.Functions.find_def_by_name "g" in let kf_f = Globals.Functions.find_def_by_name "f" in let kf_main = Globals.Functions.find_def_by_name "main" in (* add a request to select f result (output 0) in the project *) let select_f_out0 project = let ff_f = !S.Slice.create project kf_f in let select = select_retres project kf_f in !S.Request.add_slice_selection_internal project ff_f select; print_requests project; ff_f in (*=========================================================================*) (* DEBUT DU TEST *) (*=========================================================================*) (* mode DontSliceCalls *) !Db.Slicing.set_modes ~calls:0 () ; let project = mk_project () in let _ff_f = select_f_out0 project in !S.Request.apply_all_internal project; print_project project; extract_and_print project; (*=========================================================================*) (* mode PropagateMarksOnly *) !Db.Slicing.set_modes ~calls:1 () ; let project = mk_project () in let _ff_f = select_f_out0 project in !S.Request.apply_all_internal project; print_project project; extract_and_print project; (*=========================================================================*) (* mode MinimizeNbCalls *) !Db.Slicing.set_modes ~calls:2 () ; let project = mk_project () in (* slice 'f' to compute its result (output 0) and propagate to 'g' *) let ff_f = select_f_out0 project in !S.Request.apply_all_internal project; print_project project; (* call 'f' slice in 'main' *) let ff_main = !S.Slice.create project kf_main in !S.Request.add_call_slice project ~caller:ff_main ~to_call:ff_f; !S.Request.apply_all_internal project; print_project project; extract_and_print project; (*---------------------------------------------- *) (* test remove_slice and select_stmt_computation *) (* we remove ff_main : ff_f should not be called anymore *) !S.Slice.remove project ff_main; print_project project; (* try to change ff_f to check that ff_main is not in its called_by anymore *) (* select "a" before inst 14 (d++) *) (* 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 = 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; !S.Request.apply_all_internal project; print_project project; (*=========================================================================*) (* Test 'extract' when there are 2 slices for the same function *) !Db.Slicing.set_modes ~calls:2 () ; let project = mk_project () in let ff_f_1 = !S.Slice.create project kf_f in let select = select_retres project kf_f in !S.Request.add_slice_selection_internal project ff_f_1 select; let ff_f_2 = !S.Slice.create project kf_f in let select = select_data "Z" project kf_f in !S.Request.add_slice_selection_internal project ff_f_2 select; !S.Request.apply_all_internal project; print_ff ff_f_2; extract_and_print project; (*=========================================================================*) (* mode PreciseSlices *) !Db.Slicing.set_modes ~calls:3 () ; let project = test_select_retres ~do_prop_to_callers:true "f" in print_project project;; (*=========================================================================*) let () = Db.Main.extend main ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts335.c����������������������������������������������������0000644�0001750�0001750�00000000637�12155630261�017765� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -slice-pragma g -calldeps -slicing-level 3 */ /* 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 "-pdg-pot bts335" tests/slicing/bts335.c */ int T[2] = {0, 0}; void f (int i) { T[i]++; } void g (void) { f(0); /*@ slice pragma expr T[0]; */ } void main (int c) { if (c) g(); else f(1); } �������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts335b.c���������������������������������������������������0000644�0001750�0001750�00000000724�12155630261�020124� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -slice-return main -calldeps -slicing-level 3 -slicing-verbose 2 -journal-disable -then-on 'Slicing export' -print */ int X, Y; int g(int c, int x, int y, int z) { X = z ; if (c == 1) X = x; if (c == 2) X = y; Y = X ; return X; } int f(int c, int x, int y, int z) { z++; return g(c,x,y,z); } int main(int v, int w, int a, int b, int i, int j) { int r = f(1, v, a, i) ; j++; r += g(2, w, b, j) ; return r ; } ��������������������������������������������frama-c-Fluorine-20130601/tests/slicing/keep_annot.c������������������������������������������������0000644�0001750�0001750�00000002777�12155630261�021074� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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 OPT: -slice-return bts1110 -main bts1110 -then-on 'Slicing export' -print */ typedef struct { int a; double b; } las; void g (las * p) { int i=0; while (i<5) { p->b = (double)i / (double)(i+1); p->a = 1 + i; i++; } //@ assert 1<=p->a<=6; //@ assert 0.0<=p->b<=1.0; } //@assigns *p; void f (las * p, int n, int m) { g(p); //@ assert 0.0<=p->b<=1.0; //@ assert (\forall integer k; k < n ==> k < m); } /* from BTS#448 from Dillon : the loop invariant is not in the slice. * After bug fix, it is kept when using option -slicing-keep-annotations * TODO: maybe it should also be kept without the option. */ void L (float u,int nn, float dabs[], float *y) { int ii; /*@ loop invariant (\forall integer k; u<=dabs[k]); */ for (ii = nn-2; ii >= 0; ii--) { *y = u - dabs[ii+1] * 2.0; //@ assert (\forall integer k; u<=dabs[k]); } //@slice pragma expr *y; } int bts1110(int x) { int y = 3; int z; //@ assert y == 3; y = 2; //@ assert x == 5; z = 5; x = x+1; return x; } �frama-c-Fluorine-20130601/tests/slicing/loops.c�����������������������������������������������������0000644�0001750�0001750�00000015401�12155630261�020071� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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 OPT: -check -deps -lib-entry -main alarm -slice-threat alarm -journal-disable -then-on 'Slicing export' -print */ int f1 (int c) { int x = 0, s = 0; if (c) { while(1) { /* infinite loop */ s++; //@ assert s > 0 ; } //@ assert \false ; } else x = 1; //@ slice pragma stmt; x ++; return x; } void f2 (int c) { int x1 = 0, x2 = 0; while (1) { if (c) x1++; else x2++; //@slice pragma expr x1; //@ assert x2 > 0 ; } } /*-------------------------------------------*/ void stop(void) __attribute__ ((noreturn)) ; int stop_f1 (int c) { int x = 0, s = 0; if (c) { while(s < c) { s++; //@ assert s > 0 ; } stop () ; /* never returns */ } else x = 1; //@ slice pragma stmt; x ++; return x; } void stop_f2 (int c) { int x1 = 0, x2 = 0; while (x1+x2 < c + 10) { if (c) x1++; else x2++; //@slice pragma expr x1; //@ assert x2 > 0 ; stop () ; /* never loops nor returns */ x1++; /* dead code */ //@ assert \false ; } } /*-------------------------------------------*/ int G ; void test_infinite_loop_3 (int ctrl1, int ctrl2, int no_ctrl, int data1, int data2, int no_data) { G = 0 ; if (ctrl1) { G = data1 ; if (no_ctrl) { /* Don't control an assignment of G * which leads to the return */ G = no_data ; /* Don't affect the final value of G * because the assignement * does not lead to the return */ while (1) G = no_data ; /* Don't affect the final value of G * because the assignement * does not lead to the return */ G = no_data ; /* Don't affect the final value of G * because the assignement * is dead code */ } if (ctrl2) G = data2 ; } return; } void test_infinite_loop_4 (int ctrl1, int ctrl2, int no_ctrl, int data1, int data2, int no_data) { G = 0 ; while (ctrl1) { G += data1 ; if (no_ctrl) { /* Don't control an assignment of G * which leads to the return */ G += no_data ; /* Don't affect the final value of G * because the assignement * does not lead to the return */ while (1) G += no_data ; /* Don't affect the final value of G * because the assignement * does not lead to the return */ G += no_data ; /* Don't affect the final value of G * because the assignement * is dead code */ } if (ctrl2) G += data2 ; } return; } void test_infinite_loop_5 (int ctrl1, int ctrl2, int no_ctrl, int data1, int data2, int no_data) { G = 0 ; while (ctrl1) { G += data1 ; if (no_ctrl) { /* Don't control the final value of G. * It only controls the terminaison of the function. */ G += no_data ; /* Don't affect ... */ while (1) G += no_data ; /* Don't affect ... */ G += no_data ; /* Don't affect ... dead code */ } else /* <-- This is the difference with test_infinite_loop_4. * It is only a syntaxical difference, * and not a semantical difference * since the previous statement "G += no_data" is dead. */ if (ctrl2) G += data2 ; } return; } /*-------------------------------------------*/ int C1 = 1, C2 = 1 ; int X, Y, Z ; void loop (int cond) { if (cond) { int c = 0 ; /*@ loop pragma WIDEN_HINTS X, 10, 100 ; */ while (1) { //@ slice pragma ctrl ; if (c) { X++; Y = Z ; } c=1; //@ assert c==1 ; } } Z = Y ; // dead code with -main main } /*---------------------*/ /*@ assigns *p \from p, y, Z ; */ void may_write_Y_from_Z (int * p, int y) ; void test_assigns (int * p, int y) { if (y < Z) *p = y + Z; } /*---------------------*/ void main (int y) { int no_ctrl = 1 ; Z = 0; if (no_ctrl) Z = X ; may_write_Y_from_Z (&Y, y) ; if (C1) { int cond = C2 ; loop (cond) ; } } /*-------------------------------------------*/ void alarm() { int i = 1; volatile int j = 3; //@ assert i == 1; j++; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts679b.i���������������������������������������������������0000644�0001750�0001750�00000000266�12155630261�020146� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -slice-assert main -then-on "Slicing export" -print */ int X = 1 ; int main(void) { int y; L: y = 0; X++; //@ assert X > \at(X,L); return X; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/horwitz.c���������������������������������������������������0000644�0001750�0001750�00000001146�12155630261�020444� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/slicing/horwitz.opt CMD: tests/slicing/horwitz.opt OPT: -check -deps -slicing-level 0 -journal-disable */ /* bin/toplevel.opt -deps -val tests/slicing/horwitz.c */ /* bin/toplevel.opt -deps -pdg-debug -pdg tests/slicing/horwitz.c */ /* cf aussi tests/slicing/horwitz.ml */ int add (int a, int b) { return a+b; } void incr (char * pi) { *pi = add (*pi, 1); } int A (int x, char * py) { x = add (x, *py); incr (py); /*@ slice pragma expr x;*/ return x; } int main (void) { int s = 0; char i = 1; while (i < 11) { s = A (s, &i); } return s; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/min_call.ml�������������������������������������������������0000644�0001750�0001750�00000011100�12155630261�020671� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* ledit -h jnl bin/toplevel.top -deps -lib-entry g -slice-callers \ tests/slicing/min_call.c *) include LibSelect;; let main _ = (* 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 let kf_k = Globals.Functions.find_def_by_name "k" in let _kf_f = Globals.Functions.find_def_by_name "f" in let _kf_g = Globals.Functions.find_def_by_name "g" in let _top_mark = !Db.Slicing.Mark.make ~addr:true ~ctrl:true ~data:true in let add_select_fun_calls project to_call = let selections = Db.Slicing.Select.empty_selects in let selections = !Db.Slicing.Select.select_func_calls_into selections ~spare:false to_call in !Db.Slicing.Request.add_persistent_selection project selections in (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (* Project1 : * Select the call to [send_bis] in [k] as a persistent selection : * this will create a fist slice for [k]. * Then create manually a second slice for [k] : * the call to [send_bis] is visible as wished. *) let project = mk_project() in (*let pdg_k = !Db.Pdg.get kf_k;;*) let calls = !Db.Pdg.find_call_stmts ~caller:kf_k(*pdg_k*) kf_send_bis in let sb_call = match calls with c::[] -> c | _ -> assert false in let mark = !S.Mark.make ~data:true ~addr:false ~ctrl:false in 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 (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 (fun fmt -> Format.fprintf fmt "@[Project1 - result2 :@\n@]") ; !S.Project.pretty fmt project; extract_and_print project; (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (* Project2 : * same than project1, except that we use [select_min_call_internal]. * But as [send_bis] is an undefined function, this makes no difference. *) let project = mk_project() in (*let pdg_k = !Db.Pdg.get kf_k;;*) let calls = !Db.Pdg.find_call_stmts (*pdg_k*)~caller:kf_k kf_send_bis in let sb_call = match calls with c::[] -> c | _ -> assert false in let mark = !S.Mark.make ~data:true ~addr:false ~ctrl:false in let select = !S.Select.select_min_call_internal kf_k sb_call mark in !S.Request.add_selection_internal project select ; print_requests project; !S.Request.apply_all_internal project; Log.print_on_output (fun fmt -> Format.fprintf fmt "@[Project3 - result :@\n@]") ; !S.Project.pretty fmt project; extract_and_print project; (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (* Project3 : * Select the calls to [k] to be visible in a minimal version. * This builds an empty slice [k_1] for [k] and call it in [f] and [g]. * [f_1] is also called in [g_1] because it calls [k_1]. *) let project = mk_project() in add_select_fun_calls project kf_k; print_requests project; !S.Request.apply_next_internal project; print_requests project; !S.Request.apply_all_internal project; Log.print_on_output (fun fmt -> Format.fprintf fmt "@[Project3 - result :@\n@]") ; !S.Project.pretty fmt project; extract_and_print project (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (* Project4 is CAS_1 from Patrick's 19th April 2007 mail. * step 1 - select calls to send and apply : OK * step 2 - (automatically done in step1) * step 3 - select calls to send_bis and apply : TODO * step 4 - (automatically done in step3) *) (* let project = mk_project();; add_select_fun_calls project kf_send;; print_requests project;; !S.Request.apply_next_internal project;; print_requests project;; !S.Request.apply_all_internal project;; Format.printf "@[CAS 1 - step 1+2 - result :@\n@]";; extract_and_print project;; add_select_fun_calls project kf_send_bis;; print_requests project;; !S.Request.apply_all_internal project;; Format.printf "@[CAS 1 - step 3+4 - result :@\n@]";; !S.Project.pretty fmt project;; extract_and_print project;; *) (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) (* Project5 : same than the previous one, * except that we create the two requests before applying. * *) (* let project = mk_project();; add_select_fun_calls project kf_send;; add_select_fun_calls project kf_send_bis;; print_requests project;; Format.printf "@[Project 5 - result :@\n@]";; !S.Project.pretty fmt project;; extract_and_print project;; *) (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) let () = Db.Main.extend main ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/libAnim.ml��������������������������������������������������0000644�0001750�0001750�00000004577�12155630261�020512� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* Some useful function to use the graphical representation of a slicing * project. (see tests/slicing/anim.ml for a test) *) (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) let use_dot = Sys.os_type <> "Win32" && (Unix.WEXITED 0) = Unix.system ("which dot > /dev/null 2>&1") (* function to append [string_of_int n] on 3 char to basename. *) let nth_name basename n = assert (n < 1000); let str_n = string_of_int n in let str_n = if n < 100 then ("0"^str_n) else str_n in let str_n = if n < 10 then ("0"^str_n) else str_n in basename^"."^str_n ;; (* generate the nth .jpg file (generate to .dot file and then remove it) *) let print_proj basename title proj n = let name = nth_name basename n in let dot_name = (name^".dot") in let jpg_name = (name^".jpg") in !Db.Slicing.Project.print_dot ~filename:dot_name ~title:title proj; if use_dot then ignore (Sys.command ("dot -Tjpg -o "^jpg_name^" "^dot_name^" 2>/dev/null")); Sys.remove dot_name; n+1 ;; (* apply all requests of the project and generate a .jpg file for each step. * (begin at number [n]) *) let build_all_graphs basename title proj first_n = Format.printf "Processing %s : " basename; let rec next n = Format.printf ".@?"; try !Db.Slicing.Request.apply_next_internal proj; let title = title^" ("^(string_of_int (n - first_n))^")" in let n = print_proj basename title proj n in next n with Not_found -> n in let next_num = next first_n in Format.printf "@."; next_num ;; let all_files basename = basename^".*.jpg ";; let display_cmd basename = "display -resize 1000x500 "^(all_files basename);; let clean_cmd basename = "rm -f "^(all_files basename);; let build_anim_cmd basename= "convert -delay 10 -loop 1 "^(all_files basename)^" "^basename^".gif";; let print_help basename = let display_cmd = display_cmd basename in let clean_cmd = clean_cmd basename in Format.printf "To display '%s' use :@\n\t%s@\n" basename display_cmd; Format.printf "\t- use : Space/Backspace to see next/previous step@\n"; Format.printf "\t- use : 'q' to quit@\n@@\n"; Format.printf "After that, you can clear the generated files with:@\n\t%s@." clean_cmd let remove_all_files basename = Format.printf "removing generated .jpg files@."; ignore (Sys.command (clean_cmd basename)) (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) ���������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts336.c����������������������������������������������������0000644�0001750�0001750�00000005411�12155630261�017761� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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 -journal-disable -main main3 -inout -inout-callwise -calldeps -slice-return main3 -then-on 'Slicing export' -print OPT: -check -journal-disable -main main -calldeps -inout-callwise -slice-return main -then-on 'Slicing export' -print OPT: -check -journal-disable -main main4 -calldeps -inout-callwise -slice-return main4 -then-on 'Slicing export' -print OPT: -check -journal-disable -main main4 -calldeps -inout-callwise -slice-return main4 -slicing-level 3 -then-on 'Slicing export' -print OPT: -check -journal-disable -main main5 -calldeps -inout-callwise -slice-return main5 -then-on 'Slicing export' -print -calldeps -inout-callwise -slice-return main5 -then-on 'Slicing export 2' -print */ // something to do to have better results... int T[10]; int f (int i) { T[i] ++; return T[i]; } int main (void) { int x1 = f(1); int x2 = f(2); return x2; } //-------------------------------------- // Notice that the example below is very similar to the one above : // f2 also modifies T[1..2], but in this one, the slicing is ok // because T[1..2] is not in the right part of the assignment. void f2 (int i) { T[i] = i; } int main2 (void) { f2 (1); f2 (2); return T[2]; } //-------------------------------------- // This is a similar problem, but without any array. // Option -calldeps gives a better result because we can then slice f3 (&c); // but we cannot slice f3(&a) because it seems to have b as an output, // and f3 (&b); needs b as an input. void f3 (int * p) { *p += 1; } int main3 (void) { int a = 1; int b = 2; int c = 3; f3 (&a); f3 (&b); f3 (&c); return b; } //-------------------------------------- // more complicated variant of 'main3'. This has been resolved in the same way as the first 'main' of this file void f4 (int * p, int* q) { *p += 1; *q += 1; } int main4 (volatile int c) { int a1 = 1; int b1 = 2; int a2 = 3; int b2 = 4; int a3 = 5; int b3 = 6; int a4 = 7; int b4 = 8; int a5 = 9; int b5 = 10; while(c) { f4 (&a1, &b1); f4 (&a2, &b2); f4 (&a3, &b3); f4 (&a4, &b4); f4 (&a5, &b5); } return a2+b4; } //-------------------------------------- // Non-optimal example if only one phase of slicing is done. Would need a notion of "operational functional dependencies", or a callwise pdg int x5; void f5(int *p, int *q) { (*p)++; x5 = *q; } int main5() { int a1=1, a2=2, b1=3, b2=4; f5(&a1, &b1); // This call should be sliced away f5(&a2, &a1); return a2; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/loop_simple.c�����������������������������������������������0000644�0001750�0001750�00000000627�12155630261�021263� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -deps -slice-return main -journal-disable -then-on 'Slicing export' -print */ int main() { int a,c; volatile int b = 0; a = 1; while (1) break ; for (c=0; c <= 5; c++) ; /*@ loop assigns c, a ; */ for (c=0; c <= 5; c++) { a = 2; } if (b) goto L; for (c=0; c <= 5; ) { a+=2 ; L: a+=3; goto H; c++; } a++; H: if (a) c++; return a; } ���������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/libSelect.ml������������������������������������������������0000644�0001750�0001750�00000014610�12155630261�021032� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* To use this in interactive mode : #use "tests/slicing/select.ml";; *) exception Break exception No_return exception Unknown_data of string exception Unknown_stmt of int module S = Db.Slicing (*--------------------------*) (* Useful functions to find and print thinks *) let find_kf fct_name = Globals.Functions.find_by_name fct_name (* let f kf res = match res with Some kf -> res | None -> if Db.get_name kf = fct_name then Some kf else None in match Db.fold_on_functions f None with | None -> raise Not_found | Some kf -> kf *) let fmt = Format.std_formatter;; (* affichage des numros d'instructions * pour servir d'entre d'autres commandes*) let print_stmt project kf = Slicing.PrintSlice.print_fct_stmts fmt (project, kf) ;; (* affichage de debug du PDG *) let print_pdg _project kf = !Db.Pdg.pretty fmt (!Db.Pdg.get kf) ;; let print_ff ff = !S.Slice.pretty fmt ff (* affichage du projet : fonctions avec leur marques + actions en attente *) let print_project project = !S.Project.pretty fmt project ;; (* affichage des actions en attente *) let print_requests project = !S.Request.pretty fmt project ;; (* construit l'application correspondant au projet, et affiche le rsultat *) let extract_and_print project = let prj = !S.Project.extract "Sliced code" project in File.pretty_ast ~prj () (*--------------------------*) let project_number = ref 0 let mk_project () = project_number := !project_number + 1 ; !S.Project.mk_project ("slicing_" ^ (string_of_int !project_number)) let apply project = !S.Request.apply_next_internal project; print_project project (*--------------------------*) (** clear a previously computed project and load a new source file, * starting at [entry_point] to be specified iif it is different from [main]. * DOESN'T WORK at the moment because CIL datas are not cleared...*) (* [Julien 25/06/2007:] Should be possible to do now (?) *) (* let load_source_file ?entry_point filename = Db.Files.clear (); 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 in ignore (Db.get_cil_file ()); let kf = Db.find_function_def_by_name entry_point in ignore (!Db.Value.compute_entry_point kf ~library); Db.iter_on_functions (fun kf -> if Db.is_definition kf && Db.Value.is_called kf then !Db.From.compute kf) *) let get_stmt sid = fst (Kernel_function.find_from_sid sid) (** build the [zone] which represents [data] before [kinst] *) let get_zones str_data (kinst, kf) = 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.enumerate_valid_bits ~for_writing:false loc ;; let select_data_before_stmt str_data kinst _project kf = let mark = !S.Mark.make ~data:true ~addr:false ~ctrl:false in let zone = get_zones str_data (kinst, kf) in !S.Select.select_stmt_zone_internal kf kinst true zone mark (** build the selection for returned value of the function *) let select_retres _project kf = let ki = Kernel_function.find_return kf in try let loc = Db.Value.find_return_loc kf in let zone = Locations.enumerate_valid_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 with Db.Value.Void_Function -> raise No_return ;; (** build the selection for the [data] at the end of the function *) let select_data data _project kf = try let ki = Kernel_function.find_return kf in let mark = !S.Mark.make ~data:true ~addr:false ~ctrl:false in let zone = get_zones data (ki, kf) in !S.Select.select_stmt_zone_internal kf ki true zone mark (* with Logic_interp.Error (_, str) -> raise (Unknown_data data) *) with _ -> raise (Unknown_data data) ;; (** build the selection ONLY for the control dependencies of the statement * [numstmt]*) let select_ctrl numstmt _project kf = try 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 s with _ -> raise (Unknown_stmt numstmt) ;; (** build recursively all the change_call for all the callers to kf in * order to call ff instead. *) let prop_to_callers project (kf, ff) = let rec prop kf ff = let callers = !Db.Value.callers kf in let process_caller (kf_caller,_) = let ff_caller = !S.Slice.create project kf_caller in !S.Request.add_call_slice project ~caller:ff_caller ~to_call:ff; prop kf_caller ff_caller in List.iter process_caller callers in prop kf ff (** compute and print a slice of [fname] where the selection is given by * [select_fct] (which could be [select_retres] or [(select_data str_data)]. * If [do_prop_to_callers] if also recursively computes new functions for * [fname] callers in order to call the new slices. *) let test ?project fname ?(do_prop_to_callers=false) select_fct = let project = match project with | None -> mk_project () | Some project -> project in begin try let kf = Globals.Functions.find_def_by_name fname in let ff = !S.Slice.create project kf in let select = select_fct project kf in !S.Request.add_slice_selection_internal project ff select; if do_prop_to_callers then begin !S.Request.apply_all_internal project; prop_to_callers project (kf, ff) end; let fmt = Format.std_formatter in !S.Request.pretty fmt project; (* !S.Request.apply_next_internal project *) (* !S.Project.pretty fmt project *) extract_and_print project with | No_return -> Format.printf "Impossible to select 'retres' for a void function (%s)\n" fname | Unknown_data str -> Format.printf "Impossible to select this data : %s in %s\n" str fname end; project ;; let test_select_retres ?(do_prop_to_callers=false) fname = test fname ~do_prop_to_callers select_retres let test_select_data ?(do_prop_to_callers=false) fname data = test fname ~do_prop_to_callers (select_data data) ������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/horwitz.ml��������������������������������������������������0000644�0001750�0001750�00000000445�12155630261�020633� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* ledit bin/toplevel.top -deps tests/slicing/horwitz.c #use "tests/slicing/select.ml";; tests/slicing/horwitz.byte -deps tests/slicing/horwitz.c * *) include LibSelect;; let () = Db.Main.extend (fun _ -> ignore (test_select_data ~do_prop_to_callers:true "incr" "*pi"));; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts827.c����������������������������������������������������0000644�0001750�0001750�00000000420�12155630261�017761� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/unravel-point.c���������������������������������������������0000644�0001750�0001750�00000002703�12155630261�021541� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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 */ /* Small example devired from examples given for UNRAVEL tool : */ /*@ assigns *p \from \empty; assigns \result ; */ int scanf (char const *, int * p); int printf (char const *, int); int send1 (int x) { printf ("%d\n", x) ; return x; } int send2 (int x) { printf ("%d\n", x) ; return x; } int send3 (int x) { printf ("%d\n", x) ; return x; } int send4 (int x) { printf ("%d\n", x) ; return x; } main() { int input1,input2,input3,cond1,cond2; int a,b,c; int *x,*y,*z; int output1,output2,output3; scanf("%d",&input1); a = input1; scanf("%d",&input2); b = input2; scanf("%d",&input3); c = input3; scanf("%d",&cond1); scanf("%d",&cond2); x = &a; if (cond1) x = &b; y = &c; z = &b; output2 = *z + 1; *z = *y + *x; output1 = *z; output3 = *x; send1 (output1); send2 (output2); send3 (output3); send4 (cond2); } �������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/undef-fun.c�������������������������������������������������0000644�0001750�0001750�00000000436�12155630261�020626� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -slice-undef-functions -slice-return f -journal-disable -then-on 'Slicing export' -print */ int G; /*@ assigns \result \from a; assigns G \from b; */ int f (int a, int b); int main (int x, int y) { x += 1; y += 2; x = f (x, y); return x; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/unravel-flavors.c�������������������������������������������0000644�0001750�0001750�00000003104�12155630261�022060� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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 : */ /* Slicing and Dicing example */ /* Notice that scanf result is from TOP : have to use -slice-undef-functions * if we don't want to propagate this imprecision... */ /*@ assigns *p \from \empty; assigns \result ; */ int scanf (char const *, int * p); int printf (char const *, int); int send1 (int x) { printf ("%d\n", x) ; return x; } int send2 (int x) { printf ("%d\n", x) ; return x; } int send3 (int x) { printf ("%d\n", x) ; return x; } int send4 (int x) { printf ("%d\n", x) ; return x; } int nb_fetch = 0; int fetch(void) { int value; nb_fetch++; scanf ("%d",&value); return value; } int main(void) { int red, green, blue, yellow; int sweet,sour,salty,bitter; int i; red = fetch(); blue = fetch(); green = fetch(); yellow = fetch(); red = 2*red; sweet = red*green; sour = 0; for (i = 0; i < red; i++) sour += green; salty = blue + yellow; green = green + 1; bitter = yellow + green; send1 (sweet); send2 (sour); send3 (salty); send4 (bitter); return 1; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/switch.ml���������������������������������������������������0000644�0001750�0001750�00000000365�12155630261�020427� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* ledit bin/toplevel.top -deps tests/slicing/switch.c * *) include LibSelect ;; let main _ = ignore (test_select_data "main" "x"); ignore (test_select_data "main" "y"); ignore (test_select_data "main" "z") let () = Db.Main.extend main ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/select_by_annot.ml������������������������������������������0000644�0001750�0001750�00000003116�12155630261�022273� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* ledit bin/toplevel.top -deps tests/slicing/select_by_annot.c \ < tests/slicing/select_by_annot.ml *) module S = Db.Slicing;; open LibSelect;; let main _ = let project = mk_project () in let pretty_pdg fmt kf = !Db.Pdg.pretty fmt (!Db.Pdg.get kf) in let add_annot kf = let mark = !S.Mark.make ~data:true ~addr:false ~ctrl:false in let select = S.Select.empty_selects in let select = !S.Select.select_func_annots select mark ~spare:true ~threat:false ~user_assert:false ~slicing_pragma:true ~loop_inv:true ~loop_var:true kf in !Db.Slicing.Request.add_persistent_selection project select (*!S.Request.read_annotations project kf_main ;;*) in let kf_main = Globals.Functions.find_def_by_name "main" in add_annot kf_main; Format.printf "@[%a@]@\n" pretty_pdg kf_main; let kf_modifS = Globals.Functions.find_def_by_name "modifS" in (*!S.Request.read_annotations project kf_modifS ;;*) add_annot kf_modifS; Format.printf "@[%a@]@\n" pretty_pdg kf_modifS; !S.Request.pretty Format.std_formatter project; !S.Request.apply_all_internal project; !S.Project.pretty Format.std_formatter project; extract_and_print project; (** create another slice for "main" to check if it also contains the previous * selection. *) let ff = !S.Slice.create project kf_main in let select = LibSelect.select_data "b" project kf_main in !S.Request.add_slice_selection_internal project ff select; !S.Request.apply_all_internal project; !S.Project.pretty Format.std_formatter project; extract_and_print project let () = Db.Main.extend main ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/select_by_annot.c�������������������������������������������0000644�0001750�0001750�00000007353�12155630261�022114� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/slicing/select_by_annot.opt CMD: tests/slicing/select_by_annot.opt OPT: -deps -lib-entry -main main -journal-disable CMD: bin/toplevel.opt 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 */ struct Tstr { int a; int b; } S; int Sa ; int f1(int cond) { int * p = &S.a ; if (cond) { //@ assert (cond != 0); Sa = *p ; } //@slice pragma expr *p; return Sa ; } int f2(int cond) { int * p = &S.a ; if (cond) //@ assert (cond != 0); Sa = *p ; //@slice pragma expr S.a; return Sa ; } int f3(int cond) { int * p = &S.a ; if (cond) { //@ slice pragma ctrl; Sa = *p ; } return Sa ; } int f4(int cond) { int * p = &S.a ; if (cond) { //@ slice pragma stmt; Sa = *p ; } return Sa ; } int f5(int cond) { int * p = &S.a ; if (cond) { //@ slice pragma expr 1; Sa = *p ; } return Sa ; } int f6(int cond) { int * p = &S.a ; //@ slice pragma stmt; if (cond) { Sa = *p ; Sa ++ ; } return Sa ; } int f7(int cond) { int * p = &S.a ; if (cond) //@ slice pragma stmt; { Sa = *p ; Sa ++ ; } return Sa ; } int f8(int cond) { int * p = &S.a ; // /*@ loop invariant cond >= 0 ; loop variant cond ; */ while (cond) { //@ assert cond <= \at(cond,Pre) ; // assert S.a + cond == \at(S.a + cond,Pre) ; Sa = *p ; //@ slice pragma stmt; S.a ++ ; cond--; } return Sa ; } int X9, Y9, Z9 ; void f9(int c1, int c2) { if (c1 > c2) goto L; c1 = c2 ; //@ slice pragma stmt; {L: X9 = c1 ;} Y9 = Z9 ; Z9 = c2 ; } void modifS (int a, int b) { S.a += a; S.b -= b; //@slice pragma expr S.a; } int new_int (void); int d; int main (void) { int a = 0; int b = 0; int c = 0; if (d > 0) { //@ assert (b == 0); a = 1; } //@ slice pragma expr a+b; int x = a+b+c+d; modifS (a, b); // assert (d>0 => a == 1) && (!(d>0) => a==0); d = new_int (); f1(d) ; f2(d) ; f3(d) ; f4(d) ; f5(d) ; f6(d) ; f7(d) ; f8(d) ; f9(d,a) ; return x; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts179.c����������������������������������������������������0000644�0001750�0001750�00000000776�12155630261�017777� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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; int X, Y; void g (void) { S.a = 1; S.ab = 0; S.b = 2; /* here, better can be done ! */ S.d = 4; } int main (void) { g(); //@ slice pragma expr S.b; S.ab = 1; /* so that S.ab is sparecode in g() */ return S.a ; } ��frama-c-Fluorine-20130601/tests/slicing/bts326.c����������������������������������������������������0000644�0001750�0001750�00000000463�12155630261�017762� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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] ; int r; void f (int i) { t[i] = i; } void g (void) { f(0) ; f(1) ; } int main (void) { g () ; r = t[0] ; return r; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/combine.c���������������������������������������������������0000644�0001750�0001750�00000000625�12155630261�020353� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/slicing/combine.opt CMD: tests/slicing/combine.opt OPT: -check -deps -journal-disable */ //@ assigns \result \from x; int g (int x); int f (int c, int x) { int y = c ? 1 : -1; int r; if (y < 0) r = x+y; else r = 0; r = g (r); return r; } int main (int x) { int r; if (x > 0) r = f (0, x); else r = f (1, x); return r; } �����������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/slice_behavior.c��������������������������������������������0000644�0001750�0001750�00000000373�12155630261�021715� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -val -slice-assert f -slicing-level 0 -journal-disable -then-on 'Slicing export' -print */ /*@ requires a > 0; */ int f(int a) { int b = 2 * a; /*@ assert a < b; */ return 42; } int main () { f(10); return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/min_call.c��������������������������������������������������0000644�0001750�0001750�00000000456�12155630261�020517� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/slicing/min_call.opt CMD: tests/slicing/min_call.opt OPT: -check -deps -lib-entry -main g -journal-disable -slicing-level 3 */ /* dummy source file in order to test minimal calls feature * on select_return.c */ #include "tests/slicing/select_return.c" ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/loop_infinite.c���������������������������������������������0000644�0001750�0001750�00000000323�12155630261�021570� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -deps -slice-return main -journal-disable -then-on 'Slicing export' -print */ int main() { volatile int a=0,b,c; if (a) {a = 1; while (1) { a++; }; return 0;} } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/select_calls.c����������������������������������������������0000644�0001750�0001750�00000001374�12155630261�021376� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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); void send(int x); void crypt(int* x); void uncrypt(int* x); int c; int d; int f() { int x = 0; int y = 1; int z = x; send(y); /* faille averee */ send(z); crypt(&y); /* y devient public */ send(y); if (x) uncrypt(&y); /* code mort */ if (y) send(y); if (d) uncrypt(&y); send(y); /* faille potentielle */ crypt(&y); /* y devient public */ if (c) y = z; send(y); /* faille potentielle si dep. de contrle */ return 0; } void g (void) { c = 1; nothing (); d = 3; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts0190.c���������������������������������������������������0000644�0001750�0001750�00000000352�12155630261�020036� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -slice-rd y */ int z1(void); int x(int y, int z){ /*@ slice pragma expr y == 1; */ //@ assert y == 1; //@ assert y + z == 3; return 2*y*z1(); } int main() { x(1,2); return 0; } int z1() { return 1; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts0950_annot.i���������������������������������������������0000644�0001750�0001750�00000000420�12155630261�021243� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/select_simple.c���������������������������������������������0000644�0001750�0001750�00000000375�12155630261�021571� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/slicing/select_simple.opt CMD: tests/slicing/select_simple.opt OPT: -check -deps -journal-disable */ /* dummy source file in order to test select_simple.ml */ #include "tests/slicing/simple_intra_slice.c" �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/callwise.c��������������������������������������������������0000644�0001750�0001750�00000001260�12155630261�020536� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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; void f(int *p, int *q) { *p += *q; } int choose (int cond, int x, int y) { return cond ? x : y; } void fs163_f (int *p,int n) { *p = n; } int fs163_main (int n) { int A,B,C; int T[5]; fs163_f (&A, 1); fs163_f (&B, n); fs163_f (&C, 2); fs163_f (&T[0], 0); fs163_f (&T[1], 1); for (int i=0; i<5; i++) fs163_f (&T[i],i); return T[3]; } int main(void) { int n = 2, m = 3; f(&a, &b); f(&c, &d); b = choose (0, n, m); a += choose (1, n, m); a += fs163_main (10); return a; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts709.c����������������������������������������������������0000644�0001750�0001750�00000001601�12155630261�017762� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 return 0; } �������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/result/�����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020110� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/filter.c����������������������������������������������������0000644�0001750�0001750�00000001314�12155630261�020220� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 f(int); 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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/select_simple.ml��������������������������������������������0000644�0001750�0001750�00000001254�12155630261�021754� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* ledit bin/toplevel.top -deps tests/slicing/simple_intra_slice.c * *) include LibSelect ;; let main _ = ignore (test_select_data "f1" "G"); ignore (test_select_retres "f1"); !Db.Slicing.set_modes ~calls:2 (); ignore (test_select_retres "f2"); ignore (test_select_data "f6" "n"); ignore (test_select_retres "f7"); ignore (test_select_data "f7" "S.a"); ignore (test_select_data "f7" "S.b"); ignore (test_select_data "f7" "S"); ignore (test_select_data "f7" "XXX"); ignore (test_select_data "f8" "ps->a"); ignore (test_select_data "f8" "ps->b"); ignore (test_select_data "f8" "ps->c"); ignore (test_select_data "f8" "*ps") let () = Db.Main.extend main ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/mark_all_slices.c�������������������������������������������0000644�0001750�0001750�00000001025�12155630261�022056� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/slicing/mark_all_slices.opt CMD: tests/slicing/mark_all_slices.opt OPT: -check -deps -slicing-level 3 -no-slice-callers -journal-disable */ int A, B, C, D; int A2, B2, C2, D2; int all (int x) { A = x; B = x; C = x; D = x; return x+1; } int fA (void) { all (1); return A; } int fB (void) { all (1); return B; } int fC (void) { all (1); return C; } int fD (void) { all (1); return D; } int main (void) { A2 = fA(); B2 = fB(); C2 = fC(); D2 = fD(); return all (0); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/csmith.c����������������������������������������������������0000644�0001750�0001750�00000005717�12155630261�020235� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/merge.c�����������������������������������������������������0000644�0001750�0001750�00000001033�12155630261�020030� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/slicing/merge.opt CMD: tests/slicing/merge.opt OPT: -check -deps -slicing-level 3 -journal-disable */ int G1, G2, G3; void init (int a1, int a2, int a3); void add (int a1, int a2, int a3); void g (int a1, int a2, int a3); void init (int a1, int a2, int a3) { G1 = a1; G2 = a2; G3 = a3; } void add (int a1, int a2, int a3) { G1 += a1; G2 += a2; G3 += a3; } void g (int a1, int a2, int a3) { init (a1, a2, a3); add (a1, a2, a3); } void main (int x, int y, int z) { g (x, y, z); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/initialized.c�����������������������������������������������0000644�0001750�0001750�00000000320�12155630261�021234� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -slice-assert main -then-on 'Slicing export' -print **/ void main() { int x = 1; int y; L: x = 3; y = 2; //@ assert \initialized(&x); // assert !\initialized{L}(&y); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts808.c����������������������������������������������������0000644�0001750�0001750�00000000554�12155630261�017770� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 (); } ����������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts345.c����������������������������������������������������0000644�0001750�0001750�00000001374�12155630261�017765� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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) { x++ ; return x ; } int called_by_top (int x) { x++ ; int z = called_indirectly_by_top (x) ; return z ; } int top (int x, ...) { x++ ; int z = called_by_top (x) ; return z; } int call_top (int y) { y++; int z = top (y) ; return z ; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/ex_spec_interproc.c�����������������������������������������0000644�0001750�0001750�00000001017�12155630261�022446� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/slicing/ex_spec_interproc.opt CMD: tests/slicing/ex_spec_interproc.opt OPT: -check -deps -journal-disable */ int X, Y; int g (int u, int v, int w) { u++; v++; w++; X = u; Y = u+v; return w; } int Z; int f (int a, int b, int c, int d, int e) { int r; a++; b++; c++; d++; e++; r = g (a, b, c); Z = g (r, d, e); return X; } int I, J, K, L, M; int main (void) { int res; I = 0; J = 0; K = 0; L = 0; M = 0; res = f (I, J, K, L, M); return res; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts341.c����������������������������������������������������0000644�0001750�0001750�00000000270�12155630261�017753� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -slice-assert main -journal-disable -then-on 'Slicing export' -print */ int main (int c) { if (c) while (1) { ; } //@ assert c == 0; return c; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/slice_pragma_stmt.c�����������������������������������������0000644�0001750�0001750�00000013467�12155630261�022444� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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 ; //------------------- void nop1(int c1, int c2) { //@ slice pragma stmt; // <----- slicing isn't correct since the effect... ; // <----- ...is missing with -print option x = 1 ; } void nop2(int c1, int c2) { //@ slice pragma stmt; // <----- slicing isn't correct since the effect... {;} // <----- ...is missing with -print option x = 1 ; } void nop3(int c1, int c2) { //@ slice pragma stmt; // <----- slicing isn't correct since the effect... {;{;;};} // <----- ...is missing with -print option x = 1 ; } void nop4(int c1, int c2) { //@ slice pragma stmt; if (c1) {;{;;};} x = 1 ; } void nop5(int c1, int c2) { if (c2) goto L ; //@ slice pragma stmt; // <----- slicing is correct, but not the output L:; x = 1 ; } void nop6(int c1, int c2) { //@ slice pragma stmt; // <----- slicing is correct, but not the output L:; x = 1 ; } void nop7(int c1, int c2) { //@ slice pragma stmt; // <----- slicing is correct, but not the output L:{;} x = 1 ; } void nop8(int c1, int c2) { //@ slice pragma stmt; // <----- slicing is correct, but not the output {L:{;}} x = 1 ; } //------------------- void double_effect1(int c1, int c2) { //@ slice pragma stmt; // <----- slicing isn't correct since the... x += y++ ; // <----- ...effect is lost with -print option } void double_effect2(int c1, int c2) { //@ slice pragma stmt; // <----- slicing isn't correct since the... { x += y++ ; } // <----- ...effect is lost with -print option } void double_effect3(int c1, int c2) { if (c2) goto L ; //@ slice pragma stmt; // <----- slicing isn't correct since the... L: x += y++ ; // <----- ...effect is lost with -print option } void double_effect4(int c1, int c2) { if (c2) goto L ; //@ slice pragma stmt; // <----- slicing isn't correct since the... L: {x += y++ ; } // <----- ...effect is lost with -print option } void double_effect5(int c1, int c2) { if (c2) //@ slice pragma stmt; {x += y++ ; } } //------------------- void test1(int c1, int c2) { if (c1 < c2) c1 = c2 ; //@ slice pragma stmt; x = c1 ; } void test2(int c1, int c2) { if (c1 < c2) c1 = c2 ; //@ slice pragma stmt; x = c1 ; y = c2 ; } void test3(int c1, int c2) { if (c1 < c2) c1 = c2 ; //@ slice pragma stmt; {x = c1 ;} y = c2 ; } void test4(int c1, int c2) { if (c1 < c2) c1 = c2 ; //@ slice pragma stmt; // <----- slicing isn't correct since the... {x = c1 ; c2 ++ ;} // <----- ...effect is lost with -print option y = c2 ; } void test5(int c1, int c2) { if (c1 < c2) goto L; c1 = c2 ; //@ slice pragma stmt; // <----- slicing isn't correct since the... L: x = c1 ; // <----- ...effect is lost with -print option y = c2 ; } void test6(int c1, int c2) { if (c1 < c2) goto L; c1 = c2 ; //@ slice pragma stmt; // <----- slicing isn't correct since the... L: x = c1++ ; // <----- ...effect is lost with -print option y = c2 ; } void test7(int c1, int c2) { if (c1 < c2) goto L; c1 = c2 ; //@ slice pragma stmt; // <----- slicing isn't correct since the... L: {x = c1++ ; c2 ++ ;} // <----- ...effect is lost with -print option y = c2 ; } void test8(int c1, int c2) { if (c1 < c2) goto L; c1 = c2 ; //@ slice pragma stmt; // <----- slicing isn't correct since the... { L: x = c1++ ; c2 ++ ;} // <----- ...effect is lost with -print option y = c2 ; } void test9(int c1, int c2) { if (c1 < c2) goto L; c1 = c2 ; //@ slice pragma stmt; // <----- slicing isn't correct since the... { x = c1 ; L: c2 = c2 + 1 ;} // <----- ...effect is lost with -print option y = c2 ; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/mark_all_slices.ml������������������������������������������0000644�0001750�0001750�00000004735�12155630261�022257� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* ledit bin/toplevel.top -deps tests/slicing/mark_all_slices.c #use "tests/slicing/select.ml";; ou #use "tests/slicing/mark_all_slices.ml";; *) include LibSelect;; let main _ = (* we are interesting in having several slices, * so use mode PreciseSlices *) (* SlicingKernel.Mode.Calls.set 3; *) (*~~~~~~~~~~~~ Project 1 : *) let project = mk_project () in let kf_main = Globals.Functions.find_def_by_name "main" in let kf_all = Globals.Functions.find_def_by_name "all" in (* create main_1 and select A2 in it *) let ff_main = !S.Slice.create project kf_main in let select = select_data "A2" project kf_main in !S.Request.add_slice_selection_internal project ff_main select; !S.Request.apply_all_internal project; extract_and_print project; (* add a global selection in 'all' to always compute its result. * This should modify the existing slice (all_1) * *) let select = select_retres project kf_all in !S.Request.add_selection_internal project select; !S.Request.apply_next_internal project; print_requests project; !S.Request.apply_all_internal project; extract_and_print project; (* select B2 in main_1 : this should create a second slice all_2 * and its result should be computed even if it is not needed by this request *) let select = select_data "B2" project kf_main in !S.Request.add_slice_selection_internal project ff_main select; !S.Request.apply_next_internal project; print_requests project; !S.Request.apply_all_internal project; extract_and_print project; (*~~~~~~~~~~~~ Project 2 : *) let project = mk_project () in let kf_main = Globals.Functions.find_def_by_name "main" in let kf_all = Globals.Functions.find_def_by_name "all" in (* first all the global selection in 'all' to always compute its result. * This creates a first all_1 slice : I am not sure that this should be done. * *) let select = select_retres project kf_all in !S.Request.add_selection_internal project select; !S.Request.apply_next_internal project; print_requests project; !S.Request.apply_all_internal project; extract_and_print project; (* create main_1 and select A2 in it : this will create a new slice for all * that computes A and the result. *) let ff_main = !S.Slice.create project kf_main in let select = select_data "A2" project kf_main in !S.Request.add_slice_selection_internal project ff_main select; !S.Request.apply_all_internal project; extract_and_print project let () = Db.Main.extend main �����������������������������������frama-c-Fluorine-20130601/tests/slicing/anim.ml�����������������������������������������������������0000644�0001750�0001750�00000003324�12155630261�020050� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* * Small example to view graphically the building process of a slicing project. * To try it, use the following commands : make tests/slicing/anim.byte; \ tests/slicing/anim.byte -deps -lib-entry -main g -slicing-level 3 -slice-callers \ tests/slicing/select_return_bis.c *) (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) let add_select_fun_calls project kf = let selections = Db.Slicing.Select.empty_selects in let selections = !Db.Slicing.Select.select_func_calls_into selections ~spare:false kf in !Db.Slicing.Select.iter_selects_internal (fun s -> !Db.Slicing.Request.add_selection_internal project s) selections (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) let main _ = let proj_name = "slicing_project" in let project = !Db.Slicing.Project.mk_project proj_name in let n = 0 in let title = "Before start" in let n = LibAnim.print_proj proj_name title project n in let kf_send = Globals.Functions.find_by_name "send" in add_select_fun_calls project kf_send; let title = "Select 'send' calls" in let n = LibAnim.print_proj proj_name title project n in let title = "Apply : " ^ title in let n = LibAnim.build_all_graphs proj_name title project n in let kf_send_bis = Globals.Functions.find_by_name "send_bis" in add_select_fun_calls project kf_send_bis; let title = "Select 'send_bis' calls" in let n = LibAnim.print_proj proj_name title project n in let title = ("Apply : "^title) in let _n = LibAnim.build_all_graphs proj_name title project n in LibAnim.print_help proj_name;; (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) let () = Db.Main.extend main ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/unsupported.i�����������������������������������������������0000644�0001750�0001750�00000000250�12155630261�021327� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -slice-return main -journal-disable -then-on 'Slicing export' -print -check */ int main() { int t[10] = {0, 1, 2}; return t[5]+t[2]; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/top.c�������������������������������������������������������0000644�0001750�0001750�00000001053�12155630261�017535� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config * 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 * * * * * * */ int uncalled (int x) { return x+1; } int strlen(char* p ) { char* q ; int k = 0; for (q = p; *q ; q++) k++ ; return k; } int main (char *p_str[], int i ) { return strlen (p_str[i]); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts1248.i���������������������������������������������������0000644�0001750�0001750�00000000302�12155630261�020044� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -slice-rd x -main f -slicing-project-name p -then-on 'p export' -val */ int f(void) { int x = 0; return x; // <- cannot be selected since x is a local variable } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/ptr_fct.c���������������������������������������������������0000644�0001750�0001750�00000000610�12155630261�020372� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -main h -slice-return h -slicing-level 1 -journal-disable -then-on 'Slicing export' -print */ int X ; typedef void (*PTF)(int); void f1(int x) { X = x ; } void f2 (int y) ; /* no source */ PTF ptf = 0 ; void g(int arg) { ptf = (arg > 0 ? &f1 : &f2) ; (*ptf)(arg) ; } PTF h (int a, int b) { if (b) { ptf = &g; (*ptf)(a); } return ptf; } ������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/unitialized.c�����������������������������������������������0000644�0001750�0001750�00000001456�12155630261�021263� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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 */ #include "share/libc/stdio.h" int X1, X2 ; void f1() { int x1; x1 = 123; X1 = x1 ; } void f2() { int x2; x2 = 12345; X2 = x2 ; } int g() { int y ; /* Note: y is not initialised by g. */ /* Note: GCC without optimization gives X1 == y. */ printf ("%d\n", y); //@slice pragma expr y ; //@assert X1 == y ; return y; } main() { int r; f1(); f2(); r = g(); /* Note: GCC without optimization gives X2 != y. */ //@assert X2 != r ; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts0184.c���������������������������������������������������0000644�0001750�0001750�00000000353�12155630261�020042� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -slice-pragma x -journal-disable **/ int x(int y, int z) { /*@ slice pragma expr y == 1; */ //@ assert y == 1; //@ assert y + z == 3; return y; } int main() { return 0; } int z1() { return x(2,2); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/merge.ml����������������������������������������������������0000644�0001750�0001750�00000006167�12155630261�020233� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* * Small example to test function merge_slices. * To try it, use the following commands : make tests/slicing/merge.byte; \ tests/slicing/merge.byte -deps -lib-entry g -slicing-level 3 \ tests/slicing/merge.c *) (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) include LibSelect;; let main _ = let proj_name = "slicing_merge" in let project = mk_project () in let kf_init = Globals.Functions.find_def_by_name "init" in let _kf_add = Globals.Functions.find_def_by_name "add" in let kf_g = Globals.Functions.find_def_by_name "g" in let n = 0 in (* build graphs representation if there is something in [anim_title] *) let build_slice kf data n anim_title apply = let ff = !S.Slice.create project kf in let select = select_data data project kf in let _ = !S.Request.add_slice_selection_internal project ff select in let n = if anim_title = "" then (if apply then !S.Request.apply_all_internal project; n) else LibAnim.build_all_graphs proj_name anim_title project n in n, ff in ignore (LibAnim.print_proj proj_name "Beginning" project n); let n = n+1 in let title = "Select G1 in init" in let n, ff_init1 = build_slice kf_init "G1" n title true in let title = "Select G1 in g" in let n, _ff_g1 = build_slice kf_g "G1" n title true in (* Format.printf "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n";; Format.printf "=== Function g_1 computes G1 and should call init_1 :\n"; !S.Project.export None project;; Format.printf "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n";; *) let n, ff_init2 = build_slice kf_init "G2" n "" true in let n, _ff_init3 = build_slice kf_init "G3" n "" true in let n, _ff_g2 = build_slice kf_g "G2" n "" false in let n, ff_g3 = build_slice kf_g "G3" n "" true in (* Format.printf "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n";; Format.printf "=== g_2 sould call init_2 and g_3, init_3 :\n"; !S.Project.export None project;; Format.printf "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n";; *) ignore (LibAnim.print_proj proj_name "After selections" project n); let n = n+1 in ignore (!S.Request.merge_slices project ff_init1 ff_init2 ~replace:true); let title = "merging init_1 and init_2" in ignore (LibAnim.print_proj proj_name title project n); let n = n+1 in let title = "merging init_1 and init_2" in let n = LibAnim.build_all_graphs proj_name title project n in !S.Slice.remove project ff_init1; !S.Slice.remove project ff_init2; let title = "After removing init_1 and init_2" in ignore (LibAnim.print_proj proj_name title project n); let _n = n+1 in let _ = !S.Request.copy_slice project ff_g3 in extract_and_print project; (* in automatic tests, we remove the generated files. * Change [view_graphs] below to be able to display the graphs *) let view_graphs = false in if view_graphs then LibAnim.print_help proj_name else LibAnim.remove_all_files proj_name ;; (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) let () = Db.Main.extend main ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/variadic.c��������������������������������������������������0000644�0001750�0001750�00000000643�12155630261�020521� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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" ���������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/unravel-variance.c������������������������������������������0000644�0001750�0001750�00000004123�12155630261�022176� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -slice-calls printf1 -journal-disable -float-normal -remove-redundant-alarms -then-on 'Slicing export' -print OPT: -check -slice-calls printf2 -journal-disable -float-normal -remove-redundant-alarms -then-on 'Slicing export' -print OPT: -check -slice-calls printf3 -journal-disable -float-normal -remove-redundant-alarms -then-on 'Slicing export' -print OPT: -check -slice-calls printf4 -journal-disable -float-normal -remove-redundant-alarms -then-on 'Slicing export' -print OPT: -check -slice-calls printf5 -journal-disable -float-normal -remove-redundant-alarms -then-on 'Slicing export' -print */ /* Small example devired from examples given for UNRAVEL tool : */ int scanf (char const *, int * p); int printf1 (char const *, int); int printf2 (char const *, int); int printf3 (char const *, int); int printf4 (char const *, int); int printf5 (char const *, int); #define MAX 1024 main() { float x[MAX]; float var2, var3, var4 ; float var5, var1; float t1, t2; float ssq; float avg; float dev; int i, n; t2 = 0 ; t1 = 0 ; ssq = 0 ; dev = 0; scanf ("%d", &n); for ( i = 0 ; i < n ; i = i + 1) { scanf ("%f", &x[i]); t1 = t1 + x[i]; ssq = ssq + x[i] * x[i]; } avg = t1 / n; var3 = (ssq - n * avg * avg) / (n - 1); var4 = (ssq - t1 * avg) / (n - 1); t1 = t1 * t1 / n; var2 = (ssq - t1 ) / (n - 1); t1 = 0 ; for ( i = 0 ; i < n ; i = i + 1) { dev = x[i] - avg ; t2 = t2 + dev ; t1 = t1 + dev * dev ; } var5 = (t1 - t2 * t2 / n ) / (n -1); var1 = t1 / (n - 1); printf1("variance (one pass, using square of sum): %f \n",var2); printf2("variance (one pass, using average): %f \n",var3); printf3("variance (one pass, using average, sum): %f \n",var4); printf4("variance (two pass, corrected): %f \n",var5); printf5("variance (two pass): %f \n",var1); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts344.c����������������������������������������������������0000644�0001750�0001750�00000001051�12155630261�017754� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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 ; void h(int x); /*@ ensures X == \old(X) + x; */ void k(int x) { X += x ; Y ++ ; } void h(int x) { X += x ; Y ++ ; } void f(int x, ...) { void (*q) (int) = &h; void (*p) (int) = &k; h(x); } int main (int x) { f (1) ; h(2) ; k(3); return X ; } int main_bis (void) { void (*p) (int) = &k; (*p)(1) ; return Y; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/simple_intra_slice.ml���������������������������������������0000644�0001750�0001750�00000007003�12155630261�022767� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* ledit bin/toplevel.top -deps tests/slicing/simple_intra_slice.c \ < tests/slicing/simple_intra_slice.ml *) include LibSelect;; let main _ = let project = mk_project () in let pretty_pdg fmt kf = !Db.Pdg.pretty fmt (!Db.Pdg.get kf) in let apply_all_actions = !S.Request.apply_all_internal in let print_slice = !S.Slice.pretty in let print_fct_stmts kf = Slicing.PrintSlice.print_fct_stmts fmt (project, kf) in let get_fct name = let kf = Globals.Functions.find_def_by_name name in kf in let select_stmt_and_print kf num_stmt = let stmt = get_stmt num_stmt in let mark = !S.Mark.make ~data:true ~addr:true ~ctrl:true in let select = !S.Select.select_stmt_internal kf stmt mark in let ff = !S.Slice.create project kf in let _ = !S.Request.add_slice_selection_internal project ff select in !S.Request.pretty fmt project; apply_all_actions project; print_slice fmt ff in let select_and_print kf select = let ff = !S.Slice.create project kf in let _ = !S.Request.add_slice_selection_internal project ff select in !S.Request.pretty fmt project; apply_all_actions project; print_slice fmt ff in let select_out_data_and_print kf data = let select = select_data data project kf in select_and_print kf select in let select_out0_and_print kf = let select = select_retres project kf in select_and_print kf select in let select_ctrl_and_print kf numstmt = let select = select_ctrl numstmt project kf in select_and_print kf select in let print_outputs fct_name = let fct = Globals.Functions.find_by_name fct_name in let outs = !Db.Outputs.get_external fct in Format.printf "Sorties de la fonction %s = %a\n" fct_name Locations.Zone.pretty outs in let kf = get_fct "f1" in Format.printf "@[%a@]@\n" pretty_pdg kf; print_fct_stmts kf; select_stmt_and_print kf 3; (* G=x+a; *) let kf = get_fct "f2" in Format.printf "@[%a@]@\n" pretty_pdg kf; print_fct_stmts kf; select_stmt_and_print kf 10; (* c=3; *) let kf = get_fct "f3" in Format.printf "@[%a@]@\n" pretty_pdg kf; print_fct_stmts kf; select_out0_and_print kf; let kf = get_fct "f4" in Format.printf "@[%a@]@\n" pretty_pdg kf; print_fct_stmts kf; select_out0_and_print kf; select_stmt_and_print kf 29; (* G=a; in then branch of if (c>Unknown) *) let kf = get_fct "f5" in print_outputs "f5"; select_out_data_and_print kf "G"; Format.printf "@[%a@]@\n" pretty_pdg kf; print_fct_stmts kf; select_out0_and_print kf; select_ctrl_and_print kf 41; (* 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 VP 2012-04-09 sid for G++ is 44 *) let kf = get_fct "f6" in Format.printf "@[%a@]@\n" pretty_pdg kf; print_fct_stmts kf; select_ctrl_and_print kf 69; (* 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; } else { /* here*/__retres = 10*n; goto return_label; } Fixed ki number for this particular ki. 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 VP 2012-04-09: sid for return_label is 134 *) !S.Project.pretty Format.std_formatter project let () = Db.Main.extend main �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/select_return.c���������������������������������������������0000644�0001750�0001750�00000006516�12155630261�021622� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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; int get (int y) ; void send(int x); void send_bis(int x); int k(int a, int b, int c, int d) { int cond = get (d) ; G = b; H = c; if (cond) send_bis (d); return a; } void g(int b, int c) { int r = k(0,0,c,0); f(b); } int f(int y) { k(0,0,0,0); int r = k(0,y,0,0); int z = k(G,0,0,0); //@ slice pragma expr z; send (z); return z; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/combine.ml��������������������������������������������������0000644�0001750�0001750�00000004452�12155630261�020543� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ open LibSelect;; let f_slice_names kf src_called fnum = let fname = Kernel_function.get_name kf in if (fname = "main") || (fnum = 1 && not src_called) then fname else (fname ^ "_s_" ^ (string_of_int (fnum))) (* To be able to build framac-journal.ml *) let f_slice_names = Journal.register "Combine.f_slice_names" (Datatype.func Kernel_function.ty (Datatype.func Datatype.bool (Datatype.func Datatype.int Datatype.string))) f_slice_names let main _ = let project = mk_project () in let kf_main = Globals.Functions.find_def_by_name "main" in let kf_f = Globals.Functions.find_def_by_name "f" in !S.Project.change_slicing_level project kf_f 2; let ff_main = !S.Slice.create project kf_main in let select = select_retres project kf_main in let _ = !S.Request.add_slice_selection_internal project ff_main select in !S.Request.apply_all_internal project; extract_and_print project; Format.printf "Let's split 'f':@."; let ff_f = match !S.Slice.get_all project kf_f with | f :: [] -> f | _ -> assert false in ignore (!S.Request.split_slice project ff_f); !S.Request.apply_all_internal project; let proj2 = !S.Project.extract "slicing_result" ~f_slice_names project in Project.set_current proj2; Format.printf "After Slicing :@." ; File.pretty_ast (); (* let infos = object inherit Cil.nopCilVisitor method vfunc { svar = v } = Cil.log "function definition of %s (id %d at address %x)@." v.vname v.vid (Obj.magic v); Cil.DoChildren method vvdec v = Cil.log "variable definition of %s (id %d at address %x)@." v.vname v.vid (Obj.magic v); Cil.SkipChildren method vvrbl v = Cil.log "use of %s (id %d at address %x)@." v.vname v.vid (Obj.magic v); Cil.SkipChildren end;; let new_cil_file = Ast.get () in Cil.visitCilFile infos new_cil_file (* the cil file after slicing *);; *) !Db.Value.compute (); let all = Datatype.String.Set.empty in let proj3 = !Db.Constant_Propagation.get all ~cast_intro:true in Project.set_current proj3; Format.printf "After Constant propagation :@."; File.pretty_ast ~prj:proj3 (); let proj4 = !Db.Sparecode.get ~select_annot:true ~select_slice_pragma:true in Format.printf "After Sparecode :@."; File.pretty_ast ~prj:proj4 ();; let () = Db.Main.extend main ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/bts679.i����������������������������������������������������0000644�0001750�0001750�00000000303�12155630261�017774� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -slice-return main -then-on "Slicing export" -print */ void f(void) { return; } int X = 1 ; int main(void) { call: f(); //@ assert X == \at(X,call); return X; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing/slice_no_body.ml��������������������������������������������0000644�0001750�0001750�00000003757�12155630261�021746� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* ledit bin/toplevel.top -deps tests/slicing/slice_no_body.c #use "tests/slicing/select.ml";; *) include LibSelect;; let callers kf = !Db.Value.callers kf (** simple implementation to select every calls to [kf] source function. * The problem of this implementation is that it can generate several slice * for one fonction during propagation to the callers. * See [S.Request.select_fun_calls] for a better implementation. * *) let call_f project kf = let callers = callers kf in let process_caller (kf_caller,_) = let ff_caller = !S.Slice.create project kf_caller in !S.Request.add_call_fun project ~caller:ff_caller ~to_call:kf; prop_to_callers project (kf_caller, ff_caller); in List.iter process_caller callers let slice_on_fun_calls project kf = let table = Cil_datatype.Varinfo.Hashtbl.create 17 in let get_slice kf = let vf = Kernel_function.get_vi kf in try Cil_datatype.Varinfo.Hashtbl.find table vf with Not_found -> let ff = !Db.Slicing.Slice.create project kf in Cil_datatype.Varinfo.Hashtbl.add table vf ff; ff in let rec process_ff_caller ff (kf_caller,_) = let ff_caller = get_slice kf_caller in !Db.Slicing.Request.add_call_slice project ~caller:ff_caller ~to_call:ff; process_ff_callers (kf_caller, ff_caller) and process_ff_callers (kf, ff) = List.iter (process_ff_caller ff) (callers kf) in let process_src_caller kf_to_call (kf_caller,_) = let ff_caller = get_slice kf_caller in !Db.Slicing.Request.add_call_fun project ~caller:ff_caller ~to_call:kf_to_call; process_ff_callers (kf_caller, ff_caller) in List.iter (process_src_caller kf) (callers kf) let main _ = let kf_f = find_kf "f" in let project = mk_project () in call_f project kf_f; print_project project; extract_and_print project; let project = mk_project () in slice_on_fun_calls project kf_f; !S.Request.apply_all_internal project; print_project project; extract_and_print project let () = Db.Main.extend main �����������������frama-c-Fluorine-20130601/tests/syntax/�������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016470� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/oracle/������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017735� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/copy_visitor.i�����������������������������������������������0000644�0001750�0001750�00000000522�12155630251�021367� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-copy" +"-val" */ 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; } int g(int x); int g(int x) { return 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/bts0577.i����������������������������������������������������0000644�0001750�0001750�00000000150�12155630251�017746� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef enum { E1_a, E1_b, E1_c } E1; typedef enum { E2_a = E1_a, E2_b } E2; int f (E2 e) { return e; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/copy_visitor_bts_1073.c��������������������������������������0000644�0001750�0001750�00000000731�12155630251�022705� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/syntax/copy_visitor_bts_1073.ml OPT: -load-script tests/syntax/copy_visitor_bts_1073_bis.ml -test -then-on filtered -print */ int f(int x); int f(int x) { return x; } int g(int y) { return f(2*y); } #include "share/libc/stdio.h" int main (int argc, char * argv[]) { int i; printf ("Hello !\n"); for (i = 0; i < argc; i++) printf ("arg %d : %s\n", i, argv[i]); printf ("Found %d arguments\n", i - 1); return 0; } ���������������������������������������frama-c-Fluorine-20130601/tests/syntax/bts0672_link.c�����������������������������������������������0000644�0001750�0001750�00000000607�12155630251�020760� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/syntax/bts0672_link_2.c" STDOPT: +"tests/syntax/bts0672_link_2.c" +"-cpp-command 'gcc -C -E -DPROTO'" */ int Frama_C_entropy_source; //@ predicate foo(integer x) = \true; /*@ ensures foo(\result); assigns \result \from a,b,Frama_C_entropy_source; assigns Frama_C_entropy_source \from Frama_C_entropy_source; */ int Frama_C_nondet(int a, int b); �������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/get_astinfo_bts1136.i����������������������������������������0000644�0001750�0001750�00000000377�12155630251�022333� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/syntax/get_astinfo_bts1136.ml */ int f (int x) { return x; } int g (int x) { return x; } int h (int x) { return x; } int i() { int y = 0; return y; } int j() { int y = 0; return y; } int k() { int y = 0; return y; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/bts0323.c����������������������������������������������������0000644�0001750�0001750�00000000141�12155630251�017725� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/syntax/bts0323-2.c" */ #include "bts0323.h" void f() { x = 0; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/inserted_casts.ml��������������������������������������������0000644�0001750�0001750�00000000541�12155630251�022031� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������include Plugin.Register (struct let name = "test" let shortname = "test" let help = "unitary test of inserted cast hook" end) let print_warning e ot nt = result "Inserting cast for expression %a of type %a to type %a@." Printer.pp_exp e Printer.pp_typ ot Printer.pp_typ nt; nt ;; Cabs2cil.typeForInsertedCast := print_warning ���������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/vdefined_bts1241.i�������������������������������������������0000644�0001750�0001750�00000000245�12155630251�021604� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/syntax/vdefined_bts1241_1.i" */ int f(); int g() { return 0; } int f() { return 1; } int g(); int h(); int h1() { return h(); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/typedef_multi_1.c��������������������������������������������0000644�0001750�0001750�00000000254�12155630251�021724� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/syntax/typedef_multi.ml tests/syntax/typedef_multi_2.c */ #include "tests/syntax/typedef_multi.h" void f () { while(x<y) x++; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/unroll_visit.i�����������������������������������������������0000644�0001750�0001750�00000000302�12155630251�021363� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-val" +"-deps" +"-out" +"-input" +"-deps" */ void main() { /*@ loop pragma UNROLL 2; */ for(int i=0; i<100; i++) { i--; //@ assert i<100; i++; } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/line_number.c������������������������������������������������0000644�0001750�0001750�00000000062�12155630251�021126� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������//@ assert \result == 0; extern int p(void void); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/loop_annot.i�������������������������������������������������0000644�0001750�0001750�00000000360�12155630251�021006� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-simplify-cfg" +"-keep-switch" STDOPT: +"-simplify-cfg" */ void f() { int i = 0; //@ loop invariant 0 <= i <= 10; while (i < 10) { // @ invariant 0 <= i < 10; ++i; //@ assert 0 <= i <= 10; } } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/inconsistent_decl.c������������������������������������������0000644�0001750�0001750�00000000332�12155630251�022336� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/syntax/inconsistent_decl_2.i" STDOPT: +"tests/syntax/inconsistent_decl_2.i"+"-cpp-extra-args='-DWITH_PROTO'" */ #ifdef WITH_PROTO int f(); #endif int g() { int x = f(2); return x; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/formals_decl_leak.ml�����������������������������������������0000644�0001750�0001750�00000000500�12155630251�022440� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types let check_vi_exists vi _ = try ignore (Globals.Functions.get vi) with Not_found -> Kernel.fatal "%s(%d) has an entry in FormalsDecl, but does not exist in AST" vi.vname vi.vid let run () = let _ = Ast.get () in Cil.iterFormalsDecl check_vi_exists let () = Db.Main.extend run ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/float.i������������������������������������������������������0000644�0001750�0001750�00000000167�12155630251�017750� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ requires f == 0.1f ;*/ void main(float f) { /*@ assert 0xfffffffffffffffff == 0xfffffffffffffffff; */ return; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/undeclared_local_bts1113.c�����������������������������������0000644�0001750�0001750�00000000236�12155630251�023270� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void funk(int rounds) { int k[2*rounds]; int i; for (i = 0; i < 2*rounds; i++) { k[i] = i; } } int main () { funk(17); return 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/get_astinfo_bts1136.ml���������������������������������������0000644�0001750�0001750�00000002606�12155630251�022510� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ let get_formal_variables name = let add_kf_vars kf vars = try let v = Globals.Vars.find_from_astinfo name (Cil_types.VFormal kf) in Format.printf "found variable vid:%d formal in %a@." v.Cil_types.vid Cil_datatype.Kf.pretty kf; v::vars with Not_found -> vars in let vars = Globals.Functions.fold add_kf_vars [] in vars let get_local_variables name = let add_kf_vars kf vars = try let v = Globals.Vars.find_from_astinfo name (Cil_types.VLocal kf) in Format.printf "found variable vid:%d formal in %a@." v.Cil_types.vid Cil_datatype.Kf.pretty kf; v::vars with Not_found -> vars in let vars = Globals.Functions.fold add_kf_vars [] in vars let main () = Ast.compute (); let vars = get_formal_variables "x" in let vars' = get_local_variables "y" in let do_v v = let pp_kind fmt kind = match kind with | Cil_types.VGlobal -> Format.fprintf fmt "global" | Cil_types.VFormal kf -> Format.fprintf fmt "formal in %a" Cil_datatype.Kf.pretty kf | Cil_types.VLocal kf -> Format.fprintf fmt "local in %a" Cil_datatype.Kf.pretty kf in let _, kind = Globals.Vars.get_astinfo v in Format.printf "[do_v] vid:%d %a@." v.Cil_types.vid (* Cil_datatype.Localisation.pretty *) pp_kind kind in List.iter do_v vars; List.iter do_v vars' let () = Db.Main.extend main ��������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/big_local_array_script.ml������������������������������������0000644�0001750�0001750�00000000425�12155630251�023515� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������let foo () = if Project.get_name (Project.current ()) <> "prj" then begin let prj = Project.create "prj" in let () = Project.set_current prj in File.init_from_c_files [File.from_filename "tests/syntax/big_local_array.i"] end let () = Db.Main.extend foo �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/typedef_multi.h����������������������������������������������0000644�0001750�0001750�00000000044�12155630251�021506� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef int WORD; extern WORD x,y; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/enum1.c������������������������������������������������������0000644�0001750�0001750�00000000266�12155630251�017662� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/syntax/enum2.c" */ #include "enum.h" int e1() { return E1; } int f1() { return F11; } int k1() { return K11; } int i1() { return I1; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/bts0323.h����������������������������������������������������0000644�0001750�0001750�00000000066�12155630251�017740� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������extern int x; /*@ ensures x!=0; */ extern void g(); ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/enum_size_array.i��������������������������������������������0000644�0001750�0001750�00000000167�12155630251�022037� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef enum { ONE, TWO, EN_NB} T_E; typedef int T_TAB[EN_NB]; int f_return_last(T_TAB tab) { return tab[EN_NB-1]; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/implicit_args_bts1267.i��������������������������������������0000644�0001750�0001750�00000000157�12155630251�022660� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������extern unsigned short t[100000]; int f(); void main(int i) { unsigned short *p = &t[i]; int s = f(*p); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/bts0769.i����������������������������������������������������0000644�0001750�0001750�00000000146�12155630251�017756� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������struct s { struct {int ui;} _; union foo { int ii; }; } S; int main(){ return S._.ui + S.ii; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/enum.h�������������������������������������������������������0000644�0001750�0001750�00000000204�12155630251�017576� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������enum e {E1, E2}; #ifndef V enum f {F11, F12}; enum {K11, K12}; #else enum f {F21, F22}; enum {K21, K22}; #endif enum { I1, I2}; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/bts0588.i����������������������������������������������������0000644�0001750�0001750�00000000165�12155630251�017756� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������//@ 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); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/bts0916.i����������������������������������������������������0000644�0001750�0001750�00000000553�12155630251�017752� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-keep-comments" */ /* 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 ; */ } } �����������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/logic_env.i��������������������������������������������������0000644�0001750�0001750�00000000224�12155630251�020602� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/syntax/logic_env_script.ml */ //@ predicate foo(integer x) = x == 0; int X; //@ predicate bar{L} = X == 0; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/enum2.c������������������������������������������������������0000644�0001750�0001750�00000000300�12155630251�017650� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is in enum1. */ #define V #include "enum.h" int e2() { return E2; } int f2() { return F22; } int k2() { return K22; } int i2() { return I2; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/duplicated_global_bts1129.i����������������������������������0000644�0001750�0001750�00000000133�12155630251�023457� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void f(int* x); void f(int* x) { *x++; } int X; //@ ensures X==1; void f(int* x); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/lvalvoid.i���������������������������������������������������0000644�0001750�0001750�00000000431�12155630251�020455� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void* memcpy1(void* dst, const void *src,long n) { char* d=dst; char* s=src; for (int i=0;i<n;i++) d[i]=(char)(src[i]); return dst; } void* memcpy2(void* dst, const void *src,long n) { char* d=dst; char* s=src; for (int i=0;i<n;i++) dst[i]=s[i]; return dst; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/rettype.i����������������������������������������������������0000644�0001750�0001750�00000000313�12155630251�020330� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������// This test must be rejected: return type of foo is not // compatible between decl and def. //@ assigns \nothing; int foo(int* p); //@ ensures 0 <= \result < 25; unsigned short foo() { return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/bts0672_link_2.c���������������������������������������������0000644�0001750�0001750�00000000247�12155630251�021201� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is in bts0672_link.c */ #ifdef PROTO int Frama_C_nondet(int a, int b); #endif void main () { int x = Frama_C_nondet(0,59); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/merge_bts0948_2.i��������������������������������������������0000644�0001750�0001750�00000000206�12155630251�021352� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is merge_bts0948.i */ /*@ requires \valid((char*)dest_2); */ extern void *memcpy(void * dest_2); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/bad_return_bts_599.i�����������������������������������������0000644�0001750�0001750�00000000253�12155630251�022242� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ int BadReturn1(int* p) { *p++; return; } int BadReturn2(int* p) { *p++; return; } int main() { int i = 3; BadReturn2(&i); BadReturn1(&i); return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/visit_create_local.ml����������������������������������������0000644�0001750�0001750�00000001741�12155630251�022655� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types open Cil open Format class cF = object(self) inherit Visitor.frama_c_inplace method vstmt s = let fd = (Extlib.the self#current_func) in match s.skind with | Instr (Set (lv,e,loc)) -> let vi = makeLocalVar fd "varbidon" (typeOf e) in let sk = Instr (Set (var vi,new_exp ~loc (Lval lv),loc)) in let s0 = mkStmt ~valid_sid:true sk in ChangeTo (Cil.mkStmtCfgBlock [s0; s]) | _ -> SkipChildren end let run () = Visitor.visitFramacFileSameGlobals (new cF) (Ast.get()); Cfg.clearFileCFG ~clear_id:false (Ast.get()); Cfg.computeFileCFG (Ast.get()) module Computed = State_builder.False_ref (struct let name = "Bidon" let dependencies = [] end) let main () = if not (Computed.get ()) then begin Computed.set true; if not (Ast.is_computed()) then Ast.compute(); let prj = File.create_project_from_visitor "bidon" (fun prj -> new Visitor.frama_c_copy prj) in Project.on prj run (); end let () = Db.Main.extend main �������������������������������frama-c-Fluorine-20130601/tests/syntax/typedef_multi.ml���������������������������������������������0000644�0001750�0001750�00000000127�12155630251�021671� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������let run () = File.reorder_ast (); File.pretty_ast () let () = Db.Main.extend run �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/keep.i�������������������������������������������������������0000644�0001750�0001750�00000000314�12155630251�017561� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef __attribute__((FC_BUILTIN)) int foo; enum __attribute__ ((FC_BUILTIN)) bar { bla, bli }; struct __attribute__ ((FC_BUILTIN)) baz { int x; }; enum discard { a,b,c }; struct discard { int y; }; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/reorder.ml���������������������������������������������������0000644�0001750�0001750�00000004107�12155630251�020463� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types let run () = let file = Ast.get () in let kf = Globals.Functions.find_by_name "f" in let li = Cil_const.make_logic_info "i" in let lj = Cil_const.make_logic_info "j" in let lk = Cil_const.make_logic_info "k" in let ll = Cil_const.make_logic_info "l" in li.l_var_info.lv_type <- Linteger; lj.l_var_info.lv_type <- Linteger; lk.l_var_info.lv_type <- Linteger; ll.l_var_info.lv_type <- Linteger; li.l_type <- Some Linteger; lj.l_type <- Some Linteger; lk.l_type <- Some Linteger; ll.l_type <- Some Linteger; li.l_body <- LBterm (Logic_const.term (TBinOp (PlusA, Logic_const.term (Tapp(lj,[],[])) Linteger, Logic_const.term (Tapp(lk,[],[])) Linteger)) Linteger); lj.l_body <- LBterm (Logic_const.term (Tapp(ll,[],[])) Linteger); lk.l_body <- LBterm (Logic_const.term (Tapp(ll,[],[])) Linteger); ll.l_body <- LBterm (Logic_const.tinteger 1); let post_cond = [Normal, Logic_const.new_predicate (Logic_const.prel (Req, Logic_const.term (Tapp(li,[],[])) Linteger, Logic_const.term (Tapp(li,[],[])) Linteger))] in let bhv = Cil.mk_behavior ~post_cond () in Annotations.add_behaviors Emitter.end_user kf [ bhv ]; let loc = Cil_datatype.Location.unknown in let dli = Dfun_or_pred (li,loc) in let dlj = Dfun_or_pred (lj,loc) in let dlk = Dfun_or_pred (lk,loc) in let dll = Dfun_or_pred (ll,loc) in Annotations.add_global Emitter.end_user dli; Annotations.add_global Emitter.end_user dlj; Annotations.add_global Emitter.end_user dlk; Annotations.add_global Emitter.end_user dll; file.globals <- file.globals @ [ GAnnot (dli,loc); GAnnot (dlj,loc); GAnnot (dll, loc); GAnnot (dlk,loc) ]; Logic_utils.add_logic_function li; Logic_utils.add_logic_function lj; Logic_utils.add_logic_function lk; Logic_utils.add_logic_function ll; File.pretty_ast (); File.reorder_ast (); File.pretty_ast (); Visitor.visitFramacFileSameGlobals (new File.check_file "reordered") (Ast.get()) let () = Db.Main.extend run ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/one_ret_assert.i���������������������������������������������0000644�0001750�0001750�00000000243�12155630251�021652� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int X; void f(void) { X++; } int g(void) { X++; } int h(void) { if (X) { return 3; } else { return 4; } } int main() { X = h(); f(); return g(); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/array_cast_bts1099.i�����������������������������������������0000644�0001750�0001750�00000000147�12155630251�022164� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef int t[10]; typedef int u[4]; void main () { int tab1[4]; u* p = &tab1; t* p2 = (t) p; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/reorder.i����������������������������������������������������0000644�0001750�0001750�00000000324�12155630251�020300� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/syntax/reorder.ml */ int x; void f() { x++; } /*@ axiomatic Ax { @ predicate Q (integer v); @ } @*/ //@ requires Q: \let v = Q(255); !(!v||v) ; void g (void); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/forloophook.i������������������������������������������������0000644�0001750�0001750�00000000154�12155630251�021200� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/syntax/forloophook.ml */ void f() { for (int i=0; i< 10; i++); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/syntactic_hook.i���������������������������������������������0000644�0001750�0001750�00000001235�12155630251�021661� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-load-script tests/syntax/syntactic_hook.ml" */ int f(void); 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; } int f(int); //warns conflicting decls �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/syntactic_hook.ml��������������������������������������������0000644�0001750�0001750�00000004505�12155630251�022044� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cabsvisit open Cabshelper open Logic_ptree open Cil_types open Cil open Cabs open Lexing class visit = object inherit nopCabsVisitor method vstmt s = let loc = get_statementloc s in ChangeTo [{ stmt_ghost = false; stmt_node = CODE_ANNOT( AAssert([], { lexpr_node = PLat ({ lexpr_node = PLtrue; lexpr_loc = loc},"Pre"); lexpr_loc = loc}), loc)}; s] end let visitor = new visit;; Frontc.add_syntactic_transformation (Cabsvisit.visitCabsFile visitor);; let warn_pure_exp f e = let loc = e.eloc in Kernel.warning ~source:(fst loc) "[SH]: function %s, pure expression %a is dropped" f (Printer.pp_exp) e ;; Cabs2cil.register_ignore_pure_exp_hook warn_pure_exp;; let warn_proto vi = Kernel.warning ~source:(fst vi.vdecl) "[SH]: implicit declaration for prototype %a" (Format.pp_print_string) vi.vname ;; Cabs2cil.register_implicit_prototype_hook warn_proto ;; let warn_conflict oldvi vi reason = Kernel.warning ~source:(fst vi.vdecl) "[SH]: conflict with declaration of %a at line %d: %s" Format.pp_print_string vi.vname (fst oldvi.vdecl).pos_lnum reason ;; Cabs2cil.register_incompatible_decl_hook warn_conflict;; let warn_distinct oldvi vi = Kernel.warning ~source:(fst vi.vdecl) "[SH]: definition of %a does not use exactly the same prototype as \ declared on line %d" Format.pp_print_string vi.vname (fst oldvi.vdecl).pos_lnum ;; Cabs2cil.register_different_decl_hook warn_distinct;; let warn_local_func vi = Kernel.warning ~source:(fst vi.vdecl) "[SH]: definition of local function %a" Format.pp_print_string vi.vname ;; Cabs2cil.register_local_func_hook warn_local_func;; let warn_drop_effect olde e = Kernel.warning ~source:(fst e.eloc) "[SH]: dropping side effect in sizeof: %a is converted to %a" Cprint.print_expression olde Printer.pp_exp e ;; Cabs2cil.register_ignore_side_effect_hook warn_drop_effect let warn_cond_effect orig e = 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" Cprint.print_expression e Cprint.print_expression orig ;; Cabs2cil.register_conditional_side_effect_hook warn_cond_effect �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/local_uninitialized_bts_1081.i�������������������������������0000644�0001750�0001750�00000000304�12155630251�024177� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int X,Y,FOO; main(){ int foo, x, y; foo ? x : y; // should be kept foo ? X : y; // should be kept foo ? X : Y; // only foo should be kept FOO ? X : Y; // should disappear return 0; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/type_branch_bts_1081.i���������������������������������������0000644�0001750�0001750�00000000305�12155630251�022454� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������main(){ int foo, x, y; foo ? (void)x : (signed char)y; // accepted (we drop the expressions, don't care about their types) int z = foo ? (void)x: (signed char)y; // rejected return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/enum_call.i��������������������������������������������������0000644�0001750�0001750�00000000223�12155630251�020573� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef enum E { C0, C1, C2 }; void f(enum E const); void f1(enum E); void g() { f((enum E) C0); f1((enum E)C2); } void h() { f(C1); f1(C0); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/Enum_repr.ml�������������������������������������������������0000644�0001750�0001750�00000001105�12155630251�020750� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types let warn_cast = let typeForInsertedCast = !Cabs2cil.typeForInsertedCast in fun e t1 t2 -> Kernel.feedback ~source:(fst e.eloc) "Inserted implicit cast from %a to %a" Printer.pp_typ t1 Printer.pp_typ t2; typeForInsertedCast e t1 t2 let () = Cabs2cil.typeForInsertedCast := warn_cast let run () = let f = Ast.get () in let output = function | GEnumTag(e,_) -> Kernel.feedback "Enum %s is represented by %a@." e.ename Printer.pp_ikind e.ekind | _ -> () in List.iter output f.globals let () = Db.Main.extend run �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/copy_logic.i�������������������������������������������������0000644�0001750�0001750�00000000512�12155630251�020764� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-copy" +"-val" */ /*@ predicate p(int x); */ /*@ predicate q(int x) = x == 42; */ /*@ logic int f (int y); */ /*@ logic integer g (int x) = x + 42; */ /*@ frees x; */ void f(int *x); int main (int x) { int y = 42; /*@ assert q(y) && p(x); */ y+=x; /*@ assert g(x) == f(y); */ return 0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/result/������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020006� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/big_local_array.i��������������������������������������������0000644�0001750�0001750�00000000645�12155630251�021755� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-load-module lib/plugins/Report" +"-val -report" OPT: -load-module lib/plugins/Report -load-script tests/syntax/big_local_array_script.ml -then-on prj -print -report STDOPT: +"-no-initialized-padding-locals -val" */ struct S { int a[50]; int b[32]; }; int main () { struct S x[32] = { [0] = { .a = { 1,2,3 }, .b = { [5] = 5, 6, 7 }}, [3] = { 0,1,2,3,.b = { [17]=17 } } }; } �������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/simp_switch.i������������������������������������������������0000644�0001750�0001750�00000000145�12155630251�021170� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-simplify-cfg" */ void main() { switch(0) { case 0: break; } } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/unspecified_access_call_bts0888.i����������������������������0000644�0001750�0001750�00000000353�12155630251�024652� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-unspecified-access" */ int f(int); main(){ int x,y,z; x = f(x=2); // not unspecified y = (x=f(y=2))+(z=3); // not unspecified z = (x=f(y=2))+y; // unspecified y = (x=f(y=2))+(y=3); // unspecified } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/bts59.i������������������������������������������������������0000644�0001750�0001750�00000000152�12155630251�017603� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������float g() { double __retres=2; int first = 6; { int first = 5 ; return __retres; } } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/inconsistent_decl_2.i����������������������������������������0000644�0001750�0001750�00000000210�12155630251�022560� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is at tests/syntax/inconsistent_decl.c */ int f(double x); int h() { int x = f(2.0); return x; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/bts0323-2.c��������������������������������������������������0000644�0001750�0001750�00000000151�12155630251�020065� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is in bts0323.c */ #include "bts0323.h" int x = 1; void g() { x =2;} �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/bts0442.i����������������������������������������������������0000644�0001750�0001750�00000000122�12155630251�017734� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/syntax/bts0442-2.i" */ enum E { E1=1, E2=2} ve2=E2; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/vdefined_bts1241_1.i�����������������������������������������0000644�0001750�0001750�00000000152�12155630251�022021� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test at tests/syntax/vdefined_bts1241.i */ int f(); int h() { return f(); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/visit_create_local.i�����������������������������������������0000644�0001750�0001750�00000000176�12155630251�022476� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/syntax/visit_create_local.ml -then-on bidon -print */ void main() { int x,y; x = y; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/spurious_brace_bts_1273.i������������������������������������0000644�0001750�0001750�00000000043�12155630251�023205� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void foo() { } } void main () { } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/orig_name.i��������������������������������������������������0000644�0001750�0001750�00000000230�12155630251�020572� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-orig-name" */ int x = 1; int f(int x) { int y = 0; if (x == 0) { int x = 3; y = x++; } y += x; return y; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/logic_env_script.ml������������������������������������������0000644�0001750�0001750�00000001631�12155630251�022351� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types let emitter = Emitter.create "test" [ Emitter.Global_annot ] ~correctness:[] ~tuning:[] let add () = let li = Cil_const.make_logic_info "bla" in li.l_body <- LBpred Logic_const.ptrue; let glob = Dfun_or_pred (li,Cil_datatype.Location.unknown) in Logic_utils.add_logic_function li; Annotations.add_global emitter glob let check () = assert (Logic_env.find_all_logic_functions "foo" <> []); assert (Logic_env.find_all_logic_functions "bar" <> []); assert (Logic_env.find_all_logic_functions "bla" <> []); let x = List.hd (Logic_env.find_all_logic_functions "bar") in let lv = x.l_var_info in assert (x == Logic_env.find_logic_cons lv); Format.printf "Check OK@." let run () = let _ = Ast.get () in add (); check (); let prj = File.create_project_from_visitor "foo" (fun p -> new Visitor.frama_c_copy p) in Project.on prj check () let () = Db.Main.extend run �������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/merge_bts0948.i����������������������������������������������0000644�0001750�0001750�00000000331�12155630251�021130� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/syntax/merge_bts0948_1.i" +"tests/syntax/merge_bts0948_2.i" */ /*@ requires \valid((char*)dest); */ extern void *memcpy(void * dest); void* memcpy(void* region1) { return region1; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/undeclared_local_bts1126.c�����������������������������������0000644�0001750�0001750�00000002647�12155630251�023304� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ typedef struct gnutls_session_t { int f; } gnutls_session_t; typedef void(*gnutls_cipher_algorithm_t)(int); typedef void(*gnutls_mac_algorithm_t)(int); #define GNUTLS_CIPHER_UNKNOWN 0 #define GNUTLS_MAC_UNKNOWN 0 #define GNUTLS_E_INTERNAL_ERROR 0 #define GNUTLS_E_UNWANTED_ALGORITHM 0 typedef struct record_parameters_st { int initialized; gnutls_cipher_algorithm_t cipher_algorithm; gnutls_mac_algorithm_t mac_algorithm; } record_parameters_st; typedef struct cipher_suite_st { int a; } cipher_suite_st; int _gnutls_epoch_set_cipher_suite (gnutls_session_t session, int epoch_rel, cipher_suite_st * suite) { gnutls_cipher_algorithm_t cipher_algo; gnutls_mac_algorithm_t mac_algo; record_parameters_st *params; int ret; ret = _gnutls_epoch_get (session, epoch_rel, ¶ms); if (ret < 0) return gnutls_assert_val (ret); if (params->initialized || params->cipher_algorithm != GNUTLS_CIPHER_UNKNOWN || params->mac_algorithm != GNUTLS_MAC_UNKNOWN) return gnutls_assert_val (GNUTLS_E_INTERNAL_ERROR); cipher_algo = _gnutls_cipher_suite_get_cipher_algo (suite); mac_algo = _gnutls_cipher_suite_get_mac_algo (suite); if (_gnutls_cipher_is_ok (cipher_algo) != 0 || _gnutls_mac_is_ok (mac_algo) != 0) return gnutls_assert_val (GNUTLS_E_UNWANTED_ALGORITHM); params->cipher_algorithm = cipher_algo; params->mac_algorithm = mac_algo; return 0; } �����������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/add_allocates.ml���������������������������������������������0000644�0001750�0001750�00000000072�12155630251�021575� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������let () = Db.Main.extend Allocates.add_allocates_nothing ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/add_allocates.i����������������������������������������������0000644�0001750�0001750�00000000521�12155630251�021414� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/syntax/add_allocates.ml -print */ int x; void f(); //@ allocates x; void g(); //@ behavior b: requires \false; allocates x; void main(int c) { f(); while (c) { //@ loop allocates x; while (1) { while (!c); } //@ for b: loop allocates x; while (1) { } } } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/formals_decl_leak_1.i����������������������������������������0000644�0001750�0001750�00000000170�12155630251�022503� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is located in tests/syntax/formals_decl_leak.i */ void f(int y); void h () { f(4); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/formals_decl_leak.i������������������������������������������0000644�0001750�0001750�00000000232�12155630251�022262� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -print -load-script tests/syntax/formals_decl_leak.ml tests/syntax/formals_decl_leak_1.i */ void f(int x); void g() { f(3); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/unspecified_access_if_bts01114.i�����������������������������0000644�0001750�0001750�00000000201�12155630251�024364� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-unspecified-access" */ int x, *p; main(){ p = &x; *p = (*p < 3); if (*p = (*p < 3)) x = 4; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/copy_visitor_bts_1073.ml�������������������������������������0000644�0001750�0001750�00000001644�12155630251�023077� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types open Cil class vis prj = object(self) inherit Visitor.frama_c_copy prj method vglob_aux g = match g with | GFun (f,loc) -> let my_kf = Extlib.the self#current_kf in let f1 = Visitor.visitFramacFunction (self:>Visitor.frama_c_visitor) f in let v2 = Cil.copyVarinfo f.svar (f.svar.vname ^ "1") in Cil.set_varinfo self#behavior (Cil.get_original_varinfo self#behavior f.svar) v2; Cil.reset_behavior_fundec self#behavior; Cil.reset_behavior_stmt self#behavior; let f2 = Visitor.visitFramacFunction (self:>Visitor.frama_c_visitor) f in f2.svar <- v2; self#set_current_kf my_kf; ChangeTo ([GFun(f1,loc); GFun(f2,loc)]) | _ -> DoChildren end let run () = let prj = File.create_project_from_visitor "prj" (fun prj -> new vis prj) in File.pretty_ast ~prj () let () = Db.Main.extend run ��������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/arg_type.i���������������������������������������������������0000644�0001750�0001750�00000000204�12155630251�020445� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������// GCC allows such things int f(int); int f(x) short x; { return x; } // but not that int g(int); int g(short x) { return x; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/dowhilezero.c������������������������������������������������0000644�0001750�0001750�00000001374�12155630251�021171� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* Simplification do {...} while(0) into {...}. Deactivated for now, as plugins that read both the Cabs and the Cil may become desynchronized */ void f1() { //@ loop invariant \true; do { int x = 1; int y = 2; } while(0); } void f2() { do { int x = 1; int y = 2; break; } while(0); } void f3() { do { int x = 1; int y = 2; continue; } while(0); } void f4(int c) { do { int x = 1; int y = 2; } while(c); } /* Functions below are simplified */ void f5() { do { int x = 1; int y = 2; } while(0); } void f6() { do { int x = 1; int y = 2; while (1) { continue; break; } } while(0); } void f7() { do { int x = 1; int y = 2; } while((int *)0); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/bts0519.c����������������������������������������������������0000644�0001750�0001750�00000000353�12155630251�017741� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-cpp-command='gcc -C -E -I.'" STDOPT: +"-cpp-command='gcc -C -E -I. -DERR'" */ int t[4]; #ifdef ERR int q[static 3]; #endif void f(int a[static 3]) { a[2] = 3; } int main () { f(t); return 0; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/dangling_else.i����������������������������������������������0000644�0001750�0001750�00000000665�12155630251�021441� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ requires x >= 0; */ int g(int x); void main() { int c, x; if (c) { { if (c) { x = 1; };} } else { if (c) { if (c) x = 1; } else x = 2; } } int f(int a, int b, int c, int d) { int ret; ret=0; if (a) { if (b) {ret=1;} else if (c) {ret=2;} } else {if (d) {ret=4;}} if (a) {{{{/*@ assert ret >= 0; */ ret = 5; }}}} else ret = 6; if (a) g(a); else g(a); // double GUI-bullets return ret; } ���������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/unroll_labels.i����������������������������������������������0000644�0001750�0001750�00000002603�12155630251�021475� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-val" STDOPT: +"-val" +"-main main2" +"-slevel 3" */ enum { SIX = 6 } ; volatile foo; void main () { int j = 0; /*@ loop pragma UNROLL "completely", 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; } } { int x = 0; L: //@ loop pragma UNROLL 3; while(x<5) { int y=0; x++; y++; }; } j = 0; //@ loop pragma UNROLL SIX; while(foo) { switch(j) { case -1: j++; break; case 0: //@ loop pragma UNROLL 3; while (j<5) {j++;} break; case 5: j = -1; break; default: return; } } { if (j==0) goto zero; if (j==1) goto un; return; zero: //@ loop pragma UNROLL 3; while (j<5) { un: j++;} } } void main2 () { /*@ loop pragma UNROLL 2; */ for (int i=0;i<2;i++) { for (int j=0;j<2;j++){ i += 1; goto foo; i += 1; foo: } } } void main3 (int c) { int i=0; if (c == 0) goto foo; /*@ loop pragma UNROLL 2; */ for (;i<5;i++) { int j = 0 ; if (i == j) goto foo; if (i == 1) break; if (i == 2) continue; for (;j<5;j++){ if (i == j) break; if (i < j) goto foo; if (i == j+1) continue; if (i == j+2) goto up; i += 1; foo: i += 1; } up: } } �����������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/libc.c�������������������������������������������������������0000644�0001750�0001750�00000000173�12155630251�017543� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-cpp-extra-args='-nostdinc -Ishare/libc'" */ #define __FC_REG_TEST #include "fc_posix_runtime.c" �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/ptr_null_cmp_bts1027.i���������������������������������������0000644�0001750�0001750�00000000301�12155630251�022511� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ behavior normal: assumes r && !x; ensures \result == 0; behavior f: assumes !r || x; ensures \result == -1; */ int max(int *r, double x) { if (!r || x) return -1; return 0; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/func_spec_merge.i��������������������������������������������0000644�0001750�0001750�00000000200�12155630251�021753� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int f() { return 3; } int g () { return 4; } /*@ requires p == &f || p == &g; */ int main (int (*p)(void)) { return (*p)(); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/inserted_casts.c���������������������������������������������0000644�0001750�0001750�00000000347�12155630251�021647� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-load-script tests/syntax/inserted_casts" */ int f(int b) { int r; if (b*b != 0) r=0; else r=-1; return r; } int g(int a) { unsigned int r; r = a + 3; a *= r; return (a - r); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/ghost_lexing.i�����������������������������������������������0000644�0001750�0001750�00000000265�12155630251�021334� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/copy_visitor_bts_1073_bis.ml���������������������������������0000644�0001750�0001750�00000003613�12155630251�023732� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(*============================================================================*) module P = Plugin.Register (struct let name = "Testing plugin" let shortname = "test" let help = "Just to test Filter..." end) module Opt = P.False (struct let option_name = "-test" let help = "switch the plug-in on" end) (*============================================================================*) module Visi = struct exception EraseAssigns exception EraseAllocation type fct = unit type proj = unit let fct_name vf _fi = vf.Cil_types.vname let fct_info () _ = [ () ] let param_visible _ _ = true let body_visible _fi = true let loc_var_visible _ _ = true let inst_visible _ _ = true let label_visible _ _ _ = true let annotation_visible _ _ _ = true let fun_precond_visible _ _ = true let fun_postcond_visible _ _ = true let fun_variant_visible _ _ = true let fun_frees_visible _ _ = true let fun_allocates_visible _ _ = true let fun_assign_visible _ _ = true let fun_deps_visible _ _ = true let called_info _ _ = None let res_call_visible _ _ = true let result_visible _ _ = true let cond_edge_visible _ _ = true, true end (*============================================================================*) let main () = if Opt.get () then begin let _ast = Ast.get () in P.feedback "start compute"; let new_proj_name = "filtered" in let module Transform = Filter.F (Visi) in let new_prj = Transform.build_cil_file new_proj_name () in Project.on new_prj Opt.clear (); P.feedback "exported in new project : %s" new_proj_name end let () = Db.Main.extend main (*============================================================================*) ���������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/multi_dim_array_decay_bts1142.i������������������������������0000644�0001750�0001750�00000000162�12155630251�024344� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������struct P { int val[2][2]; }; int main() { struct P* pp; struct P p; pp = &p; *(pp->val); *(p.val); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/forloophook.ml�����������������������������������������������0000644�0001750�0001750�00000001554�12155630251�021365� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cabs let () = Cabs2cil.register_for_loop_all_hook (fun _ _ _ _ -> Format.printf "Found a for loop@.") let () = Cabs2cil.register_for_loop_init_hook (fun fc -> match fc with | FC_EXP _ -> Format.printf "No declaration@." | FC_DECL _ -> Format.printf "Local declaration@.") let () = Cabs2cil.register_for_loop_test_hook (fun e -> match e.expr_node with | NOTHING -> Format.printf "No test@." | _ -> Format.printf "Has a test@.") let () = Cabs2cil.register_for_loop_incr_hook (fun e -> match e.expr_node with | NOTHING -> Format.printf "No increment@." | _ -> Format.printf "Has an increment@.") let () = Cabs2cil.register_for_loop_body_hook (fun s -> match s.stmt_node with | NOP _ -> Format.printf "No body@." | _ -> Format.printf "Has a body@.") ����������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/enum_repr.i��������������������������������������������������0000644�0001750�0001750�00000001143�12155630251�020632� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/syntax/Enum_repr.cmxs OPT: -load-module tests/syntax/Enum_repr.cmxs -enums int -print -check OPT: -load-module tests/syntax/Enum_repr.cmxs -enums gcc-short-enums -print -check OPT: -load-module tests/syntax/Enum_repr.cmxs -enums gcc-enums -print -check */ typedef enum { A = 3 } foo; typedef enum __attribute__((packed)) { B = 6 } bar; int main () { foo x = A; bar y = B; if (x==A && y == B) { return 0; } return 1; } typedef unsigned int bla; int f(bla x); int g() { foo x = A; int res = f((bla) x); res+= f((unsigned int) x); res+= f(x); return res; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/typedef_multi_2.c��������������������������������������������0000644�0001750�0001750�00000000267�12155630251�021731� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is at tests/syntax/typedef_multi_1.c */ #include "tests/syntax/typedef_multi.h" void g() { /*@ loop invariant x<=(3+2); */ while (x<y) x++; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/reject_use_decl_mismatch_bts728.c����������������������������0000644�0001750�0001750�00000000650�12155630251�024747� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-cpp-extra-args='-DHAS_PROTO'" STDOPT: +"-cpp-extra-args='-DNO_PROTO'" */ #ifdef HAS_PROTO int f(); #endif int G; int H; int main () { int T=99; H= f(2); return T; /* gcc -O0 -> 26; gcc -O3 -> 99 */ } int f(int x,int y, int z, int t,int t1,int t2,int t3,int t4,int t5,int t6) { x = 17; y=18; z=19; t=20; t1= 21; t2 = 22; t3 = 23; t4= 24; t5 = 25; t6 = 26; return x; } ����������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/merge_bts0948_1.i��������������������������������������������0000644�0001750�0001750�00000000206�12155630251�021351� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is merge_bts0948.i */ /*@ requires \valid((char*)dest_1); */ extern void *memcpy(void * dest_1); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/syntax/bts0442-2.i��������������������������������������������������0000644�0001750�0001750�00000000154�12155630251�020100� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/syntax/bts0442.i" */ enum E { E0=0, E1=1} ve1=E1; void f (void) { ve1=E0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/���������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016075� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bug0196.c������������������������������������������������������0000644�0001750�0001750�00000000377�12155630321�017340� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*run.config STDOPT: +"-simplify-cfg" +"-check" +"-print" */ int fact(int n) { int r = 1 ; while ( n > 0 ) { //@ assert n > 0 ; before: r *= n-- ; //@ assert r == \at(r*n,before) ; } return r ; } int main () { return fact(3); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/switch_cast.i��������������������������������������������������0000644�0001750�0001750�00000001460�12155630321�020556� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������extern unsigned char x; void g() { int y; x = x / 16; switch((int)x) { case 0: y = x; break; case 1: y = x * 2; break; case 2: y = x * 3; break; case 3: y = x * 4; break; case 4: y = x * 5; break; case 5: y = x * 6; break; case 6: y = x * 7; break; case 7: y = x * 8; break; case 8: y = x * 9; break; case 9: y = x * 10; break; case 10: y = x * 11; break; case 11: y = x * 12; break; case 12: y = x * 13; break; case 13: y = x * 14; break; case 14: y = x * 15; break; case 15: y = x * 16; break; case 16: y = x * 17; break; case 17: y = x * 18; break; default: } y += 1; Frama_C_show_each(y); } void main() { g(); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/test.i���������������������������������������������������������0000644�0001750�0001750�00000001053�12155630321�017220� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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]; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/oracle/��������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017342� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/logtrap.ml�����������������������������������������������������0000644�0001750�0001750�00000000315�12155630321�020071� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/non_iso_initializer.i������������������������������������������0000644�0001750�0001750�00000000136�12155630321�022311� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int G0 = 42; int G1 = G0>>1; int G2 = G0 ^ G1 ; int G3 = -1; void main (void) { G3=G0+G2; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/big_lib_entry.i������������������������������������������������0000644�0001750�0001750�00000000714�12155630321�021054� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -lib-entry -context-width 4 */ typedef struct { int f1; float f2; char f3; // padding char* f4; char f5; // trailing padding } ts; struct { char c1; ts tcs[10]; char c2; } s; typedef struct { int f1; const int f2; } ss; typedef struct { double f1; double f2; } ds; int* t1[5000000]; int t2[5000000]; ts t3[1000]; char t4[5000000]; int* t5[3]; // test big context-width ds t6[5000000]; void main () { } ����������������������������������������������������frama-c-Fluorine-20130601/tests/misc/div_strange.i��������������������������������������������������0000644�0001750�0001750�00000000113�12155630321�020542� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int main() { int x = -1; x /= sizeof(unsigned int); CEA_F(x); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/folding.i������������������������������������������������������0000644�0001750�0001750�00000000676�12155630321�017675� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/semaphore.i����������������������������������������������������0000644�0001750�0001750�00000001010�12155630321�020215� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -memory-footprint 1 -val -deps -out -input -main g -journal-disable */ int Sa, Sb; void P(int), V(int); 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); } */ ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/call.i���������������������������������������������������������0000644�0001750�0001750�00000001506�12155630321�017157� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int p[10],q[10]; int *r; int res; void f(int*t) { 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(int*X) { res = *X; } void caller_ptr() { int * e = res?&x.a:&x.b; f_ptr(e); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/usp.i����������������������������������������������������������0000644�0001750�0001750�00000000334�12155630321�017051� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int a = -12; int b; unsigned int *p=&a; unsigned int *q=&b; int X, Y, Z, T; main(int c){ b = c ? -1 : 5; if (*p == 3) X = *p; else Y = *p; if (*q == ((unsigned int)-1)) Z = *q; else T = *q; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/change_formals.c�����������������������������������������������0000644�0001750�0001750�00000001015�12155630321�021201� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/misc/Change_formals.cmxs OPT: -load-module tests/misc/Change_formals.cmxs -cpp-extra-args="-DNO_PROTO" -check -then-on test -print OPT: -load-module tests/misc/Change_formals.cmxs -cpp-extra-args="-DNO_IMPLEM" -check -then-on test -print OPT: -load-module tests/misc/Change_formals.cmxs -check -then-on test -print */ #ifndef NO_PROTO int f(int x); #endif #ifndef NO_IMPLEM int f(int x) { return x; } #endif // needed to prevent erasure of f in NO_IMPLEM case int g() { return f(0); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/loop3.c��������������������������������������������������������0000644�0001750�0001750�00000000226�12155630321�017270� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ int i,j,k; #include "any_int.c" void main(void) { j = 0; int b = any_int (); // if (b<0) j=b; for (i=0;i<100;i++) {j = j+3; k = k + 8;}; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/context_free.i�������������������������������������������������0000644�0001750�0001750�00000002130�12155630321�020723� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; extern struct { int f1; void *p; // void* field: valid, size unknown } svoid; extern void *qvoid; // void* pointer: valid, size unknown 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; char* pvoid = svoid.p; *pvoid = 1; pvoid = qvoid; *pvoid = &pvoid; return g("toto"); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bitfield_longlong.c��������������������������������������������0000644�0001750�0001750�00000001074�12155630321�021717� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts0489.ml�����������������������������������������������������0000644�0001750�0001750�00000000776�12155630321�017551� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types class visitor = object inherit Visitor.frama_c_inplace method vexpr e = match e.enode with | Const(CInt64 (_,_,Some s)) -> Format.printf "Found representation %s@." s; Cil.SkipChildren | Const(CInt64(n,_,None)) -> Format.printf "No representation for %s@." (Integer.to_string n); Cil.SkipChildren | _ -> Cil.DoChildren end let run () = let file = Ast.get () in Visitor.visitFramacFile (new visitor) file let () = Db.Main.extend run ��frama-c-Fluorine-20130601/tests/misc/shift.i��������������������������������������������������������0000644�0001750�0001750�00000001242�12155630321�017356� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-val" STDOPT: +"-val -no-val-left-shift-negative-alarms" */ int a,b,d,e,f,g,h; unsigned int ua,ub,uc,ud,ue,uf; void printf(const char* c,...); char t[10]; int main(int c, int z, int zz) { a=5024; d = 255; f= -255; if ((c<=3) && (c>=0)) { c = 2*c-1; a = 157 << c; d=1975; d = d >> c; f= -1975; f = f >> c; } if (z & 1) z=1<<32; if (zz) zz=1>>5555; if (z & 16) { b = 66; b = b << b; }; ua = 5607; ua >>= 2 ; ub = (unsigned int)(-3000); ub >>= 2; printf("ua:%u\nub:%u\n",ua,ub); if (z & 32) { int r = (unsigned long)t << 8; r += (long)t << 8; } return b; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bug_0244.i�����������������������������������������������������0000644�0001750�0001750�00000000161�12155630321�017466� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int R,*p; void main(void) { int a,i; a=2; for(i=0; i<2; i++) { int u=a; p = &u; } R = *p; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/simple_packed.c������������������������������������������������0000644�0001750�0001750�00000000542�12155630321�021035� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/branch.i�������������������������������������������������������0000644�0001750�0001750�00000000217�12155630321�017477� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/dead_code2.i���������������������������������������������������0000644�0001750�0001750�00000000205�12155630321�020210� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/eval_separated.c�����������������������������������������������0000644�0001750�0001750�00000002325�12155630321�021215� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int x, y, t1[6], t2[6]; void main (int c1, int c2) { int *p, *q, *r; //@ assert !\separated(&x, &x); //@ assert \separated(&x, &y); //@ assert !\separated(&x+2, &x+2); //@ assert \separated(&x+2, &x+3); q = (int)&q+ (int)&q; r = (int)&r+ (int)&r; //@ assert !\separated(q, q); //@ assert \separated(q, q+2); //@ assert \separated(q, r); //@ assert !\separated(&t1[1-1],&t1[0]); //@ assert !\separated(&t1, &t1); //@ assert !\separated(&t1[0]+(0..0), &t1[0]); //@ assert \separated(&t1[0]+(0.. -1), &t1[0]); //@ assert !\separated(&t1[0]+2, &t1[0]+2); //@ assert \separated(&t1[0]+2, &t1[0]+3); //@ assert \separated(&t1[0], &t2[0]); //@ assert \separated(t1, t2); //@ assert \separated(t1, &t1[1]); //@ assert \separated(&t1[0]+(0..3), &t1[0]+(4..5)); //@ assert !\separated(&t1[0]+(0..3), &t1[0]+(3..5)); //@ assert \separated(&t1[c1], &t2[c1]); p= &x; //@ assert !\separated(&x, p); p = &t1[c1]; //@ assert \separated(p, &t2[c2]); if (c1 >= 0 && c1 <= 3 && c2 >= 3 && c2 <= 4) { //@ assert \separated(&t1[c1], &t1[c2+1]); //@ assert \separated(&t1[c1], &t1[c2]); // Really unknown //@ assert \separated(&t1[c1], &t1[c1+1]); // Unknown by imprecision } } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/dead_inout.i���������������������������������������������������0000644�0001750�0001750�00000001103�12155630321�020350� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -out -input -inout -inout -inout-callwise -main main_all */ // This tests a potential imprecision with the computation of input and outputs if one forgets to test that a statement is dead int a, b; void f() { a = b; } void g () { int x = 0; if (x) f (); } void main(){ f (); g (); } // This tests the computation of inout with non-conditional ifs void f2(int v, int *p, int *q) { if (v) *q = 1; if (v) *p = 2; } void main2() { int x, y; f2(0, &x, &x); f2(1, &x, &y); } // Main void main_all() { main(); main2(); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/strings_cond.i�������������������������������������������������0000644�0001750�0001750�00000000200�12155630321�020726� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ void foo(char *s) { Frama_C_dump_each(); while(*s) { Frama_C_show_each_s(s); s++; } } void main(void) { foo("Bla"); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/loop_no_var.i��������������������������������������������������0000644�0001750�0001750�00000000034�12155630321�020554� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int main() { while(1) {} } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cast_hetero.i��������������������������������������������������0000644�0001750�0001750�00000000211�12155630321�020534� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int X; int*pt; 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); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/g1.i�����������������������������������������������������������0000644�0001750�0001750�00000000041�12155630321�016544� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������extern int G = 1; void main (){} �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/from_res_2.i���������������������������������������������������0000644�0001750�0001750�00000000430�12155630321�020274� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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(); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts0452.i������������������������������������������������������0000644�0001750�0001750�00000002403�12155630321�017344� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/annot_valid.i��������������������������������������������������0000644�0001750�0001750�00000002101�12155630321�020532� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int G; int main (int u) { int *p; L: 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; case 15: //@ assert p != \null; break; case 16: //@ assert \valid{L}(p); //@ assert !\at(\valid(p), L); break; case 17: { int x; p = &x; //@ assert !\valid{L}(p); // Incorrect break; } } return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/loop_join.i����������������������������������������������������0000644�0001750�0001750�00000000341�12155630321�020230� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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: } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/ineq.c���������������������������������������������������������0000644�0001750�0001750�00000000760�12155630321�017173� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#include "any_int.c" int G[10] ={0}; int g=0,h=0,i=0,j=0,k=1,l=1,m=-1,n=-1; void main () { int x; x = any_int(); if (0 <= x) { g = x; } if (0 >= x) { h =x; } if (x >= 0) { i =x; } if (x <= 0) { j =x; } if (0 < x) { k =x; } if (0 > x) { m =x; } if (x > 0) { l =x; } if (x < 0) { n =x; } G[0] = 0; if ((0 <= x) && (5 >= x)) G[0] = 7; } ����������������frama-c-Fluorine-20130601/tests/misc/function_return_serial_casts.i���������������������������������0000644�0001750�0001750�00000000325�12155630321�024222� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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(); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/leaf_spec.i����������������������������������������������������0000644�0001750�0001750�00000000624�12155630321�020165� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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); } ������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/CruiseControl.c������������������������������������������������0000644�0001750�0001750�00000052034�12155630321�021033� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -float-normal -val -deps -out -input tests/misc/CruiseControl_const.c -lib-entry -main CruiseControl -context-depth 10 -context-valid-pointers -journal-disable OPT: -float-hex -all-rounding-modes -val -deps -out -input tests/misc/CruiseControl_const.c -lib-entry -main CruiseControl -context-depth 10 -context-valid-pointers -journal-disable */ /*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** Command : ** l2C CruiseControl.lus -node CruiseControl ** -noexp @ALL@ ** -keep_named_var ** -const ** -bitwise ** -loc_ctx ** -no_copy_mem ** -debug ** date of generation (MM/DD/YYYY): 07/06/2007 13:30:09 ** last modification date for CruiseControl.lus (MM/DD/YYYY): 07/06/2007 ********************************************************************$*/ #include "CruiseControl.h" #include "CruiseControl_extern.h" /* ============== */ /* INITIALISATION */ /* ============== */ void CruiseSpeedMgt_init(_C_CruiseSpeedMgt * _C_) { (_C_->_M_init_0_CruiseControl) = true; } void SaturateThrottle_init(_C_SaturateThrottle * _C_) { } void ThrottleRegulation_init(_C_ThrottleRegulation * _C_) { (_C_->_M_init_0_CruiseControl) = true; SaturateThrottle_init(&(_C_->_C0_SaturateThrottle)); } void ThrottleCmd_init(_C_ThrottleCmd * _C_) { (_C_->_M_init_0_CruiseControl) = true; ThrottleRegulation_init(&(_C_->_C0_ThrottleRegulation)); (_C_->_M_condact_2_CruiseControl) = true; } void CruiseStateMgt_init(_C_CruiseStateMgt * _C_) { (_C_->_M_init_0_CruiseControl) = true; } void DetectPedalsPressed_init(_C_DetectPedalsPressed * _C_) { } void DetectSpeedLimits_init(_C_DetectSpeedLimits * _C_) { } void CruiseControl_init(_C_CruiseControl * _C_) { CruiseSpeedMgt_init(&(_C_->_C0_CruiseSpeedMgt)); DetectPedalsPressed_init(&(_C_->_C1_DetectPedalsPressed)); DetectSpeedLimits_init(&(_C_->_C2_DetectSpeedLimits)); CruiseStateMgt_init(&(_C_->_C3_CruiseStateMgt)); (_C_->_M_condact_0_CruiseControl) = true; ThrottleCmd_init(&(_C_->_C4_ThrottleCmd)); (_C_->_M_init_CruiseControl) = true; } /* ================================*/ /* MAIN NODE (AND UNEXPANDED NODES) */ /* ================================ */ bool CruiseSpeedMgt(_C_CruiseSpeedMgt * _C_) { /*#code for node CruiseSpeedMgt */ (_C_->_L1_CruiseControl) = (_C_->_I4_Speed); (_C_->_L2_CruiseControl) = (_C_->_I1_Set); (_C_->_L3_CruiseControl) = (_C_->_I0_On); (_C_->_L6_CruiseControl) = ((_C_->_L2_CruiseControl) | (_C_->_L3_CruiseControl)); (_C_->_L21_CruiseControl) = ZeroSpeed; if ((_C_->_M_init_0_CruiseControl)) { (_C_->_L10_CruiseControl) = (_C_->_L21_CruiseControl); } else { (_C_->_L10_CruiseControl) = (_C_->_L7_CruiseControl); } (_C_->_L12_CruiseControl) = SpeedInc; (_C_->_L13_CruiseControl) = ((_C_->_L10_CruiseControl) + (_C_->_L12_CruiseControl)); (_C_->_L15_CruiseControl) = SpeedMax; (_C_->_L16_CruiseControl) = ((_C_->_L13_CruiseControl) <= (_C_->_L15_CruiseControl)); (_C_->_L4_CruiseControl) = (_C_->_I2_QuickAccel); (_C_->_L17_CruiseControl) = ((_C_->_L16_CruiseControl) & (_C_->_L4_CruiseControl)); (_C_->_L11_CruiseControl) = SpeedInc; (_C_->_L14_CruiseControl) = ((_C_->_L10_CruiseControl) - (_C_->_L11_CruiseControl)); (_C_->_L19_CruiseControl) = SpeedMin; (_C_->_L18_CruiseControl) = ((_C_->_L14_CruiseControl) >= (_C_->_L19_CruiseControl)); (_C_->_L5_CruiseControl) = (_C_->_I3_QuickDecel); (_C_->_L20_CruiseControl) = ((_C_->_L18_CruiseControl) & (_C_->_L5_CruiseControl)); if ((_C_->_L20_CruiseControl)) { (_C_->_L9_CruiseControl) = (_C_->_L14_CruiseControl); } else { (_C_->_L9_CruiseControl) = (_C_->_L10_CruiseControl); } if ((_C_->_L17_CruiseControl)) { (_C_->_L8_CruiseControl) = (_C_->_L13_CruiseControl); } else { (_C_->_L8_CruiseControl) = (_C_->_L9_CruiseControl); } if ((_C_->_L6_CruiseControl)) { (_C_->_L7_CruiseControl) = (_C_->_L1_CruiseControl); } else { (_C_->_L7_CruiseControl) = (_C_->_L8_CruiseControl); } (_C_->_O0_CruiseSpeed) = (_C_->_L7_CruiseControl); (_C_->_M_init_0_CruiseControl) = false; /*#end code for node CruiseSpeedMgt */ return (true); } bool SaturateThrottle(_C_SaturateThrottle * _C_) { /*#code for node SaturateThrottle */ (_C_->_L18_CruiseControl) = RegThrottleMax; (_C_->_L12_CruiseControl) = (_C_->_I0_ThrottleIn); (_C_->_L7_CruiseControl) = ((_C_->_L12_CruiseControl) > (_C_->_L18_CruiseControl)); (_C_->_L17_CruiseControl) = ZeroPercent; (_C_->_L9_CruiseControl) = ((_C_->_L12_CruiseControl) < (_C_->_L17_CruiseControl)); if ((_C_->_L9_CruiseControl)) { (_C_->_L6_CruiseControl) = (_C_->_L17_CruiseControl); } else { (_C_->_L6_CruiseControl) = (_C_->_L12_CruiseControl); } if ((_C_->_L7_CruiseControl)) { (_C_->_L8_CruiseControl) = (_C_->_L18_CruiseControl); } else { (_C_->_L8_CruiseControl) = (_C_->_L6_CruiseControl); } (_C_->_O0_ThrottleOut) = (_C_->_L8_CruiseControl); (_C_->_L13_CruiseControl) = ((_C_->_L9_CruiseControl) | (_C_->_L7_CruiseControl)); (_C_->_O1_Saturate) = (_C_->_L13_CruiseControl); /*#end code for node SaturateThrottle */ //@ assert (_C_->_O1_Saturate == 1) ==> (_C_->_O0_ThrottleOut == ZeroPercent || _C_->_O0_ThrottleOut == RegThrottleMax ); return (true); } bool ThrottleRegulation(_C_ThrottleRegulation * _C_) { /*#code for node ThrottleRegulation */ (_C_->_L1_CruiseControl) = (_C_->_I1_CruiseSpeed); (_C_->_L2_CruiseControl) = (_C_->_I2_VehiculeSpeed); (_C_->_L3_CruiseControl) = ((_C_->_L1_CruiseControl) - (_C_->_L2_CruiseControl)); (_C_->_L6_CruiseControl) = Kp; (_C_->ProportionnalAction) = ((_C_->_L3_CruiseControl) * (_C_->_L6_CruiseControl)); (_C_->_L22_CruiseControl) = ZeroSpeed; if ((_C_->_M_init_0_CruiseControl)) { (_C_->HoldIntegralAction) = true; } else { (_C_->HoldIntegralAction) = (_C_->_L14_CruiseControl); } if ((_C_->HoldIntegralAction)) { (_C_->_L16_CruiseControl) = (_C_->_L22_CruiseControl); } else { (_C_->_L16_CruiseControl) = (_C_->_L3_CruiseControl); } (_C_->_L23_CruiseControl) = ZeroSpeed; if ((_C_->_M_init_0_CruiseControl)) { (_C_->_L18_CruiseControl) = (_C_->_L23_CruiseControl); } else { (_C_->_L18_CruiseControl) = (_C_->_L21_CruiseControl); } (_C_->_L10_CruiseControl) = ((_C_->_L16_CruiseControl) + (_C_->_L18_CruiseControl)); (_C_->_L8_CruiseControl) = Ki; (_C_->IntegralAction) = ((_C_->_L10_CruiseControl) * (_C_->_L8_CruiseControl)); (_C_->_L4_CruiseControl) = ((_C_->ProportionnalAction) + (_C_->IntegralAction)); /* call to node not expanded SaturateThrottle */ (_C_->_C0_SaturateThrottle._I0_ThrottleIn) = (_C_->_L4_CruiseControl); if (!SaturateThrottle(&(_C_->_C0_SaturateThrottle))) return (false); (_C_->_L13_CruiseControl) = (_C_->_C0_SaturateThrottle._O0_ThrottleOut); (_C_->_L14_CruiseControl) = (_C_->_C0_SaturateThrottle._O1_Saturate); (_C_->_O0_Throttle) = (_C_->_L13_CruiseControl); (_C_->_L19_CruiseControl) = (_C_->_I0_Reset); if ((_C_->_L19_CruiseControl)) { (_C_->_L21_CruiseControl) = (_C_->_L22_CruiseControl); } else { (_C_->_L21_CruiseControl) = (_C_->_L10_CruiseControl); } (_C_->_M_init_0_CruiseControl) = false; /*#end code for node ThrottleRegulation */ return (true); } bool ThrottleCmd(_C_ThrottleCmd * _C_) { /*#code for node ThrottleCmd */ if ((_C_->_M_init_0_CruiseControl)) { (_C_->_L21_CruiseControl) = false; } else { (_C_->_L21_CruiseControl) = (_C_->_L20_CruiseControl); } (_C_->_L20_CruiseControl) = (_C_->_I0_Regul_ON); (_C_->_L22_CruiseControl) = ((_C_->_L21_CruiseControl) ^ true); (_C_->ONRisingEdge) = ((_C_->_L20_CruiseControl) & (_C_->_L22_CruiseControl)); (_C_->_L26_CruiseControl) = ZeroPercent; (_C_->_L1_CruiseControl) = (_C_->_I1_CruiseSpeed); (_C_->_L2_CruiseControl) = (_C_->_I2_VehiculeSpeed); /* begin condact */ if ((_C_->_L20_CruiseControl)) { /* call to node not expanded ThrottleRegulation */ (_C_->_C0_ThrottleRegulation._I0_Reset) = (_C_->ONRisingEdge); (_C_->_C0_ThrottleRegulation._I1_CruiseSpeed) = (_C_->_L1_CruiseControl); (_C_->_C0_ThrottleRegulation._I2_VehiculeSpeed) = (_C_->_L2_CruiseControl); if (!ThrottleRegulation(&(_C_->_C0_ThrottleRegulation))) return (false); (_C_->_L19_CruiseControl) = (_C_->_C0_ThrottleRegulation._O0_Throttle); (_C_->_M_condact_2_CruiseControl) = false; } else { if (_C_->_M_init_0_CruiseControl) { (_C_->_L19_CruiseControl) = (_C_->_L26_CruiseControl); } } /* end condact */ (_C_->_L25_CruiseControl) = (_C_->_I3_Accelerator); if ((_C_->_L20_CruiseControl)) { (_C_->_L24_CruiseControl) = (_C_->_L19_CruiseControl); } else { (_C_->_L24_CruiseControl) = (_C_->_L25_CruiseControl); } (_C_->_O0_Throttle) = (_C_->_L24_CruiseControl); (_C_->_M_init_0_CruiseControl) = false; /*#end code for node ThrottleCmd */ return (true); } bool CruiseStateMgt(_C_CruiseStateMgt * _C_) { /*#code for node CruiseStateMgt */ if ((_C_->_M_init_0_CruiseControl)) { (_C_->_LE24_CruiseControl) = false; } else { (_C_->_LE24_CruiseControl) = (_C_->_LE23_CruiseControl); } (_C_->_LE0_CruiseControl) = (_C_->_I0_BrakePressed); (_C_->_LE4_CruiseControl) = (_C_->_I4_Off); if ((_C_->_M_init_0_CruiseControl)) { (_C_->_LE40_CruiseControl) = false; (_C_->_LE26_CruiseControl) = false; (_C_->_LE28_CruiseControl) = false; } else { (_C_->_LE40_CruiseControl) = (_C_->_LE39_CruiseControl); (_C_->_LE26_CruiseControl) = (_C_->_LE25_CruiseControl); (_C_->_LE28_CruiseControl) = (_C_->_LE27_CruiseControl); } (_C_->_LE9_CruiseControl) = ((_C_->_LE26_CruiseControl) | (_C_->_LE28_CruiseControl)); (_C_->_LE10_CruiseControl) = ((_C_->_LE24_CruiseControl) | (_C_->_LE9_CruiseControl)); (_C_->_LE11_CruiseControl) = ((_C_->_LE40_CruiseControl) | (_C_->_LE10_CruiseControl)); if ((_C_->_M_init_0_CruiseControl)) { (_C_->_LE33_CruiseControl) = false; (_C_->_LE35_CruiseControl) = false; (_C_->_LE38_CruiseControl) = false; } else { (_C_->_LE33_CruiseControl) = (_C_->_LE32_CruiseControl); (_C_->_LE35_CruiseControl) = (_C_->_LE34_CruiseControl); (_C_->_LE38_CruiseControl) = (_C_->_LE37_CruiseControl); } (_C_->_LE12_CruiseControl) = ((_C_->_LE35_CruiseControl) | (_C_->_LE38_CruiseControl)); (_C_->_LE13_CruiseControl) = ((_C_->_LE33_CruiseControl) | (_C_->_LE12_CruiseControl)); (_C_->_LE14_CruiseControl) = ((_C_->_LE11_CruiseControl) | (_C_->_LE13_CruiseControl)); (_C_->_LE17_CruiseControl) = (((_C_->_LE4_CruiseControl) ^ true) & (_C_->_LE14_CruiseControl)); (_C_->_LE18_CruiseControl) = ((((_C_->_LE0_CruiseControl) ^ true) & (_C_-> _LE17_CruiseControl)) & (_C_->_LE10_CruiseControl)); (_C_->_LE3_CruiseControl) = (_C_->_I3_On); if ((_C_->_M_init_0_CruiseControl)) { (_C_->_LE16_CruiseControl) = false; (_C_->_LE41_CruiseControl) = true; } else { (_C_->_LE16_CruiseControl) = (_C_->_LE15_CruiseControl); (_C_->_LE41_CruiseControl) = (_C_->_LE19_CruiseControl); } (_C_->_LE19_CruiseControl) = ((_C_->_LE41_CruiseControl) & ((_C_->_LE3_CruiseControl) ^ true)); (_C_->_LE20_CruiseControl) = (((_C_->_LE3_CruiseControl) & (_C_-> _LE16_CruiseControl)) | (((_C_-> _LE19_CruiseControl) ^ true) & (_C_-> _LE41_CruiseControl))); (_C_->_LE21_CruiseControl) = (((_C_->_LE24_CruiseControl) & (_C_-> _LE18_CruiseControl)) | (((_C_-> _LE0_CruiseControl) ^ true) & (_C_-> _LE20_CruiseControl))); (_C_->_LE1_CruiseControl) = (_C_->_I1_AcceleratorPressed); (_C_->_LE5_CruiseControl) = (_C_->_I5_SpeedOutOffLimits); (_C_->_LE22_CruiseControl) = (((_C_->_LE1_CruiseControl) ^ true) & ((_C_-> _LE5_CruiseControl) ^ true)); (_C_->_LE23_CruiseControl) = ((_C_->_LE21_CruiseControl) & (_C_->_LE22_CruiseControl)); (_C_->_LE25_CruiseControl) = (((_C_->_LE18_CruiseControl) & (_C_->_LE9_CruiseControl)) & (_C_-> _LE22_CruiseControl)); (_C_->_LE29_CruiseControl) = ((_C_->_LE17_CruiseControl) & (_C_->_LE13_CruiseControl)); (_C_->_LE2_CruiseControl) = (_C_->_I2_Resume); (_C_->_LE30_CruiseControl) = ((_C_->_LE40_CruiseControl) & (_C_->_LE17_CruiseControl)); (_C_->_LE31_CruiseControl) = (((_C_->_LE33_CruiseControl) & (_C_-> _LE29_CruiseControl)) | ((_C_-> _LE2_CruiseControl) & (_C_-> _LE30_CruiseControl))); (_C_->_LE32_CruiseControl) = ((((_C_->_LE0_CruiseControl) ^ true) & (_C_-> _LE22_CruiseControl)) & (_C_->_LE31_CruiseControl)); (_C_->_LE34_CruiseControl) = (((((_C_->_LE0_CruiseControl) ^ true) & (_C_-> _LE29_CruiseControl)) & (_C_->_LE12_CruiseControl)) & (_C_->_LE22_CruiseControl)); (_C_->_LE42_CruiseControl) = ((((_C_->_LE23_CruiseControl) | (_C_-> _LE25_CruiseControl)) | (_C_-> _LE32_CruiseControl)) | (_C_->_LE34_CruiseControl)); (_C_->_LE6_CruiseControl) = (_C_->_LE42_CruiseControl); (_C_->_O0_Regul_ON) = (_C_->_LE6_CruiseControl); (_C_->_LE15_CruiseControl) = ((((_C_->_LE3_CruiseControl) ^ true) & (_C_-> _LE16_CruiseControl)) | ((_C_->_LE4_CruiseControl) & (_C_->_LE14_CruiseControl))); (_C_->_LE39_CruiseControl) = (((((_C_->_LE0_CruiseControl) & (_C_-> _LE29_CruiseControl)) | ((_C_-> _LE0_CruiseControl) & (_C_-> _LE20_CruiseControl))) | (((_C_->_LE2_CruiseControl) ^ true) & (_C_->_LE30_CruiseControl))) | (((_C_-> _LE0_CruiseControl) & (_C_-> _LE17_CruiseControl)) & (_C_-> _LE11_CruiseControl))); (_C_->_LE43_CruiseControl) = (((_C_->_LE19_CruiseControl) | (_C_->_LE15_CruiseControl)) | (_C_-> _LE39_CruiseControl)); (_C_->_LE7_CruiseControl) = (_C_->_LE43_CruiseControl); (_C_->_O1_Regul_OFF) = (_C_->_LE7_CruiseControl); (_C_->_LE27_CruiseControl) = ((((_C_->_LE23_CruiseControl) ^ true) & (_C_-> _LE21_CruiseControl)) | ((((_C_->_LE25_CruiseControl) ^ true) & (_C_-> _LE18_CruiseControl)) & (_C_->_LE9_CruiseControl))); (_C_->_LE36_CruiseControl) = ((((_C_->_LE34_CruiseControl) ^ true) & (_C_-> _LE29_CruiseControl)) | ((_C_->_LE2_CruiseControl) & (_C_->_LE30_CruiseControl))); (_C_->_LE37_CruiseControl) = ((((_C_->_LE0_CruiseControl) ^ true) & ((_C_-> _LE32_CruiseControl) ^ true)) & (_C_-> _LE36_CruiseControl)); (_C_->_LE44_CruiseControl) = (((_C_->_LE27_CruiseControl) | (_C_->_LE37_CruiseControl)) | (_C_-> _LE39_CruiseControl)); (_C_->_LE8_CruiseControl) = (_C_->_LE44_CruiseControl); (_C_->_O2_Regul_STDBY) = (_C_->_LE8_CruiseControl); (_C_->_M_init_0_CruiseControl) = false; /*#end code for node CruiseStateMgt */ return (true); } bool DetectPedalsPressed(_C_DetectPedalsPressed * _C_) { /*#code for node DetectPedalsPressed */ (_C_->_L2_CruiseControl) = (_C_->_I0_Brake); (_C_->_L8_CruiseControl) = ZeroPercent; (_C_->_L4_CruiseControl) = ((_C_->_L2_CruiseControl) > (_C_->_L8_CruiseControl)); (_C_->_O0_BrakePressed) = (_C_->_L4_CruiseControl); (_C_->_L1_CruiseControl) = (_C_->_I1_Accelerator); (_C_->_L7_CruiseControl) = ZeroPercent; (_C_->_L3_CruiseControl) = ((_C_->_L1_CruiseControl) > (_C_->_L7_CruiseControl)); (_C_->_O1_AcceleratorPressed) = (_C_->_L3_CruiseControl); /*#end code for node DetectPedalsPressed */ return (true); } bool DetectSpeedLimits(_C_DetectSpeedLimits * _C_) { /*#code for node DetectSpeedLimits */ (_C_->_L7_CruiseControl) = (_C_->_I0_speed); (_C_->_L13_CruiseControl) = SpeedMin; (_C_->_L8_CruiseControl) = ((_C_->_L7_CruiseControl) < (_C_->_L13_CruiseControl)); (_C_->_L14_CruiseControl) = SpeedMax; (_C_->_L9_CruiseControl) = ((_C_->_L7_CruiseControl) > (_C_->_L14_CruiseControl)); (_C_->_L17_CruiseControl) = ((_C_->_L8_CruiseControl) | (_C_->_L9_CruiseControl)); (_C_->_O0_SpeedOutOffLimits) = (_C_->_L17_CruiseControl); /*#end code for node DetectSpeedLimits */ return (true); } bool CruiseControl(_C_CruiseControl * _C_) { /*#code for node CruiseControl */ (_C_->_L73_CruiseControl) = (_C_->_I0_On); (_C_->_L59_CruiseControl) = (_C_->_I7_Brake); (_C_->_L62_CruiseControl) = (_C_->_I6_Accel); /* call to node not expanded DetectPedalsPressed */ (_C_->_C1_DetectPedalsPressed._I0_Brake) = (_C_->_L59_CruiseControl); (_C_->_C1_DetectPedalsPressed._I1_Accelerator) = (_C_->_L62_CruiseControl); if (!DetectPedalsPressed(&(_C_->_C1_DetectPedalsPressed))) return (false); (_C_->BrakePressed) = (_C_->_C1_DetectPedalsPressed._O0_BrakePressed); (_C_->AcceleratorPressed) = (_C_->_C1_DetectPedalsPressed._O1_AcceleratorPressed); (_C_->_L61_CruiseControl) = (_C_->_I2_Resume); (_C_->_L60_CruiseControl) = (_C_->_I0_On); (_C_->_L58_CruiseControl) = (_C_->_I1_Off); (_C_->_L95_CruiseControl) = (_C_->_I8_Speed); /* call to node not expanded DetectSpeedLimits */ (_C_->_C2_DetectSpeedLimits._I0_speed) = (_C_->_L95_CruiseControl); if (!DetectSpeedLimits(&(_C_->_C2_DetectSpeedLimits))) return (false); (_C_->SpeedOutOffLimits) = (_C_->_C2_DetectSpeedLimits._O0_SpeedOutOffLimits); /* call to node not expanded CruiseStateMgt */ (_C_->_C3_CruiseStateMgt._I0_BrakePressed) = (_C_->BrakePressed); (_C_->_C3_CruiseStateMgt._I1_AcceleratorPressed) = (_C_->AcceleratorPressed); (_C_->_C3_CruiseStateMgt._I2_Resume) = (_C_->_L61_CruiseControl); (_C_->_C3_CruiseStateMgt._I3_On) = (_C_->_L60_CruiseControl); (_C_->_C3_CruiseStateMgt._I4_Off) = (_C_->_L58_CruiseControl); (_C_->_C3_CruiseStateMgt._I5_SpeedOutOffLimits) = (_C_->SpeedOutOffLimits); if (!CruiseStateMgt(&(_C_->_C3_CruiseStateMgt))) return (false); (_C_->_L82_CruiseControl) = (_C_->_C3_CruiseStateMgt._O0_Regul_ON); (_C_->_L83_CruiseControl) = (_C_->_C3_CruiseStateMgt._O1_Regul_OFF); (_C_->_L84_CruiseControl) = (_C_->_C3_CruiseStateMgt._O2_Regul_STDBY); (_C_->_L19_CruiseControl) = ((_C_->_L82_CruiseControl) | (_C_->_L84_CruiseControl)); (_C_->_L96_CruiseControl) = ZeroSpeed; (_C_->_L38_CruiseControl) = (_C_->_I3_Set); (_C_->_L39_CruiseControl) = (_C_->_I4_QuickAccel); (_C_->_L40_CruiseControl) = (_C_->_I5_QuickDecel); (_C_->_L23_CruiseControl) = (_C_->_I8_Speed); /* begin condact */ if ((_C_->_L19_CruiseControl)) { /* call to node not expanded CruiseSpeedMgt */ (_C_->_C0_CruiseSpeedMgt._I0_On) = (_C_->_L73_CruiseControl); (_C_->_C0_CruiseSpeedMgt._I1_Set) = (_C_->_L38_CruiseControl); (_C_->_C0_CruiseSpeedMgt._I2_QuickAccel) = (_C_->_L39_CruiseControl); (_C_->_C0_CruiseSpeedMgt._I3_QuickDecel) = (_C_->_L40_CruiseControl); (_C_->_C0_CruiseSpeedMgt._I4_Speed) = (_C_->_L23_CruiseControl); if (!CruiseSpeedMgt(&(_C_->_C0_CruiseSpeedMgt))) return (false); (_C_->CruiseSpeed) = (_C_->_C0_CruiseSpeedMgt._O0_CruiseSpeed); (_C_->_M_condact_0_CruiseControl) = false; } else { if (_C_->_M_init_CruiseControl) { (_C_->CruiseSpeed) = (_C_->_L96_CruiseControl); } } /* end condact */ (_C_->_O0_Cruise_speed) = (_C_->CruiseSpeed); (_C_->_L26_CruiseControl) = (_C_->_I6_Accel); /* call to node not expanded ThrottleCmd */ (_C_->_C4_ThrottleCmd._I0_Regul_ON) = (_C_->_L82_CruiseControl); (_C_->_C4_ThrottleCmd._I1_CruiseSpeed) = (_C_->CruiseSpeed); (_C_->_C4_ThrottleCmd._I2_VehiculeSpeed) = (_C_->_L23_CruiseControl); (_C_->_C4_ThrottleCmd._I3_Accelerator) = (_C_->_L26_CruiseControl); if (!ThrottleCmd(&(_C_->_C4_ThrottleCmd))) return (false); (_C_->_L22_CruiseControl) = (_C_->_C4_ThrottleCmd._O0_Throttle); (_C_->_O1_Throttle_cmd) = (_C_->_L22_CruiseControl); (_C_->_O2_Regul_ON) = (_C_->_L82_CruiseControl); (_C_->_O3_Regul_OFF) = (_C_->_L83_CruiseControl); (_C_->_O4_Regul_STDBY) = (_C_->_L84_CruiseControl); (_C_->_M_init_CruiseControl) = false; /*#end code for node CruiseControl */ return (true); } /*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** End of file CruiseControl.c ** End of generation (MM/DD/YYYY) : 07/06/2007 13:30:09 ********************************************************************$*/ bool main(_C_CruiseControl * _C_){ CruiseControl_init(_C_); while (CruiseControl(_C_)); return false; } /* run.config GCC: DONTRUN: */ /*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** Command : ** l2C CruiseControl.lus -node CruiseControl ** -noexp @ALL@ ** -keep_named_var ** -const ** -bitwise ** -loc_ctx ** -no_copy_mem ** -debug ** date of generation (MM/DD/YYYY): 07/06/2007 13:30:09 ** last modification date for CruiseControl.lus (MM/DD/YYYY): 07/06/2007 ********************************************************************$*/ #include "CruiseControl.h" const Speed ZeroSpeed = (real) 0.0; const Speed SpeedInc = (real) 2.0; const Speed SpeedMax = (real) 150.0; const Speed SpeedMin = (real) 30.0; const Percent ZeroPercent = (real) 0.0; const real Kp = (real) 8.113; const real Ki = (real) 0.5; const Percent RegThrottleMax = (real) 45.0; /*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** End of file CruiseControl_const.c ** End of generation (MM/DD/YYYY) : 07/06/2007 13:30:09 ********************************************************************$*/ ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/offset_top.i���������������������������������������������������0000644�0001750�0001750�00000000274�12155630321�020415� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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]; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/from_ptr.i�����������������������������������������������������0000644�0001750�0001750�00000001113�12155630321�020066� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/enum.i���������������������������������������������������������0000644�0001750�0001750�00000000553�12155630321�017211� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �����������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/recursion.i����������������������������������������������������0000644�0001750�0001750�00000002420�12155630321�020251� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*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 ff() { if (G) ff(); return 5; } int x; volatile int c; struct s { int f1; int f2; } s; // Use given assigns /*@ assigns x \from x, y; assigns s.f1 \from s.f2; assigns \result \from s; */ struct s f(int y) { x = 2+y; Frama_C_show_each(x, y); if (c) { s = f(y); Frama_C_show_each(x, y); } s.f1 = s.f2; return s; } // Infers assigns \nothing void g() { g(); } // Infer assigns clause that overwrite *p1 and *p2 void h(int *p1, int *p2) { h(p1, p2); } int *pg; /* &i escapes. The precondition is true on all calls, but could be computed false if one overwrites the value of i naively at each call */ /*@ requires stage > 0 ==> *pg == i-5; assigns *pg \from \nothing; ensures stage > 0 ==> *pg == 8; */ void escaping_formal(int stage, int i) { pg = &i; Frama_C_show_each (pg, *pg, stage, i); escaping_formal (1, i+5); if (stage > 0) *pg = 8; Frama_C_show_each (pg, *pg, stage, i); pg = 0; } int main() { G = ff(); g(); int v1, v2; h(&v1, &v2); Frama_C_show_each(v1, v2); escaping_formal(0, 10); struct s r = f(0); Frama_C_show_each(x); return r.f1+1; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/input.i��������������������������������������������������������0000644�0001750�0001750�00000000105�12155630321�017375� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int f(int x, ...); int a,b; int main () { return f(a,b); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/raz.i����������������������������������������������������������0000644�0001750�0001750�00000000472�12155630321�017041� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } */ ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/split_return.i�������������������������������������������������0000644�0001750�0001750�00000003710�12155630321�020775� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-slevel-function init:3,main1:3,f2:4,main2:4,f4:3,main5:3" +"-val-split-return-function f2:0,f3:-2,f4:4,f5:-2" +"-then -report" STDOPT: +"-slevel 6" +"-val-split-return-auto" +"-then -report" */ /*@ assigns \result \from \nothing; assigns *p \from \nothing; ensures \result == 0 && \initialized(p) || \result == 1; */ int init(unsigned int *p); unsigned int main1() { unsigned int x; int r = init(&x); switch(r) { case 0: x = x /2 + 2; break; case 1: x = 0; break; default: //@ assert \false; } return x; } extern unsigned int i2; unsigned int f2() { if (!i2) { i2 = 0; return 0; } else if (!(i2+1)) { i2 = 5; return 5; } else { i2 = 5; return 7; } } void main2() { unsigned int r = f2(); Frama_C_show_each_f2(r, i2); if (r == 0) { //@ assert i2 == 0; } else { Frama_C_show_each_f2_2(r, i2); //@ assert i2 != 0; } } extern int i3; int f3() { int res1, res2; if (i3) { i3 = 0; res1 = -2; } else { i3 = 5; res1 = 7; } res2 = res1; return res2; } void main3() { int r = f3(); Frama_C_show_each_f3(r, i3); if (r == -2) { //@ assert i3 == 0; } else { //@ assert i3 != 0; } } extern int i4; int f4() { if (i4) { i4 = 0; return 4; } else { i4 = 5; return 7; } } void main4() { int r = f4(); Frama_C_show_each_f4(r, i4); if (r == 4) { //@ assert i4 == 0; } else { //@ assert i4 != 0; } } extern int i5; int f5() { int res; if (i5) { i5 = 0; res = -2; } else { i5 = 5; res = 7; } return res; } void main5() { int r = f5(); Frama_C_show_each_f5(r, i5); if (r == -2) { //@ assert i5 == 0; } else { //@ assert i5 != 0; } } void main() { main1(); main2(); main3(); // not enough slevel in f3. One warning main4(); // not enough slevel in main4. No warning main5(); // no need for slevel, because we do not fuse on return instr } ��������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bitfield.i�����������������������������������������������������0000644�0001750�0001750�00000001744�12155630321�020032� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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(); } ����������������������������frama-c-Fluorine-20130601/tests/misc/simplify_cfg.i�������������������������������������������������0000644�0001750�0001750�00000000400�12155630321�020707� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bigarray.c�����������������������������������������������������0000644�0001750�0001750�00000000536�12155630321�020040� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#define SIZE (1<<23) const int T[SIZE]={2,3}; const char*S = "uututututututu"; int main(int c) { int i; if (c) *(char*)S = 'E'; for(i=0; i < SIZE/4; i++) *(int*)&T[i] = 1; for(i=0; i< SIZE/8; i++) *(int*)&T[i] = 1; for(i=0; i< SIZE/16; i++) *(int*)&T[i] = 1; for(i=0; i< SIZE/32; i++) *(int*)&T[i] = 1; return 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/inline.h�������������������������������������������������������0000644�0001750�0001750�00000000033�12155630321�017513� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int f(int x) { return x; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/jacques.i������������������������������������������������������0000644�0001750�0001750�00000000574�12155630321�017703� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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(); } ������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/lock.i���������������������������������������������������������0000644�0001750�0001750�00000001767�12155630321�017205� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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); } ���������frama-c-Fluorine-20130601/tests/misc/call_deep.i����������������������������������������������������0000644�0001750�0001750�00000000541�12155630321�020152� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int R=77; int G; int* pG; int F0; int f0(int *p0) { F0 = R; *p0 = R; return R; } int F1; int f1(int**pp1) { 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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/imprecise.c����������������������������������������������������0000644�0001750�0001750�00000002422�12155630321�020214� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +" -then -lib-entry" */ struct s; //@ assigns *p \from \nothing; void f(struct s *p); void invalid_assigns_imprecise() { struct s *p = 0; f(p); // p is invalid, but could be considered valid since sizeof(*p) = Top } void write_garbled() { // Write through a garbled mix int i = 1; int j = 2; int k[5] = { 2, 3}; int *p = &j + (int) &k; *p = 1; Frama_C_dump_each(); *p = p; } volatile int v; struct s v1, v2; struct u v3, v5; struct s t[10]; // struct ss { struct s f1; int f2; }; Does not parse void Frama_C_memset(unsigned char*p, int c, unsigned long); void abstract_structs() { char *p = &v1; if (v) { char w1 = *p+1; } if (v) { char w = *p; } if (v) { struct s v4 = v1; } *p = 1; char q = *p; if (v) { v1 = v2; } v2 = v1; Frama_C_memset(&v3, -5, sizeof(v3)); int *p2 = ((int*)&v2)+1; *p2 = &v; t[5] = v2; char *p4 = ((char*)&v5) + (short)v; *p4 = 18; char *p4 = ((char*)&v5) + (signed int)v; *p4 = 19; char *p4 = ((char*)&v5) + (unsigned int)v; *p4 = 20; } void cast_address() { int x; int *p = &x; char c1 = p; char c2 = *((char*)&p); char c3 = *((char*)&p)+0; } void main() { invalid_assigns_imprecise(); write_garbled(); abstract_structs(); cast_address(); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/pointer3.i�����������������������������������������������������0000644�0001750�0001750�00000000173�12155630321�020006� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/abstract_struct_2.c��������������������������������������������0000644�0001750�0001750�00000000147�12155630321�021666� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: linked with abstract_struct_1.c */ struct abstracttype { int c1; int c2; }; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/alloc.c��������������������������������������������������������0000644�0001750�0001750�00000002142�12155630321�017325� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -memory-footprint 1 -val -deps -out -input -journal-disable OPT: -memory-footprint 1 -val -deps -out -input -absolute-valid-range 0x100-0x200 -main main_abs -journal-disable */ #define FRAMA_C_MALLOC_INDIVIDUAL #include "share/libc/stdlib.c" int *p,*q,*r,a,b; char *t,*u,*v; char ch = 44; void main(int c, int d, int e) { p = malloc(4); t = malloc (10); if (!c++) p[-1] = 0; if (!c++) p[1] = 0; if (!c++) t[-1] = 0; if (!c++) t[10] = 0; t[0] = t[9] = 'o'; *p = 'k'; q = malloc(4);*q=0; r = - (int) q; *r = *(r+1); (*q)++; a = *q; /* it is incorrect to find 1 here */ u = malloc(!d); v = malloc(1 + !d); *u = ch; *u=33; if (e & 1) u[1] = ch; if (e & 2) u[1] = 34; *v = ch; *v=35; v[1] = ch; v[1]=36; if (e & 4) v[2] = ch; if (e & 8) v[2] = 37; } void main_abs(int c) { q = malloc(4);*q=0; r = - (int) q; *(int*)0x104=0; *r = r; (*q)++; a = *q; /* it is incorrect to find 1 here */ } void bug(int c) { int a; p = &a; if (!c++) p[-1] = 0; if (!c++) p[-1] = 0; if (!c++) p[-1] = 0; if (!c++) p[-1] = 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bitfield_assign.i����������������������������������������������0000644�0001750�0001750�00000000771�12155630321�021375� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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); } �������frama-c-Fluorine-20130601/tests/misc/assert_builtin.i�����������������������������������������������0000644�0001750�0001750�00000000155�12155630321�021272� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int t[10]; void Frama_C_assert(int cond); main(unsigned int c){ Frama_C_assert(c < 10); return t[c]; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts0489.i������������������������������������������������������0000644�0001750�0001750�00000007266�12155630321�017372� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 */ } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/noreturn.i�����������������������������������������������������0000644�0001750�0001750�00000001223�12155630321�020114� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/pure_exp.i�����������������������������������������������������0000644�0001750�0001750�00000000202�12155630321�020063� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* bug #5877 on gforge */ int *t = 0; int main(void) { /* should lead to an alarm. */ *t == 42; return 0; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/pointer_arg.i��������������������������������������������������0000644�0001750�0001750�00000000306�12155630321�020552� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int main(char*arg,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'; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/ensures.ml�����������������������������������������������������0000644�0001750�0001750�00000001340�12155630321�020104� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types let run () = Dynamic.Parameter.Bool.set "-context-valid-pointers" true; !Db.Value.compute (); Globals.Functions.iter (fun kf -> let kf_name = Kernel_function.get_name kf in let spec = Annotations.funspec kf in let ip = Property.ip_of_spec kf Kglobal spec in List.iter (fun ip -> let bname = match Property.get_behavior ip with | None -> "?" | Some b -> b.b_name in 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) let () = Db.Main.extend run ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cond_integer_cast_of_float.i�����������������������������������0000644�0001750�0001750�00000003746�12155630321�023577� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -no-results -then -float-hex -main mainbis */ int b; extern float f1, f2, f3, f4; extern double d1, d2, d3; extern int i; volatile unsigned int c; /*@ requires 0. <= f1 <= 8. && 0. <= d1 <= 8. ; */ void main1() { if ((int)f1 >= 2) Frama_C_show_each_float_(f1); if ((int)f1 <= 4) Frama_C_show_each_float_(f1); if ((int)f1 != 0) Frama_C_show_each_float_(f1); if ((int)f1 == 3) Frama_C_show_each_float_(f1); if ((int)d1 >= 2) Frama_C_show_each_double(d1); if ((int)d1 <= 4) Frama_C_show_each_double(d1); if ((int)d1 != 0) Frama_C_show_each_double(d1); if ((int)d1 == 3) Frama_C_show_each_double(d1); switch ((char)d1) { case 0: b = 0; break; case 1: b = 1; break; case 2: b = 2; break; case 3: b = 3; break; case 4: b = 4; break; case 5: b = 5; break; case 6: b = 6; break; case 7: b = 7; break; case 8: b = 8; break; default : b = 999; break; } Frama_C_show_each(d1, b); } void main2() { if ((double)f1 > 1.17) { Frama_C_show_each_float_(f1); } if (d1 > (float)1.17) { Frama_C_show_each_double(d1); } if (d2 > 1.17) { Frama_C_show_each_double(d2); } } /* Reduction by numeric predicates in the logic, with arguments of different type */ /*@ requires -1000. <= f4 <= 1000; // Must fit in an int requires -1000. <= d2 <= 1000; */ void main3() { // Float/real, cast to bigger float //@ assert f1 > 10.; // Ok //@ assert (double)f2 > 10.; // Ok //@ assert d1 > 10.; // Ok // Float/integer //@ assert f3 > 10; // Ok // Integer/real //@ assert i > 50.; // TODO //@ assert (int)f4 > 10; //@ assert (int)d2 > 10; Frama_C_dump_each(); } void main() { switch(c) { case 1: main1 (); break; case 2: main2 (); break; case 3: main3 (); break; } } void mainbis() { // Only to get hex floating-point display main(); } ��������������������������frama-c-Fluorine-20130601/tests/misc/incorrect_reduce_expr.i����������������������������������������0000644�0001750�0001750�00000000277�12155630321�022625� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/copy_stdin.i���������������������������������������������������0000644�0001750�0001750�00000000133�12155630321�020412� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int * leaf(void); void main () { int * stdin, *toto; stdin = leaf(); toto = stdin; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/from_global.i��������������������������������������������������0000644�0001750�0001750�00000000160�12155630321�020522� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int A,B,C,D,E; int f(int x) { B = A; C = x; return C; } int main(void) { A = D; f(E); return 0; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/unroll_simple.i������������������������������������������������0000644�0001750�0001750�00000000442�12155630321�021126� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void main (int c) { int G=0,i=4; int MAX = 12; int JMAX=5; int j=3; //@ loop pragma UNROLL 128; do { G += i; i++; j--; } while (i<=256 || j>=0); //@ loop pragma UNROLL 10; do { if(c) continue; if(c--) goto L; c++; L: c++; } while(c); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/array_overlap.i������������������������������������������������0000644�0001750�0001750�00000000407�12155630321�021111� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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]); } } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/inline.c�������������������������������������������������������0000644�0001750�0001750�00000000166�12155630321�017515� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: test for the gui only */ #include "inline.h" int main () { int x = f(42); return 0; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts0775.i������������������������������������������������������0000644�0001750�0001750�00000000073�12155630321�017355� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������main(){ int r = 0xE2DB80EBBD4856CDLL >= 1; return r; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/sign_of_bitfiled_int.c�����������������������������������������0000644�0001750�0001750�00000001037�12155630321�022375� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -cpp-command "gcc -C -E -DPTEST" -journal-disable OPT: -machdep ppc_32 -val -cpp-command "gcc -C -E -DPTEST" -journal-disable */ #ifndef PTEST #include <stdio.h> #endif struct sbf { int c:16 ; unsigned int u:16 ;} bf ; int main () { int int_inside_bitfield_is_unsigned ; bf.u --; bf.c --; int_inside_bitfield_is_unsigned = (bf.u > bf.c) ; #ifndef PTEST printf("int_inside_bitfield_is_unsigned = %d\n", int_inside_bitfield_is_unsigned); #endif return int_inside_bitfield_is_unsigned ; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/assigns.i������������������������������������������������������0000644�0001750�0001750�00000001424�12155630321�017712� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int G; //@ assigns s[..] \from s[..]; void F1(char *s); char T[100]; char Tpost[100]; typedef struct { int f1; int f2; } ts; ts t[10]; int t2[100000]; int t3[100000]; //@ assigns *(p+(0..3)) \from *(p+(4..7)); void f (char *p); //@ assigns t2[((unsigned char)len)+1 .. ((unsigned char)len)+1] \from \nothing; void g(int len); //@ assigns p[..] \from \nothing; void h(int *p); /*@ logic int foo(int p) ; */ //@ assigns p[0..foo(*p)] \from \nothing; void j(int *p); int x; int k = 53; /*@ assigns \at(x, Post) \from \at(x, Post); assigns Tpost[\at(i, Post)]; assigns Tpost[\at(k, Post)]; */ void assigns_post(int i); void main(void) { F1(T); for (int i=0;i<=5;i++) f(&t[i].f2); g(2 * (int)(&T) ); h(2 * (int)(&t3) ); j(T+9); assigns_post(18); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bitwise_pointer.i����������������������������������������������0000644�0001750�0001750�00000000561�12155630321�021452� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �����������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/not.i����������������������������������������������������������0000644�0001750�0001750�00000000105�12155630321�017036� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int x; void main() { volatile int loc=0; x = loc?!(0):0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/reduce_index.i�������������������������������������������������0000644�0001750�0001750�00000002745�12155630321�020710� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int t[10]; int u[11]; volatile int maybe; extern int c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12; int f1_aux () { return 1; } void f1 () { t[c1]=f1_aux(); c1 = c1; } int f2() { c2 = c2; return t[c2]; } int f3() { t[c3]; c3 = c3; return 0; } int f4() { if(t[c4]) { int x = 1; } c4 = c4; return 0; } int f5() { int c = t[c5]; c5 = c5; return 0; } void f6() { u[c6] = t[c6]; t[c6] = u[c6]; c6 = c6; } void f7() { t[c7] = u[c7]; u[c7] = t[c7]; c7 = c7; } typedef struct { int f1; int f2; } typs; typs ts[10]; typs *p8; int f8 () { p8 = &ts[c8]; p8->f1 = 1; p8->f2 = 2; c8 = c8; p8 = p8; return 0; } int f9 () { ts[c9].f1 = 1; c9 = c9; return 0; } typedef int ti4[4]; typedef int ti7[7]; int ti_4[4]; int ti_7[7]; void f10 () { ti7* p7 = &ti_7; (*p7)[c10] = 10; c10 = c10; } void f11 () { ti4* p4 = &ti_4; ti7* p7 = (ti7*)p4; (*p7)[c11]=11; c11 = c11; } void f12 () { ti7* p7 = &ti_7; ti4* p4 = (ti4*)p7; (*p4)[c12]=12; c12 = c12; } extern int k1, k2, k3, k4; void pointer_index(void) { int *p = u; int l; l = p[k1]; k1 = k1; p = (char*)u + 5; l = p[k2]; k2 = k2; p = (char*)u + 11; l = p[k3]; k3 = k3; p = u + 3; l = p[k4]; k4 = k4; } extern int nulli; void null_index(void) { *((int*)0+nulli) = 0; } void main () { f1(); f2(); f3(); f4(); f5(); f6(); f7(); f8(); f9(); f10(); f11(); f12(); pointer_index(); if (maybe) null_index(); } ���������������������������frama-c-Fluorine-20130601/tests/misc/Change_formals.ml����������������������������������������������0000644�0001750�0001750�00000004572�12155630321�021342� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types module Options = Plugin.Register(struct let name = "Test" let shortname= "test" let help = "test" end) class transform prj = object(_self) inherit Visitor.frama_c_copy prj method vglob_aux = function | GFun (_fdec, _loc) as g -> let mk_formal = function l -> begin match l with | GFun (fundec, loc) :: [] -> Project.on prj (fun () -> Options.feedback "current prj = %a" Project.pretty (Project.current ()); ignore(Cil.makeFormalVar fundec "ok" Cil.intType)) (); let g = GFun({ fundec with svar = fundec.svar }, loc) in [g] | _ -> assert false end in Cil.ChangeDoChildrenPost( [g], mk_formal) | GVarDecl (_fspec, _vi, _loc) as g -> let mk_gvar_decl = function l -> begin match l with | (GVarDecl (_fspec, vi, _loc) as g) :: [] -> if (Cil.isFunctionType vi.vtype && not (Cil.Frama_c_builtins.mem vi.vname)) then begin match vi.vtype with | TFun(typ, args, varity, attr) -> let vtype = Cil.argsToList args in let new_fun_typ = TFun( typ, Some (vtype @ [ "ok", Cil.intType, [] ]), varity, attr) in vi.vtype <- new_fun_typ; Project.on prj (fun () -> Cil.setFormalsDecl vi new_fun_typ;) (); [ g ] | _ -> assert false end else [g] | _ -> assert false end in Cil.ChangeDoChildrenPost ([g], mk_gvar_decl) | GVar _ | GType _ | GCompTag _ | GCompTagDecl _ | GEnumTag _ | GEnumTagDecl _ | GAsm _ | GPragma _ | GText _ | GAnnot _ -> Cil.DoChildren method vinst = function | Call(_,{ Cil_types.enode = Lval (Var _, NoOffset)},_,_) as i -> let add_zero = function | [Call(res,f,args,loc)] -> let args = args @ [ Cil.zero ~loc ] in [Call(res,f,args,loc)] | _ -> assert false in Cil.ChangeDoChildrenPost([i], add_zero) | _ -> Cil.DoChildren end let generate_code name = let transform prj = new transform prj in File.create_project_from_visitor name transform let main () = if Project.get_name (Project.current()) <> "test" then ignore (generate_code "test") let () = Db.Main.extend main (* Local Variables: compile-command: "make -C ../.. tests/misc/Change_formals.cmo" End: *) ��������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/fun_ptr.i������������������������������������������������������0000644�0001750�0001750�00000001210�12155630321�017711� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ 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); } double h(short a, short b) { return a + b; } volatile int v; main(int c){ test1(!(c&1)); test2(!(c&2)); if (c&4) test3(!(c&8)); double (*ph)() = h; if (c&16) ph(1., 2.); if (c&32) ph(); if (c&64) ph((short)1, (short)2); return 0; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cast1.i��������������������������������������������������������0000644�0001750�0001750�00000000507�12155630321�017257� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/inout.i��������������������������������������������������������0000644�0001750�0001750�00000002622�12155630321�017402� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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) ; } ��������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/find_enclosing_loop.ml�����������������������������������������0000644�0001750�0001750�00000001423�12155630321�022434� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil open Cil_types class check = object(self) inherit Visitor.frama_c_inplace val current_loop = Stack.create () method vstmt_aux s = let res = match s.skind with | Loop _ -> Stack.push s current_loop; ChangeDoChildrenPost (s, fun s -> ignore (Stack.pop current_loop); s) | _ -> DoChildren in let has_loop = try Some (Kernel_function.find_enclosing_loop (Extlib.the self#current_kf) s) with Not_found -> None in (match has_loop with | Some s -> assert (s == Stack.top current_loop) | None -> assert (Stack.is_empty current_loop)); res end let run () = Visitor.visitFramacFileSameGlobals (new check) (Ast.get()) let () = Db.Main.extend run ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/log_twice.i����������������������������������������������������0000644�0001750�0001750�00000000217�12155630321�020216� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/misc/log_twice */ int* f() { int x; return &x; } void main(int x) { int *p = f(); *p = 1; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/sep.i����������������������������������������������������������0000644�0001750�0001750�00000001412�12155630321�017027� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -slevel 10 -lib-entry -main f1 -separate-n 0 -separate-of 3 OPT: -val -slevel 10 -lib-entry -main f1 -separate-n 1 -separate-of 3 OPT: -val -slevel 10 -lib-entry -main f1 -separate-n 2 -separate-of 3 OPT: -val -slevel 10 -lib-entry -main f1 -separate-n 3 -separate-of 3 OPT: -val -slevel 10 -lib-entry -main f1 -val-split-return-auto */ 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]; return -1; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/deep_conditionals.i��������������������������������������������0000644�0001750�0001750�00000000235�12155630321�021725� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 ; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/va_list.c������������������������������������������������������0000644�0001750�0001750�00000000322�12155630321�017672� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef void *va_list; #define va_start(AP, LASTARG) \ (AP = ((va_list) __builtin_next_arg (LASTARG))) void main(const char *pszMessage,...) { va_list vlParameters; va_start(vlParameters,pszMessage); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bug_0209.ml����������������������������������������������������0000644�0001750�0001750�00000001226�12155630321�017652� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������let main () = (* File.create_project_from_visitor calls File.cil_init but never calls Logic_env.Builtins.apply *) ignore (File.create_project_from_visitor "foo" (fun p -> new Visitor.generic_frama_c_visitor (Cil.copy_visit p))); let p = Project.create "bar" in (* Computing the AST first calls File.cil_init, than calls Logic_env.Builtins.apply. This second call raises an exception because logic builtins were registered twice by File.cil_init (even if File.cil_init was called on two different projects: the hook Logic_env.Builtins is not projectified) *) Project.on p Ast.compute () let () = Db.Main.extend main ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/nested_struct_init.i�������������������������������������������0000644�0001750�0001750�00000002144�12155630321�022154� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/merge_bits.i���������������������������������������������������0000644�0001750�0001750�00000000370�12155630321�020362� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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))=2U<<31 | 2U << 30 | 2U << 27 | 2U << 3; CEA_F(*((int*)(T))); return 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/tab.c����������������������������������������������������������0000644�0001750�0001750�00000001115�12155630321�017000� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#include "any_int.c" int x=55,y=77,t[4]; void main0() { int i = any_int (); t[1] = x; t[i] = y; } void main() { int i = any_int (); t[i] = 1; t[1] = y; } int TT[5][5]={0,1,1,0,0,0,0,0,0,0,0,1}; int TTT[5][5]={1,2,3,4,5,0,0,0,0,0,1}; void main1(){ TT[5][5] =2; } /* typedef struct {int a; int b;} T; void g() { int x,y,i,t[4],*p; T s1,s2; t[i] = y; t[1] = x; s1 = s2; s1.a = s2.a; s1.b = s2.b; } int t[10][10]; int ***p, i,j,x; char **c; void g1() { // *(*(p+2)) = &i; // ***(p+i) = x; *(*(c+2)+1) = 'a'; } void h1() { *(*(*(&c+2)+1)+5) = 'a'; } */ ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/mergestruct1.i�������������������������������������������������0000644�0001750�0001750�00000000143�12155630321�020665� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: */ struct s { int a; } s1; void f(void); main() { s1.a = 1; f(); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/machdep.c������������������������������������������������������0000644�0001750�0001750�00000001004�12155630321�017630� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -val -cpp-command "gcc -C -E -DPTEST" -journal-disable -then -machdep x86_64 -then -machdep x86_16 */ #ifndef PTEST #include <stdio.h> #endif int test1 () { unsigned long long u, w, *q ; u = (unsigned long long) -1LL ; q = (unsigned long long *) u; w = (unsigned long long) q; int c1 = (sizeof (q) == sizeof (u)) ; int c2 = (w == u) ; #ifndef PTEST printf("%d==1 => %d==1\n", c1, c2); #endif return c1!=1||c2==1 ; } int main() { return test1() ; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bad_loop.i�����������������������������������������������������0000644�0001750�0001750�00000000330�12155630321�020015� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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: ; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/branch2.i������������������������������������������������������0000644�0001750�0001750�00000000435�12155630321�017563� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ 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; } } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/disjoint_status.i����������������������������������������������0000644�0001750�0001750�00000000572�12155630321�021474� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-then" +"-report" */ int x; void f(unsigned int c, unsigned int d) { //@ assert c != 1 || d != 2; //@ assert d/2-c !=0; x = 1/(d/2-c); } /*@ requires c + 1 == 2; @ requires c+d==3; */ //implied: requires c==1 && d==2; void main(unsigned int c, unsigned int d) { if (c == 1 && d==2) f(c, d); /*@ assert c==1 && d==2; */ f(d,c); } ��������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/div.i����������������������������������������������������������0000644�0001750�0001750�00000001104�12155630321�017020� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/loopinv.c������������������������������������������������������0000644�0001750�0001750�00000000700�12155630321�017717� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-module lib/plugins/Report -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 \valid(p) && 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); } } ����������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/relations_difficult.i������������������������������������������0000644�0001750�0001750�00000000520�12155630321�022270� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cond2.i��������������������������������������������������������0000644�0001750�0001750�00000002323�12155630321�017247� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cast_return.c��������������������������������������������������0000644�0001750�0001750�00000000524�12155630321�020566� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: STDOPT: +"-no-collapse-call-cast" */ extern int i; int f () { return i; } volatile int c; int g() { int x; if (c) x = 1; return x; } char h() { return 1; } void main () { if(c) {float f_ = f();} if(c) {long long v = g();} if(c) { int* x = 0;; int **p = &x; **p = h(); } } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/switch.i�������������������������������������������������������0000644�0001750�0001750�00000001617�12155630321�017550� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �����������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/arith_pointer.c������������������������������������������������0000644�0001750�0001750�00000000543�12155630321�021105� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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,j; for (i=-10; i< 10; i++) { t[i+10] = (int*)(i+10)-(int*)10; // printf("%d\n",(int*)(i+10)-(int*)10); } j = -i; // printf("%d %d\n",(int)&a,(int)(&a-(int*)0)); } �������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/pointer_comparison.c�������������������������������������������0000644�0001750�0001750�00000001067�12155630321�022152� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 x,y,*p; main(){ p = &x; if (p++ != &y) Frama_C_show_each_1t(p); else Frama_C_show_each_1e(p); if (p++ != &y) Frama_C_show_each_2(p); else Frama_C_show_each_2e(p); if (p++ != &y) Frama_C_show_each_3(p); else Frama_C_show_each_3e(p); if (p++ != &y) Frama_C_show_each_4(p); else Frama_C_show_each_4e(p); while (p++ != &y) Frama_C_show_each_5(p); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/sizeof.i�������������������������������������������������������0000644�0001750�0001750�00000000604�12155630321�017541� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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*)); //@ assert sizeof("BLA") != sizeof("FOOBAR"); return; } ����������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/logicdeps.i����������������������������������������������������0000644�0001750�0001750�00000000566�12155630321�020222� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -memexec-all -inout -inout-callwise -calldeps -no-deps -no-input -no-out */ int t[50]; int *p; //@ assigns t[20..*p+20] \from t[0..*p]; void f(); void g() { f(); } extern int y, z; void main() { //@ assert 0 <= y <= 10; //@ assert 15 <= z <= 20; p = &y; g(); g(); g(); //@ assert \true; p = &z; g(); g(); g(); } ������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/pragma.c�������������������������������������������������������0000644�0001750�0001750�00000001400�12155630321�017476� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#pragma section DATA ".CRCPPRAM_TIME_I" ".CRCPPRAM_TIME" far-absolute #pragma section DATA ".IRAM_BIT_I" ".IRAM_BIT" near-data #pragma section CONST ".CA_ROM" ".CA_ROM" far-absolute #pragma section SCONST ".CA_ROM" ".CA_ROM" far-absolute #pragma option -Xpragma-section-last #pragma option -Xsmall-const=0 #pragma section CODE ".illegal_code" standard RX #pragma section CONST ".illegal_const" ".illegal_const" far-absolute R #pragma section SCONST ".illegal_sconst" ".illegal_sconst" near-code R #pragma section STRING ".illegal_string" far-absolute R #pragma section DATA ".illegal_data" ".illegal_bss" near-data RW #pragma section SDATA ".illegal_sdata" ".illegal_sbss" near-data RW #pragma section CODE ".illegal_code" standard RX void main () { return; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/conditional_initializer.i��������������������������������������0000644�0001750�0001750�00000000052�12155630321�023145� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int T[1] = {0?(char)1:2}; void main () {} ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/precond.c������������������������������������������������������0000644�0001750�0001750�00000000545�12155630321�017672� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-module lib/plugins/Report -lib-entry -val -then -report -report-print-properties */ int x; /*@ requires i+1 >= 0; requires i >= 0; assigns x; */ void f (int i) { x = i; } //@ requires x <= 8; void g(); void main (int c) { void (*p)(int) = f; if (c) { f(1); if(c) f(0); } g (); (*p)(0); (*p)(-1); } �����������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/case_analysis.i������������������������������������������������0000644�0001750�0001750�00000000575�12155630321�021067� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �����������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts0451.i������������������������������������������������������0000644�0001750�0001750�00000000707�12155630321�017350� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ���������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/vis_spec.i�����������������������������������������������������0000644�0001750�0001750�00000000212�12155630321�020050� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/misc/vis_spec.i */ //@ assigns \nothing; void g () ; //@ assigns \nothing; void f () { g(); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/implies.i������������������������������������������������������0000644�0001750�0001750�00000000214�12155630321�017701� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int A,B; int main(int c, int d) { A = !!d; /*@ assert ((A ==> \false) ==> \false); */ /*@ assert c ==> \false; */ return 1 + c; }������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/from_ptr2.i����������������������������������������������������0000644�0001750�0001750�00000000276�12155630321�020161� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; */ ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts0506.i������������������������������������������������������0000644�0001750�0001750�00000001234�12155630321�017345� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*run.config STDOPT: +"-no-collapse-call-cast" +"-print" STDOPT: +"-collapse-call-cast" +"-print" */ int f1(); long f2(); unsigned int f3(); float f4(); double f5(); int *f6(); void *f7(); void main2() { long r1 = f1(); short r2 = f1(); int r3 = f1(); unsigned int r4 = f1(); long r5 = f2(); int r6 = f2(); unsigned long r7 = f2(); unsigned int r8 = f3(); int r8 = f3(); float r9 = f4(); double r10 = f4(); float r11 = f5(); double r12 = f5(); void* r13 = f6(); int* r14 = f6(); char* r15 = f6(); void* r16 = f7(); int* r17 = f7(); } int f(int x) { return x+1; } void main () { short x = 4; x = f(42); main2(); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cmp_ptr.i������������������������������������������������������0000644�0001750�0001750�00000001214�12155630321�017704� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts1201.ml�����������������������������������������������������0000644�0001750�0001750�00000000210�12155630321�017507� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������let main () = !Db.Value.compute (); Globals.set_entry_point "main2" false; !Db.Value.compute (); ;; let () = Db.Main.extend main ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/addr2.i��������������������������������������������������������0000644�0001750�0001750�00000000370�12155630321�017236� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ 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; } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/val_if.i�������������������������������������������������������0000644�0001750�0001750�00000001304�12155630321�017500� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/enum2.c��������������������������������������������������������0000644�0001750�0001750�00000002020�12155630321�017254� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -check -cpp-command "gcc -C -E -I. %1 -o %2" -memory-footprint 1 -val -deps -out -input -journal-disable share/libc/stdio.c */ /* This test of enums doubles with a test of the % syntax in -cpp-command */ #include "share/libc/stdio.h" #define BIT_DE_SIGNE_1 (0x98765432) #define BIT_DE_SIGNE_0 (0x12345678) typedef enum { E1_MOINS1 = -1, E1_SGN1 = BIT_DE_SIGNE_1, E1_SGN0 = BIT_DE_SIGNE_0 } E1 ; E1 f(E1 x) { E1 y = x; return x; } unsigned char enum1_sgn1_positif (void) { unsigned char res = (f((E1)E1_SGN1)) > 0; printf ("enum1_sgn1_positif = %d\n", res); return res; /* WARN : ppc->0 ; gcc->1 */ } unsigned char enum1_sgn1_inf_sgn0 (void) { unsigned char res = E1_SGN1 < E1_SGN0; printf ("enum1_sgn1_inf_sgn0 = %d\n", res); return res; /* WARN : ppc->1 ; gcc->0 */ } 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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bitwise_or.c���������������������������������������������������0000644�0001750�0001750�00000001220�12155630321�020375� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -big-ints-hex 256 -val -journal-disable share/builtin.c */ #include "../../share/builtin.h" int or1, or2, or3, or4, or5; int and1, and2, and3, and4, xor1, xor2; unsigned int uand1, uand2, uand3, uand4, uand5; int a,b,c,d,e; extern unsigned short s; 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; xor1 = a ^ a; xor2 = a ^ b; unsigned i1 = s * 2; unsigned i2 = s * 4; unsigned v1 = i1 & i2; unsigned v2 = i1 | i2; return 0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cond.i���������������������������������������������������������0000644�0001750�0001750�00000001402�12155630321�017162� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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, char**argv) { 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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/deps_mixed.i���������������������������������������������������0000644�0001750�0001750�00000000220�12155630321�020355� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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)); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bitwise_float.c������������������������������������������������0000644�0001750�0001750�00000000316�12155630321�021067� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������//@ requires 0.05 <= a <= 5.0; unsigned long main(float a) { unsigned long x; x = (unsigned long)*((unsigned long *)(& a)); Frama_C_show_each_x(x); x = (*(unsigned long *)(&x)) & 2UL; return x; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/separated.i����������������������������������������������������0000644�0001750�0001750�00000000611�12155630321�020210� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ char t[15]; char *p = t; int x; main(int c){ if (c&1) /*@ assert \separated(p, p+1) ; */ x = 1; else if (c&2) /*@ assert \separated(p, p) ; */ x = 1; else if (c&4) /*@ assert \separated(p+1, p+1) ; */ x = 1; else if (c&8) /*@ assert \separated(p+(0..8), p+(8..12)) ; */ x = 1; else /*@ assert \separated(p+(0..5), p+(6..12)) ; */ x = 1; } �����������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/behavior_names.i�����������������������������������������������0000644�0001750�0001750�00000000346�12155630321�021227� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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++; } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/undef_fct.i����������������������������������������������������0000644�0001750�0001750�00000000037�12155630321�020177� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int main() { return f(3); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/loop_long.i����������������������������������������������������0000644�0001750�0001750�00000000165�12155630321�020234� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������char T[368200]; int main(int c1, int c2) { int i; for(i = 0; i < 368; i++) { T[i] = 33; } return i; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/char_ampamp.c��������������������������������������������������0000644�0001750�0001750�00000000236�12155630321�020505� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/switch2.i������������������������������������������������������0000644�0001750�0001750�00000000503�12155630321�017623� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cabscond.c�����������������������������������������������������0000644�0001750�0001750�00000001130�12155630321�020003� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: not robust enough + require native dynlink OPT: -load-script tests/misc/cabscond_script.ml -print */ /* run.config_cabscond OPT: -load-script tests/misc/cabscond_script.ml -print */ // Tests with: // ptests tests/misc/cabscond.c -config cabscond int f(int); int test(int a,int b,int c) { if ( (f(a) && !f(b)) || f(c) ) { return 0; } else { return 1; } if ( (f(a) && !f(a)) || f(a) ) { return 0; } else { return 1; } while ( (f(a) && !f(a)) || f(c) ) { return 0; } for ( a=0 ; (f(a) && !f(b)) || f(c) ; a+=c ) { return 0; } } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts0525-2.i����������������������������������������������������0000644�0001750�0001750�00000000203�12155630321�017500� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -typecheck -check tests/misc/bts0525.i */ typedef enum {E1=2, E2} T_EN1 ; int f2(T_EN1 p2) { return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/leaf2.i��������������������������������������������������������0000644�0001750�0001750�00000000176�12155630321�017237� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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++; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/from_termin.i��������������������������������������������������0000644�0001750�0001750�00000000123�12155630321�020557� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int b,c,d,e; void main(int a) { if (a) b = c; else while (1) d = e; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/read.c���������������������������������������������������������0000644�0001750�0001750�00000000254�12155630321�017150� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#include "../../share/libc.c" int main (FILE * file) { int BUFFER[10]; size_t r; r = read(file,BUFFER,sizeof(BUFFER)); r += BUFFER[3]; return r+BUFFER[5]; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/no_results.c���������������������������������������������������0000644�0001750�0001750�00000000401�12155630321�020424� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-no-results-function init" +"-inout-callwise" +"-calldeps" +"-inout" +"-slevel 10000" */ #define N 3000 int t[N]; void init() { for(int i=0; i<N; i++) t[i]=i; } void f() { t[1]=t[0]; } void main() { init(); f(); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/endian.i�������������������������������������������������������0000644�0001750�0001750�00000001170�12155630321�017477� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ 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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/volatile.i�����������������������������������������������������0000644�0001750�0001750�00000002065�12155630321�020064� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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}; struct sv sv3 = {3}; struct sv sv4 = {4, 5}; int fn2(int, int); int fn1(int x, int y) { Frama_C_show_each_1(x); Frama_C_show_each_2(y); return x + y; } int R1, R2; int main () { /* passing volatile things to functions */ R1 = fn1(G, G|0); R2 = fn2(G, G|0); Frama_C_show_each_d(G); 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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/pointer_comp.c�������������������������������������������������0000644�0001750�0001750�00000001303�12155630321�020727� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/array_loop.i���������������������������������������������������0000644�0001750�0001750�00000000301�12155630321�020403� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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]; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/undefined_sequence.i�������������������������������������������0000644�0001750�0001750�00000002423�12155630321�022074� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-unspecified-access" STDOPT: +"-no-unspecified-access" */ /* detection of undefined behavior for read/write accesses in unspecified order */ int G[10]; volatile int c; int f (int x) { return x+1;} int g (int x) { return x+2;} int r, H; int h(int i) { if (c) r = r++; //UB i = r++; //Not UB H = i; return i; } int func(int x, int y) { return x + y; } //volatile int c; int ub_ret(void) { int d = 5; return d + (d=0); // UB } int main (int a) { int x, *y, i,j; x = 0; y = &x; if (c) i=(x=0)+(*y=1); // UB 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; if (c) { while(j<9 && i<9) { if (c) G[j] = G[j++]; // UB if (c) G[i++] = G[i]; // UB }} i=j=0; if (c) { while(j<9 && i<9) { if (c) G[j] += G[j++]; // UB if (c) G[i++] += G[i]; // UB }} if (c) 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; if (c) G[9] = ub_ret(); return (c ? (my_f=g, f(1)) + my_f(2) : 0); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/dur.i����������������������������������������������������������0000644�0001750�0001750�00000007677�12155630321�017055� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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;} } �����������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/long_const.i���������������������������������������������������0000644�0001750�0001750�00000001701�12155630321�020406� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-no-warn-signed-overflow" STDOPT: +"-warn-signed-overflow" */ long long int LL_ABS(long long int a) { return ((a) >= 0LL ? (a) : -(a)); } /*@ requires -9223372036854775807LL <= numerateur <= 9223372036854775807LL; requires -9223372036854775807LL <= denominateur <= 9223372036854775807LL; */ long long int div64 (long long int numerateur, long long int denominateur) { long long int loc_num; long long int loc_den; long long int signe_negatif; signe_negatif = (numerateur ^ denominateur) & 0x8000000000000000; loc_num = LL_ABS(numerateur); loc_den = LL_ABS(denominateur); Frama_C_show_each(numerateur, loc_num, denominateur, loc_den); return 0LL; } void main(long long int v1, long long int v2) { unsigned long long i; i = 0xFFFF804000000000UL; unsigned long j= ((((((256ULL) >> 8) * 0xffff000000000000UL) | (256ULL << 39) )) + (1ULL << 39)/2ULL); CEA_f(sizeof(long),i,j); div64(v1, v2); } ���������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/visitor_creates_func_bts_1349.i��������������������������������0000644�0001750�0001750�00000000173�12155630321�024013� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -check -load-script tests/misc/Visitor_creates_func_bts_1349.ml -then-on test -print */ int a = 10; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/library_precond.i����������������������������������������������0000644�0001750�0001750�00000000166�12155630321�021423� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ /*@ requires t > 0; assigns \result; */ int mxml(int t); int main() { int p = -3; int a = mxml(p); return a; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/null_lt_valid.i������������������������������������������������0000644�0001750�0001750�00000000662�12155630321�021076� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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); } ������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/offset_misaligned.i��������������������������������������������0000644�0001750�0001750�00000000127�12155630321�021724� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������char t[300]; main(unsigned char u){ t[0] = 1; *(int*)(t+1) = 2; t[u+10] = 3; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/plevel.i�������������������������������������������������������0000644�0001750�0001750�00000001036�12155630321�017531� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-plevel 40" +"-big-ints-hex 0x55" */ int t[0xFFFF]; volatile int i; void main() { int i1 = i; //@ assert 0 <= i1 <= 0x20; int i2 = i; //@ assert 0 <= i2 <= 0x40; t[0x100 + i1] = 1; t[0x200 + i2] = 2; t[0x300 + 2*i1] = 3; t[0x400 + 2*i2] = 4; int *p; p = &t[0x500+i1]; *p = 0x5555; p = (int*)((short*)p+1); *p = 0x5656; p = &t[0x600+i2]; *p = 0x6666; p = (int*)((short*)p+1); *p = 0x6767; p = ((char*)&t[0x700])+i1; *p = 7; p = ((char*)&t[0x800])+i2; *p = 8; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/packed.c�������������������������������������������������������0000644�0001750�0001750�00000000446�12155630321�017467� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ typedef __attribute__((__packed__ (1,256,1))) struct { volatile char Reserved[4]; } T_HCCA; #define __packed__(...) __attribute__((__packed__(__VA_ARGS__))) typedef __packed__ (1,256,1) struct { volatile char Reserved[4]; } T_HCCB; T_HCCA x; T_HCCB y; void main() { } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/modifies.i�����������������������������������������������������0000644�0001750�0001750�00000000361�12155630321�020041� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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]++;}; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/if.i�����������������������������������������������������������0000644�0001750�0001750�00000002113�12155630321�016635� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/automalloc.i���������������������������������������������������0000644�0001750�0001750�00000000541�12155630321�020402� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef unsigned int size_t; void*malloc(size_t s); void*realloc(void*ptr,size_t s); void*alloca(size_t s); void free (void * ptr); void*calloc (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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/access_path.i��������������������������������������������������0000644�0001750�0001750�00000000041�12155630321�020512� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int main(int **p) { (**p)++; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/logic.c��������������������������������������������������������0000644�0001750�0001750�00000003422�12155630321�017332� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int t[10], u[11]; struct ts { int f1; int f2; } s1, s2, s3[10]; unsigned int x; void eq_tsets () { //@ assert \union() == \union(); //@ assert \union(1) == \union(1); //@ assert \union(1, 2) == \union(1, 2); //@ assert \union(2, 1) == \union(1, 2); //@ assert ! (\union(1, 2) == \union(1, 3)); //@ assert ! (\union(1, 2) == \union(1)); //@ assert ! (\union(1 ,2) == \union(3, 4)); //@ assert \union(1, 2) != \union(1, 3); //@ assert \union(1, 2) != \union(1); //@ assert \union(1 ,2) != \union(3, 4); //@ assert \union(x, x+1) != \union(-1, -3); //@ assert \union(1.0) == \union(1.0); //@ assert \union(&t) == \union(&t); //@ assert ! (\union(&t[0..1]) == \union(&t[0..2])); //@ assert ! (\union(&t[0..1]) == \union(&t[2..3])); //@ assert (\union(&t[0..1]) == \union(&t[0..1])); // Seems to be OK according to the typing given by the kernel. The WP is also happy //@ assert \union(\union(1,2)) == \union(\union(1), \union(2)); //@ assert \union(\union(1,2)) == \union(\union(1), 2); //@ assert \union(\union(1,2)) == \union(1, 2); //@ assert \union(\union(1,1)) == \union(\union(1), 1); //@ assert &s3[0..1].f2 != 0; //@ assert &s3[0 .. -1].f1 != &s3[0..1].f2; //@ assert &s3[0 .. 1].f1 != &s3[0..1].f1; //@ assert s1 == s2; // True at link-time //@ assert t != u; // false //@ assert \union(0) == \union(0.0); //@ assert \union(1.0) == \union(1); //@ assert \union(1, 1.0) == \union(1.0, 1); //@ assert \union() != \union(x); } void eq_char() { char c = '\x82'; // equal to 130. Very different from \130 which is in octal Frama_C_show_each(c); //@ assert c == '\x82'; //@ assert c == 130-256; } void casts() { //@ assert (float)5 == 5.; //@ assert (double)5 == 5.; } void main () { eq_tsets(); eq_char(); casts(); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts1347.ml�����������������������������������������������������0000644�0001750�0001750�00000001477�12155630321�017542� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������let emitter = Emitter.create "emitter" ~correctness:[] ~tuning:[] [ Emitter.Code_annot; Emitter.Property_status ] let run () = Globals.Functions.iter (fun kf -> if not (Cil.is_builtin (Kernel_function.get_vi kf)) then begin Globals.set_entry_point (Kernel_function.get_name kf) true; !Db.Value.compute(); let hyps = Alarms.fold (fun _ kf' s ~rank:_ _ a l -> if Kernel_function.equal kf kf' then Property.ip_of_code_annot_single kf s a :: l else l) [] in let s = Kernel_function.find_return kf in let ca = !Db.Properties.Interp.code_annot kf s "assert 32.5>=10.;" in Annotations.add_code_annot emitter ~kf s ca; let ip = Property.ip_of_code_annot_single kf s ca in Property_status.emit emitter ~hyps ip Property_status.True end) let () = Db.Main.extend run �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts0990_link_1.i�����������������������������������������������0000644�0001750�0001750�00000000205�12155630321�020606� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is at bts_0990_link.i */ char s[100]; void perror(const char *); void g(void){ perror(s); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/origin.i�������������������������������������������������������0000644�0001750�0001750�00000004417�12155630321�017537� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 */ char f(); 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; } /************************************/ �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/pointer.i������������������������������������������������������0000644�0001750�0001750�00000000657�12155630321�017732� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ���������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts0858.i������������������������������������������������������0000644�0001750�0001750�00000000247�12155630321�017362� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef long int64_t; typedef unsigned long uint64_t; int main() { uint64_t tmp = 18446744073709551615UL ; if (0xffffffffUL == tmp) return 1; return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/array_zero_length.i��������������������������������������������0000644�0001750�0001750�00000000721�12155630321�021760� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -val -journal-disable OPT: -memory-footprint 1 -val -lib-entry -journal-disable */ char T[]; char U[0]; char V[][2]; char W[][0]; char *pW; void main(int c, char **v) { T[2]= 3; if (c&1) T[1] = T[3] +3; if (c&2) U[2] = 3; if (c&4) U[1] = U[3] +3; if (c&8) V[2][1] = 3; if (c&16) V[1][1] = V[3][1] +3; if (c&32) W[2][1] = 3; if (c&64) W[1][1] = W[3][1] +3; if (c&128) pW = &W[0][1]; } �����������������������������������������������frama-c-Fluorine-20130601/tests/misc/uninitialized_gnubody.i����������������������������������������0000644�0001750�0001750�00000000121�12155630321�022633� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int main () { int x = 0; x = ({ int y = 0; y++; y + 1;}) + 42; return x; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/degeneration2.i������������������������������������������������0000644�0001750�0001750�00000000472�12155630321�020773� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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]; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/join_misaligned.i����������������������������������������������0000644�0001750�0001750�00000001552�12155630321�021400� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-big-ints-hex 257" */ int t[5]={0}; int u[5]={1,1,1,1,1}; int v[7]={0x22222222,0x22222222,0x22222222,1,1,1,1}; int w[7]={0}; char x[5]={0}; int y[7]={0x22222222,0x22222222,0x22222222,1,1,1,1}; unsigned char z[5] = {0xFF,0xFF,0xFF,0xFF,0xFF}; unsigned int a; volatile unsigned short va; void main(int c) { if (c) { ((char*)t)[6]='a'; ((char*)u)[6]='c'; *((short*)((char*)v+6))=0x44444444; *((short*)((char*)w+6))=57; *((int*)((char*)y+6))=&t; *((short*)(&z[3])) = 0x1111; *((short*) &a) = 0xFFFF; *((short*) &a+1) = 0xFFFF; } else { ((char*)t)[6]='b'; ((char*)u)[6]='d'; *((short*)((char*)v+7))=0x55555555; *((short*)((char*)w+7))=59; x[0]=1; x[1]=0; x[2]=1; *((int*)((char*)y+7))=&u; a = va; a <<= 12; a--; } } ������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/loop_array.i���������������������������������������������������0000644�0001750�0001750�00000000463�12155630321�020414� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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: } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/obfuscate.i����������������������������������������������������0000644�0001750�0001750�00000000675�12155630321�020225� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-module lib/plugins/Obfuscator -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(int*p) { f(p); } �������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/loop2.i��������������������������������������������������������0000644�0001750�0001750�00000001531�12155630321�017275� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/malloc_individual.c��������������������������������������������0000644�0001750�0001750�00000000274�12155630321�021716� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#define FRAMA_C_MALLOC_INDIVIDUAL #include "share/libc/stdlib.c" int *p; int A,B,C; void main(int c) { p = malloc(sizeof(int)); if (c) *p = 3; A = *p; C = 1 + *p; B = A; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/save_comments.i������������������������������������������������0000644�0001750�0001750�00000000232�12155630321�021102� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/mergestruct3.i�������������������������������������������������0000644�0001750�0001750�00000000433�12155630321�020671� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -print -journal-disable tests/misc/mergestruct1.i tests/misc/mergestruct2.i OPT: -memory-footprint 1 -print -journal-disable tests/misc/mergestruct2.i tests/misc/mergestruct1.i */ struct s { float a; } s2; void f(void) { s2.a = 1.0; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/return.i�������������������������������������������������������0000644�0001750�0001750�00000000257�12155630321�017565� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/reduce_valid.i�������������������������������������������������0000644�0001750�0001750�00000000576�12155630321�020700� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int t[2], u[2]; int *p,*q,*r, A, offs; void main(int c, int d, int e, int f, int g, unsigned short h) { 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); u[h+1] = 1; } ����������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/const_typedef.i������������������������������������������������0000644�0001750�0001750�00000001161�12155630321�021107� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -print -then -val -lib-entry -no-print */ typedef int INT[3][3]; typedef int INT2[][3]; typedef int INT3[2][]; const __attribute__((BLA)) INT x1 = {1, 2, 3, 4, 5, 6, 7}; const __attribute__((BLA)) INT x1bis; const __attribute__((BLA)) INT2 x2 = {1, 2, 3, 4, 5, 6, 7 }; const __attribute__((BLA)) INT3 x3 = {1, 2, 3, 4, 5, 6, 7}; typedef struct { int s1; int s2; } ts; const __attribute__((BLA)) ts s[3] ={ 1, 2, 3, 4, 5}; typedef int INT4[7]; typedef int INT5[]; const INT4 y1 = {0, 1, 2, 3, 4}; const INT5 y2 = {1, 2, 3, 4, 5}; extern const INT4 y3; const int y3[7] = {1, 2}; int main() { } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/save_comments.ml�����������������������������������������������0000644�0001750�0001750�00000002536�12155630321�021273� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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())) Printer.pp_location loc1 Printer.pp_location 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 ������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/volatilestruct.c�����������������������������������������������0000644�0001750�0001750�00000000627�12155630321�021325� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-no-warn-signed-overflow" */ struct ss { char *f1; int *f2; int f3; }; struct s { struct ss f4; int f5; }; volatile struct s *p; struct s s2; char x; int y; void main() { p = &s2; p->f4.f1 = &x+1; p->f4.f2 = &y-3; char *q1 = p->f4.f1; int *q2 = p->f4.f2; int i = p->f5; int j = p->f4.f2; int r = (&x - p->f4.f1)+1; int s = (&y - p->f4.f2)+3; } ���������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/invalid_access.i�����������������������������������������������0000644�0001750�0001750�00000000352�12155630321�021211� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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];*/ } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cast.i���������������������������������������������������������0000644�0001750�0001750�00000002563�12155630321�017202� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void printf(const char*c, ...); 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; j =(int*)0 + i; return (j/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 = 2*H;}} 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();} ���������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/local.i��������������������������������������������������������0000644�0001750�0001750�00000000434�12155630321�017335� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/loop_wvar.i����������������������������������������������������0000644�0001750�0001750�00000001431�12155630321�020251� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/imprecise_invalid_write.i��������������������������������������0000644�0001750�0001750�00000000053�12155630321�023140� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int x; int main(int c) { *(int*)c = x; }�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cast_fun.i�����������������������������������������������������0000644�0001750�0001750�00000002524�12155630321�020047� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-calldeps" */ //@ assigns \nothing; int f1(); //@ assigns \nothing; int f2(void); //@ assigns \nothing; int f3(int); //@ assigns \nothing; void f4(int); //@ assigns \nothing; int f5(int, int); struct s1 { int f1; int f2; }; struct s2 { int f1; int f2; }; struct s3 { int f1; int f2; int f3; }; //@ assigns \nothing; void f6(struct s1); //@ assigns \nothing; void f7(struct s2); //@ assigns \nothing; void f8(struct s3); //@ assigns \nothing; void f9(int, ...); //@ assigns \nothing; void f10(); void main(volatile int c) { int (*p1)(int); void (*p2)(struct s1); void (*p3)(int, ...); void (*p4)(); int x; struct s1 s = {0}; if (c){ p1 = f1; x = (*p1)(c); } if (c){ p1 = f2; x = (*p1)(c); } if (c){ p1 = f3; x = (*p1)(c); } if (c){ p1 = f4; x = (*p1)(c); } if (c){ p1 = f5; x = (*p1)(c); } if (c){ p2 = f6; (*p2)(s); } if (c){ p2 = f7; (*p2)(s); } if (c){ p2 = f8; (*p2)(s); } if (c) { p3 = f9; (*p3)(c,c); } if (c) { p3 = f10; (*p3)(c,c); } if (c) { p4 = f9; (*p4)(c,c); } if (c) { p4 = f10; (*p4)(c,c); } if (c) { p1 = f10; x = (*p1)(c); } if (c) { p1 = f10; (*p1)(c); } if (c) { p4 = f1; (*p4)(c); } } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/call_3.i�������������������������������������������������������0000644�0001750�0001750�00000000220�12155630321�017371� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cast2.i��������������������������������������������������������0000644�0001750�0001750�00000000522�12155630321�017255� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ extern int any_int(void); void g() { int t; unsigned int G; t = any_int(); G = t; t = t+1; } unsigned char G = (unsigned char)(-1); void h() { G = -255; } void passcast() { int i = (char)(any_int()); if ((char) i <= 100) { Frama_C_show_each(i); } else while(1); } void main() { g(); h(); passcast(); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/loop_test.i����������������������������������������������������0000644�0001750�0001750�00000005742�12155630321�020262� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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(); } ������������������������������frama-c-Fluorine-20130601/tests/misc/bug.i����������������������������������������������������������0000644�0001750�0001750�00000000427�12155630321�017022� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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:; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/CruiseControl_const.c������������������������������������������0000644�0001750�0001750�00000002044�12155630321�022235� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: DONTRUN: */ /*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** Command : ** l2C CruiseControl.lus -node CruiseControl ** -noexp @ALL@ ** -keep_named_var ** -const ** -bitwise ** -loc_ctx ** -no_copy_mem ** -debug ** date of generation (MM/DD/YYYY): 07/06/2007 13:30:09 ** last modification date for CruiseControl.lus (MM/DD/YYYY): 07/06/2007 ********************************************************************$*/ #include "CruiseControl.h" const Speed ZeroSpeed = (real) 0.0; const Speed SpeedInc = (real) 2.0; const Speed SpeedMax = (real) 150.0; const Speed SpeedMin = (real) 30.0; const Percent ZeroPercent = (real) 0.0; const real Kp = (real) 8.113; const real Ki = (real) 0.5; const Percent RegThrottleMax = (real) 45.0; /*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** End of file CruiseControl_const.c ** End of generation (MM/DD/YYYY) : 07/06/2007 13:30:09 ********************************************************************$*/ ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cfg.i����������������������������������������������������������0000644�0001750�0001750�00000000463�12155630321�017004� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/justcopy.i�����������������������������������������������������0000644�0001750�0001750�00000000102�12155630321�020113� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/misc/justcopy.ml -check */ ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/deref.i��������������������������������������������������������0000644�0001750�0001750�00000000311�12155630321�017322� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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]; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/typedef_function.i���������������������������������������������0000644�0001750�0001750�00000000207�12155630321�021606� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef void T(void); extern T F476 ; static T* const G209[] = { 0,& F476}; int main () { int i = (int)G209[0]; return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/inout_formals.i������������������������������������������������0000644�0001750�0001750�00000000217�12155630321�021123� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/fptr.i���������������������������������������������������������0000644�0001750�0001750�00000002116�12155630321�017215� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -memory-footprint 1 -val -deps -out -journal-disable OPT: -memory-footprint 1 -val -deps -out -main main_uninit -journal-disable -inout-callwise */ 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]); } } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/deps_local.i���������������������������������������������������0000644�0001750�0001750�00000000277�12155630321�020355� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int G,H; int h(int *argh) { // G = *argh; *argh = H; return H; } int g() { int ga; h(&ga); return 0; } int f() { int fa; h(&fa); return 0; } int main() { f(); g(); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/linked_list.c��������������������������������������������������0000644�0001750�0001750�00000001240�12155630321�020532� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: STDOPT: +"-plevel 100" +"-big-ints-hex 257" STDOPT: +"-slevel 12" +"-big-ints-hex 257" */ #define FRAMA_C_MALLOC_HEAP #include "share/libc/stdlib.c" #include "share/libc/stdio.h" #include "share/libc/stdio.c" struct list_el { int val; struct list_el * next; }; typedef struct list_el item; void main() { item * curr, * head; int i; head = NULL; for(i=1;i<=10;i++) { CEA_DUMP(); curr = (item *)malloc(sizeof(item)); CEA_DUMP(); curr->val = i; curr->next = head; head = curr; } curr = head; while(curr) { printf("%d\n", curr->val); curr = curr->next ; } } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/behavior_names.ml����������������������������������������������0000644�0001750�0001750�00000000651�12155630321�021406� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������let run () = let _ = Ast.get () in let kf = Globals.Functions.find_by_name "f" in let pretty_list fmt l = Pretty_utils.pp_list ~sep:"@ " Format.pp_print_string fmt l in Format.printf "@[stmt: %a@\nnew1: %s@\nnew2: %s@]@." pretty_list (Annotations.behavior_names_of_stmt_in_kf kf) (Annotations.fresh_behavior_name kf "foo") (Annotations.fresh_behavior_name kf "bla") let () = Db.Main.extend run ���������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/struct_p_call.i������������������������������������������������0000644�0001750�0001750�00000000222�12155630321�021074� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ 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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/call_multi.c���������������������������������������������������0000644�0001750�0001750�00000001453�12155630321�020364� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-unspecified-access" */ #include "share/libc/stdio.c" int uppol2(int al1,int al2,int plt,int plt1,int plt2) { long int wd2,wd4; int apl2; wd2 = 4L*(long)al1; if((long)plt*plt1 >= 0L) wd2 = -wd2; /* check same sign */ /* CONDITION */ wd2 = wd2 >> 7; /* gain of 1/128 */ // CEA_TEST(plt,plt2,(long)plt*plt2>= 0L); if((long)plt*plt2 >= 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); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bug_023.i������������������������������������������������������0000644�0001750�0001750�00000000124�12155630321�017400� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int i; int x; int f(); int main() { if (i == 0 || i == 1) { i += f(); } } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/library.i������������������������������������������������������0000644�0001750�0001750�00000001355�12155630321�017712� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -memory-footprint 1 -val -deps -out -input -lib-entry -main main -context-depth 3 -journal-disable -then -main main2 -then -context-width 4 */ int f_int(int x); int *f_star_int(int x); int ****G; int G0,*G1; typedef int (*pfun)(int *p1, const int *p2); pfun gen(); extern pfun f; float *i(); double *k(); void main(pfun g) { G0 = f_int(2); G1 = f_star_int(5); *G1 = 5; ****G=1; int x = 3; int y = 4; pfun h = gen(); int z1 = f(&x, &y); int z2 = g(&x, &y); int z3 = h(&x, &y); float *pf = i(); float vf = *pf; *pf = 1.; *pf += *pf; double *pd = k(); *pd = 2.; } struct { void (*f[2])(); } s; struct { struct ss *p[8]; struct ss (*q)[8]; } ss; void (*ff)(); void main2(){} �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/array_array.c��������������������������������������������������0000644�0001750�0001750�00000002640�12155630321�020552� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -memory-footprint 1 -val -deps -out -input -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 */ char StaticAllocHEAP[10000]={2,2,2,2}; void *LIB_MEM_StaticAlloc(int size, int hint) { static int next_free=0; CEA_ALLOCATION_WITH_STATIC_ALLOC(size); void * new = &(StaticAllocHEAP[next_free]); /* Enforce a 4 byte boundary for allocation */ next_free += (size%4==0)?size:size+4-size%4; return new; } struct S {int fst; char snd;}; #define MAX 3 void main() { struct S (*v)[MAX]; v = (struct S(*)[MAX]) LIB_MEM_StaticAlloc(sizeof(struct S) * MAX, 0); int i = 29; do { CEA_I(i); v[0][i].snd=1;} while (i-- > -1); v[0][i].fst = 0; } void main2(void) { struct S (*v)[3] ; int i ; int tmp___0 = 0; { v = (struct S (*)[3])LIB_MEM_StaticAlloc((int )(sizeof(struct S ) * 3U), 0); i = 29; { while (1) { CEA_TMP(tmp___0); CEA_I(i); (*(v + 0))[i].snd = (char)1; tmp___0 = i; i --; if (! (tmp___0 > -1)) { goto while_0_break; } } while_0_break: /* CIL Label */ ; } (*(v + 0))[i].fst = 0; return; } } void main3() { struct S (*v)[MAX]; v = (struct S(*)[MAX]) LIB_MEM_StaticAlloc(sizeof(struct S) * MAX, 0); int i = 29; do { v[0][i].snd=1; i--;} while (i > 0); v[0][i].fst = 0; } ������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/precond2.c�����������������������������������������������������0000644�0001750�0001750�00000000746�12155630321�017757� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-module lib/plugins/Report -rte -rte-precond -then -val -then -report -report-print-properties OPT: -load-module lib/plugins/Report -val -then -rte -rte-precond -then -report -report-print-properties */ // Fuse with precond.c when bts #1208 is solved int x; /*@ requires i+1 >= 0; requires i >= 0; assigns x; */ void f (int i) { x = i; } //@ requires x <= 8; void g(); void main (int c) { if (c) { f(1); if(c) f(-1); } g ();g (); } ��������������������������frama-c-Fluorine-20130601/tests/misc/deps_addr.i����������������������������������������������������0000644�0001750�0001750�00000000111�12155630321�020160� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int *t; int a; int tt[5][5]; int main () { return *(&(t[(int)&a])); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/qualified_arrays.i���������������������������������������������0000644�0001750�0001750�00000000636�12155630321�021573� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ��������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/offset_neg.i���������������������������������������������������0000644�0001750�0001750�00000000047�12155630321�020362� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int G[5]; int main () { G[-1] = 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/resolve.i������������������������������������������������������0000644�0001750�0001750�00000000236�12155630321�017722� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ 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); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/output_leafs.i�������������������������������������������������0000644�0001750�0001750�00000000714�12155630321�020756� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ int *H,G,K,L,M,N,P; /*@ assigns G \from G,*H; @ assigns *H \from P; @ assigns *x \from \empty; */ void crypt(int*x); 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(); } ����������������������������������������������������frama-c-Fluorine-20130601/tests/misc/tab1.i���������������������������������������������������������0000644�0001750�0001750�00000000201�12155630321�017062� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int G[10] ={0}; void main (int x) { if (0 <= x) { G[0] =x; } if (0 >= x) { G[1] =x; } } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/assert_ptr.i���������������������������������������������������0000644�0001750�0001750�00000000446�12155630321�020434� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 \valid(*q) && *q != 0 ; */ Frama_C_show_each_q(s_q); return 0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/loopfun.i������������������������������������������������������0000644�0001750�0001750�00000000376�12155630321�017732� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -slevel 50 -val -deps -out -input -journal-disable -no-results */ static int a = 7; int test() { return a--; } int main() { for(test();test();test()) { Frama_C_show_each_t(test()); } return 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/degeneration.i�������������������������������������������������0000644�0001750�0001750�00000000237�12155630321�020710� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ 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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/scade_types.h��������������������������������������������������0000644�0001750�0001750�00000001544�12155630321�020550� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** Command : ** l2C CruiseControl.lus -node CruiseControl ** -noexp @ALL@ ** -keep_named_var ** -const ** -bitwise ** -loc_ctx ** -no_copy_mem ** -debug ** date of generation (MM/DD/YYYY): 07/06/2007 13:30:09 ** last modification date for CruiseControl.lus (MM/DD/YYYY): 07/06/2007 ********************************************************************$*/ /* ===== */ /* TYPES */ /* ===== */ #include "config_types.h" #define _INCLUDE_SCADE_TYPES typedef real Percent; typedef real Speed; /*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** End of file scade_types.h ** End of generation (MM/DD/YYYY) : 07/06/2007 13:30:09 ********************************************************************$*/ ������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/CruiseControl.h������������������������������������������������0000644�0001750�0001750�00000021670�12155630321�021042� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** Command : ** l2C CruiseControl.lus -node CruiseControl ** -noexp @ALL@ ** -keep_named_var ** -const ** -bitwise ** -loc_ctx ** -no_copy_mem ** -debug ** date of generation (MM/DD/YYYY): 07/06/2007 13:30:09 ** last modification date for CruiseControl.lus (MM/DD/YYYY): 07/06/2007 ********************************************************************$*/ #ifndef _INCLUDE_SCADE_TYPES # include "scade_types.h" #endif #include "definitions.h" /* ======================== */ /* CONTEXT for node CruiseSpeedMgt */ /* ======================== */ /* Type for context */ typedef struct { bool _I0_On; bool _I1_Set; bool _I2_QuickAccel; bool _I3_QuickDecel; Speed _I4_Speed; Speed _O0_CruiseSpeed; Speed _L1_CruiseControl; bool _L2_CruiseControl; bool _L3_CruiseControl; bool _L6_CruiseControl; Speed _L21_CruiseControl; Speed _L10_CruiseControl; Speed _L12_CruiseControl; real _L13_CruiseControl; Speed _L15_CruiseControl; bool _L16_CruiseControl; bool _L4_CruiseControl; bool _L17_CruiseControl; Speed _L11_CruiseControl; real _L14_CruiseControl; Speed _L19_CruiseControl; bool _L18_CruiseControl; bool _L5_CruiseControl; bool _L20_CruiseControl; real _L9_CruiseControl; real _L8_CruiseControl; Speed _L7_CruiseControl; bool _M_init_0_CruiseControl; } _C_CruiseSpeedMgt; /* ======================== */ /* CONTEXT for node SaturateThrottle */ /* ======================== */ /* Type for context */ typedef struct { Percent _I0_ThrottleIn; Percent _O0_ThrottleOut; bool _O1_Saturate; Percent _L18_CruiseControl; Percent _L12_CruiseControl; bool _L7_CruiseControl; Percent _L17_CruiseControl; bool _L9_CruiseControl; Percent _L6_CruiseControl; Percent _L8_CruiseControl; bool _L13_CruiseControl; } _C_SaturateThrottle; /* ======================== */ /* CONTEXT for node ThrottleRegulation */ /* ======================== */ /* Type for context */ typedef struct { bool _I0_Reset; Speed _I1_CruiseSpeed; Speed _I2_VehiculeSpeed; Percent _O0_Throttle; Speed _L1_CruiseControl; Speed _L2_CruiseControl; real _L3_CruiseControl; real _L6_CruiseControl; real ProportionnalAction; Speed _L22_CruiseControl; bool HoldIntegralAction; Speed _L16_CruiseControl; Speed _L23_CruiseControl; Speed _L18_CruiseControl; real _L10_CruiseControl; real _L8_CruiseControl; real IntegralAction; real _L4_CruiseControl; Percent _L13_CruiseControl; bool _L14_CruiseControl; bool _L19_CruiseControl; Speed _L21_CruiseControl; bool _M_init_0_CruiseControl; _C_SaturateThrottle _C0_SaturateThrottle; } _C_ThrottleRegulation; /* ======================== */ /* CONTEXT for node ThrottleCmd */ /* ======================== */ /* Type for context */ typedef struct { bool _I0_Regul_ON; Speed _I1_CruiseSpeed; Speed _I2_VehiculeSpeed; Percent _I3_Accelerator; Percent _O0_Throttle; bool _L21_CruiseControl; bool _L20_CruiseControl; bool _L22_CruiseControl; bool ONRisingEdge; Percent _L26_CruiseControl; Speed _L1_CruiseControl; Speed _L2_CruiseControl; Percent _L19_CruiseControl; Percent _L25_CruiseControl; Percent _L24_CruiseControl; bool _M_init_0_CruiseControl; _C_ThrottleRegulation _C0_ThrottleRegulation; bool _M_condact_2_CruiseControl; } _C_ThrottleCmd; /* ======================== */ /* CONTEXT for node CruiseStateMgt */ /* ======================== */ /* Type for context */ typedef struct { bool _I0_BrakePressed; bool _I1_AcceleratorPressed; bool _I2_Resume; bool _I3_On; bool _I4_Off; bool _I5_SpeedOutOffLimits; bool _O0_Regul_ON; bool _O1_Regul_OFF; bool _O2_Regul_STDBY; bool _LE24_CruiseControl; bool _LE0_CruiseControl; bool _LE4_CruiseControl; bool _LE40_CruiseControl; bool _LE26_CruiseControl; bool _LE28_CruiseControl; bool _LE9_CruiseControl; bool _LE10_CruiseControl; bool _LE11_CruiseControl; bool _LE33_CruiseControl; bool _LE35_CruiseControl; bool _LE38_CruiseControl; bool _LE12_CruiseControl; bool _LE13_CruiseControl; bool _LE14_CruiseControl; bool _LE17_CruiseControl; bool _LE18_CruiseControl; bool _LE3_CruiseControl; bool _LE16_CruiseControl; bool _LE41_CruiseControl; bool _LE19_CruiseControl; bool _LE20_CruiseControl; bool _LE21_CruiseControl; bool _LE1_CruiseControl; bool _LE5_CruiseControl; bool _LE22_CruiseControl; bool _LE23_CruiseControl; bool _LE25_CruiseControl; bool _LE29_CruiseControl; bool _LE2_CruiseControl; bool _LE30_CruiseControl; bool _LE31_CruiseControl; bool _LE32_CruiseControl; bool _LE34_CruiseControl; bool _LE42_CruiseControl; bool _LE6_CruiseControl; bool _LE15_CruiseControl; bool _LE39_CruiseControl; bool _LE43_CruiseControl; bool _LE7_CruiseControl; bool _LE27_CruiseControl; bool _LE36_CruiseControl; bool _LE37_CruiseControl; bool _LE44_CruiseControl; bool _LE8_CruiseControl; bool _M_init_0_CruiseControl; } _C_CruiseStateMgt; /* ======================== */ /* CONTEXT for node DetectPedalsPressed */ /* ======================== */ /* Type for context */ typedef struct { Percent _I0_Brake; Percent _I1_Accelerator; bool _O0_BrakePressed; bool _O1_AcceleratorPressed; Percent _L2_CruiseControl; Percent _L8_CruiseControl; bool _L4_CruiseControl; Percent _L1_CruiseControl; Percent _L7_CruiseControl; bool _L3_CruiseControl; } _C_DetectPedalsPressed; /* ======================== */ /* CONTEXT for node DetectSpeedLimits */ /* ======================== */ /* Type for context */ typedef struct { Speed _I0_speed; bool _O0_SpeedOutOffLimits; Speed _L7_CruiseControl; Speed _L13_CruiseControl; bool _L8_CruiseControl; Speed _L14_CruiseControl; bool _L9_CruiseControl; bool _L17_CruiseControl; } _C_DetectSpeedLimits; /* ======================== */ /* CONTEXT for node CruiseControl */ /* ======================== */ /* Type for context */ typedef struct { bool _I0_On; bool _I1_Off; bool _I2_Resume; bool _I3_Set; bool _I4_QuickAccel; bool _I5_QuickDecel; Percent _I6_Accel; Percent _I7_Brake; Speed _I8_Speed; Speed _O0_Cruise_speed; Percent _O1_Throttle_cmd; bool _O2_Regul_ON; bool _O3_Regul_OFF; bool _O4_Regul_STDBY; bool _L73_CruiseControl; Percent _L59_CruiseControl; Percent _L62_CruiseControl; bool BrakePressed; bool AcceleratorPressed; bool _L61_CruiseControl; bool _L60_CruiseControl; bool _L58_CruiseControl; Speed _L95_CruiseControl; bool SpeedOutOffLimits; bool _L82_CruiseControl; bool _L83_CruiseControl; bool _L84_CruiseControl; bool _L19_CruiseControl; Speed _L96_CruiseControl; bool _L38_CruiseControl; bool _L39_CruiseControl; bool _L40_CruiseControl; Speed _L23_CruiseControl; Speed CruiseSpeed; Percent _L26_CruiseControl; Percent _L22_CruiseControl; bool _M_init_CruiseControl; _C_CruiseSpeedMgt _C0_CruiseSpeedMgt; _C_DetectPedalsPressed _C1_DetectPedalsPressed; _C_DetectSpeedLimits _C2_DetectSpeedLimits; _C_CruiseStateMgt _C3_CruiseStateMgt; bool _M_condact_0_CruiseControl; _C_ThrottleCmd _C4_ThrottleCmd; } _C_CruiseControl; /* ============== */ /* INITIALISATION */ /* ============== */ extern void CruiseSpeedMgt_init(_C_CruiseSpeedMgt *); extern void SaturateThrottle_init(_C_SaturateThrottle *); extern void ThrottleRegulation_init(_C_ThrottleRegulation *); extern void ThrottleCmd_init(_C_ThrottleCmd *); extern void CruiseStateMgt_init(_C_CruiseStateMgt *); extern void DetectPedalsPressed_init(_C_DetectPedalsPressed *); extern void DetectSpeedLimits_init(_C_DetectSpeedLimits *); extern void CruiseControl_init(_C_CruiseControl *); /* ================ */ /* CYCLIC FUNCTIONS */ /* ================ */ extern bool CruiseSpeedMgt(_C_CruiseSpeedMgt *); extern bool SaturateThrottle(_C_SaturateThrottle *); extern bool ThrottleRegulation(_C_ThrottleRegulation *); extern bool ThrottleCmd(_C_ThrottleCmd *); extern bool CruiseStateMgt(_C_CruiseStateMgt *); extern bool DetectPedalsPressed(_C_DetectPedalsPressed *); extern bool DetectSpeedLimits(_C_DetectSpeedLimits *); extern bool CruiseControl(_C_CruiseControl *); /*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** End of file CruiseControl.h ** End of generation (MM/DD/YYYY) : 07/06/2007 13:30:09 ********************************************************************$*/ ������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/false.i��������������������������������������������������������0000644�0001750�0001750�00000000361�12155630321�017334� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ 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); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/paths.i��������������������������������������������������������0000644�0001750�0001750�00000001244�12155630321�017362� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/termination.i��������������������������������������������������0000644�0001750�0001750�00000000546�12155630321�020600� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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); } ����������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bug0277.i������������������������������������������������������0000644�0001750�0001750�00000000247�12155630321�017342� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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() ; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/syntax.i�������������������������������������������������������0000644�0001750�0001750�00000000376�12155630321�017576� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } } // ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/call_simple.i��������������������������������������������������0000644�0001750�0001750�00000000265�12155630321�020531� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/from_pb.i������������������������������������������������������0000644�0001750�0001750�00000002627�12155630321�017675� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } } ���������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/loop.i���������������������������������������������������������0000644�0001750�0001750�00000002236�12155630321�017216� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/strings.i������������������������������������������������������0000644�0001750�0001750�00000004245�12155630321�017740� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -val -deps -out -input -main main1 -journal-disable OPT: -val -deps -out -input -main main6 -journal-disable OPT: -val -deps -out -input -main main7 -journal-disable OPT: -val -deps -out -input -main main8 -slevel-function strcmp:50 -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(char*dst, char*src) { char* ldst=dst; /*@ loop pragma UNROLL 20; */ while (*ldst++ = *src++) ; return dst; } unsigned int strlen(char *s) { unsigned int l=0; /*@ loop pragma UNROLL 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; } int strcmp(const char *s1, const char *s2) { if (s1 == s2) return (0); while (*s1 == *s2++) if (*s1++ == '\0') return (0); return (*(unsigned char *)s1 - *(unsigned char *)--s2); } //@ assigns p[0..s-1]; ensures \initialized(&p[0..s-1]); void assigns(char *p, unsigned int s); int main8() { char tc[30]; char long_chain[] = "really really really long chain"; assigns(&tc[0],30); int x = strcmp(long_chain, tc); int x = strcmp(long_chain, tc); return x; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/result/��������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017413� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/slevel_return.i������������������������������������������������0000644�0001750�0001750�00000001116�12155630321�021132� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* Test that we do not perform a merge on return instructions, even if there is insufficient slevel. */ int x; int y; //@ ensures x < 0 || y == x + 1; void main1(int c) { if (c == 1) { x = 0; y = 1; return; } else if (c == 2) { x = 5; y = 6; return; } else { x = -3; return; } } //@ ensures x < 0 || y == x + 1; void main2(int c) { if (c == 1) { x = 0; y = 1; return; } if (c == 2) { x = 5; y = 6; return; } x = -3; Frama_C_dump_each(); } void main3(); void main(int c) { main1(c); main2(c); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/struct2.i������������������������������������������������������0000644�0001750�0001750�00000014413�12155630321�017653� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -memory-footprint 1 -val -deps -out -input -main f_precis -journal-disable -absolute-valid-range 0x1000-0x2000 */ 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; volatile int v; 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*)0x1000; r = (int*)0; *q = p; if (v) **r = a; p2 = &tab1[2]; p3 = &tab1[i]; if (v) b = *(p3+2); p4 = p; p5 = (int *) 0x1000; p6 = (int*)0x1010; *p6 = *(int *) 0x1020 + i; p7 = p2 + 1; /* p8 = p2 - i; */ s = (int*)0x1030; *s = (int *) 0x1040; t = (int*)0x1050; (*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 = *((char*)(tab2[k] + s5.e[tabst2[tab3[l] + m].a].b)+0x1060); /*------------------------------*/ /* 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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/garbled_init.c�������������������������������������������������0000644�0001750�0001750�00000000214�12155630321�020654� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#define BAR ((unsigned long)0xFFFFF000000) int PTR; unsigned long G = (unsigned long)&PTR - BAR; void main () { *((int*)(G+BAR)) = 1; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/struct_incl.i��������������������������������������������������0000644�0001750�0001750�00000001072�12155630321�020573� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; volatile int v; 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; if (v) s1.d[10] = 777; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/array_ptr.i����������������������������������������������������0000644�0001750�0001750�00000000252�12155630321�020244� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int G = 1; typedef int param_check[20]; int f(param_check **x) { G=(**x)[0]; (**x)[0] = 2; return 2; } param_check l={1}; int main() { int g = &l; f(&g); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/f2.i�����������������������������������������������������������0000644�0001750�0001750�00000000312�12155630321�016545� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 10; */ while(1) { return 0 ;} return 2; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/user_assertion_uninit_var.i������������������������������������0000644�0001750�0001750�00000000273�12155630321�023547� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void main(void) { int i,n,x; for(i = 0; i < 10; i++) { n = i; } /*@ assert 0 <= n <= 9; */ // only to show that n may be uninitialized at this point if (n) x = 0; else x = 1; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/mini_pointrer.i������������������������������������������������0000644�0001750�0001750�00000000271�12155630321�021120� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int T[2]; int**ppp; int pp[2]; int p; void main(int c1, int c2, int c3) { pp [c1] = &T[c1]; if (c2) ppp = &pp; else ppp = &T[-1]; **ppp=9; if (c2>=0 && c2<=5) T[c2] = 4; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/const2.i�������������������������������������������������������0000644�0001750�0001750�00000000211�12155630321�017444� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ 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); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/alias.i��������������������������������������������������������0000644�0001750�0001750�00000011142�12155630321�017332� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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(char*x,int*y) { (*x)++; *x++; (*x)++; (*y)++; } void f2(char*x) { 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]; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/array_bounds.i�������������������������������������������������0000644�0001750�0001750�00000000471�12155630321�020734� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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;} } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/pointer_int_cast.i���������������������������������������������0000644�0001750�0001750�00000000276�12155630321�021613� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/infinite.i�����������������������������������������������������0000644�0001750�0001750�00000000256�12155630321�020052� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int G; void pause(int); void main () { int count; G++; if (G==1) while(1) { G++; if(G==5) break; pause(3); G--; }; G=0; return; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/period.c�������������������������������������������������������0000644�0001750�0001750�00000001562�12155630321�017522� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#define t Frama_C_periodic_t_320 int g[10] __attribute__ ((Frama_C_periodic)); // garbled typedef struct { short s1; short s2; short s3; } ts; int t[60]= {1}; int (u __attribute__ ((Frama_C_periodic)))[60]= {-1,-2,-3}; int v[3] __attribute__ ((Frama_C_periodic)) = {-1,-2,-3}; ts w[10] __attribute__ ((Frama_C_periodic)); int Au,Bu,Cu,Du,Eu,Fu,Gu = 12, Hu; int At,Bt,Ct,Dt,Et,Ft,Gt = 12, Ht; void main() { At = t[0]; Bt = t[11]; Ft = 2 * (t[20] + 1); t[13] = Ft; Ct = t[2]; t[41] = 3 * Ft; Et = t[12]; t[4] = 2 * Gt; Ht = 2 * t[25] + 1; Au = u[0]; Bu = u[11]; Fu = 2 * (u[22] + 1); u[13] = Fu; Cu = u[2]; u[41] = 3 * Fu; Eu = u[12]; u[4] = 2 * Gu; Hu = 2 * u[25] + 1; v[1] = 1; w[0].s1 = 1; w[1].s2 = 2; w[2].s3 = w[0].s1 + w[1].s2; Frama_C_dump_each(); int *p = &g + (int)&g; *p = 1; int vg = *p; *p = &vg; } ����������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/array_degenerating_loop.i��������������������������������������0000644�0001750�0001750�00000000151�12155630321�023122� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int t[100]={1,1}; void main(int arg) { int G=55; int i; for (i=0; i<=arg; i++) G += t[i]; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/callsite.ml����������������������������������������������������0000644�0001750�0001750�00000000734�12155630321�020226� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types 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 (fun fmt -> Format.fprintf fmt "Call Sites for %s:@\n" f ; List.iter (fun (ckf,stmt) -> Format.fprintf fmt " - From %s at #%03d@\n" (Kernel_function.get_name ckf) stmt.sid) csites) let main () = Ast.compute () ; List.iter dump ["f";"g";"h";"k"] let () = Db.Main.extend main ������������������������������������frama-c-Fluorine-20130601/tests/misc/bts1201.i������������������������������������������������������0000644�0001750�0001750�00000000212�12155630321�017331� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -value-verbose 2 -load-script tests/misc/bts1201.ml -print */ void main() { //@ assert \true; } void main2() { } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/relations.i����������������������������������������������������0000644�0001750�0001750�00000001567�12155630321�020253� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ 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; } �����������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/test_arith.c���������������������������������������������������0000644�0001750�0001750�00000000726�12155630321�020407� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ #include "any_int.c" int t[10]; int j,k,ecart,tmp,**pptr,*ptr,*qtr,m1,m2,m3; void main(int v,int n) { t[1] = 4; pptr = &ptr; ptr = t+1; t[5] = 7+t[1]; j = t[2+3]+t[5]; j = j+1; *ptr = 0; n = n + 1; qtr = ptr + 1; k = (int)ptr + 1; ecart = &t[7] - &t[5]; } int G; void main1() { G=0; G = 1; *((char*)&G) = 0; G = G+1; } void main2(void) { t[1] = 4; } void mul(void) { m1 = 24*any_int()+7; m2 = 60*any_int()+5; m3 = m1*m2; } ������������������������������������������frama-c-Fluorine-20130601/tests/misc/dead_code.i����������������������������������������������������0000644�0001750�0001750�00000000266�12155630321�020135� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/strange.i������������������������������������������������������0000644�0001750�0001750�00000000220�12155630321�017677� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/changeret.i����������������������������������������������������0000644�0001750�0001750�00000000563�12155630321�020206� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������// Test a change in [lv] during a call [lv = f()] int x, y; int *p; volatile int v; int f() { p = &y; return 1; } void main1() { p = &x; *p = f(); // Warn } int g() { int z = *p; return 1; } void main2() { p = &y; if (v) p++; *p = g(); //Do not warn (even though p is {&y, &y+1} before and {&y} after) } void main() { main1(); main2(); } ���������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/find_ivaltop.i�������������������������������������������������0000644�0001750�0001750�00000000241�12155630321�020715� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/if2.i����������������������������������������������������������0000644�0001750�0001750�00000000776�12155630321�016734� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ��frama-c-Fluorine-20130601/tests/misc/cond3.i��������������������������������������������������������0000644�0001750�0001750�00000001642�12155630321�017253� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ����������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/callsite.i�����������������������������������������������������0000644�0001750�0001750�00000000700�12155630321�020037� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/misc/callsite.ml */ // Don't use -debug 1 option in the test command. 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) ����������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/memcmp.c�������������������������������������������������������0000644�0001750�0001750�00000001473�12155630321�017517� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: */ #include "share/builtin.h" int main() { unsigned char t[6] = { 0xef, 0xcd , 0xab , 0x00, 0x01, 0x01 }; char s[6] = { 0xef, 0xcd , 0xab , 0x00, 0x01, 0x01 }; const char* s1 = "hello world\n"; const char* s2 = "bla+hello world\n"; int x = 0x00abcdef; int y = 0x01abcdef; int z = Frama_C_memcmp(&x,&x,4); //@ assert(z == 0); int a = Frama_C_memcmp(&x,&y,4); //@ assert(a < 0); int b = Frama_C_memcmp(&y,&x,4); //@ assert(b > 0); int c = Frama_C_memcmp(&x,t,4); //@ assert(c == 0); int d = Frama_C_memcmp(t,&x,4); //@ assert(d == 0); int e = Frama_C_memcmp(s,&x,4); //@ assert(e == 0); int f = Frama_C_memcmp(&x,s,4); //@ assert(f == 0); // int g = Frama_C_memcmp(&x,s,6); int h = Frama_C_memcmp(s1,s2+4,13); //@ assert(h == 0); return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/loop_simple.i��������������������������������������������������0000644�0001750�0001750�00000000477�12155630321�020574� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/serv.i���������������������������������������������������������0000644�0001750�0001750�00000000231�12155630321�017215� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: cannot find entry point: main */ void f1() { f3(); } void f2() { f4(); } void f3() { f4 (); } void f4() { f3 (); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/ghost.i��������������������������������������������������������0000644�0001750�0001750�00000000720�12155630321�017365� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ /* 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 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 aprs H */ ������������������������������������������������frama-c-Fluorine-20130601/tests/misc/copy_paste_hidden_by_dummy_cast.i������������������������������0000644�0001750�0001750�00000000517�12155630321�024645� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/inout_proto.i��������������������������������������������������0000644�0001750�0001750�00000001612�12155630321�020623� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*run.config OPT: -inout -input-with-formals -inout-with-formals -inout-callwise -main main_main */ 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); } int a, b, c; //@ assigns a, b, c \from b; void f(); //@ assigns p[0..3] \from p[3..4]; void g(int *p); int t[10], u[20]; void g1() { g(&t[3]); } void g2() { g(&t[0]); } void g3(int *p) { g(p); } void main2(int i) { f(); g1(); g2(); if (i >= 5 && i <= 6) g3(&u[i]); } void main_main(const MESSAGE_ADDR_TYPE msg, int i) { main(msg); main2(i); } ����������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cabscond_script.ml���������������������������������������������0000644�0001750�0001750�00000000117�12155630321�021561� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ let () = Cabscond.active := true let () = Db.Main.extend Cabsbranches.compute �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/broken_loop.i��������������������������������������������������0000644�0001750�0001750�00000000316�12155630321�020553� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/local_variables.i����������������������������������������������0000644�0001750�0001750�00000001116�12155630321�021363� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -val -deps -out -input -journal-disable -inout -inout-callwise */ int w(int *, int*); int unkn(void); 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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/memset_block.i�������������������������������������������������0000644�0001750�0001750�00000000674�12155630321�020715� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-initialized-padding-locals" STDOPT: +"-no-initialized-padding-locals" */ int main(void) { 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); return sizeof(U); } ��������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/struct3.i������������������������������������������������������0000644�0001750�0001750�00000000744�12155630321�017656� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; volatile int v; 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; if (v) s1.d[10] = 2; } ����������������������������frama-c-Fluorine-20130601/tests/misc/loop1.i��������������������������������������������������������0000644�0001750�0001750�00000000403�12155630321�017271� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������char U[100]={1, 2}; char NULL_GLOBAL_LOOSING_BITS_ONE_BY_ONE = 0; void main1 () { int i; for(i=0;i<100; i++) { U[i]=7; } } void main2 () { int i; for(i=0;i<=100; i++) { U[i]=7; } } int main () { main1(); main2(); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bool.i���������������������������������������������������������0000644�0001750�0001750�00000000404�12155630321�017173� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-print" */ void printf(const char*,...); _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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/strucval.c�����������������������������������������������������0000644�0001750�0001750�00000001240�12155630321�020074� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -val -deps -out -input -journal-disable */ typedef enum { BDP_BITE_NORMAL, BDP_BITE_ANORMAL, BDP_BITE_TRUC } BDP_Te_FunctionCode; typedef struct { BDP_Te_FunctionCode FunctionCode; unsigned short int MachineNumber; /* machine number */ unsigned long int Line; /* line number*/ } BDP_Ts_SharedData; #define BNR_Ct_MachineNumber 1456 //@ assigns \nothing; extern void h(const BDP_Ts_SharedData sd); void main() { BDP_Ts_SharedData SharedData; SharedData.FunctionCode = BDP_BITE_NORMAL; SharedData.MachineNumber = BNR_Ct_MachineNumber; SharedData.Line = __LINE__; h(SharedData); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/limits.c�������������������������������������������������������0000644�0001750�0001750�00000000750�12155630321�017537� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -val -warn-signed-overflow -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; } ������������������������frama-c-Fluorine-20130601/tests/misc/ptr_relation.i�������������������������������������������������0000644�0001750�0001750�00000001642�12155630321�020747� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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. } //----------------------------------------- ����������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/initialized.c��������������������������������������������������0000644�0001750�0001750�00000003632�12155630321�020545� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-big-ints-hex 257" +"-inout-callwise" */ #include "../../share/builtin.h" extern int b1, b2, b3, b4, b5, b6; //@ ensures \initialized(&t[1..n-2]); void f(int m, int* t, int n) { if (m) for (int i=1;i<n-1;i++) t[i]=i; } volatile rand; void g1 (){ int t1[20], t2[20], t3[20], t4[20], t5[20], t6[20], i, j; for (int i=0; i<20; i++) if (rand) { t1[i]=1; t2[i]=2; t3[i]=3; t4[i]=4; t5[i]=5; t6[i]=6; } //@ assert \initialized(&t1[..]); //@ assert \initialized(&t2[4..]); i=Frama_C_interval(3,6); j=Frama_C_interval(12,15); //@ assert \initialized(&t3[i..j]); i=Frama_C_interval(3,7); j=Frama_C_interval(7,15); //@ assert \initialized(&t4[i..j]); i=Frama_C_interval(7,9); j=Frama_C_interval(4,6); //@ assert \initialized(&t5[i..j]); i=Frama_C_interval(7,9); j=Frama_C_interval(4,7); //@ assert \initialized(&t6[i..j]); } void g2() { int t[14]; if (b4) { t[0]=0x11223344; t[1]=t[0]; t[2]=0x55667788; t[3]=t[2]; if (b5) t[4]=0x12345678; else t[4] = 0x23456789; t[5]=t[4]; t[6]=(int)&b4+(int)&b4; t[7]=t[6]; t[8] = b5 ? 1 : 2; t[9] = t[8]; t[10] = 0; t[11] = 0; int *p = (char*)(&t[10])+3; *p = 0x11111111; t[12] = 0; t[13] = 0; p+=2; *p = b5 ? 0x11111111: 0x22222222; } Frama_C_dump_each(); int *p = ((char*)t)+7; //@ assert \initialized(p); Frama_C_dump_each(); Frama_C_show_each(*p); // assert *p == 0x66778811; //@ assert \initialized(p+2); //@ assert \initialized(p+4); //@ assert \initialized(&t[9]); //@ assert \initialized(&t[11]); //@ assert \initialized(&t[13]); } void g3() { int r1, x1, x2, r2, x3, r3; int t1[5]; int t2[250]; if (b1) x1 = 1; //@ assert \initialized(&x1); r1 = x1+1; if (b2) x2 = r2 + 1; if (b3) x3 = 1; r3 = x3 + 1; f(b6, &t1, 4); f(b6, &t2, 250); } int main () { g1(); g2(); g3(); return 0; } ������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/inversion.i����������������������������������������������������0000644�0001750�0001750�00000001134�12155630321�020255� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ 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++; } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/statement_contract.i�������������������������������������������0000644�0001750�0001750�00000000436�12155630321�022146� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/uninit.i�������������������������������������������������������0000644�0001750�0001750�00000000054�12155630321�017547� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int main () { int i; i++; return i; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/biz.i����������������������������������������������������������0000644�0001750�0001750�00000000352�12155630321�017026� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/with_comment.i�������������������������������������������������0000644�0001750�0001750�00000001232�12155630321�020735� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 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; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/rec.i����������������������������������������������������������0000644�0001750�0001750�00000000055�12155630321�017013� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void main() { int X=0; if (X) main(); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/justcopy.ml����������������������������������������������������0000644�0001750�0001750�00000000371�12155630321�020303� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types let main () = Ast.compute (); let o prj = object(self) inherit Visitor.frama_c_copy prj method vglob_aux _g = Cil.JustCopy end in ignore (File.create_project_from_visitor "justcopy" o) let () = Db.Main.extend main �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/config.h�������������������������������������������������������0000644�0001750�0001750�00000000663�12155630321�017513� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* config.h. Generated from config.h.in by configure. */ /* #undef HAVE_WCHAR_T */ #define HAVE_STDLIB_H 1 #define HAVE_STRINGS_H 1 /* #undef HAVE_SYS_TIME_H */ #define HAVE_UNISTD_H 1 /* #undef HAVE_CONST */ /* #undef HAVE_INLINE */ /* #undef HAVE_TIME_H */ /* #undef HAVE_MEMCP */ /* #undef HAVE_MKDIR */ /* #undef HAVE_SELECT */ /* #undef HAVE_SOCKET */ #define TYPE_SIZE_T "unsigned long" #define TYPE_WCHAR_T "int" �����������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/CruiseControl_extern.h�����������������������������������������0000644�0001750�0001750�00000001770�12155630321�022426� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** Command : ** l2C CruiseControl.lus -node CruiseControl ** -noexp @ALL@ ** -keep_named_var ** -const ** -bitwise ** -loc_ctx ** -no_copy_mem ** -debug ** date of generation (MM/DD/YYYY): 07/06/2007 13:30:09 ** last modification date for CruiseControl.lus (MM/DD/YYYY): 07/06/2007 ********************************************************************$*/ /* ========= */ /* CONSTANTS */ /* ========= */ extern const Speed ZeroSpeed; extern const Speed SpeedInc; extern const Speed SpeedMax; extern const Speed SpeedMin; extern const Percent ZeroPercent; extern const real Kp; extern const real Ki; extern const Percent RegThrottleMax; /*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** End of file CruiseControl_extern.h ** End of generation (MM/DD/YYYY) : 07/06/2007 13:30:09 ********************************************************************$*/ ��������frama-c-Fluorine-20130601/tests/misc/bug0223.i������������������������������������������������������0000644�0001750�0001750�00000001310�12155630321�017321� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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(); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/init_from_cil.ml�����������������������������������������������0000644�0001750�0001750�00000000335�12155630321�021240� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������let run () = let a = Ast.get () in let prj = Project.create "foo" in File.init_project_from_cil_file prj a; Project.set_current prj; Printer.pp_file Format.std_formatter (Ast.get()) let () = Db.Main.extend run ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/init.i���������������������������������������������������������0000644�0001750�0001750�00000000701�12155630321�017203� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-initialized-padding-globals" STDOPT: +"-uninitialized-padding-globals" */ 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); } ���������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/pointer_loop.i�������������������������������������������������0000644�0001750�0001750�00000002040�12155630321�020747� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/small_conditionals.i�������������������������������������������0000644�0001750�0001750�00000000076�12155630321�022123� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������char Y,Z,U ; void main(char X) { Y = X?:2; Z = U?3:4; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/struct_array.i�������������������������������������������������0000644�0001750�0001750�00000000340�12155630321�020761� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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++; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/arch.i���������������������������������������������������������0000644�0001750�0001750�00000000217�12155630321�017157� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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*); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts1135_ulevel.i�����������������������������������������������0000644�0001750�0001750�00000000510�12155630321�020714� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -ulevel 2 -typecheck -print */ /* small test cases to verify C labels are correclty managed into annotations */ int X ; void main (int c) { for (int i = 0 ; i < 10 ;) { if (c) //@ ensures \false ; goto there ; X++; there: i++; //@ assert c==0 ==> \at(X,there)==i+1; } } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/context_width.i������������������������������������������������0000644�0001750�0001750�00000000446�12155630321�021131� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-context-width 3 -then -print -then -context-width 1" */ int a; void main(int *p) { if (! (p == 0)) { if (! (p+1 == 0)) { if (! (p+2 == 0)) {} } if (p+1 == &a) {} *p = 1; *(p+1) = 2; *(p+2) = 3; } else { /*@ assert \false; */ } } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/logtrap.i������������������������������������������������������0000644�0001750�0001750�00000000214�12155630321�017707� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: waiting ocaml 3.12 */ // OPT: -load-script tests/misc/logtrap.ml // Should raise an assertion-failure exception. ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/ilevel.i�������������������������������������������������������0000644�0001750�0001750�00000001120�12155630321�017514� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -slice-return main -then-on "Slicing export" -val -val-ilevel 16 -then-on "default" -val-ilevel 17 -then -val-ilevel 48 */ // Test in particular that ilevel is by-project, even though it is an ocaml ref volatile int v; int i, j, k, l; int main () { do { i = v; } while (! (0 <= i && i < 8)); do { j = v; } while (! (0 <= j && j < 17)); k = j; if (k == 16) k = 15; l = v; if (v) { //@ assert 0 <= l <= 4; } else { //@ assert 6 <= l <= 9; } Frama_C_show_each(l); // Possible problem with cache on offsetmap join return i+j+k+l; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/val_ptr.i������������������������������������������������������0000644�0001750�0001750�00000001502�12155630321�017707� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/long.i���������������������������������������������������������0000644�0001750�0001750�00000000153�12155630321�017200� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ int i,j,k; void f(void) { for (i=0;i<1000;i++); } void main(void) { for (j=0;j<1000;j++) f(); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts0990_link.i�������������������������������������������������0000644�0001750�0001750�00000000347�12155630321�020375� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: tests/misc/bts0990_link_1.i */ // NB: This test is meant to return an error, as s is declared as an array in // tests/misc/bts0990_link_1.i char *s; void perror(const char *); void f(void){ perror(s); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/arg_array.i����������������������������������������������������0000644�0001750�0001750�00000000140�12155630321�020204� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void main(int *ptr, int T[4]) { *T=0; ptr = T; ptr[1]=1; 2[ptr] = 2; T=T; return; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/reading_null.i�������������������������������������������������0000644�0001750�0001750�00000001355�12155630321�020711� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts0452.ml�����������������������������������������������������0000644�0001750�0001750�00000000204�12155630321�017521� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* Checks that even Jessie-specific normalization does not create spurious warnings. *) Cabs2cil.setDoAlternateConditional ();; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/slevelex.i�����������������������������������������������������0000644�0001750�0001750�00000002541�12155630321�020073� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-slevel 5 -slevel-function main:0 -slevel-function gu:21 -slevel-function ginc:21" */ volatile int c; int f(void) { int x, y; if (c) { x = 1; y = 1; } else { x = 2; y = 2; } return x*x - y*y; } 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 x*x == y*y ; 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); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/undefined_sequence2.i������������������������������������������0000644�0001750�0001750�00000002546�12155630321�022164� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-unspecified-access" */ /* based on an example from J. Regehr on the why list */ /* precondition: false */ int a[2]; volatile int foo; 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; if (foo) { multiple_update_wrong_1(&b, &c); Frama_C_show_each_passed1(); } if (foo) { multiple_update_wrong_2(b); Frama_C_show_each_passed2(); } if (foo) { multiple_update_wrong_3(c); Frama_C_show_each_passed3(); } if (foo) { multiple_update_unsafe(&b,&c); /* does not lead to an alarm */ Frama_C_show_each_passed4(); } if (foo) { multiple_update_unsafe(&b, &b); Frama_C_show_each_passed5(); } if (foo) { multiple_update_safe(&b,&c); /* does not lead to an alarm */ Frama_C_show_each_passed6(); } if (foo) { multiple_update_safe(&c,&c); /* does not lead to an alarm */ Frama_C_show_each_passed7(); } return 0; } ����������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/inversion2.i���������������������������������������������������0000644�0001750�0001750�00000000304�12155630321�020335� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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]);}; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cast_axalto.c��������������������������������������������������0000644�0001750�0001750�00000000613�12155630321�020536� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ #define STATE_FREE 1 #define STATE_USE 0 struct struct_my { char state; int data[]; } /* __attribute__((__packed__)) */; typedef struct struct_my my_structure; int * my_tab; void f(void) { my_structure * p; p = (my_structure *)my_tab; p->state = STATE_FREE; p->data [2] = 99; } int G[10] = {77,88,99,100}; int main(void){ my_tab = &G[1]; f(); return 1;} ���������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/anonymous_field.i����������������������������������������������0000644�0001750�0001750�00000000445�12155630321�021440� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/not_ct_array_arg.i���������������������������������������������0000644�0001750�0001750�00000000323�12155630321�021555� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������// Cf. Bts 856 volatile int v; void main(int a, int tb[10][a], int tc[a][10]) { *(int*)tb = 1; Frama_C_dump_each(); tb[9][100] = &tb; Frama_C_dump_each(); tc[1][1] = 3; if (v) tc[1][16] = 0; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/tricky_logic.i�������������������������������������������������0000644�0001750�0001750�00000001530�12155630321�020723� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������volatile int vol; char * str = "abc"; int x; int y; struct ts { int i1; int i2; }; void f1 () { //@ assert \valid_read(str); //@ assert !\valid(str); } void f2() { x = 4; y = 5; //@ assert \at(x == 2 && y == 3, Pre) && x == 4 && y == 5; } void f3() { //@ assert \at(x == 2, Pre) || \at(x == 3, Pre); //@ assert \at(x == 2 || x == 3, Pre); //@ assert \at(x == 2, Pre) ==> x == 2; } void g4(struct ts s) { int x = 1; s.i1 = 3; //@ assert \initialized{Pre}(&s) ==> \at(s.i1 == 1,Pre); //@ assert \initialized{Pre}(&s) ==> s.i1 == 1; } void f4() { int *p, *q; int z; p = &z; q = &x; struct ts s; if (vol) { s.i1 = 1; s.i2 = 2; } g4(s); //@ assert !\initialized{Pre}(p); //@ assert \initialized{Pre}(q); } void main() { f1(); x = 2; y = 3; f2(); x = vol ? 2 : 3; f3(); f4(); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/for_loops.c����������������������������������������������������0000644�0001750�0001750�00000001370�12155630321�020237� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: STDOPT: +"-main main_2" STDOPT: +"-main g" */ #include "share/libc/__fc_builtin.c" 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]; return; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/modulo.i�������������������������������������������������������0000644�0001750�0001750�00000002656�12155630321�017552� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-slevel-function pgcd1:100,pgcd2:100,pgcd3:100" */ int A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R; extern int i; void main2 () { A = (4 * i) % 4; B = (4 * i + 1) % 4; //@ assert ((i>=-100) && (i<=100)) ; E = (3*i + 1) % 12; //@ assert ((i>=0) && (i<=100)) ; C = (4 * i + 1) % 4; D = (3*i + 1) % 12; F = (24*i + 5) % 12; G = (24*i + 5) % 13; H = i % 1000; I = (2 * i+1101) % 1000; J = (5 * i - 201) % 1000; K = (5 * i - 201) % 10; L = K % J; M = K % D; N = J % I; O = I % G; P = A % J; Q = J % L; } extern int a, b; /*@ requires -10<=x<=10 && -10<=y<=10; */ int pgcd1(int x, int y) { int a = x, b = y; /*@ loop invariant -10<=b<0||b==0||0<b<=10; loop invariant -10<=a<0||a==0||0<a<=10; */ while(b!=0) { int tmp = a % b; Frama_C_show_each_1(a,b,tmp); a = b; b = tmp; } return a; } /*@ requires -10<=x<=10 && -10<=y<=10; */ int pgcd2(int x, int y) { int a = x, b = y; /*@ loop invariant -10<=b<0||b==0||0<b<=10; */ while(b!=0) { int tmp = a % b; Frama_C_show_each_2(a,b,tmp); a = b; b = tmp; } return a; } /*@ requires -10<=x<=10 && -10<=y<=10; */ int pgcd3(int x, int y) { int a = x, b = y; while(b!=0) { int tmp = a % b; Frama_C_show_each_3(a,b,tmp); a = b; b = tmp; } return a; } volatile int v; void main() { if (v) { pgcd1(a, b); } if (v) { pgcd2(a, b); } if (v) { pgcd3(a, b); } main2(); } ����������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/relation_shift.i�����������������������������������������������0000644�0001750�0001750�00000000530�12155630321�021252� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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(); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/threat_redundant.c���������������������������������������������0000644�0001750�0001750�00000000410�12155630321�021562� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#define NULL ((void*)0) char * strchr(const char * s, int c) { for(; *s != (char) c; ++s) if (*s == '\0') return NULL; return (char *) s; } char s1[10]={'a','b','a','b','a','b','a','b','a','b'}; char *x; void main(void) { x = strchr(s1, 'c'); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/typeof.i�������������������������������������������������������0000644�0001750�0001750�00000000063�12155630321�017547� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������extern void y(); void main() { (typeof(y()))0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/va_list2.c�����������������������������������������������������0000644�0001750�0001750�00000000600�12155630321�017753� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#include "stdarg.h" void main(const char* fmt, ...) { va_list args; va_start(args, fmt); while (*fmt) { switch(*fmt) { case 1: { int i = va_arg(args, int); Frama_C_show_each_i(i); break; } case 2: { float f = va_arg(args, float); Frama_C_show_each_f(f); break; } //default: } fmt++; } va_end(args); } ��������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/copy_paste.i���������������������������������������������������0000644�0001750�0001750�00000000207�12155630321�020407� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/val6.i���������������������������������������������������������0000644�0001750�0001750�00000001005�12155630321�017106� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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'; return 0; } int f1() { *((char*)17) = 27; *((char*)19) = 29; x = c?17:19; b = (char*)x; *b = 0; return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/label.i��������������������������������������������������������0000644�0001750�0001750�00000000773�12155630321�017330� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �����frama-c-Fluorine-20130601/tests/misc/absolute_pointer.i���������������������������������������������0000644�0001750�0001750�00000000506�12155630321�021621� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -memory-footprint 1 -val -deps -out -input -absolute-valid-range 0-0x3 -journal-disable */ int * f() { return 100; } void crash () { unsigned int v = 1; *((f()))=v; } char R; void main(int c) { if(c) crash(); *((char*)0)=2; R = *((char*)1); *((char*)2)=2; R = *((char*)3); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/buffer_overflow.i����������������������������������������������0000644�0001750�0001750�00000000667�12155630321�021447� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/change_main.ml�������������������������������������������������0000644�0001750�0001750�00000000441�12155630321�020652� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types class visitor prj = object inherit Visitor.frama_c_copy prj method vfunc f = f.svar.vname <- "g"; Cil.SkipChildren end let run () = ignore (File.create_project_from_visitor "change_main" (fun prj -> new visitor prj)) let () = Db.Main.extend run �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/threat_array.i�������������������������������������������������0000644�0001750�0001750�00000000441�12155630321�020726� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/find_enclosing_loop.c������������������������������������������0000644�0001750�0001750�00000000306�12155630321�022245� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/misc/find_enclosing_loop.ml */ int f () { int x = 0; int y = 0; while (x<15) { x++; while (y<15) { y++; } x++; y =0; } x=0; y=0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/constarraylibentry.i�������������������������������������������0000644�0001750�0001750�00000001124�12155630321�022176� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -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 } ; typedef struct { int f1; const int f2; } ss; typedef struct { int f0; const char f2; } ss2; const int t4[12] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; ss t5[7] = {{1, 2}, {3}, 5, 6, 7, 8, 9, 10}; ss2 t6[6] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; extern const t7[5]; // Do not initialize to 0 extern const t8[5] = {1, 2}; // Ignore extern (done by Cil) void main(){ int *x = t7; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/threat_if.i����������������������������������������������������0000644�0001750�0001750�00000000436�12155630321�020212� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int *p; int l,m; int i; int X=-992; void printf(const char* c,...); 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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/goto.i���������������������������������������������������������0000644�0001750�0001750�00000000142�12155630321�017207� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int stop () { L: goto L; } int main() { volatile int c=0; c = c?1:0; if (c) stop (); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/miel.i���������������������������������������������������������0000644�0001750�0001750�00000001305�12155630321�017167� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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() { } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/definitions.h��������������������������������������������������0000644�0001750�0001750�00000002006�12155630321�020552� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** Command : ** l2C CruiseControl.lus -node CruiseControl ** -noexp @ALL@ ** -keep_named_var ** -const ** -bitwise ** -loc_ctx ** -no_copy_mem ** -debug ** date of generation (MM/DD/YYYY): 07/06/2007 13:30:09 ** last modification date for CruiseControl.lus (MM/DD/YYYY): 07/06/2007 ********************************************************************$*/ #define _copy_mem(t,d,s) Copy_mem(t,d,s) extern int _copy_mem(int, void *, const void *); #define _comp_mem(t,x,y) Comp_mem(t,x,y) extern int _comp_mem(int, const void *, const void *); extern int printf(const char *, ...); #define __assert(x) printf ("Violation of the assertion %s\n", x); return (false) /*$************* SCADE_KCG KCG Version 5.1.1 (build i10) ************** ** End of file definitions.h ** End of generation (MM/DD/YYYY) : 07/06/2007 13:30:09 ********************************************************************$*/ ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/Debug_category.ml����������������������������������������������0000644�0001750�0001750�00000001331�12155630321�021343� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������include Plugin.Register( struct let name = "test" let shortname = "test" let help = "test" end) let akey = register_category "a" let ckey = register_category "a:b:c" let bkey = register_category "a:b" let dkey = register_category "d" let run () = debug ~dkey:akey "A is enabled"; debug ~dkey:bkey "B is enabled"; debug ~dkey:ckey "C is enabled"; debug ~dkey "D is enabled"; result ~dkey:akey "A is enabled"; result ~dkey:bkey "B is enabled"; result ~dkey:ckey "C is enabled"; result ~dkey "D is enabled"; feedback ~dkey:akey "A is enabled"; feedback ~dkey:bkey "B is enabled"; feedback ~dkey:ckey "C is enabled"; feedback ~dkey "D is enabled" let () = Db.Main.extend run �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/misaligned_tabs.i����������������������������������������������0000644�0001750�0001750�00000004024�12155630321�021367� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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} ; void 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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/sort4.i��������������������������������������������������������0000644�0001750�0001750�00000004750�12155630321�017323� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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,3); 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; } } ������������������������frama-c-Fluorine-20130601/tests/misc/pointer2.i�����������������������������������������������������0000644�0001750�0001750�00000000440�12155630321�020002� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/abs.i����������������������������������������������������������0000644�0001750�0001750�00000000124�12155630321�017004� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ //@ requires \valid(p); void main (int* p) { if (*p<0) *p=-*p; return; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/abs_addr.i�����������������������������������������������������0000644�0001750�0001750�00000001534�12155630321�020004� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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(); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/memset.i�������������������������������������������������������0000644�0001750�0001750�00000002522�12155630321�017535� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-calldeps" +"-no-deps" +"-inout-callwise" +"-inout" +"-value-msg-key imprecision" +"-plevel 500" */ //@ assigns *((char*)dst+(0..size-1)) \from v; void Frama_C_memset(void * dst, int v, unsigned long size); int t1[100]; int t2[100]; int t3[100]; int t4[100]; int t5[100]; int t6[100]; int t7[100]; int t8[100]; int t9[100]; int t10[100]; int t11[100]; struct s { char f1; short f2; int f3; int f4[3]; }; struct s ts[5]; volatile int vol; void main() { Frama_C_memset(t1, 0x11, sizeof(t1)); // basic Frama_C_memset(t2+(int)t2, 0x12, sizeof(t2)); // garbled dest Frama_C_memset(t3+10, 0x11, t1); // garbled size if (vol) { Frama_C_memset(t4+1, 1, sizeof(t4)); // out of bounds } Frama_C_memset(t5, t1, sizeof(t4)); // garbled char int *p = vol ? t6+10 : t7; Frama_C_memset(p, 0x22, 16); // multiple dest p = vol ? (char*) 0 : t8; Frama_C_memset(p, 0x22, 16); // one valid dest; TODO p = t9+20; while (1) { if (vol) break; p++; } Frama_C_memset(p, 0x8FE, 4); // imprecise dest unsigned long s = 12; if (vol) s += 24; Frama_C_memset(t10+4, 0x88, s); // imprecise size unsigned long s = 8; if (vol) s += 8; p = t11 + 2; if (vol) p++; Frama_C_memset(p, 0x99, s); // imprecise dest+size with juxtaposition if (vol) Frama_C_memset(ts, 254, sizeof(ts)); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/ulongvslonglong.i����������������������������������������������0000644�0001750�0001750�00000000573�12155630321�021504� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/addition.i�����������������������������������������������������0000644�0001750�0001750�00000003467�12155630321�020047� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -memory-footprint 1 -val -deps -out -input -absolute-valid-range 0x2D-0x30 -journal-disable -then -absolute-valid-range 0x2D-0x31 */ int t[10],x,y,z,zz; int p1,p2,p3,p4,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17; 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, int u4) { 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+32*t) * (2+3*s); mm2 = (4+32*t) * (16+96*s); mm3 = (1+15*t) * (1+35*s); quo6 = (2007+15*s) / (-5); qu1 = (2007+15*s) / (20 + s); qu2 = (7+15*s) / (20 + s); ll1 = (long long)(5*s+3) + 0xFFFFFFFFL; ll2 = (long long)(5*s+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; p17 = -0x80000000; if (u4 & 1) p17 %= -1; return (*(2+t)) + t[2]; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/redundant_alarms.c���������������������������������������������0000644�0001750�0001750�00000000621�12155630321�021556� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -remove-redundant-alarms -print -slice-threat main1 -then-on 'Slicing export' -print **/ volatile int v; void main1(int c) { int x, y, t; int *p = c ? &x : &y; *p = 1; int z = *p+1; int w = *p+2; x = t; y = t; x = t; if (v) {z = *p+2;} } void main2(int i) { int t[10]; t[i] = 1; t[i] += 3; t[i] += 5; } void main() { if (v) main1(v); main2(v); } ���������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/static.i�������������������������������������������������������0000644�0001750�0001750�00000000507�12155630321�017533� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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]; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/local_slevel.i�������������������������������������������������0000644�0001750�0001750�00000000220�12155630321�020700� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int *p; main(){ int i; for (i=0; i<2; i++) { int a; if (i==0) { Frama_C_split(0); p=&a; Frama_C_merge(0); } *p = 3; } } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/cert_exp35_c.i�������������������������������������������������0000644�0001750�0001750�00000002567�12155630321�020537� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void printf(const char* c,...); 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. */ �����������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/deps.i���������������������������������������������������������0000644�0001750�0001750�00000001651�12155630321�017200� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 (int*pt) { 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); } ���������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/my_visitor.c���������������������������������������������������0000644�0001750�0001750�00000000625�12155630321�020443� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config <<<<<<< .working EXECNOW: make -s tests/misc/my_visitor_plugin/my_visitor.opt CMD: ./tests/misc/my_visitor_plugin/my_visitor.opt OPT: -main f ======= OPT: -load-script tests/misc/my_visitor_plugin/my_visitor.ml -main f OPT: -load-script tests/misc/dashtbl_plugin/dashtbl_plugin.ml -main f >>>>>>> .merge-right.r18651 */ int f() { int y = 0; y++; /*@ assert y == 1; */ return 0; } �����������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/lazy.i���������������������������������������������������������0000644�0001750�0001750�00000000665�12155630321�017230� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ���������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/from1.i��������������������������������������������������������0000644�0001750�0001750�00000000373�12155630321�017271� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/context_free_simple.i������������������������������������������0000644�0001750�0001750�00000000132�12155630321�022274� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ int z=1; int f(int x,int y) { z = x+y; return y+1; } void main(void) { f(2,3); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/recursion2.i���������������������������������������������������0000644�0001750�0001750�00000000373�12155630321�020340� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*run.config OPT: -journal-disable -input -val -out -inout */ int x, y; void h2 (int); void h1 (int); void h1 (int i) { int r = x; if (i) h2 (i); } void h2 (int j) { int q = y; if (!j) h1 (j); } void main() { h2(0); h1(1); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/memexec.c������������������������������������������������������0000644�0001750�0001750�00000000662�12155630321�017663� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-rte-select fbug -rte -memexec-all" */ int x1, y1, z1; volatile int c; void f11() { x1 = 1; } void f1 () { f11(); f11(); f11(); x1 = 0; f11(); x1 = 1; f11(); x1 = 2; f11(); f11(); } void f2 () { } void f3 () { } int *p; int fbug() { return *p; } void bug() { p = 0; int x; if (c) fbug(); p = &x; fbug(); } void main () { f1 (); f2 (); f3 (); bug(); } ������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/f1.i�����������������������������������������������������������0000644�0001750�0001750�00000000071�12155630321�016546� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ extern int f(int x); void main() { f(5); return; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/undef_behavior_bts1059.i���������������������������������������0000644�0001750�0001750�00000001044�12155630321�022410� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-unspecified-access" */ /*@ assigns \nothing; */ void f(int,int); /*@ assigns \nothing; */ void g(int,int); volatile int c; int main() { int a = 1; int b = 0; if (c) if (a = b || ++a == 2) //UB (no sequence point between ++a and a=...) f(a, b); else g(a, b); b = b++ || a--; // NO UB (we first incr b, decr a, set b to the result, // with a sequence point between all operations. a = (a++,b++); // NO UB if (c) a = (b++, a++); // UB return 0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/memcpy.c�������������������������������������������������������0000644�0001750�0001750�00000005144�12155630321�017532� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-calldeps" +"-no-deps" +"-slevel-function" +"init:2000" +"-inout-callwise" +"-inout" +"-value-msg-key imprecision" +"-plevel 150" +"-then" +"-report" */ #include "share/builtin.h" extern unsigned int i; char src[20]; char dst1[20], dst2[20], dst3[20]; char dst4[20], dst5[100]; void init () { int j; for (j=0;j<20;j++) { src[j] = j+1; dst1[j] = -1; dst2[j] = -1; dst3[j] = -1; dst4[j] = -1; } for (j=0;j<100;j++) dst5[j] = -1; } volatile maybe; void buggy () { char c; char *p = maybe ? &c: "abc"; Frama_C_memcpy(p,"d",1); } int tm[1000]; int um[1000]; typedef struct { short ts; int ti; } typ; typ ttyp[1000]; void many() { char s[] = "abcd"; unsigned int p = maybe; //@ assert p < 1000; tm[0]=0; Frama_C_memcpy(&tm[p],s,4); um[0]=0; Frama_C_memcpy(&um[p],s,2); typ ty = {1, 2}; ttyp[0] = ty; Frama_C_memcpy(&ttyp[p],&ty,sizeof(typ)); } struct t1 { int x; int y; int* p;} v1,v2, v3, v4, v5; struct t1 t[4]; void main (int a, int b){ buggy (); many (); init (); //@ assert 5 <= b && b <= 15; Frama_C_memcpy(dst1+1, src+2, b); Frama_C_memcpy(dst2+1, src+2, 2*b); //@ assert 5 <= b && b <= 14; Frama_C_memcpy(dst3+5, src+2, b); Frama_C_memcpy(dst4+5, src+2, 2*b); v2 = v2; v2.p = &v1.y; t[1]=v2; v1.x = 5; v1.y = 7; Frama_C_memcpy(&v2, &v1, sizeof(v1)); Frama_C_memcpy(t+2, t, (1+!a)*sizeof(v1)); Frama_C_memcpy(&v3, t+(int)t, sizeof(v1)); Frama_C_memcpy(&v4 + (int)&v4, &v1, sizeof(v1)); v4.y = &t[0]; Frama_C_memcpy(&v5 + (int)&v5, &v4, sizeof(v4)); if (maybe) { int x=1; while(1) Frama_C_memcpy((void *)&x, (void const*)&x, i); } char *p; p = maybe ? &dst5[0] : &dst5[20]; Frama_C_memcpy(p, &src[0], b); b = maybe; //@ assert 1 <= b < 20; p = maybe ? &dst5[40] : &dst5[70]; Frama_C_memcpy(p, &src[0], b); // Destination pointer is unbounded char ptop1[100]; int *pptop = ptop1; while (1) { pptop++; if (maybe) break; } Frama_C_memcpy(pptop, src, 4); char ptop2[100]; pptop = &ptop2[50]; while (1) { pptop--; if (maybe) break; } Frama_C_memcpy(pptop, src+1, 4); char ptop3[100]; pptop = &ptop3[2]; while (1) { if (maybe) pptop--; if (maybe) pptop++; if (maybe) break; } Frama_C_memcpy(pptop, src+2, 4); char ptop4[100]; pptop = &ptop4[2]; while (1) { if (maybe) pptop--; if (maybe) pptop++; if (maybe) break; } Frama_C_memcpy(pptop, src+2, 5); // Size is a garbled mix char garbledsize[100]; int* pgarbledsize = &garbledsize[10]; Frama_C_memcpy(pgarbledsize, src, garbledsize); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/call_alias.i���������������������������������������������������0000644�0001750�0001750�00000001040�12155630321�020321� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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); return I; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/struct_call.i��������������������������������������������������0000644�0001750�0001750�00000001355�12155630321�020565� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 main1(void) { int i = 2 - 1; t[1].y = G; GG = g(tt[i]); struct A init = create_A(); return g(t[i]); } struct CC { short c1; char * c2; }; extern struct CC C; void h(struct CC c) { Frama_C_show_each(c.c1, c.c2); } void main() { main1(); h(C); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/abstract_struct_1.c��������������������������������������������0000644�0001750�0001750�00000000446�12155630321�021667� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/misc/abstract_struct_2.c" +"-lib-entry" */ #include "share/libc/stdlib.h" struct abstracttype; struct something { struct abstracttype *data; }; static struct something *repositories; void main(void) { repositories = calloc(1, sizeof(struct something)); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/extern.i�������������������������������������������������������0000644�0001750�0001750�00000000323�12155630321�017545� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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]; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/m12_2.i��������������������������������������������������������0000644�0001750�0001750�00000004121�12155630321�017060� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 + ( 3*8*1 && i++ ) ; // RULE 12.2.1: conflits entre terme du + z = ++i + ( y, y++ ) ; z = ++i + ( 3*8*0 || i++ ) ; // RULE 12.2.1: idem z = ++i + ( i, y++ ) ; // le resultat de terme droit ne depend pas de i return z; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/local_cleanup.c������������������������������������������������0000644�0001750�0001750�00000000252�12155630321�021034� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-inout-callwise" */ void f(int *p){ p[1]=12; } void g(int x){ int t[2]; f(t); } void main(){ int lmain[2]; f(lmain); g(2); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/reduce_by_valid.i����������������������������������������������0000644�0001750�0001750�00000002521�12155630321�021362� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef struct { int a; int b; } ts; long t[5]; ts u[5]; volatile unsigned int v; void f () { long *p = &t[v]; //@ assert \valid(p+3); p[3]=1; long *q = ((int*)&t[v])+1; //@ assert \valid(q+3); q[3]=1; p = p; q = q; } void g() { ts *p = &u[v]; ts *q = ((int*)&u[v])+1; ts *r = ((int*)&u[v])+1; ts *s = ((int*)&u[v])+1; //@ assert \valid(&p->b); p->a = 1; //@ assert \valid(&q->a); q->a = 2; //@ assert \valid(&r->b); r->b = 3; //@ assert \valid(s); s->a = 4; p = p; q = q; r = r; s = s; } void h(unsigned int c1, unsigned int c2) { int *p = &t[c1]; int *q = &c2; //@ assert \valid(\union(q, q)); //@ assert \valid(\union(p, q)); p = p; } void i(unsigned int c1, unsigned int c2, unsigned int c3, unsigned int c4) { //@ assert \valid(&t[c1]); //@ assert \valid(&t[c2]); int *p = &t[0]; //@ assert \valid(p+c3); ts *q = &u[0]; //@ assert \valid(&(q+c4)->a); c1 = c1; c2 = c2; c3 = c3; c4 = c4; } void j() { int y; int *q = &y; int *p; int *r; { int x = 0; p = &x; } //@ assert \valid(q); //@ assert \valid(&y); //@ assert !\valid(p); if (v) p = & y+3; else p = &q+4; //@ assert !\valid(p); p = 0; //@ assert !\valid(p); if (v) r = &y; //@ assert \valid(r); } void main () { f(); g(); h(v,v); i(v,v,v,v); j(); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/invalid_lval_arg.i���������������������������������������������0000644�0001750�0001750�00000000321�12155630321�021533� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/addrofstring.c�������������������������������������������������0000644�0001750�0001750�00000000335�12155630321�020723� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/add_approx.i���������������������������������������������������0000644�0001750�0001750�00000000154�12155630321�020363� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bitfield_receives_result.i�������������������������������������0000644�0001750�0001750�00000000152�12155630321�023305� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������struct S { int b:31; } s; int f(void) { return -1; } main(){ s.b = f(); Frama_C_dump_each(); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/mixed_val.i����������������������������������������������������0000644�0001750�0001750�00000000215�12155630321�020210� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/pointer4.i�����������������������������������������������������0000644�0001750�0001750�00000000457�12155630321�020014� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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;} } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/vis_spec.ml����������������������������������������������������0000644�0001750�0001750�00000002050�12155630321�020232� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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@]@." Printer.pp_funspec sp; Format.printf "@[It is@ @['%a'@]@ through get_spec@]@." Printer.pp_funspec (Annotations.funspec (Globals.Functions.get f.svar)); ) | None -> Format.printf "@[Function prototype;@ Funspec is@ @['%a'@]@]@." Printer.pp_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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/duff.i���������������������������������������������������������0000644�0001750�0001750�00000001056�12155630321�017170� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: */ int Ato[100]; int Afrom[100]; void main(int count) { int*to = &Ato; int*from = &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); } } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts1347.i������������������������������������������������������0000644�0001750�0001750�00000000477�12155630321�017361� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config_no_native_dynlink CMD: bin/toplevel.byte OPT: -load-script tests/misc/bts1347.ml -load-module lib/plugins/Report -then -report */ /* run.config OPT: -load-script tests/misc/bts1347.ml -load-module lib/plugins/Report -then -report */ int f(int *x) { return *x; } int g(int *x) { return *(x++); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/postcondition.i������������������������������������������������0000644�0001750�0001750�00000002431�12155630321�021136� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 <= 100*cmd) { if (u()) return ret; ret++; } return ret; } /*@ ensures EX <= cmd ; */ int bound(int cmd) { cmd = 2; /* vicious */ return 0; } //@ 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--; return 0; } /*@ 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(); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/multi_access.i�������������������������������������������������0000644�0001750�0001750�00000000236�12155630321�020716� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/video_detect.i�������������������������������������������������0000644�0001750�0001750�00000001054�12155630321�020700� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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)); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/unsigned_overflow.c��������������������������������������������0000644�0001750�0001750�00000000302�12155630321�021766� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������extern unsigned int i1, i2; int main(int c) { //@ assert i1 > 10; //@ assert i2 > 10; unsigned int v = i1 + i2; if (c) { unsigned int w = -i1; Frama_C_show_each_dead (); } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/struct.i�������������������������������������������������������0000644�0001750�0001750�00000002014�12155630321�017563� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/Visitor_creates_func_bts_1349.ml�������������������������������0000644�0001750�0001750�00000002661�12155630321�024137� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types class test prj = object(self) inherit Visitor.frama_c_copy prj method private create_f () = let f = Cil.emptyFunction "f" in f.svar.vdefined <- true; let x = Cil.makeFormalVar f "x" Cil.intType in Cil.setReturnType f Cil.intType; Queue.add (fun () -> Cil.setFormals f [x]) self#get_filling_actions; f.sbody <- Cil.mkBlock [Cil.mkStmt ~valid_sid:true (Return (Some (Cil.evar x),Cil_datatype.Location.unknown))]; Queue.add (fun () -> Globals.Functions.replace_by_definition (Cil.empty_funspec()) f Cil_datatype.Location.unknown) self#get_filling_actions ; [GVarDecl(Cil.empty_funspec(),f.svar,Cil_datatype.Location.unknown); GFun(f,Cil_datatype.Location.unknown)] method vglob_aux = function | GVar (v,i,loc) -> let v'= Visitor.visitFramacVarDecl (self:>Visitor.frama_c_visitor) v in let i'= match i.init with | None -> { init = None } | Some i -> { init = Some (Visitor.visitFramacInit (self:>Visitor.frama_c_visitor) v' NoOffset i) } in let g = GVar(v',i',loc) in Cil.ChangeToPost (g::self#create_f(),fun x -> x) | _ -> Cil.DoChildren end let run () = let vis prj = new test prj in ignore (File.create_project_from_visitor "test" vis) let () = Db.Main.extend run �������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/FP5.i����������������������������������������������������������0000644�0001750�0001750�00000000650�12155630321�016635� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ 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; } } ����������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/long_ident.c���������������������������������������������������0000644�0001750�0001750�00000000653�12155630321�020362� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-module lib/plugins/Obfuscator -memory-footprint 1 -obfuscate -journal-disable */ /*@ ensures \valid(q); // <-- obfuscation error [bts#404] */ int f(int *q) ; #define LV X_9999999999999999999999999999999999999999999999999999 int LV; enum { OK = 1, NOT_OK = 0 } e ; /*@ ensures \valid(p); */ void main (int LV, int * p) { int LV = 0; e = OK ; // <-- obfuscation error [bts#403] f(p); } �������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/debug_category.i�����������������������������������������������0000644�0001750�0001750�00000001030�12155630321�021217� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/misc/Debug_category.cmxs OPT: -load-module tests/misc/Debug_category.cmxs -test-msg-key help OPT: -load-module tests/misc/Debug_category.cmxs -test-msg-key a OPT: -load-module tests/misc/Debug_category.cmxs -test-msg-key a -test-msg-key-unset a:b OPT: -load-module tests/misc/Debug_category.cmxs -test-msg-key a -test-msg-key-unset a:b -test-msg-key a:b:c OPT: -load-module tests/misc/Debug_category.cmxs -test-msg-key "a:b:c,d" OPT: -load-module tests/misc/Debug_category.cmxs -test-msg-key "*" */ ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bug_0209.c�����������������������������������������������������0000644�0001750�0001750�00000000141�12155630321�017457� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/misc/bug_0209.ml */ // Everything is done by the script �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/align_char_array.c���������������������������������������������0000644�0001750�0001750�00000001512�12155630321�021520� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -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 struct s { char c; char a[2]; }; struct s S; char t[10][10]={0,0,1,1,1,1,1}; int d1,s1,d2,s2,overlapread1, overlapread2, overlapread3, overlapread4; int main(void) { d1 = (int)&S.a - (int)&S.c; s1 = (int)sizeof(struct s); d2 = (int)&t[2][2] - (int)&t[0][0]; s2 = (int)sizeof(t); overlapread1 = *(int*)((int)t + 3); overlapread3 = 1 + *(int*)((int)t + 3); overlapread2 = *(int*)((int)t + 2); overlapread4 = 1 + *(int*)((int)t + 2); #ifndef PTEST printf("a-c: %d\nsize: %d\n", d1, s1); printf("t[2][2]-t[0][0]: %d\nsize: %d\n", d2, s2); #endif return 0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/ai_annot.i�����������������������������������������������������0000644�0001750�0001750�00000000353�12155630321�020033� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-remove-redundant-alarms -context-width 3" */ int u,v,w; int main(int x,int *p) { /*@ assert x >=0; */ /*@ assert \valid(p+1); */ /*@ assert \valid_read(p+2); */ *(p+1)=x; return x+*(p+2); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/from_call.i����������������������������������������������������0000644�0001750�0001750�00000002424�12155630321�020202� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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(); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts0525.i������������������������������������������������������0000644�0001750�0001750�00000000262�12155630321�017346� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/control.i������������������������������������������������������0000644�0001750�0001750�00000000350�12155630321�017720� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/val9.i���������������������������������������������������������0000644�0001750�0001750�00000001355�12155630321�017121� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/addr.i���������������������������������������������������������0000644�0001750�0001750�00000000451�12155630321�017154� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bug0245.i������������������������������������������������������0000644�0001750�0001750�00000000456�12155630321�017337� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-slevel 4" */ 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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/any_int.c������������������������������������������������������0000644�0001750�0001750�00000000330�12155630321�017671� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -memory-footprint 1 -val -deps -out -input -main any_int -journal-disable */ int any_int() { volatile int y=0; int x=0; while(y) {y++;y++; if (y-1) x++; else x--;} return x; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/const.i��������������������������������������������������������0000644�0001750�0001750�00000002667�12155630321�017403� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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'excution * 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 indertermine, mais * dpendant 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 ; } �������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/log_twice.ml���������������������������������������������������0000644�0001750�0001750�00000000421�12155630321�020373� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ (* Run the user commands *) let run () = let p_default = Project.create_by_copy ~src:(Project.from_unique_name "default") "default" in !Db.Value.compute (); Project.set_current p_default; !Db.Value.compute (); () let () = Db.Main.extend run �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts1306.i������������������������������������������������������0000644�0001750�0001750�00000000257�12155630321�017350� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -constfold -slevel 0 -val -print -then -slevel 10 -val -print */ void g(double x) { double y= x*x; } int main(double x) { g(x); return 0; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/const_syntax.i�������������������������������������������������0000644�0001750�0001750�00000000317�12155630321�020777� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������const unsigned char INSTRU_N_00_01_001_CRC___1525983317999999999994352352523523993424999 = 0; void main () { const unsigned char INSTRU_N_00_01_001_CRC___1525983317999999999994352352523523993424999 = 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/overflow_cast_float_int.i��������������������������������������0000644�0001750�0001750�00000000336�12155630321�023160� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������volatile v; int main() { float vf1; signed int e; unsigned int d; int c1, c2; d = 0x7FFFFFFFll; if (v) { vf1 = d * 1.0; e = (int)vf1; } c1 = 2147483647.5; if (v) { c2 = -2147483649.5; } } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/pb.i�����������������������������������������������������������0000644�0001750�0001750�00000000030�12155630321�016634� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ void main () { f() ; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/struct_deps.i��������������������������������������������������0000644�0001750�0001750�00000000471�12155630321�020603� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������struct Tstr { int a; int b; }; int f (struct Tstr * ps) { return ps->a; } int f3(int*p) { 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); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/mergestruct2.i�������������������������������������������������0000644�0001750�0001750�00000000241�12155630321�020665� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -print -journal-disable tests/misc/mergestruct3.i tests/misc/mergestruct1.i */ struct s *p; void g(void) { p = 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/ensures.i������������������������������������������������������0000644�0001750�0001750�00000000325�12155630321�017726� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/init_from_cil.i������������������������������������������������0000644�0001750�0001750�00000000166�12155630321�021062� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/misc/init_from_cil.ml -check */ int f(int x); int main () { return f(0); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/change_main.i��������������������������������������������������0000644�0001750�0001750�00000000210�12155630321�020464� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -main f -load-script tests/misc/change_main.ml -then-on change_main -main g -val */ int f(int x) { return x; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/overflow.i�����������������������������������������������������0000644�0001750�0001750�00000001664�12155630321�020114� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -val -deps -out -input -warn-signed-overflow OPT: -memory-footprint 1 -val -deps -out -input -no-warn-signed-overflow */ extern int printf (__const char *__restrict __format, ...); /* L'analyseur dborde 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; } ����������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/annot.i��������������������������������������������������������0000644�0001750�0001750�00000001737�12155630321�017371� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ 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, unsigned int uc, int m, int n) { 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 0 <= m <= n <= 9; Frama_C_show_each_mn(m, n); int a = 0, b = 1; /*@ assert (a || b) == b; */ /*@ assert (a && a) == a; */ int tt[3]; tt[0] = 1; //@ assert (uc > 0 || tt[uc] == 1) == \true; /*@ assert y == z; */ return z; } ���������������������������������frama-c-Fluorine-20130601/tests/misc/recol.c��������������������������������������������������������0000644�0001750�0001750�00000002215�12155630321�017340� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -slevel 100 -memory-footprint 1 -cpp-command "gcc -C -E -DPTEST " -journal-disable -no-warn-signed-overflow OPT: -val -slevel 100 -memory-footprint 1 -cpp-command "gcc -C -E -DPTEST " -journal-disable -machdep ppc_32 -no-warn-signed-overflow */ #ifndef PTEST #include <stdio.h> #endif #define S 100 char s[S]; int c=0; int s_int; int *p_int; char ones[]="11111111"; char one23[]="1223"; int col_ones; int col_123; int main(void) { char *p = s; col_ones = 1 + * (int*) ones; col_123 = 1 + * (int*) one23; while (p <= s+S-sizeof(int)) { c = 7 * c + 97; if (c % 3 == 0) *p++ = c; else if (c % 3 == 1) { *(short*)p = c; p += sizeof(short); } else { *(int*)p = c; p += sizeof(int); } } for (p_int = (int*) s; p_int < (int*)(s+S); p_int++) { s_int = 11 * s_int + *p_int; } #ifndef PTEST printf("s_int: %d col_ones: %d col_123:%d\n", s_int, col_ones, col_123); #endif /* rsultat attendu, avec int 32-bits : little endian: s_int = -833811464 big_endian : s_int: -1480071902 col_ones: 825307442 col_123:825373236 */ return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/align.i��������������������������������������������������������0000644�0001750�0001750�00000000515�12155630321�017335� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/call_2.i�������������������������������������������������������0000644�0001750�0001750�00000000416�12155630321�017377� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-warn-signed-overflow" */ void ff(float f, int i, int j){ Frama_C_show_each(i, f, j); } void main(int i, int j, int c) { float f; int z; int *p = (int*)&f; *p = i; if (c) z = 1; ff(f, i+j, z); // Arguments with potential RTE } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/leaf.i���������������������������������������������������������0000644�0001750�0001750�00000004052�12155630321�017152� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 */ } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/affect_corrupt.i�����������������������������������������������0000644�0001750�0001750�00000000345�12155630321�021252� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/config_types.h�������������������������������������������������0000644�0001750�0001750�00000000135�12155630321�020731� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ #define false 0 #define true 1 #define bool int #define _int int #define real float �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/unroll.i�������������������������������������������������������0000644�0001750�0001750�00000003051�12155630321�017554� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������enum { NB_TIMES=12, FIFTY_TIMES = 50 }; void main (int c) { int G=0,i; int MAX = 12; int JMAX=5; int j,k,S; /*@ loop pragma UNROLL 14; */ // first loop unrolled 14 times for (i=0; i<=MAX; i++) { G+=i; } /*@ loop pragma UNROLL 124; */ for (i=0; i<=10*MAX; i++) { G+=i; } /*@ loop pragma UNROLL 12+2; */ // loop unrolled 14 times for (i=0; i<=MAX; i++) { j=0; /*@ loop pragma UNROLL FIFTY_TIMES; */ while (j<=JMAX) { G+=i; j++; } } //@ loop pragma UNROLL 128*sizeof(char); do { G += i; i++; j--; } while (i<=256 || j>=0); //@ loop pragma UNROLL 10; do { if(c) continue; if(c--) goto L; c++; L: c++; } while(c); //@ loop pragma UNROLL c; while(0); S=1; k=1; //@ loop pragma UNROLL "completly", NB_TIMES; do { S=S*k; k++; } while (k <= NB_TIMES) ; } #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 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 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/from_result.c��������������������������������������������������0000644�0001750�0001750�00000001223�12155630321�020573� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -deps -journal-disable */ #define FRAMA_C_MALLOC_INFINITE #include "../../share/libc/stdlib.c" struct T { int a; int b; }; /*@ assigns \result.b \from x; @ assigns \result.a \from y; */ struct T create_t(int x, int y); /*@ assigns \result.a \from x; @ assigns \result.b \from y; */ struct T create_t1(int x, int y); int* bar (int x) { int* ax = (int *)malloc(sizeof(int)); *ax = x; return ax; } void change_t(struct T* t0, int x, int y) { t0->a = x; t0->b = y; } int main() { int* t = bar(0); int* t1 = bar(1); struct T v = create_t(*t,*t1); struct T v1 = create_t1(*t,*t1); change_t(&v,0,0); return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/inout_diff.i���������������������������������������������������0000644�0001750�0001750�00000000372�12155630321�020372� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-ulevel 10 -inout" */ int t[50]; int u[50]; int x; main(int c){ int i; for (i=0; i<50; i+=5) { t[i] = 1; t[i+1] = 1; u[i] = 1; } c = 7 * (c & 15); x = t[c]; x += u[c]; x += u[c+1]; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/relation_reduction.i�������������������������������������������0000644�0001750�0001750�00000000430�12155630321�022130� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/wide_string.c��������������������������������������������������0000644�0001750�0001750�00000000561�12155630321�020554� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#include "share/libc/stddef.h" int main(volatile int v) { // 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; if((*p)[3] != 0) return 3; if((*q)[3] != 0) return 4; if (v) { char c = (*p)[4]; } if (v) { wchar_t wc = (*q)[4]; } return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/strlen.c�������������������������������������������������������0000644�0001750�0001750�00000002223�12155630321�017542� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: */ #include "share/builtin.h" const char* static_str = "Hello World\n"; const char* zero_str = "abc\0\0\0abc"; #define TSZ 12 const char* tab_str[TSZ] = { "" , // 0 "a", // 1 "aa" , // 2 "aaa" , // 3 "aaaa" , // 4 "aaaaa" , // 5 "aaaaaa" , // 6 /* hole */ "aaaaaaaaa" , // 9 "aaaaaaaaaa" , "aaaaaaaaaaa", "aaaaaaaaaaaa" , "aaaaaaaaaaaaa" }; // 13 int main () { const char* loc_str = "Bonjour Monde\n"; char loc_char_array[5]; size_t sz1,sz2,sz3,sz4,sz5; int x = 0xabcdef00; int z = 0x12345600; int i; char *str; str = Frama_C_nondet(0,1) ? static_str : loc_str; sz1 = Frama_C_strlen(str); //@ assert(sz1 == 12) || (sz1 == 14); str = &x; str = Frama_C_nondet(0,1) ? str : str + 3; sz2 = Frama_C_strlen(str); //@ assert(sz2 == 0) ; // no, could also do an RTE i = Frama_C_interval(0,TSZ-1); str = tab_str[i]; sz3 = Frama_C_strlen(str); //@ assert (sz3 >= 0) && (sz3 <= 13); loc_char_array[3] = '\0'; sz4 = Frama_C_strlen(loc_char_array); //@ assert (sz4 >=0) && (sz4 <=3); sz5 = Frama_C_strlen(zero_str); //@ assert(sz5 == 3); return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/array_access.c�������������������������������������������������0000644�0001750�0001750�00000001064�12155630321�020674� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int t1[] = {1,2,3,4,5,6,7,8,9}; int t2[] = {11,12,13,14,15,16,17,18,19}; char ch[] = { 0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,1,1,0,1,0,1,0,1,0,1, 0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1, 0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1, 0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,2,3,4 }; int R; #include "any_int.c" void main () { int i,j=10,k=88,c,*p,LT[10]={1}; i = any_int(); c= any_int(); if (i>=0 && i<=8 ) {CEA_I(i);p=(c?t1:t2)+i;j = *p+1-1; k = LT[-i-1] + 1 -1 ; } R = ((int*)ch)[any_int()]; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/bts0541.c������������������������������������������������������0000644�0001750�0001750�00000000372�12155630321�017340� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -pp-annot -cpp-extra-args="-I./share/libc" -pp-annot -val */ #include <stdbool.h> #include <stdint.h> #include <stdlib.h> #include <string.h> int main() { _Bool x = true; /*@ assert x==false ==> \false; */ return 0; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/simple_path.i��������������������������������������������������0000644�0001750�0001750�00000000137�12155630321�020550� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int G,H; int *p = &G; int *q = &H; void main(void) { G = 4; *p = 3; p = &H; *p = 5; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/misc/global_bug.i���������������������������������������������������0000644�0001750�0001750�00000000122�12155630321�020332� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int i = 1; int G = 99<<63; int j = 2; int main () { G ++; return (i == j); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/minix/��������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016266� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/minix/oracle/�������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017533� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/minix/tmrs_exp.c����������������������������������������������������0000644�0001750�0001750�00000007652�12155630245�020305� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*License Copyright (c) 1987,1997, 2006, Vrije Universiteit, Amsterdam, The Netherlands All rights reserved. Redistribution and use of the MINIX 3 operating system in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the Vrije Universiteit nor the names of the software authors or contributors may be used to endorse or promote products derived from this software without specific prior written permission. * Any deviations from these conditions require written permission from the copyright holder in advance Disclaimer THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS, AUTHORS, AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR ANY AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ #define LONG_MAX 2147483647L /* maximum value of a long */ #define NULL ((void *)0) typedef void (*tmr_func_t)(struct timer *tp); typedef union { int ta_int; long ta_long; void *ta_ptr; } tmr_arg_t; typedef long clock_t; /* unit for system accounting */ typedef struct timer { struct timer *tmr_next; /* next in a timer chain */ clock_t tmr_exp_time; /* expiration time */ tmr_func_t tmr_func; /* function to call when expired */ tmr_arg_t tmr_arg; /* random argument */ } timer_t; /* Used when the timer is not active. */ #define TMR_NEVER ((clock_t) -1 < 0) ? ((clock_t) LONG_MAX) : ((clock_t) -1) #undef TMR_NEVER #define TMR_NEVER ((clock_t) LONG_MAX) void tmrs_exptimers (timer_t **tmrs, clock_t now, clock_t *new_head); /*===========================================================================* * tmrs_exptimers * *===========================================================================*/ //@ predicate ptime_var(clock_t * time) = \valid(time) && *time >= 0 && *time <= 2147483647 ; //@ predicate time_var(clock_t time) = time >= 0 && time <= 2147483647; /*@ requires \valid(tmrs) && ptime_var(new_head) && time_var(now); @ ensures \valid(new_head); @*/ void tmrs_exptimers(tmrs, now, new_head) timer_t **tmrs; /* pointer to timers queue */ clock_t now; /* current time */ clock_t *new_head; { /* Use the current time to check the timers queue list for expired timers. * Run the watchdog functions for all expired timers and deactivate them. * The caller is responsible for scheduling a new alarm if needed. */ timer_t *tp; //@ loop invariant tp->tmr_exp_time <= now ; while ((tp = *tmrs) != NULL && tp->tmr_exp_time <= now) { *tmrs = tp->tmr_next; tp->tmr_exp_time = TMR_NEVER; (*tp->tmr_func)(tp); } //@ assert tp->tmr_exp_time > now; if(new_head) { if(*tmrs) *new_head = (*tmrs)->tmr_exp_time; else *new_head = 0; } } void f(struct timer *tp) { int i = (tp->tmr_arg).ta_int; i += 5; } int main(clock_t realtime, timer_t tp, timer_t *clock_timers ) { tp.tmr_next = NULL; tp.tmr_exp_time = 10; tp.tmr_func = f; (tp.tmr_arg).ta_int = 5; tmrs_exptimers(&clock_timers, realtime, NULL); return 0; } ��������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/minix/result/�������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017604� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic/������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016566� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic/oracle/�����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020033� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic/abstract.ml�������������������������������������������������0000644�0001750�0001750�00000010701�12155630245�020722� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ (* register functions using abstract types "t" and "u" *) module A : sig end = struct type t = A of int | B of bool type tt = t let mk () = 1.05 let _ = B false let f = function A n -> n | B false -> min_int | B true -> max_int module T = Datatype.Make(struct type t = tt let name = "A.t" let reprs = [ A 1 ] include Datatype.Undefined end) let t = T.ty module U = Datatype.Make(struct type t = float let name = "A.u" let reprs = [ 1.0 ] include Datatype.Undefined end) let u = U.ty let mk = Dynamic.register ~plugin:"A" ~journalize:false "mk" (Datatype.func Datatype.unit u) mk let _ = Dynamic.register ~plugin:"A" ~journalize:false "f" (Datatype.func t Datatype.int) f let _ = Dynamic.register ~plugin:"A" ~journalize:false "g" (Datatype.func u Datatype.int) (fun x -> Format.printf "%f@." x; int_of_float x) let v1 = Dynamic.register ~plugin:"A" ~journalize:false "v1" t (A 1) let _ = Dynamic.register ~plugin:"A" ~journalize:false "v2" t (A 2) let _ = Dynamic.register ~plugin:"A" ~journalize:false "h" (Datatype.func t (Datatype.func u Datatype.bool)) (fun x y -> match x with A x -> Format.printf "params = %d %f@." x y; x = int_of_float y | B _ -> false) let _ = Dynamic.register ~plugin:"A" ~journalize:false "succ" (Datatype.func Datatype.int Datatype.int) succ let _ = Dynamic.register ~journalize:false "ho" ~plugin:"A" (Datatype.func (Datatype.func Datatype.int Datatype.int) (Datatype.func t u)) (fun ff x -> float (ff (f x))) let _ = Dynamic.register ~journalize:false ~plugin:"A" "ppu" (Datatype.func u Datatype.unit) (fun f -> Format.printf "ppu %f@." f) let ho2 = Dynamic.register ~plugin:"A" "ho2" ~journalize:false (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) ()) module UA = Type.Abstract(struct let name = "A.u" end) let __ : UA.t = Dynamic.get ~plugin:"A" "mk" (Datatype.func Datatype.unit UA.ty) () let _ = Dynamic.register ~journalize:false ~plugin:"A" "poly" (Datatype.list u) [ 1.; 2.; 3. ] let _ = Dynamic.register ~journalize:false ~plugin:"A" "poly2" (Datatype.list u) [ mk (); ho2 (function A n -> n | B _ -> min_int) v1; ho2 f v1 ] end (* use of the abstract functions *) module B = struct 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 ] 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) let f = Dynamic.get ~plugin:"A" "f" (Datatype.func ty Datatype.int) let h = Dynamic.get ~plugin:"A" "h" (Datatype.func ty (Datatype.func ty' Datatype.bool)) let v1 = Dynamic.get ~plugin:"A" "v1" ty let v2 = Dynamic.get ~plugin:"A" "v2" ty let cinq = Dynamic.get ~plugin:"A" "succ" (Datatype.func Datatype.int Datatype.int) 4 let () = Format.printf "succ=%d@." cinq let () = Format.printf "n=%d@." (g (mk ())) let () = Format.printf "v1=%d@." (f v2) let () = Format.printf "b1=%b@." (h v1 (mk ())) let () = Format.printf "b2=%b@." (h v2 (mk ())) let ho = Dynamic.get ~plugin:"A" "ho" (Datatype.func (Datatype.func Datatype.int Datatype.int) (Datatype.func ty ty')) let ppu = Dynamic.get ~plugin:"A" "ppu" (Datatype.func ty' Datatype.unit) let res = ho (Dynamic.get ~plugin:"A" "succ" (Datatype.func Datatype.int Datatype.int)) v2 let () = Format.printf "print:@."; ppu res let ho_bug = try ignore (Dynamic.get ~plugin:"A" "ho" (Datatype.func (Datatype.func ty Datatype.int) (Datatype.func ty ty')) f v2); assert false with Dynamic.Incompatible_type s -> print_endline s (* 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*) let () = List.iter (Dynamic.get ~plugin:"A" "ppu" (Datatype.func ty' Datatype.unit)) (Dynamic.get ~plugin:"A" "poly2" (Datatype.list ty')) end ���������������������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic/dynamic.i���������������������������������������������������0000644�0001750�0001750�00000000246�12155630245�020366� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*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 */ ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic/empty_gui.ml������������������������������������������������0000644�0001750�0001750�00000000066�12155630245�021124� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* An empty ml file in order to test dynamic module*) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic/abstract2.ml������������������������������������������������0000644�0001750�0001750�00000001717�12155630245�021013� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ module AA : sig end = struct type _t = string let ty = Type.register ~name:"AA.t" ~ml_name:None Structural_descr.Unknown [ "" ] let _mk = Dynamic.register ~plugin:"AA" ~journalize:false "mk" (Datatype.func Datatype.unit ty) (fun () -> "a") end module BB : sig end = struct type _t = float let ty = Type.register ~name:"BB.t" ~ml_name:None Structural_descr.Unknown [ 1.0 ] let _print = Dynamic.register ~plugin:"BB" ~journalize:false "print" (Datatype.func ty Datatype.unit) print_float end let main () = 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 �������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic/result/�����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020104� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic/empty.ml����������������������������������������������������0000644�0001750�0001750�00000000066�12155630245�020260� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* An empty ml file in order to test dynamic module*) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/����������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�015714� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/oracle/���������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017161� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/dpds_intra.c����������������������������������������������������0000644�0001750�0001750�00000005143�12155630327�020213� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: 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 -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 -pdg-dot */ extern int G; typedef struct { int a; int b; } Tstr; extern Tstr S; int test_struct (void) { Tstr s1, s2; s1.a = 1; /* s1.b = 2; */ s2 = s1; return s2.a; } int multiple_global_inputs (void) { return S.a + G; } int test_if_simple (void) { int x0 = 0, x1 = 1, x2 = 2, x3 = 10, x; if (G < x0) /* G < 0 */ x = x0; else /* G >= 0 */ if (G < x1) /* G < 1 */ x = x1; else /* G >= 1 */ if (G > x2) { /* G > 2 */ if (G < x3) x = x3; else x = -1; } // pas de else return x; } int test_goto_simple (void) { int r; if (G > 0) goto Lelse; r = -1; goto Lfin; Lelse : r = 1; Lfin : return r; } int test_goto_arriere (void) { int x = 1; L : x++; if (G-- > 0) goto L; return x; } int test_goto_else (void) { int x, a, b = 0; if (G) { x = 1; goto L; } else { a = 1; L : b = 1; } return b; } /* ne passe pas l'analyse de valeur (bouclage) ./bin/toplevel.opt -val -main test_ctrl_dpd_multiple tests/slicing/dpds_intra.c * cf. mail Pascal Re: loop_pragma UNROLL_LOOP du 09.05.2006 15:03 */ int test_ctrl_dpd_multiple (void) { int x = 0; if (G > 3) x = 1; else L : x = x - 2; if (G < x) goto L; return x; } int test_simple_loop (int n) { int i, s = 0; for (i = 0; i < n; i++) { s++; } return s; } int main (void) { int a; int b = G; int res = 0; Tstr s = { 1, 2 }; int *p, *q; a = b++ + s.a; b = 2*a; if (b > G) p = &a; else { int a = 1; p = &b; a++; } *p += 1; res += test_struct (); res += test_if_simple (); res += test_goto_simple (); res += test_goto_arriere (); res += test_goto_else (); res += test_simple_loop (G); res += multiple_global_inputs (); return *p + res; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/simple_call.c���������������������������������������������������0000644�0001750�0001750�00000002451�12155630327�020347� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: 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; typedef struct { int a; int b; } Tstr; extern Tstr S, S1, S2; /*----------------------------------------------*/ /* check if we don't mix up inputs and outputs */ void mix_G1_G2 (void) { int tmp = G1; G1 = G2; G2 = tmp; } int call_mix_G1_G2 (void) { int x1, x2; mix_G1_G2 (); x1 = G1; x2 = G2; return x1+x2; } /*----------------------------------------------*/ void multiple_global_outputs (int x, int y) { S.a = x; G = y; } void call_multiple_global_outputs (int x, int y) { multiple_global_outputs (x, y); } /*----------------------------------------------*/ int call (int x, int y) { G += y; return x; } int call_in_loop (int c) { int i, a = 0; for (i = 0; i < G; i++) a += call (i, c); return a; } int main (void) { int a = 0, b = 1, c = 3; int i; a = call (a+b, b+c); return a; } /*----------------------------------------------*/ �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/simple_intra_slice.c��������������������������������������������0000644�0001750�0001750�00000003350�12155630327�021727� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -pdg -journal-disable -pdg-print -pdg-verbose 2 */ /* test conu initialement comme test pour le slicing */ int Unknown; int G; /* on slectionne le return. on doit garder juste a (pas G et b) */ int f1 (int x, int y) { int a = 1, b = 2; G = x + a; return y + b; } /* on slectionne le return. pas de rduction intreproc -> b doit tre marqu Spare et recursivement a aussi. */ int f2 (void) { int a = 1, b = a+1, c = 3; return f1 (b, c); } /* avec un IF : slection de la branche then */ int f3 (int c) { int a = 1, b = 2; int x = 0; if (c > Unknown) x = b; else G = a; return x; } /* avec un IF : slection de la branche else */ int f4 (int c) { int a = 1, b = 2; int x = 0; if (c > Unknown) G = a; else x = b; return x; } int f5 (int c) { int x = 0; if (c > Unknown) goto Lsuite; x += 1; Lsuite : if (c < Unknown) goto L2; G++; L2 : x += 1; return x; } int f6 (int n) { int i = 0; while (n < 10) { if (Unknown > 3) { i = 1; break; } if (n%2) continue; n++; } if (i) return 0; else return 10*n; } typedef struct { int a; int b; int c; } Tstr; Tstr S, S1, S2; void f7 (Tstr s0) { int x = S.a; if (x > 0) { S.a += 3; } else { s0.a += 1; S = s0; } } void f8 (Tstr * ps) { ps->a ++; ps->b ++; } int main (void) { int res = 0; /* make Unknown really unknown */ volatile int uninit=0, uninit2=0 ; while(uninit) if (uninit-1) Unknown++; else Unknown--; while(uninit2) if (uninit2-1) S.a++; else S.a--; res += f2 (); res += f3 (1); res += f4 (1); res += f5 (1); res += f6 (Unknown); f7 (S); if (Unknown) f8 (&S1); else f8 (&S2); return res; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/dyn_dpds.ml�����������������������������������������������������0000644�0001750�0001750�00000003277�12155630327�020064� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* make -s tests/pdg/dyn_dpds.byte ; \ tests/pdg/dyn_dpds.byte -deps tests/pdg/dyn_dpds.c; \ zgrviewer tests/pdg/dyn_dpds_1.dot ; \ zgrviewer tests/pdg/dyn_dpds_2.dot ; *) 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 stmt (Cil.new_exp ~loc:Cil_datatype.Location.unknown (Cil_types.Lval lval)) in loc let main _ = let memo_debug = Kernel.Debug.get () in Kernel.Debug.set 1; File.pretty_ast (); Kernel.Debug.set memo_debug ; let kf = Globals.Functions.find_def_by_name "main" in let pdg = !Db.Pdg.get kf in !Db.Pdg.pretty Format.std_formatter pdg; !Db.Pdg.extract pdg "tests/pdg/dyn_dpds_0.dot"; let assert_sid = 5 in (* assert ( *p>G) *) let assert_stmt, kf = Kernel_function.find_from_sid assert_sid in let _assert_node = match !Db.Pdg.find_simple_stmt_nodes pdg assert_stmt with | n::[] -> n | _ -> assert false in let star_p = get_zones "*p" (assert_stmt, kf) in let data_nodes, undef = !Db.Pdg.find_location_nodes_at_stmt pdg assert_stmt ~before:true star_p in assert (undef = None); let g_zone = get_zones "G" (assert_stmt, kf) in let g_nodes, undef = !Db.Pdg.find_location_nodes_at_stmt pdg assert_stmt ~before:true g_zone in let _data_nodes = g_nodes @ data_nodes in let undef = match undef with None -> assert false | Some z -> z in Format.printf "Warning : cannot select %a in this function...@\n" Locations.Zone.pretty undef; !Db.Pdg.pretty Format.std_formatter pdg; !Db.Pdg.extract pdg "tests/pdg/dyn_dpds_1.dot" let () = Db.Main.extend main ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/loops.c���������������������������������������������������������0000644�0001750�0001750�00000005702�12155630327�017221� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: 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 */ /* Choix de la fonction sur laquelle on travaille : F=maybe_infinite Pour voir le CFG : bin/toplevel.opt -lib-entry -main $F -deps -verbose tests/pdg/loops.c zgrviewer ./$F_cfg.dot Pour voir les postdominateurs : bin/toplevel.opt -lib-entry -main $F -fct-pdg $F -dot-postdom p tests/pdg/loops.c ; zgrviewer ./p.$F.dot Pour voir le PDG : bin/toplevel.opt -lib-entry -main $F -fct-pdg $F -pdg-dot pdg tests/pdg/loops.c ; zgrviewer ./pdg.$F.dot */ int after; int simple (int n) { int s = 0; int i = 0; while (i < n) { s += 2; i++; } after = 0; return s; } int simple_with_break (int n) { int s = 0; int i = 0; while (1) { if (i < n) { s += 2; i++; } else break; } after = 0; return s; } int infinite (int n) { int s = 0; int i = 0; while (1) { s += 2; i++; } after = 0; return s; } int infinite2 (int n) { int s = 0; int i = 1; while (i) { s += 2; } after = 0; return s; } int maybe_infinite (int n) { int s = 0, i = 0; if (n > 0) { while (1) { i+=1; if (s < 10) s += 2; i+=2; } } else s = 1; after = 0; return s; } int two_infinite_loops (int n) { int s = 0, i1 = 0, i2 = 0; if (n > 0) { while (1) { i1 += 1; if (s < 10) s += 2; else { i2 = 0; while (1) { i2++; } i2+=2; } i1+=2; } } else s = 1; after = 0; return s; } int loop_with_goto (int n) { if (n > 0) { L : n--; if (1) goto L; } return n; } /* this function is similar to [test_ctrl_dpd_multiple] in * [tests/pdg/dpds_intra.c] but the value analysis converges, * so we can see that [x=x+2;] has a control dependency on both [n<0] and [x<n]. */ int non_natural_loop (int n) { int x = 1; if (n < 0) { x = 0; n = 10; } else { n = 20; L : x = x + 2; } if (x < n) goto L; return x; } int dead_code (int n) { int x = 0; goto L; W : x++; if (n > 0) goto W; L: x+=n; return x; } ��������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/inter_alias.c���������������������������������������������������0000644�0001750�0001750�00000000404�12155630327�020351� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -val -out -input -calldeps -pdg -journal-disable -pdg-print -pdg-verbose 2 */ int G; int f1 (int * p1, int x1) { *p1 += G + x1; return *p1; } int main (void) { int a = 0, b = 0; f1(&a, 3); f1(&b, 4); return a+b; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/sets.c����������������������������������������������������������0000644�0001750�0001750�00000000702�12155630327�017036� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/pdg/sets.ml -lib-entry -main f -pdg -inout -journal-disable -pdg-print -pdg-verbose 2 */ int b, c, x, y, z, t; void f(int a) { y = 0; // 1, node 9 if (a) y = 1; // 2 puis 3, (y = 1: node 11) z = y; // 5 y++; // 6 (node 14) x = z; // 8 b = a; // 9 t = b + y; // 11 y = 5; // 12 c = 8; // shouldn't have any relation with node 14... } ��������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/annot.c���������������������������������������������������������0000644�0001750�0001750�00000000775�12155630327�017211� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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; int f1 (int x) { int a = 10; if (x < 10) x = 10; L : x++; //@ assert x > G+a ; x = 3; // @ assert x < \at(x,L) ; TODO : \at not implemented yet return x; } int loop (int n) { int i, s = 0; /*@ loop invariant 0 <= i <= n ; @ loop variant n-i; */ for (i = 0; i < n; i++) s += 2; return s; } ���frama-c-Fluorine-20130601/tests/pdg/dyn_dpds.c������������������������������������������������������0000644�0001750�0001750�00000000736�12155630327�017673� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/pdg/dyn_dpds.ml -deps -journal-disable -pdg-print -pdg-verbose 2 */ /* To have a look at the dot PDG : bin/toplevel.byte -deps -pdg-dot pdg -fct-pdg main tests/pdg/dyn_dpds.c ; zgrviewer pdg.main.dot or use tests/pdg/dyn_dpds.ml to test the dynamic dependencies. */ int G; int main (int a, int b, int c) { int x; int * p ; x = a + b; p = &x; if (c < 0) { x = -x; //@assert (*p > G); } return x; } ����������������������������������frama-c-Fluorine-20130601/tests/pdg/bts1194.c�������������������������������������������������������0000644�0001750�0001750�00000001103�12155630327�017163� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -inout-callwise -inout -pdg -pdg-print -calldeps -deps -then -slice-return main -then-on "Slicing export" -print */ int Y, X; volatile v; //@ assigns \result \from \nothing; int input(); void f (void) { int l = 0; Y = input (); if (l > 0) { Y ++; } //@ assert Y > 0; } //@ ensures \false; void g() { while(1); } void h() { if (v) g(); else X = X + 2; // X is a sure output, as the other branch does not return } int main (void) { Y = 3; // Dead when slicing on the value of Y at the end of main f (); h(); return Y; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/decl_dpds.c�����������������������������������������������������0000644�0001750�0001750�00000000626�12155630327�020006� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -fct-pdg main -journal-disable -pdg-print -pdg-verbose 2 */ extern int G; typedef struct { int a; int b; } Tstr; extern Tstr S; int main (int argc, char *argv[4]) { int argc0 = argc++; int argc1 = argc; char c = argv[argc-1][0]; argv[argc-1][0] = 'a'; argc = 0; if (argc0) { int * p = &argc0; *p = *p + 1; } return argc0 + argc1 + G + S.a; } ����������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/multiple_calls.c������������������������������������������������0000644�0001750�0001750�00000001315�12155630327�021072� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: 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; int fct1 (int x, int y, int z) { G1 = z; G3 = y; G4 = z; return x; } int fct2 (int x, int y, int z) { G2 = z; G3 = x; return y; } int appel_ptr_fct (int c, int d) { int a = 1, b = 2; int (*pf) (int, int, int) = c ? &fct1 : &fct2; int x = (*pf)(a, b, d); return x + G1 + G2; } int appel_ptr_fct_bis (int c, int a, int b, int d) { int (*pf) (int, int, int) = c ? &fct1 : &fct2; G4 = (*pf)(a, b, d); return G4 ; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/result/���������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017232� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/calls_and_implicits.c�������������������������������������������0000644�0001750�0001750�00000001113�12155630327�022052� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config * GCC: * OPT: -fct-pdg main -inout -journal-disable -pdg-print -pdg-verbose 2 * */ int printf(const char * restrict format, ...); #define SIZE 5 int t[SIZE]; int G, G2; int f (void) { G += 2; return 1; } int f2 (void) { G2 = G; return G+1; } void swap (void) { int tmp = G; G = G2; G2 = tmp; } void print (void) { int i; for (i = 0; i < SIZE; i++) printf ("t[%d] = %d\n", i, t[i]); printf ("G = %d ; G2 = %d\n\n", G, G2); } int main (void) { G = 0; G2 = 0; t[G] = f(); t[G] = f(); G = f2(); print(); swap(); print(); return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/no_body.c�������������������������������������������������������0000644�0001750�0001750�00000000605�12155630327�017513� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config * GCC: * OPT: -fct-pdg main -inout -journal-disable -pdg-print -pdg-verbose 2 */ /* * ledit bin/toplevel.top tests/slicing/no_body.c -fct-pdg main * #use "tests/slicing/select.ml";; * test "loop" (select_data "G");; */ int G; int f (int a); void loop (int x) { while (f(x)) { x++; G++; } } void main (void) { int x = 1; G = f(x); loop (x); } ���������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/globals.c�������������������������������������������������������0000644�0001750�0001750�00000001134�12155630327�017503� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: 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; extern struct Tstr S; int f (struct Tstr * p) { return p ? X : 0; } int g (void) { return f (&S); } struct Tstr { int a; int b;}; struct Tstr2 { int a2; int b2; struct { int c2; } s2; }; int X = 3; int *P = &X; int h (int x) { struct Tstr2 s2; s2.a2 = x; s2.b2 = *P; return s2.a2 + s2.b2; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/array_struct.i��������������������������������������������������0000644�0001750�0001750�00000000331�12155630327�020606� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -pdg -pdg-print -journal-disable -pdg-verbose 2 */ typedef struct { int a; int b; } ts; ts t[100]; void f(int c) { t[c].a=t[c].a; t[c].b=t[c].b; } void main(int c) { f(c); f(c); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/inter_alias2.c��������������������������������������������������0000644�0001750�0001750�00000001154�12155630327�020436� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config * GCC: * 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; } int f1 (int a) { int x1 = a; incr_ptr (&x1); return x1; } int f2 (int b) { int x2 = b; incr_ptr (&x2); return x2; } int main (int i1, int i2) { int v1 = f1 (i1); int v2 = f2 (i2); /*@ slice pragma expr v1; */ return v1 + v2; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/top_pdg_input.c�������������������������������������������������0000644�0001750�0001750�00000001337�12155630327�020740� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -out -input -deps -pdg -journal-disable -pdg-print -pdg-verbose 2 -then -main main_asm */ int ** top_input() ; int tab[2] = {0, 7}; typedef struct {int a; int t[5]; } Ts; Ts S; int G; int f1 (void) { int i = **top_input(); /* InTop element of PDG */ int v = tab[i]; G ++; return v; } int f2 (void) { int i = **top_input(); /* InTop element of PDG */; Ts s; S.a = 2; s = S; return s.a + s.t[i]; } int strlen(char* p ) { char* q ; int k = 0; for (q = p; *q ; q++) k++ ; return k; } int main (char *p_str[]) { int i = f1 (); i += f2 (); return strlen (p_str[i]); } int fun_asm(i) { asm("BLA"); return i+1; } int main_asm () { int j = 3; return fun_asm(j); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/pb_infinite_loop.c����������������������������������������������0000644�0001750�0001750�00000002146�12155630327�021403� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: 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 for the points from which there is no path to the exit. It means that we cannot compute the control dependencies in the infinite loops... */ extern int G; int test_infinite_loop (void) { if (G < 0) { int i = 0; while (1) { if (i % 2) G++; i++; } G = G/2; /* dead code */ } return G; } int test_infinite_loop_2 (void) { int i = 0; while (1) { if (i % 2) G++; i++; } return G; /* dead code */ } /* At the moment, there is no special things done for exit, * As it is seen like a normal call to an external function : no problem... */ void exit (int x); int test_exit (int c) { if (c) return 1; else { exit (1); return 0; } } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/call.c����������������������������������������������������������0000644�0001750�0001750�00000000573�12155630327�017001� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -lib-entry -main g -pdg -pdg-dot tests/pdg/call -journal-disable -pdg-print -pdg-verbose 2 */ /* Ne pas modifier : exemple utilis dans le rapport. */ /*BDOC*/ struct {int a; int b; } G; int A, B; int f (int a, int b) { G.b = b; return a + G.a; } int g (int x, int y, int z) { int r = f (x+y, z); A = G.a; B = G.b; return r; } �������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/doc_dot.c�������������������������������������������������������0000644�0001750�0001750�00000000545�12155630327�017500� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -lib-entry -main g -fct-pdg g -pdg-dot 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 */ int G1, G2, T[10]; int f (int a, int b, int c) { return a+c; } int g (void) { int x = f(G1, G2, 0); if (0 < x && x < 10) T[x] = 0; return x; } �����������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/variadic.c������������������������������������������������������0000644�0001750�0001750�00000001222�12155630327�017640� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config * GCC: * OPT: -pdg -journal-disable -pdg-print -pdg-verbose 2 */ #include <stdarg.h> int f (int n, ...) { va_list arg; int i, s = 0; va_start (arg, n); for (i = 0; i < n; i++) { int x = va_arg (arg, int); s += x; } va_end (arg); return s; } int lib_f (int n, ...); int f1 (int a) { return lib_f (1, a); } int f2 (int a, int b) { return lib_f (2, a, b); } int f3 (int a, int b, int c) { return lib_f (3, a, b, c); } int main (void) { int a1 = 1, a2 = 2, a3 = 3, a4 = 4, a5 = 5, a6 = 6; int s, s1, s2, s3; s1 = f1 (a1); s2 = f2 (a2, a3); s3 = f3 (a4, a5, a6); s = f2 (s1, s2); return s; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/sets.ml���������������������������������������������������������0000644�0001750�0001750�00000004124�12155630327�017226� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Db;; open Cil_types;; let pp_nodes msg nodes = Kernel.result "%s" msg ; List.iter (fun n -> Kernel.result "%a" (!Pdg.pretty_node false) n) nodes;; exception Find of varinfo;; let main _ = let f = Globals.Functions.find_by_name "f" in let pdg = !Pdg.get f in (* Uncomment to retrieve sid *) (*Kernel.Debug.set 1;; Format.eprintf "@[%a@]@." Printer.pp_global (Kernel_function.get_global f);; *) (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) let stmt_1 = fst (Kernel_function.find_from_sid 1) in (* y = 0 *) let node = !Pdg.find_stmt_node pdg stmt_1 in let nodes = !Pdg.all_uses pdg [node] in pp_nodes "Test [all_uses] stmt1" nodes; (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) let y = try Globals.Vars.iter (fun v _ -> if v.vname = "y" then raise (Find v)); assert false with Find v -> v in let y_zone = Locations.enumerate_valid_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 in assert (undef = None); let y_at_11_nodes = List.map (fun (n,_z) -> n) y_at_11_nodes in let () = pp_nodes "Test [find_location_nodes_at_stmt] y@11" y_at_11_nodes in (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) let nodes = !Pdg.all_dpds pdg y_at_11_nodes in let () = pp_nodes "Test [all_dpds] y@11" nodes in (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) let nodes = !Pdg.all_uses pdg y_at_11_nodes in let () = pp_nodes "Test [all_uses] y@11" nodes in (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) let all_related_nodes pdg = let all n = (!Pdg.direct_uses pdg n) @ (!Pdg.direct_dpds pdg n) in !Pdg.custom_related_nodes all in let nodes = all_related_nodes pdg y_at_11_nodes in pp_nodes "Test [all_related_nodes] y@11" nodes (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) let () = Db.Main.extend main ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/pdg/calls_and_struct.c����������������������������������������������0000644�0001750�0001750�00000000652�12155630327�021410� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -deps -input -out -inout -pdg -journal-disable -pdg-print -pdg-verbose 2 */ struct Tstr { int a; int b; int c; }; struct Tstr S; int A, B, C; int f (struct Tstr s) { A += s.a; S.a = S.b; return s.b; } int asgn_struct (void) { struct Tstr s = S; return s.a; /* \result FROM S{.a; .b; .c; }; */ } int main () { int a = asgn_struct (); A = a; B = 2; C = 3; return f (S); } ��������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/demo_cpt/�����������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016734� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/demo_cpt/types.h����������������������������������������������������0000644�0001750�0001750�00000002240�12155630273�020250� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#include <stdlib.h> #define INCR_OP_NB 100 typedef enum { false = 0, true } bool; typedef struct { char day; char month; int year; } t_date; typedef struct { t_date date; char * description; int bank_code; // 0 iff not a bank operation int amount; } t_operation; const int op_size = sizeof(t_operation); typedef struct { int size; // taille du tableau d'operations int nb; // nombre d'operation dans le tableau t_operation * ops; } t_operations; /*@ predicate operations_ok{L}(t_operations ops) = 0 <= ops.nb && ops.nb <= ops.size && \valid(ops.ops); */ typedef struct { char * name; t_operations operations; int balance; int bk_balance; } t_account; /*@ predicate account_ok{L}(t_account c) = operations_ok{L}(c.operations); */ extern t_account BankAcc; extern t_account SaveAcc; extern t_operations BankOps; //@ ensures \result == false || account_ok{Here}(*c); bool init_account (char * filename, t_account * c); //@ assigns \nothing; bool save_account (char * filename, t_account * c); /*@ assigns BankOps \from \nothing; ensures 0 <= BankOps.nb; ensures operations_ok{Here}(BankOps); */ bool get_bank_operations (void); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/demo_cpt/oracle/����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020201� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/demo_cpt/account.c��������������������������������������������������0000644�0001750�0001750�00000004175�12155630273�020544� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* frama-c-gui -val -deps account.c */ /* frama-c-gui -val -deps account.c -main update_account -slice-pragma update_account */ /* frama-c-gui -val -deps account.c -main update_account -sparecode-analysis */ /* frama-c -jessie -jessie-gui inv.c -jessie-int-model exact account.c */ #include "types.h" bool increase_size (t_operations * ops) { int i; int new_size = ops->size + INCR_OP_NB; t_operation * new_ops = (t_operation *) malloc (new_size * op_size); if (new_ops) { t_operation * old_ops = ops->ops; ops->ops = new_ops; ops->size = new_size; for (i = 0; i < ops->nb; i++) { ops->ops [i] = old_ops[i]; } free (old_ops); return true; } return false; } /*@ requires account_ok(*c); @ ensures \result == false || account_ok(*c); */ bool add_operation_to_account (t_operation * op, t_account * c) { if (c->operations.nb == c->operations.size) { bool ok = increase_size (&(c->operations)); if (!ok) return false; } c->operations.ops[c->operations.nb] = *op; c->operations.nb ++; c->balance += op->amount; if (op->bank_code != 0) c->bk_balance += op->amount; return true; } /*@ ensures min <= balance + \result <= max; */ int check_account (int balance, int min, int max) { int res = 0; if (balance < min) res = balance - min; if (balance > max) res = max - balance; return res; } /*@ requires \valid(bk_ops) && \valid(bk_ops->ops + (0..bk_ops->nb-1)); */ bool process_bank_operations (t_operations * bk_ops, t_account * c) { int i; bool ok = true; for (i = 0; i < bk_ops->nb; i++) { ok = add_operation_to_account (bk_ops->ops + i, c); if (!ok) break; } return ok; } /*@ requires \valid(bk_ops) && \valid(bk_ops->ops + (0..bk_ops->nb-1)); */ int update_account (t_operations * bk_ops, t_account * c) { int todo; int min = 200; int max = 2000; char * fname = "current.cpt"; process_bank_operations (bk_ops, c); todo = check_account (c->balance, min, max); /* if (todo < 0) { // get money from savings... if any ! t_operation op = { today(), "From savings", 0, x }; */ //@ slice pragma expr c->balance; return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/demo_cpt/result/����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020252� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/bugs/���������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016102� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/bugs/oracle/��������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017347� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/bugs/jc.c�����������������������������������������������������������0000644�0001750�0001750�00000000105�12155630322�016632� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ //@ requires \valid(p); void g(int*p); void f(int *a){ g(a); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/bugs/enum.c���������������������������������������������������������0000644�0001750�0001750�00000000136�12155630322�017206� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������enum fixed_addresses { A, B = -1UL, BASE, END = BASE, }; enum e f(void) { return A; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/bugs/evoting.c������������������������������������������������������0000644�0001750�0001750�00000026545�12155630322�017731� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* evoting.c - An example program of electronic voting in C */ /* copyright 2004-2009 David MENTRE */ /* this program is under GNU GPL license */ /* This program presents a prototype of electronic machine written in C. Its intent is to implement the core algorithms as a reference for further analysis */ /* TODO: */ #define _GNU_SOURCE #define __SINGLE_THREAD__ #include <stdio.h> #include <stdlib.h> #include <stdarg.h> #include <sys/time.h> #include <time.h> #include <string.h> #if 0 #include "check_specs.h" #if 0 #include <C:/Frama-C/share/frama-c/jessie/jessie_prolog.h> #else #include </usr/local/share/frama-c/jessie/jessie_prolog.h> #endif #endif #include "jessie_prolog.h" #define MAX_CANDIDATES 20 #define MAX_STRING_SIZE 255 #define MAX_VOTES_PER_CANDIDATE 100000 char *candidates[MAX_CANDIDATES]; int num_candidates; int number_of_votes; int counters[MAX_CANDIDATES]; FILE *log_desc; /*@ assigns \nothing; ensures \result <= a && \result <= b; ensures \result == a || \result == b; */ int min(int a, int b) { return (a)<(b)?(a):(b); } #ifdef NO_FRAMA_C /*@ requires valid_string(str); assigns \nothing; */ void print_string(char *str) { printf(str); } /*@ assigns \nothing; */ void print_int(int n) { printf("%d", n); } #else /* to avoid overhead of Frama-C regarding static C strings */ #define print_string(s) #define print_int(n) #endif /*@ requires choice >= 0 && choice <= num_candidates; assigns \nothing; */ void print_candidate(int choice) { print_int(choice); print_string("-'"); print_string(candidates[choice]); print_string("'"); } /*@ requires valid_string(filename); assigns candidates[..]; ensures \result > 1 && \result < MAX_CANDIDATES; ensures \forall integer i; 0 <= i < \result ==> valid_string(candidates[i]); */ int read_candidates(char *filename) { int i; FILE *f; char buf[MAX_STRING_SIZE]; char *s; f = fopen(filename, "r"); if (f == NULL) { perror("unable to open candidates file"); exit(1); } candidates[0] = strndup("None of those candidates", MAX_STRING_SIZE); i = 1; s = fgets(buf, MAX_STRING_SIZE, f); /*@ loop invariant 1 <= i && i < MAX_CANDIDATES; loop invariant \forall integer j; 0 <= j < i ==> valid_string(candidates[j]); loop invariant s == NULL || valid_string(buf); */ while (i < MAX_CANDIDATES - 1 && s != NULL) { int len, copied_len; len = strlen(buf); if (len > 0) { copied_len = min(MAX_STRING_SIZE, len - 1); /* do not copy newline */ candidates[i] = strndup(buf, copied_len); i++; } s = fgets(buf, MAX_STRING_SIZE, f); } if (i <= 1) { print_string("Not enough candidates\n"); exit(1); } fclose(f); return i; } /*@ assigns \nothing; */ void print_candidate_array(void) { int i; for (i = 0; i < num_candidates; i++) { print_string(" "); print_int(i); print_string(". "); print_string(candidates[i]); print_string("\n"); } } /*@ requires \valid(argv +(0..1)); requires valid_string(argv[1]); assigns num_candidates, candidates[..]; ensures num_candidates > 1 && num_candidates < MAX_CANDIDATES; ensures \forall integer i; 0 <= i < num_candidates ==> valid_string(candidates[i]); */ void vote_setup(char **argv) { print_string("**** Vote Setup ****\n"); print_string("* reading candidates file '"); print_string(argv[1]); print_string("'\n"); num_candidates = read_candidates(argv[1]); print_int(num_candidates); print_string(" candidates:\n"); print_candidate_array(); } /*@ requires \valid(stdin); assigns \nothing; ensures \result >= 0 && \result < num_candidates; */ int get_vote(void) { char buf[MAX_STRING_SIZE]; char *s = NULL; while (1) { print_string("Choose a candidate:\n"); print_candidate_array(); print_string("Your choice (0-"); print_int(num_candidates - 1); print_string("):"); s = fgets(buf, MAX_STRING_SIZE, stdin); if (s != NULL) { int choice; choice = atoi(buf); if (choice >= 0 && choice < num_candidates) { print_string("Are you sure your vote "); print_candidate(choice); print_string(" is correct? (y/n)"); s = fgets(buf, MAX_STRING_SIZE, stdin); if (s != NULL && strncmp(buf, "y", 1) == 0) { return choice; } else { print_string("Vote canceled, redo\n"); } } else { print_string("Invalid choice ("); print_int(choice); print_string("), redo\n"); } } else { print_string("bad input, redo\n"); } } } /*@ requires number_of_votes == 0; requires \forall integer i; 0 <= i < MAX_CANDIDATES ==> counters[i] == 0; requires 1 < num_candidates && num_candidates < MAX_CANDIDATES; requires \valid(stdin); assigns counters[..]; assigns number_of_votes; ensures number_of_votes < MAX_CANDIDATES * MAX_VOTES_PER_CANDIDATE; ensures number_of_votes >= 0; ensures \forall integer i; 0 <= i < num_candidates ==> counters[i] < MAX_VOTES_PER_CANDIDATE; ensures \forall integer i; 0 <= i < num_candidates ==> counters[i] >= 0; ensures \forall integer i; num_candidates <= i < MAX_CANDIDATES ==> counters[i] == 0; ensures num_candidates < MAX_CANDIDATES; */ // ensures number_of_votes == \sum(0, num_candidates, // \lambda integer i; counters[i]); void voting(void) { char buf[MAX_STRING_SIZE]; char *s = ""; print_string("**** Voting ****\n"); /*@ loop invariant \forall integer i; 0 <= i < MAX_CANDIDATES ==> 0 <= counters[i] && counters[i] < MAX_VOTES_PER_CANDIDATE; loop invariant 0 <= number_of_votes; loop invariant number_of_votes < MAX_CANDIDATES * MAX_VOTES_PER_CANDIDATE; loop invariant \forall integer i; num_candidates <= i < MAX_CANDIDATES ==> counters[i] == 0; loop invariant \valid(stdin); */ while (number_of_votes < num_candidates * MAX_VOTES_PER_CANDIDATE) { print_string("* Do you want to Vote or Stop the vote (v/\"end of vote\")?"); s = fgets(buf, MAX_STRING_SIZE, stdin); if (s != NULL && strncmp(buf, "end of vote", 11) == 0) { return; } if (s != NULL && strncmp(buf, "v", 1) == 0) { int chosen_vote; chosen_vote = get_vote(); // Stop votes when we have reach the max of vote per candidate if (counters[chosen_vote] < MAX_VOTES_PER_CANDIDATE - 1) { counters[chosen_vote]++; number_of_votes++; print_string("Vote stored: "); print_candidate(chosen_vote); print_string("\n"); } else return; } } } /* FIXME: in following function, we don't consider the case when two candidates have the same counters. */ /*@ requires 1 < num_candidates && num_candidates < MAX_CANDIDATES; assigns \nothing; ensures \result >= 1 && \result < num_candidates; ensures \forall integer i; 1 <= i < num_candidates ==> counters[\result] >= counters[i]; */ int compute_winner(void) { int i, winner; winner = 1; /* "No vote" is NOT taken into account */ /*@ loop invariant 2 <= i && i < MAX_CANDIDATES; loop invariant \forall integer j; 1 <= j < i ==> counters[winner] >= counters[j]; loop invariant winner >= 1 && winner < num_candidates; */ for (i = 2; i < num_candidates; i++) { if (counters[i] > counters[winner]) { winner = i; } } return winner; } /*@ requires 1 < num_candidates && num_candidates < MAX_CANDIDATES; requires \forall integer i; 0 <= i < MAX_CANDIDATES ==> counters[i] < MAX_VOTES_PER_CANDIDATE && counters[i] >= 0; assigns \nothing; */ void compute_results(void) { int total = 0; int i, winner, valid_total; print_string("**** Result ****\n"); /*@ loop invariant 0 <= i && i <= num_candidates; loop invariant 0 <= counters[i] < MAX_VOTES_PER_CANDIDATE; loop invariant total >= 0; loop invariant total <= i * MAX_VOTES_PER_CANDIDATE; loop invariant \forall integer j; 0<=j<i ==> total >= counters[j]; */ for (i = 0; i < num_candidates; i++) { total += counters[i]; } //@ assert total < MAX_CANDIDATES * MAX_VOTES_PER_CANDIDATE; //@ assert total >= counters[0]; //@ assert counters[0] >= 0; valid_total = total - counters[0]; //@ loop invariant 0 <= i; for (i = 0; i < num_candidates; i++) { print_int(counters[i]); print_string(" vote(s): "); print_candidate(i); print_string("\n"); } /* for (i = 0; i < num_candidates; i++) { */ /* dual_log(" %d. %s % 5d vote(s) (%.03f %%)\n", */ /* i, candidates[i], counters[i], */ /* (double)counters[i] / (double)valid_total * 100.0); */ /* } */ print_string("Total number of votes: "); print_int(total); print_string("\n"); print_string("Total number of valid votes: "); print_int(valid_total); print_string("\n"); winner = compute_winner(); print_string("* Winner: "); print_int(winner); print_string("-"); print_string(candidates[winner]); print_string("\n"); } /*@ requires \valid(stdin); requires \valid(argv +(0..argc-1)); requires valid_string(argv[1]); assigns log_desc; assigns num_candidates, candidates[..]; assigns number_of_votes; assigns counters[..]; */ int main(int argc, char **argv) { int i; log_desc = fopen("c-evote.log", "w"); if (log_desc == NULL) { perror("unable to open log file c-evote.log"); exit(1); } print_string("**** Start of vote program (C version) ****\n"); if (argc != 2) { fputs("bad number of arguments\n", stderr); fputs("usage: c-evoting candidates.txt\n", stderr); exit(1); } // clean-up all global data structures number_of_votes = 0; /*@ loop invariant \forall integer j; 0 <= j < i ==> counters[j] == 0; loop invariant 0 <= i && i <= MAX_CANDIDATES; loop invariant \valid(argv +(0..argc-1)); loop invariant argc == 2; loop invariant valid_string(argv[1]); */ for (i = 0; i < MAX_CANDIDATES; i++) counters[i] = 0; vote_setup(argv); // We have at least the "None of those candidates" option for voters //@ assert num_candidates > 1; // All candidates have a valid description string /*@ assert \forall integer i; 0 <= i < num_candidates ==> valid_string(candidates[i]); */ // All candidates have their counters set to zero and no vote registered //@ assert \forall integer i; 0 <= i < MAX_CANDIDATES ==> counters[i] == 0; //@ assert number_of_votes == 0; voting(); // All candidates have their counters potentially incremented //@ assert \forall integer i; 0 <= i < num_candidates ==> counters[i] >= 0; // FIXME: How to specify that nothing is changed after voting? compute_results(); /* free data structures */ //@ assert num_candidates < MAX_CANDIDATES; //@ loop invariant 0 <= i && i <= MAX_CANDIDATES; for (i = 0; i < num_candidates; i++) free(candidates[i]); print_string("**** Stop of vote program (C version) ****\n"); fclose(log_desc); return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/bugs/switch.i�������������������������������������������������������0000644�0001750�0001750�00000000127�12155630322�017551� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int g(int); void f(void) { int x = 0; switch (1) { case 1: x = (int)g(x); } } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/bugs/simple_func.c��������������������������������������������������0000644�0001750�0001750�00000000215�12155630322�020544� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ /*@ ensures *q == \old(*p) && *p == \old(*q) ; assigns *p,*q; */ void f (int *p,int*q) { int t = *p; *p = *q; *q = t; return; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/bugs/check_specs.h��������������������������������������������������0000644�0001750�0001750�00000001200�12155630322�020512� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������// for SSIZE_MAX //#include <limits.h> #undef putchar /* assigns \nothing; */ int putchar(int c); #ifdef NO_FRAMA_C /*@ assigns \nothing; */ void perror(const char *s); #else #define perror(s) #endif /* To avoid issue with errno with is defined as "int *__errno_location (void);" in system includes, we define our own errno. */ #undef errno #define errno global_error_number int global_error_number; /*@ requires \valid(s); assigns \nothing; */ int puts(const char *s); #ifdef NO_FRAMA_C /*@ assigns \nothing; */ int fputs(const char *s, FILE *stream); #else #define fputs(...) #endif ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/bugs/result/��������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017420� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/bugs/imbricated_comments.c������������������������������������������0000644�0001750�0001750�00000000235�12155630322�022252� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#define MAX_NAME_LENGTH 30 typedef char NAME_TYPE[MAX_NAME_LENGTH]; extern void F (const NAME_TYPE /* in */ name); void G (void) { F("toto") ; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/sparecode/����������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017107� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/sparecode/oracle/���������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020354� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/sparecode/dead_code.c�����������������������������������������������0000644�0001750�0001750�00000000406�12155630324�021140� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -sparecode-debug 1 -sparecode -journal-disable OPT: -slicing-level 2 -slice-return main -journal-disable -then-on 'Slicing export' -print */ int main (void) { int c = 1, x; x = 0; if (c) x = 1; else x = 2; return x; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/sparecode/bts324_bis.c����������������������������������������������0000644�0001750�0001750�00000002107�12155630324�021127� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -sparecode-analysis -sparecode-debug 1 -journal-disable OPT: -sparecode-analysis -sparecode-debug 1 -main main_bis -journal-disable OPT: -sparecode-analysis -sparecode-debug 1 -sparecode-no-annot -journal-disable */ int ki[2], k ; int f (int vi, int i) { static int si[2] = 0, so[2] = 0; int vo = so[i]/k + ki[i]*(vi - si[i]) ; so[i] = vo ; si[i] = vi ; return vo ; } int volatile e0,e1; int s0, s1 ; void loop_body (void) { int acq0 = e0 ; int acq1 = e1; int val0 = f (acq0, 0) ; int val1 = f (acq1, 1) ; s0 = val0 ; s1 = val1 ; } int is_ok ; void init (int *pres) { ki[0] = 2 ; ki[1] = 4 ; k = 8 ; *pres = 1 ; } void main (int c) { init (& is_ok); if (is_ok) while (1) { loop_body () ; // note: sparecode conserve les pragmas de slicing et par consquent ce // qui calcule "s0", l'option -sparecode-no-annot ni change rien //@ impact pragma expr s0; //@ slice pragma expr s1; } } void main_bis (int c) { init (& is_ok); if (is_ok) while (1) { loop_body () ; } } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/sparecode/intra.c���������������������������������������������������0000644�0001750�0001750�00000005160�12155630324�020370� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -sparecode-debug 1 -sparecode-analysis -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 -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: * 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; } /*-------------------------------------*/ ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/sparecode/glob_decls.c����������������������������������������������0000644�0001750�0001750�00000001755�12155630324�021356� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -lib-entry -journal-disable -sparecode-debug 1 -sparecode-analysis 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 */ // can be removed int G1, G2; int * PG1 = &G1; // can be removed typedef struct { int a; } Ts; Ts Gts; typedef Ts * Ps; Ps GPs; // Cannot be removed : used in spec typedef struct { int a; int b; } Ts2; Ts2 S2; /* same type name for something else : renamed by cil. Cool !*/ typedef char Ts2; Ts2 C = 'a'; // Can be removed : used in an unused function typedef struct { int a; int b; int c; } Ts3; Ts3 S3; int f (void) { return S3.a + S3.b + S3.c; } typedef int Int; typedef Int Tx; char Size; 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; �������������������frama-c-Fluorine-20130601/tests/sparecode/se.c������������������������������������������������������0000644�0001750�0001750�00000000404�12155630324�017656� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -sparecode-debug 1 -sparecode-analysis -lib-entry -main Se -journal-disable */ int glob; void Se(int e1, int e2, int *es, int *s1, int tab[]) { *s1=0; glob=10; if (e1==0) *s1=1; else tab[e1]=5; if (*es==1) *es=0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/sparecode/bts334.c��������������������������������������������������0000644�0001750�0001750�00000002177�12155630324�020302� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*run.config OPT: -main main_init -sparecode-analysis -sparecode-no-annot -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] ; int f(int vi , int i ) ; static int si[2] = {0, 0}; static int so[2] = {0, 0}; int f(int vi , int i ) { int vo ; {vo = so[i] / kf + k[i] * (vi - si[i]); so[i] = vo; si[i] = vi; return (vo);} } int volatile e0 ; int volatile e1 ; int s0 ; int s1 ; void loop_body(void) { int acq0 ; int acq1 ; int val0 ; int val1 ; {/*@ slice pragma expr s0; */ ; ; acq0 = (int )e0; acq1 = (int )e1; val0 = f(acq0, 0); val1 = f(acq1, 1); s0 = val0; s1 = val1; return;} } int kf ; int k[2] ; void process(int conf ) { {kf = conf; k[0] = 3; k[1] = 14; while (1) {loop_body();} return;} } /*@ behavior default: assigns *p; */ extern int init(int *p ) ; void main_init(void) { int is_ok ; int config ; {config = init(& is_ok); if (is_ok) {process(config);} return;} } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/sparecode/params.c��������������������������������������������������0000644�0001750�0001750�00000000763�12155630324�020542� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -sparecode-debug 1 -sparecode-analysis -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 * compilable result. But unfortunatly, this leads to also select [b=1] in * [main]. This should be enhanced... */ int main1 (int x, int y, int z){ y = 3; return y; } int main (void) { int a = 0, b = 1, c = 3; return main1 (a, b, c); } �������������frama-c-Fluorine-20130601/tests/sparecode/result/���������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020425� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/sparecode/bts927.c��������������������������������������������������0000644�0001750�0001750�00000000677�12155630324�020315� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -no-warn-signed-overflow -sparecode OPT: -warn-signed-overflow -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; } } �����������������������������������������������������������������frama-c-Fluorine-20130601/tests/sparecode/top.c�����������������������������������������������������0000644�0001750�0001750�00000001225�12155630324�020053� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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; } int main_top (int nb, ...) { int x = 3; int y = f (2); return x; } 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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/sparecode/calls.c���������������������������������������������������0000644�0001750�0001750�00000000730�12155630324�020347� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -sparecode-debug 1 -sparecode-analysis -journal-disable OPT: -slicing-level 2 -slice-return main -journal-disable -then-on 'Slicing export' -print */ 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; } ����������������������������������������frama-c-Fluorine-20130601/tests/sparecode/bts324.c��������������������������������������������������0000644�0001750�0001750�00000001311�12155630324�020266� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -sparecode-analysis -sparecode-debug 1 -journal-disable OPT: -sparecode-analysis -sparecode-debug 1 -main main_bis -journal-disable OPT: -sparecode-analysis -sparecode-debug 1 -main main_ter -journal-disable */ int i0, o0; /*@ assigns i0, o0 ; */ void loop_body () ; /*@ assigns *p_res; */ void init (int * p_res) ; int is_ko = -1; void main () { init (&is_ko); if (is_ko) while (1) loop_body () ; } void main_bis (void) { init (&is_ko); if (is_ko) while (1) { loop_body () ; /*@ slice pragma expr o0 ;*/ } } void main_ter () { init (&is_ko); if (is_ko) while (1) { /*@ slice pragma stmt ;*/ loop_body () ; } } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/�������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016417� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/oracle/������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017664� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/call.i�������������������������������������������������������0000644�0001750�0001750�00000001644�12155630330�017504� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 (); } ��������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/slicing.i����������������������������������������������������0000644�0001750�0001750�00000000554�12155630330�020220� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ����������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/variadic.i���������������������������������������������������0000644�0001750�0001750�00000001747�12155630330�020357� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-impact-pragma main" +"-then -main main1 -impact-pragma main1" +"-then -main main2 -impact-pragma main2" +"-then -main main3 -impact-pragma aux3" +"-then -main main4 -impact-pragma aux4" */ int f(int, ...); int main () { int i=0; /*@ impact pragma stmt; */ i++; f(i); } int y; //@ assigns y \from y, x; void g1(int x, ...) { y = x + y; } //@ assigns y \from x; void g2(int x, ...); int main1() { int x = 3; //@ impact pragma stmt; g1(1, 2, 3); g1(1, 2); return y; } int main2() { int x = 3; //@ impact pragma stmt; g2(1, 2, 3); g2(1, 2); return y; } int z; //@ assigns z \from y; void g3(int , ...); int aux3(int x, ...) { int x = 3; //@ impact pragma stmt; g1(x); g1(x); return y; } int main3() { aux3(1, 2); aux3(2, 3); return y; } void aux4(int x) { //@ impact pragma stmt; y = x; } int aux4bis(int x, ...) { aux4(x); return y; } int main4() { aux4bis(1, 2); aux4bis(1, 2, 3); return y; } �������������������������frama-c-Fluorine-20130601/tests/impact/depend5.i����������������������������������������������������0000644�0001750�0001750�00000000473�12155630330�020114� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-calldeps" +"-then" +"-impact-pragma g" +"-then" +"-inout-callwise" */ int a, b, c, d, e; void f() { if (a) c = d; // should not be selected else b = e; } void g() { //@ impact pragma stmt; d = 2; e = d; f(); } void main () { a = 1; f(); a = 0; g(); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/first.i������������������������������������������������������0000644�0001750�0001750�00000000425�12155630330�017714� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/loop2.i������������������������������������������������������0000644�0001750�0001750�00000001010�12155630330�017607� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-impact-pragma main" +"-lib-entry" +"-calldeps" +"-inout-callwise" +"-then" +"-ulevel 10" */ volatile v; int t[10], u[10], w[10]; void init() { for (int i=0; i<10; i++) { u[i] = v; } } void f(int i) { int v = t[i]; // should not be selected w[i] = i; // should not be selected (selection depends on if (t[i]) in main t[i] = u[i]; } void main() { //@ impact pragma stmt; init (); for (int i=0; i<10; i++) { if (t[i]) // should not be selected f(i); } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/loop.i�������������������������������������������������������0000644�0001750�0001750�00000000362�12155630330�017536� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/depend4.i����������������������������������������������������0000644�0001750�0001750�00000000562�12155630330�020112� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-calldeps" +"-inout-callwise" +"-then" +"-impact-pragma main" */ int a, r1, r2; void f() { a = 1; } void aux(int *p, int cond) { if(cond) r1 = *p; else r2 = *p; // Ne devrait pas tre slectionn } void g1() { aux(&a, 0); } void g2() { aux(&a, 1); } void main () { g1(); //@ impact pragma stmt; f(); g2(); } ����������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/result/������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017735� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/alias.i������������������������������������������������������0000644�0001750�0001750�00000000472�12155630330�017660� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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+1; *y = 4; int a = *(x+1) + 2; *y = 2; if (c) return *(x+1); else { y = P; return *y; } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/depend3.c����������������������������������������������������0000644�0001750�0001750�00000000644�12155630330�020104� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-impact-pragma main" */ #define N 32 extern int ring[N] ; int find(int x) { for (int k=0; k<N; k++) if (ring[k]=x) return k; for (int k=0; k<N; k++) if (ring[k]==0) { ring[k] = x ; return k; } return -1; } int apply(int x,int y) { return find(x); } int main() { int a = apply( 1 , 100 ); /*@ impact pragma stmt; */ int b = apply( 2 , 200 ); return a+b ; } ��������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/topbot.c�����������������������������������������������������0000644�0001750�0001750�00000000372�12155630330�020067� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-impact-pragma main -pdg -pdg-print" */ //@ requires \false; void f() { // Bottom PDG } void main(int c) { /*@ impact pragma stmt; */ int x = 1; int y, z; if (c) { y = x; f(); z = x; } z = x; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/undef_function.i���������������������������������������������0000644�0001750�0001750�00000000222�12155630330�021566� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-impact-pragma main" */ int y; void g(int); int main() { /*@ impact pragma stmt; */ y=2; g(y); return y; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/depend2.i����������������������������������������������������0000644�0001750�0001750�00000000357�12155630330�020112� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 ; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/depend1.i����������������������������������������������������0000644�0001750�0001750�00000000334�12155630330�020104� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 ; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/initial.i����������������������������������������������������0000644�0001750�0001750�00000002351�12155630330�020216� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-pdg-verbose 0" +"-main main1 -impact-pragma g1" +"-then -main main2 -impact-pragma g2" +"-then -main main3 -impact-pragma g3" */ int x1, x2, y2, z2, x3; volatile int c; /* First case: Out(x1) in main1 is not impacted. It is equivalent to Out(x1) in g1, which is part of the initial query */ void f1() { x1 = 1; } void g1() { if (c) { //@ impact pragma stmt; f1(); } } void main1() { while(1) { g1(); } } /* Second case: Out(x2) in main2 IS impacted, due to the circular dependency x2 <- y2 <- z2; However, this cannot be seen immediately, so the nodes Out(x2) in in h2 and main2 are first put in the worklist as belonging to the initial impact. */ void f2() { x2 = y2; } void aux2() { y2 = z2; } void g2() { if (c) { //@ impact pragma stmt; f2(); if (c) aux2(); } } void h2() { g2(); z2 = x2; } void main2() { while(1) { h2(); } } void f3() { x3 = 1; } void g3() { //@ impact pragma stmt; f3(); if (c) { x3 = x3; } } /* Third case: Out(x3) in main3 is impacted, as it represents Out(x3) in the call to f3(), AND x3=x3. However, Out(x3) in the call to f3() is not self-impacting */ void main3() { while(1) { g3(); } } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/impact/called.i�����������������������������������������������������0000644�0001750�0001750�00000000636�12155630330�020015� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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); } ��������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic_plugin/�����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020144� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic_plugin/oracle/����������������������������������������������0000755�0001750�0001750�00000000000�12155634043�021411� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic_plugin/apply.ml���������������������������������������������0000644�0001750�0001750�00000001525�12155630322�021622� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Datatype module Param = Plugin.Register (struct let name = "apply" let shortname = "apply" let help = "testing purpose" end) module Test = Param.False (struct let option_name = "-dynamic-test" let help = "print dynamic test" end) let main () = 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" (func int (func (list char) (func (pair string float) unit))) 42 ['a'] ("r",6.8) with Dynamic.Incompatible_type s -> Param.feedback "%s" s; try Dynamic.get ~plugin:"Register_mod2" "unknown" (func unit unit) () with Dynamic.Unbound_value s -> Param.feedback "value %S not registered" s end let () = Db.Main.extend main ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic_plugin/register_mod1.ml�������������������������������������0000644�0001750�0001750�00000000557�12155630322�023245� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������module L = List open Datatype module List = L (* Test with a mutual recursive function *) let f_test i j= Format.printf "Use f_test %d %d@." i j; if i = 0 then j else Dynamic.get ~plugin:"Register_mod2" "g_test" (func int int) (j-1) let __ : int = Dynamic.register ~plugin:"Register_mod1" "f_test" ~journalize:false (func int (func int int)) f_test 3 4 �������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic_plugin/result/����������������������������������������������0000755�0001750�0001750�00000000000�12155634043�021462� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/dynamic_plugin/register_mod2.ml�������������������������������������0000644�0001750�0001750�00000000615�12155630322�023241� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������module L = List open Datatype module List = L (* Test with a mutual recursive function *) let g_test j= Format.printf "Use g_test %d@." j; if j mod 3 = 0 then j else Dynamic.get ~plugin:"Register_mod1" "f_test" (func int (func int int)) (j-1) j let __ : int -> int = Dynamic.register ~journalize:false ~plugin:"Register_mod2" "g_test" (func int int) g_test �������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/journal/������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016614� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/journal/oracle/�����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020061� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/journal/control2.c��������������������������������������������������0000644�0001750�0001750�00000001505�12155630326�020523� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: BIN control_journal2.ml ./bin/toplevel.opt -journal-enable -memory-footprint 1 -val -deps -out -main f -journal-name tests/journal/result/control_journal2 tests/journal/control2.c > /dev/null 2> /dev/null EXECNOW: LOG control2_sav.res LOG control2_sav.err BIN control_journal_next2.ml FRAMAC_LIB=lib/fc ./bin/toplevel.byte -journal-enable -load-script tests/journal/result/control_journal2 -lib-entry -journal-name tests/journal/result/control_journal_next2 tests/journal/control2.c > ./tests/journal/result/control2_sav.res 2> ./tests/journal/result/control2_sav.err CMD: FRAMAC_LIB=lib/fc ./bin/toplevel.byte OPT: -load-script tests/journal/result/control_journal_next2 */ 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; } } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/journal/intra.i�����������������������������������������������������0000644�0001750�0001750�00000005101�12155630326�020100� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } /*-------------------------------------*/ ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/journal/abstract_cpt.ml���������������������������������������������0000644�0001750�0001750�00000001252�12155630326�021617� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������let mk () = ref 0 let incr c = incr c; !c include Datatype.Make(struct (* order of lines below does matter *) include Datatype.Serializable_undefined include Datatype.Ref(Datatype.Int) let varname _ = "cpt" let name = "Abstract_cpt.t" end) let mk = Dynamic.register ~journalize:true ~plugin:"Abstract_cpt" "mk" (Datatype.func Datatype.unit ty) mk let incr = Dynamic.register ~journalize:true ~plugin:"Abstract_cpt" "incr" (Datatype.func ty Datatype.int) incr let pretty = Dynamic.register ~journalize:true ~plugin:"Abstract_cpt" "pretty" (Datatype.func ty Datatype.unit) (fun n -> Format.printf "%d@." !n) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/journal/result/�����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020132� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/journal/use_cpt.ml��������������������������������������������������0000644�0001750�0001750�00000001036�12155630326�020610� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ let main () = let module T = Type.Abstract(struct let name = "Abstract_cpt.t" end) in let c = Dynamic.get ~plugin:"Abstract_cpt" "mk" (Datatype.func Datatype.unit T.ty) () in let incr = Dynamic.get ~plugin:"Abstract_cpt" "incr" (Datatype.func T.ty Datatype.int) in let pretty = Dynamic.get ~plugin:"Abstract_cpt" "pretty" (Datatype.func T.ty Datatype.unit) in let incr_and_pretty c = ignore (incr c); pretty c in for i = 1 to 3 do incr_and_pretty c done let () = Db.Main.extend main ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/journal/intra.ml����������������������������������������������������0000644�0001750�0001750�00000000110�12155630326�020253� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������let () = Db.Main.extend (fun _ -> ignore (!Db.Sparecode.get true true)) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/journal/control.i���������������������������������������������������0000644�0001750�0001750�00000002357�12155630326�020455� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config COMMENT: do not compare generated journals since they depend on current time 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 EXECNOW: BIN abstract_cpt_journal.ml FRAMAC_LIB=lib/fc ./bin/toplevel.byte -journal-enable -load-script tests/journal/abstract_cpt.ml -load-script tests/journal/use_cpt.ml -journal-name tests/journal/result/abstract_cpt_journal > /dev/null 2> /dev/null CMD: FRAMAC_LIB=lib/fc ./bin/toplevel.byte OPT: -load-script tests/journal/result/abstract_cpt_journal.ml -load-script tests/journal/abstract_cpt.ml -load-script tests/journal/use_cpt.ml */ 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; } } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/metrics/������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016610� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/metrics/oracle/�����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020055� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/metrics/func_ptr.c��������������������������������������������������0000644�0001750�0001750�00000000715�12155630325�020576� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-metrics-value-cover" +"-metrics-cover main" STDOPT: +"-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; } } ���������������������������������������������������frama-c-Fluorine-20130601/tests/metrics/unreachable.c�����������������������������������������������0000644�0001750�0001750�00000000401�12155630325�021217� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-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; } } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/metrics/cyclo_comp5.c�����������������������������������������������0000644�0001750�0001750�00000000660�12155630325�021171� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-metrics-ast cil" **/ void printf(const char *format); int complexity5(int n){ if (n > 0) { switch (n) { case 0 : case 1: printf("Zero or one\n"); break; case 2: printf("Two\n"); break; case 3: case 4: printf("Three or four\n"); break; default: break; }} else printf("Negative\n"); return(n); } int main() { return complexity5(1); } ��������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/metrics/result/�����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020126� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/metrics/fc_libc.c���������������������������������������������������0000644�0001750�0001750�00000004750�12155630325�020342� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-check" **/ #include "share/libc/assert.c" #include "share/libc/complex.c" #include "share/libc/ctype.c" #include "share/libc/errno.c" #include "share/libc/__fc_builtin.c" #include "share/libc/fenv.c" #include "share/libc/float.c" #include "share/libc/inttypes.c" #include "share/libc/iso646.c" #include "share/libc/limits.c" #include "share/libc/locale.c" #include "share/libc/math.c" #include "share/libc/setjmp.c" #include "share/libc/signal.c" #include "share/libc/stdarg.c" #include "share/libc/stdbool.c" #include "share/libc/stddef.c" #include "share/libc/stdio.c" #include "share/libc/stdlib.c" #include "share/libc/string.c" #include "share/libc/test.c" #include "share/libc/tgmath.c" #include "share/libc/time.c" #include "share/libc/wchar.c" #include "share/libc/wctype.c" #include "share/libc/assert.h" #include "share/libc/ctype.h" #include "share/libc/dirent.h" #include "share/libc/errno.h" #include "share/libc/__fc_builtin.h" #include "share/libc/__fc_define_blkcnt_t.h" #include "share/libc/__fc_define_blksize_t.h" #include "share/libc/__fc_define_dev_t.h" #include "share/libc/__fc_define_ino_t.h" #include "share/libc/__fc_define_intptr_t.h" #include "share/libc/__fc_define_iovec.h" #include "share/libc/__fc_define_mode_t.h" #include "share/libc/__fc_define_nlink_t.h" #include "share/libc/__fc_define_null.h" #include "share/libc/__fc_define_off_t.h" #include "share/libc/__fc_define_pid_t.h" #include "share/libc/__fc_define_restrict.h" #include "share/libc/__fc_define_size_t.h" #include "share/libc/__fc_define_ssize_t.h" #include "share/libc/__fc_define_suseconds_t.h" #include "share/libc/__fc_define_time_t.h" #include "share/libc/__fc_define_uid_and_gid.h" #include "share/libc/__fc_define_useconds_t.h" #include "share/libc/__fc_define_wchar_t.h" #include "share/libc/__fc_machdep.h" #include "share/libc/fcntl.h" #include "share/libc/__fc_string_axiomatic.h" #include "share/libc/float.h" #include "share/libc/inttypes.h" #include "share/libc/iso646.h" #include "share/libc/limits.h" #include "share/libc/locale.h" #include "share/libc/math.h" #include "share/libc/pwd.h" #include "share/libc/setjmp.h" #include "share/libc/signal.h" #include "share/libc/stdarg.h" #include "share/libc/stdbool.h" #include "share/libc/stddef.h" #include "share/libc/stdint.h" #include "share/libc/stdio.h" #include "share/libc/stdlib.h" #include "share/libc/string.h" #include "share/libc/syslog.h" #include "share/libc/termios.h" #include "share/libc/time.h" #include "share/libc/unistd.h" ������������������������frama-c-Fluorine-20130601/tests/metrics/reach.c�����������������������������������������������������0000644�0001750�0001750�00000000662�12155630325�020041� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-metrics-by-function" +"-metrics-value-cover" **/ void (*bar) (int); void (*t[2])(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; } } ������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/���������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016074� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/assign_in_spec.c�����������������������������������������������0000644�0001750�0001750�00000000045�12155630271�021222� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ //@ ensures \result = 1; int f(); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/preprocess_string.c��������������������������������������������0000644�0001750�0001750�00000000100�12155630271�022001� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ ensures "/*"[0] == '/'; */ char f(void) { return "/*"[1]; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/oracle/��������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017341� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/multidecl.c����������������������������������������������������0000644�0001750�0001750�00000000507�12155630271�020223� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ predicate p0(integer x) = x == 0; @ predicate p1(integer x) = x == 1; @ lemma excl: \forall integer x; ! (p0(x) && p1(x)); @*/ // not well-typed (testing localization of error messages) /*@ predicate p2(int x) = x == 0; @ predicate p3(int x) = x == 1; @ lemma excl2: \forall integer x; ! (p2(x) && p3(x)); @*/ �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/permut.c�������������������������������������������������������0000644�0001750�0001750�00000002051�12155630271�017551� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ /*@ axiomatic Permut { @ // permut{L1,L2}(t1,t2,n) is true whenever t1[0..n-1] in state L1 @ // is a permutation of t2[0..n-1] in state L2 @ predicate permut{L1,L2}(double t1[], double t2[], integer n); @ // reads \at(t1[..],L1), \at(t2[..],L2); @ axiom permut_refl{L} : @ \forall double t[], integer n; permut{L,L}(t,t,n); @ axiom permut_sym{L1,L2} : @ \forall double t1[], double t2[], integer n; @ permut{L1,L2}(t1,t2,n) ==> permut{L2,L1}(t2,t1,n) ; @ axiom permut_trans{L1,L2,L3} : @ \forall double t1[], double t2[], double t3[], integer n; @ permut{L1,L2}(t1,t2,n) && permut{L2,L3}(t2,t3,n) @ ==> permut{L1,L3}(t1,t3,n) ; @ axiom permut_exchange{L1,L2} : @ \forall double t1[], double t2[], integer i, integer j, integer n; @ \at(t1[i],L1) == \at(t2[j],L2) && @ \at(t1[j],L1) == \at(t2[i],L2) && @ (\forall integer k; 0 <= k < n && k != i && k != j ==> @ \at(t1[k],L1) == \at(t2[k],L2)) @ ==> permut{L1,L2}(t1,t2,n); @ } @*/ ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts0655.ml�����������������������������������������������������0000644�0001750�0001750�00000000761�12155630271�017541� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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" Printer.pp_term t Printer.pp_logic_type t.Cil_types.term_type; Cil.DoChildren end let run () = let f = Ast.get () in Visitor.visitFramacFileSameGlobals (new check_float) f let () = Db.Main.extend run ���������������frama-c-Fluorine-20130601/tests/spec/pragma.i�������������������������������������������������������0000644�0001750�0001750�00000000425�12155630271�017515� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#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 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/array_conversion.c���������������������������������������������0000644�0001750�0001750�00000001564�12155630271�021630� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef int foo[4]; foo X = {0,1,2,3}; /*@ predicate p1(int* a) = \valid_range(a,0,3); */ /*@ predicate q1(int* a) = \valid(a + (0..3)); */ // [VP] Incompatible with the idea that foo denotes a logic array which can // not be seen as a pointer. /* @ lemma tauto: \forall foo a; p1(a) <==> q1(a); */ // There's a slight difference between the two following lemmas: the first // one speaks of the address of X, while the second speaks of the address of the // first element of X (the type is different in particular) /*@ lemma vaddrof: \valid(&X); */ /*@ lemma vaddrof2: \valid(&X[0]); */ /*@ lemma tauto1{L}: q1(X); */ /*@ requires p1(x); */ 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; ��������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/multiple_file_2.c����������������������������������������������0000644�0001750�0001750�00000000171�12155630271�021311� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: linked with multiple_file_1.c which is the real test. */ /*@ requires y <= 0; */ int g(int y); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/first.c��������������������������������������������������������0000644�0001750�0001750�00000000324�12155630271�017365� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/acsl_by_example.c����������������������������������������������0000644�0001750�0001750�00000024522�12155630271�021373� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ 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 < i ==> a[k] == b[k]; loop variant n-i; */ for (int i = 0; i < n; i++) if (a[i] != b[i]) return 0; return 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 < i ==> a[k] != val; loop variant n-i; */ for (int i = 0; i < n; i++) if (a[i] == val) return i; return n; } /*@ 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; } /*@ 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; } /*@ 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 < i ==> 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)]; } /*@ 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; } /*@ 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; } /*@ 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 < i ==> a[k] == \at(b[k],Pre); loop invariant \forall int k; 0 <= k < i ==> b[k] == \at(a[k],Pre); loop variant n-i; */ for (int i = 0; i < n; i++) swap(&a[i], &b[i]); } /*@ 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 < i ==> a[k] == val; loop variant n-i; */ for (int i = 0; i < n; i++) a[i] = val; } /*@ 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 < i ==> a[k] == b[k]; loop variant n-i; */ for (int i = 0; i < n; ++i) b[i] = a[i]; } /*@ 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 < i ==> 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; } /*@ 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; } /*@ 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 < i ==> a[k] == val+k; loop variant n-i; */ for(int i = 0; i < n; ++i) a[i] = val + i; } /*@ 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 invariant 0 <= i < n; loop invariant !adjacent_found(a, i); loop invariant 0 < i ==> 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; } /*@ 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 < i ==> 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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/annot_decl_bts1009.i�������������������������������������������0000644�0001750�0001750�00000000153�12155630271�021534� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void f() { //@ assert 0==0; int x; //@ ensures x==3; int y = x = 3; x = 0; y = 1; return; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/conf1.h��������������������������������������������������������0000644�0001750�0001750�00000001322�12155630271�017250� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#ifndef _INCLUDE_conf1 #define _INCLUDE_conf1 /* spcification de l'oprateur CONF1 _E1 : BOOLEAN _S1 : BOOLEAN Calcul : _S1 = TRUE si la dure de l'tat TRUE sur _E1 est >= Time et tant que _E1 = TRUE _S1 = FALSE si la dure de l'tat TRUE sur _E1 est < Time ou si _E1 = FALSE Initialisation : _S1 = FALSE */ #define CONF1(NNN, _E1, _Time, _S1) {\ static INTEGER CONF1_Timeout;\ INTEGER Horl_BR;\ Horl_BR = M_Horloge_BR;\ if (_E1)\ {\ if ((CONF1_Timeout)==0)\ {\ (CONF1_Timeout)=(Horl_BR)+(_Time);\ }\ (_S1)=(BOOLEAN)((Horl_BR)>=(CONF1_Timeout));\ }\ else\ {\ (CONF1_Timeout)=0;\ (_S1)=FALSE;\ }\ } #endif ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts0655.i������������������������������������������������������0000644�0001750�0001750�00000000546�12155630271�017362� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config 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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/model1.c�������������������������������������������������������0000644�0001750�0001750�00000000400�12155630271�017412� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/spec/model2.c" */ #include "tests/spec/model1.h" void main () { struct S s; reset(&s); inc(&s); /*@ assert s.foo > 0; */ /*@ loop variant s.foo; */ while (is_pos(&s)) dec(&s); /*@ assert s.foo <= 0; */ } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/merge_assigns_bts1253.i����������������������������������������0000644�0001750�0001750�00000000374�12155630271�022262� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ assigns \result \from nptr[..] ; */ double atof(const char *nptr); /*@ assigns \result \from *(nptr+(..)); */ double atof(const char *nptr); /*@ assigns nptr[..] ; */ void f(char *nptr); /*@ assigns *(nptr+(..)); */ void f(const char *nptr); ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/assume.c�������������������������������������������������������0000644�0001750�0001750�00000000450�12155630271�017533� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������//@ behavior b1: assumes x>=0; behavior b2: assumes x<=0; void f(int x); //@ disjoint behaviors b1, b2; void f(int x) { int * p,*q; //@ for b1,b2: behavior default: assumes \valid(p); // je ne veux pas vrifier cette assert q = p ; //@ assert \valid(q); // je veux vrifier cette assert } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/behavior_names.c�����������������������������������������������0000644�0001750�0001750�00000002503�12155630271�021221� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ behavior foo: ensures \true; behavior bar: complete behaviors foo, bar, UNEXISTENT_BEHAVIOR; */ void f() { } /*@ predicate should_be_rejected = \true; */ /*@ predicate should_be_kept = \true; */ /*@ behavior foo: ensures \true; behavior bar: disjoint behaviors foo, bar, UNEXISTENT_BEHAVIOR; */ void g() { /*@ behavior foo: ensures \true; */ { /*@ for foo: assert should_be_kept; */ f(); /*@ for foo: assert should_be_kept; */ f(); } /*@ for foo: assert should_be_rejected; */ return; } /*@ behavior foo: ensures \true; behavior foo: ensures should_be_rejected; */ void h () { } /*@ behavior foo: ensures \true; */ void i () { //@ behavior foo: ensures should_be_rejected; ; } void j () { int x = 0; //@ behavior foo: ensures \true; { x++; //@ behavior foo: ensures should_be_rejected; if (x) { //@ behavior bar: ensures \true; x++; } else { //@ behavior bar: ensures should_be_kept; x++; } } } /*@ behavior boolean: ensures boolean:\true; behavior char: ensures char:\true; behavior for: ensures for:\true; behavior while: ensures while:\true; behavior ensures: ensures ensures: \true; behavior logic: ensures logic: \true; */ void keyword_as_behavior_and_term_names () { ; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/multiple_file_1.c����������������������������������������������0000644�0001750�0001750�00000000341�12155630271�021307� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -print tests/spec/multiple_file_2.c -journal-disable */ /* see bug #43 */ /*@ requires x >= 0; */ extern int f(int x); /*@ requires x >= 0; */ extern int g(int x); int main () { g(0); return f(0); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts0812.c������������������������������������������������������0000644�0001750�0001750�00000000201�12155630271�017333� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ lemma fib_3: \true; // proved automatically */ /*@ lemma fib_46: \true; */ /*@ assigns \nothing; // Bla */ void main() { } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/error_msg.i����������������������������������������������������0000644�0001750�0001750�00000000354�12155630271�020246� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������// All annotations below present an error that should be expressed by a // friendlier msg than the usual unexpected 'bla' token /*@ requires x >= 0 ensures \result == 0; */ int f(int x); /*@ ensures \result >= 0 */ int g(int x); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/assigns_void.c�������������������������������������������������0000644�0001750�0001750�00000000312�12155630271�020723� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -print -journal-disable -continue-annot-error OPT: -val -main g -print -no-annot -journal-disable */ //@ assigns *x; void f(void *x); void g() { int y; int* x = &y; f(x); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/sizeof.c�������������������������������������������������������0000644�0001750�0001750�00000000142�12155630271�017533� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ requires i > sizeof(int); @ ensures \result > sizeof(i); @*/ int f(int i) { return i; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/multiple_decl_def_1.c������������������������������������������0000644�0001750�0001750�00000000355�12155630271�022122� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -print tests/spec/multiple_decl_def_2.c -journal-disable */ /* see bug #43 && #128 */ /*@ requires x >= 0; */ extern int f(int x); /*@ requires x >= 0; */ extern int g(int x); int main () { g(0); return f(0); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/comparison.ml��������������������������������������������������0000644�0001750�0001750�00000001770�12155630271�020604� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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" Printer.pp_term t1 Printer.pp_logic_type t1.term_type Printer.pp_term t2 Printer.pp_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" Printer.pp_term t1 Printer.pp_logic_type t1.term_type Printer.pp_term t2 Printer.pp_logic_type t2.term_type; DoChildren | _ -> DoChildren end in Visitor.visitFramacFileSameGlobals vis (Ast.get()) ;; let () = Db.Main.extend run ��������frama-c-Fluorine-20130601/tests/spec/logic_label.c��������������������������������������������������0000644�0001750�0001750�00000001542�12155630271�020475� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void f () { int x = 0; L: x++; /*@ ensures \at(\true,Pre); */ x++; /*@ assert \at(x,L) == 0; */ /*@ assert \at(x==0,L); */ } int g(int i) { lab: //@ assert i == \at(i,lab); return i; } //@ predicate modified{L1,L2}(int x) = \at(x,L1)!=\at(x,L2); //@ logic integer diff{L1,L2}(integer x) = \at(x,L1) - \at(x,L2); int h() { int x = 0; l: x++; //@ assert modified{Here,l}(x) && diff{Here,l}(x) == 1; return 0; } //@ logic integer foo{L}(integer x) = x+1; //@ assigns x[0..foo(0)]; int u(int *x) { *(x++)=0; *x = 1; /*@ assert \at(\true,Pre); */ return *x; } int X; void labels_in_stmt_annot (void) { X ++; /*@ requires X > \at(X, Pre); ensures X == \old(X) + 1; ensures X == \at(X,Pre) + 2; ensures X == \at(X,Post); */ X++; //@ ensures X == \at(X,Here); X++; //@ assert X == \at(X,Pre) + 3; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/sizeof_logic.i�������������������������������������������������0000644�0001750�0001750�00000000263�12155630271�020722� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ lemma bad: \forall integer x; sizeof(x) == sizeof(int); */ /*@ lemma bad2: sizeof(integer) == sizeof(int); */ /*@ lemma good: \forall short x; sizeof(x) <= sizeof(int); */ ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/setjmp.c�������������������������������������������������������0000644�0001750�0001750�00000002116�12155630271�017541� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: syntactically incorrect include + no spec here... */ #ifndef PTEST #include <stdio.h> #else extern int printf (__const char *__restrict __format, ...); #endif #ifndef PTEST #include <setjmp.h> #else typedef int __jmp_buf[6]; typedef struct { unsigned long int __val[(1024 / (8 * sizeof (unsigned long int)))]; } __sigset_t; typedef struct __jmp_buf_tag { __jmp_buf __jmpbuf; int __mask_was_saved; __sigset_t __saved_mask; } jmp_buf[1]; extern int _setjmp (struct __jmp_buf_tag __env[1]) __attribute__ ((__nothrow__)); extern void longjmp (struct __jmp_buf_tag __env[1], int __val) __attribute__ ((__nothrow__)) __attribute__ ((__noreturn__)); #define setjmp(env) _setjmp(env) #endif jmp_buf buf; int previous_setjmp = 0 ; void f(void) { longjmp(buf, 1); } int main(void) { previous_setjmp = -1 ; int setjmp_result = setjmp(buf); if (setjmp_result != 0) { printf("longjmp: setjmp_result=%d previous_setjmp=%d\n", setjmp_result, previous_setjmp); return 0; } previous_setjmp = setjmp_result ; f(); return 1; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/all.c����������������������������������������������������������0000644�0001750�0001750�00000006440�12155630271�017013� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* Terms */ /*@ lemma z: \forall int x ; (x & x) == x ; */ // OK /*@ lemma a: \forall int x ; (x --> x) == -1 ; */ // OK /*@ lemma b: \forall int x ; (x <--> x) == -1 ; */ // OK /*@ lemma c: (\let x = 0 ; x+1) == 1 ; */ // OK /*@ lemma d: (name:77) == 76+1 ; */ // OK /* Predicates */ /*@ axiomatic Test { predicate P ; // OK predicate Q ; // OK axiom e: P ^^ Q ; // OK axiom f: 0?P:Q; // OK axiom g: P?P:Q; // OK axiom h: \let x = 0 ; x+1 == 1 ; // OK axiom i: name:77 == 76+1 ; // OK } */ /*@ predicate R(integer i, integer j) = (1?i+j:j:j)==i+j;*/ // OK /*@ predicate S(integer i, integer j) = (1?(i:j):j)==j; */ // OK /*@ predicate T(integer i, integer j) = (1?i:j)==i; */ // OK /*@ lemma tauto: 0?T(0,0):R(1,2); */ // OK /*@ lemma tauto2: R(0,1)?S(3,4):T(5,6); */ // OK /*@ lemma reject_1 : 0 != 1 != 2 ; */ // OK /*@ lemma hex_oct : 0xFFFFUl != 06666uL ; */ // OK /*@ requires \offset(p) == 0; // OK behavior b : assumes \true; requires \valid(p); ensures 0 == 1 ; assigns *p \from G ; */ // OK void h(int G,int*p) ; /*@ behavior b : assumes \true; requires \valid(p); ensures 0 == 1 ; assigns *p \from G = G + 77; */ // KO (functional update void f(int G,int*p) { //@ for ZZZ_INEXISTENT_BEHAVIOR : assert \false ; // OK //@ assert \false ; // OK /*@ assert \base_addr(&G) == \base_addr(&G) ; */ // OK /*@ assert \block_length(&G) == 4 ; */ // OK /*@ assert \block_length(&G) == sizeof(G) ; */ // OK /*@ assert \base_addr(&G)+\offset(&G+4) == (char*)(&G+4); */ // OK /*@ assert \null != &G ; */ // OK /*@ loop invariant &G != \null; */ // OK do G++; while (0) ; *p = G + 76; } struct st { int a, b ; } ; /*@ axiomatic St { logic struct st fl(struct st s) ; } */ //OK /*@ ensures fl(s).a == \result.a ; */ // OK struct st fc (struct st s) {return s;} void fd(char *x) { /*@ assert (const char*)x == (char * const) x; */ x="abcdef"; //@ assert !\valid(x) && \valid_read(x); // OK return; } /*@ logic integer x = 1 ; */ // OK /*@ axiomatic Test2 {logic integer y ;} */ // OK /*@ logic integer z = \let f = \lambda integer a ; a + 1; f(12) ; */ // OK /*@ logic a id<a>(a x) = x; */ // OK /*@ logic integer z1 = \max(5,10,id) ; */ // OK /*@ logic integer z2 = \min(5,10,id) ; */ // OK /*@ logic integer z3 = \sum(5,10,id) ; */ // OK /*@ logic integer z4 = \product(5,10,id) ; */ // OK /*@ logic integer z5 = \numof(0,10,\lambda integer i; 3<=i<=5) ; */ // OK /* ALL CONCRETE LOGIC TYPES */ ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/typedef.c������������������������������������������������������0000644�0001750�0001750�00000000216�12155630271�017676� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef struct _list { int i; } *list; /*@ requires \valid(p); */ void f(list p) {} /*@ requires \valid(p); */ void g(struct _list* p) {} ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts0578.i������������������������������������������������������0000644�0001750�0001750�00000000375�12155630271�017366� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/const.c��������������������������������������������������������0000644�0001750�0001750�00000000213�12155630271�017361� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������//@ logic integer strlen(char* c); //@ requires strlen(c) < n; ensures strlen(a) <=n; void f(const char* c, char* restrict a, int n) { } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/null_ptr.c�����������������������������������������������������0000644�0001750�0001750�00000000624�12155630271�020100� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������//@ predicate null(char *x) = x == 0; //@ predicate eq(char *x, char *y) = x == y; //@predicate my_null(char *x) = x == (void*)0; void f(char *x) { x = 0; //@ assert x == (void*)0; //@ assert my_null(x); //@ assert null(x); //@ assert eq(x,0); } //@ ensures \result == \true; int g() { return 1; } /*@ predicate foo (integer x) = x != 0; */ /*@ ensures foo(\true); */ int h() { return 1; } ������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/loop_labels_unroll.i�������������������������������������������0000644�0001750�0001750�00000000604�12155630271�022133� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int main () { int x = 0; /*@ loop pragma UNROLL 4; loop invariant \at(x,LoopEntry) == 0; loop invariant \at(x,LoopCurrent) <= 15; */ while (x<15) { x++; /*@ assert x == \at(x,LoopCurrent) + 1; */ int i = 0; /*@ loop invariant \at(i,LoopEntry) == 0; */ while (i<4) { i++; /*@ assert \at(i,LoopCurrent) == i-1; */ } /*@ assert i > 0; */ } } ����������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/prec_i.h�������������������������������������������������������0000644�0001750�0001750�00000000521�12155630271�017503� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* This code is AIRBUS property */ #ifndef _INCLUDE_prec_i #define _INCLUDE_prec_i /* spcification de l'oprateur PREC_I _E1 : INTEGER _S1 : INTEGER Calcul : _S1[k] = _E1[k-1] Initialisation : _E1[k-1] = FALSE */ #define PREC_I(NNN, _E1, _S1) {\ static INTEGER PREC_I_RE1;\ (_S1)=PREC_I_RE1;\ PREC_I_RE1=(_E1);\ } #endif �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/enum.c���������������������������������������������������������0000644�0001750�0001750�00000000461�12155630271�017204� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef enum{ VRAI=1, FALSE=0 }T_BOOLEEN; /*@logic T_BOOLEEN test (integer b)= @ @ ((b==1)? @ (T_BOOLEEN)VRAI @ : (T_BOOLEEN)FALSE); @*/ /*@ensures \result == test(boo); @*/ T_BOOLEEN test(int boo) { T_BOOLEEN b; if (boo==1) b = VRAI; else b= FALSE; return b; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/for_scope.c����������������������������������������������������0000644�0001750�0001750�00000000113�12155630271�020211� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void f() { //@ loop invariant i >= 0; for (int i = 0; i < 10; ++i) ; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts0698.i������������������������������������������������������0000644�0001750�0001750�00000001251�12155630271�017363� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* -------------------------------------------------------------------------- */ /* --- 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) ; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/third.c��������������������������������������������������������0000644�0001750�0001750�00000000305�12155630271�017347� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/string.c�������������������������������������������������������0000644�0001750�0001750�00000000312�12155630271�017541� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ logic char* foo = "\123tyfoo"; logic unsigned long* bar = (unsigned long*) L"\xabcdt\65ab"; logic char* split = "abc" "def"; */ unsigned long* test = (unsigned long*) L"\xabcdt\65ab"; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/parsing.c������������������������������������������������������0000644�0001750�0001750�00000001020�12155630271�017673� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* cf bug 298 */ /*@ lemma bidon{Here} : @ \forall int *t; ! (t[0] > 0); @*/ /*@ lemma bidon1{Here} : @ \forall int *t; ! t[0] == 0; @*/ /*@ lemma bidon2{Here} : @ \forall int *t; (! t[0]) == 0; @*/ /*@ lemma bidon3{Here} : @ \forall int *t; ! t[0] >= 0; @*/ /*@ lemma bidon4{Here}: @ \forall int *t; (! t[0]) < 0; @*/ /*@ predicate foo{L}(int* a,int* b, int length) = ! \forall integer k; 0 <= k < length ==> a[k] == b[k]; */ /* Cf bug 1358 */ struct foo { /*@ private bla */ int x; }; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts0589.i������������������������������������������������������0000644�0001750�0001750�00000000114�12155630271�017357� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int x; int g(void) { int a; //@ assigns a,x ; a = x++ ; return a; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/property_test.i������������������������������������������������0000644�0001750�0001750�00000000307�12155630271�021170� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/localization.c�������������������������������������������������0000644�0001750�0001750�00000001031�12155630271�020722� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* This file contains various annotations errors to test the localization of error messages. */ /*@ logic integer f(integer i) = 1; @ logic integer g(integer i) = j; @ logic integer h(integer i) = k; @ logic integer i(integer i) = l; @*/ void ComposerPage(void) { int x = 0; x++; /*@ assert bar; */ //@ assert foo; return ; } void f() { //@ ghost int index = 0; // comment int x = 0; //@ assert wrong; return; } void g() { } typedef struct _S S; /*@ axiomatic S { logic S S00; logic S1 S0; } */ �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/model.ml�������������������������������������������������������0000644�0001750�0001750�00000002372�12155630271�017531� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types let find () = let module M = struct exception Found of typeinfo end in try List.iter (function | GType (ty,_) -> if ty.tname = "T" then raise (M.Found ty) | _ -> ()) (Ast.get ()).globals; Kernel.fatal "No typedef for T: test is broken" with M.Found ty -> ty let print_models typ = let models = Annotations.model_fields typ in Format.printf "Model fields for type %a:@\n" Printer.pp_typ typ; List.iter (fun m -> Format.printf "%s, " m.mi_name) models; Format.printf "@\n" let e = Emitter.create "test" [Emitter.Global_annot] ~correctness:[] ~tuning:[] let add_model ty = let m = { mi_name = "test_field"; mi_field_type = Linteger; mi_base_type = ty; mi_decl = Cil_datatype.Location.unknown } in let annot = Dmodel_annot (m,Cil_datatype.Location.unknown) in Annotations.add_global e annot; annot let remove_model annot = Annotations.remove_global e annot let main () = let t = find () in let typ = TNamed(t,[]) in print_models typ; let m = add_model typ in Format.printf "After adding field@."; print_models typ; remove_model m; Format.printf "After removing field@."; print_models typ; Format.print_flush () let () = Db.Main.extend main ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/merge_1.i������������������������������������������������������0000644�0001750�0001750�00000000334�12155630271�017564� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/source_annot.c�������������������������������������������������0000644�0001750�0001750�00000003253�12155630271�020741� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: static local variables & specifications */ typedef int INTEGER; typedef enum {TRUE=1, FALSE=0} BOOLEAN; #include "prec_i.h" extern INTEGER E1[], S1[]; /* @ // proposition avec requires dans les behaviors requires k >= 0; ensures PREC_I_RE1==E1[k]; behavior COND_prec_C0 : assumes k==0 ; requires PREC_I_RE1 == 0; ensures S1[0] == 0; behavior COND_prec_CN : assumes k >= 1; requires PREC_I_RE1 == E1[k-1]; ensures S1[k]==E1[k-1]; */ /* @ // qui se desucre en: requires k >= 0 && (k==0 ==> PREC_I_RE1 == 0) && (k >= 1 ==> PREC_I_RE1 == E1[k-1]); ensures PREC_I_RE1==E1[k]; behavior COND_prec_C0 : assumes k==0 ; ensures S1[0] == 0; behavior COND_prec_CN : assumes k >= 1; ensures S1[k]==E1[k-1]; */ /*@ // proposition actuelle requires k >= 0; behavior default : ensures PREC_I_RE1==E1[k]; behavior COND_prec_C0 : assumes k==0 && PREC_I_RE1 == 0; ensures S1[0] == 0; behavior COND_prec_CN : assumes k >= 1 && PREC_I_RE1 == E1[k-1]; ensures S1[k]==E1[k-1]; */ void prec(INTEGER k) { PREC_I(0, E1[k], S1[k]); } /*@ requires HYPOTHESE_RAM_0_iter_prec : PREC_I_RE1 == 0 ; */ void iter_prec() { INTEGER k=0; /*@ loop invariant I1_1 : k>=0; loop invariant I1_2 : k==0 ==> PREC_I_RE1==0; loop invariant I1_3 : k>=1 ==> PREC_I_RE1==E1[k-1]; */ while (1) { prec(k); k++; } } #include "conf1.h" extern volatile INTEGER M_Horloge_BR; extern BOOLEAN EB[]; extern BOOLEAN S[]; INTEGER Time_CONF1; void conf1(INTEGER k) { CONF1(0, EB[k], Time_CONF1, S[k]); } void iter_conf1() { INTEGER N=0; while (1) { conf1(N); N++; } } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts0578.ml�����������������������������������������������������0000644�0001750�0001750�00000000574�12155630271�017547� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types open Logic_const let main () = let s, kf = Kernel_function.find_from_sid 2 in let add a = Annotations.add_code_annot Emitter.end_user ~kf s (new_code_annotation a) in add (AInvariant(["foo"], true, ptrue)); add (AVariant(tinteger 0, None)); add (AInvariant([], true, ptrue)); add (AInvariant(["foo"], true, ptrue)) let () = Db.Main.extend main ������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/range.c��������������������������������������������������������0000644�0001750�0001750�00000000334�12155630271�017333� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������struct foo { char bar[4]; }; /*@ assigns x->bar[0..3] \from x->bar[0..3]; */ int f(struct foo* x); typedef char baz[4]; struct bli { baz bli; }; /*@ assigns x[0..3] \from y->bli[0..3]; */ int g(baz x,struct bli* y); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/Type_of_term.ml������������������������������������������������0000644�0001750�0001750�00000002036�12155630271�021062� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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" Printer.pp_term t Printer.pp_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" Printer.pp_term_lval plain_lval Printer.pp_logic_type tyh; result "Offset: %a, type is %a" Printer.pp_term_offset off Printer.pp_logic_type tyoff; result "Lval: %a, type is %a" Printer.pp_term_lval lv Printer.pp_logic_type ty; Cil.DoChildren end let run () = let ast = Ast.get () in Visitor.visitFramacFileSameGlobals (new visitor) ast ;; Db.Main.extend run ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/regions.c������������������������������������������������������0000644�0001750�0001750�00000001524�12155630271�017707� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ /*@ requires \valid(p); @ ensures *p == n; @*/ void g(int *p, int n) { *p = n; } /*@ requires \valid(x) && \valid(y); @ ensures *x == 1 && *y==2; @*/ void f(int *x, int *y) { g(x,1); g(y,2); } struct S { int t1[2]; int t2[2]; }; //@ ensures s.t1[0]==1 && s.t2[0]==2 && s.t1[1]==2 && s.t2[1]==1; void main(struct S s) { f(&s.t1[0],&s.t2[1]); f(&s.t2[0],&s.t1[1]); f(&s.t1[0],&s.t1[0]); } /* on veut : zones globales : Zone 0: {s.t1[0]; }; Zone 1: {s.t1[1]; }; Zone 2: {s.t2[0]; }; Zone 3: {s.t2[1]; }; zones locales : f: Zone 4: { *x; } Zone 5: { *y; } g: Zone 6; { *p; } Appels: g(..) ligne 13: zone 6 -> zone 4 g(..) ligne 14: zone 6 -> zone 5 f(..) ligne 24: zone 4 -> zone 0, zone 5 -> zone 2 f(..) ligne 25: zone 4 -> zone 3, zone 5 -> zone 1 f(..) ligne 26: zone 4 -> zone 0, zone 5 -> zone 0 */ ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/nested.c�������������������������������������������������������0000644�0001750�0001750�00000000103�12155630271�017513� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* void f() { int i = 0; //@ assert i == 0; } */ void g() { } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/if.c�����������������������������������������������������������0000644�0001750�0001750�00000000260�12155630271�016633� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ int a,b; /*@ requires MyPre : (a<b)?\true:\false; */ void main(){ return ;} //@ predicate P(char *s); void g(char*s); void f() { int x = 0; //@ assert P(x); g(x); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/old_prm.i������������������������������������������������������0000644�0001750�0001750�00000000221�12155630271�017674� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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]; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/terminates.c���������������������������������������������������0000644�0001750�0001750�00000000116�12155630271�020410� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ terminates c>0; assigns \nothing; */ void f (int c) { while(!c); return;} ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bsearch.c������������������������������������������������������0000644�0001750�0001750�00000002207�12155630271�017647� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ lemma mean_1 : \forall integer x, y; x <= y ==> x <= (x+y)/2 <= y; */ /*@ predicate sorted{L}(int t[],integer n) = @ \forall integer i, j; @ 0 <= i <= j <= n ==> t[i] <= t[j] ; @*/ /* bsearch(t,n,v) search for element v in array t between index 0 and n-1 array t is assumed sorted in increasing order returns an index i between 0 and n-1 where t[i] equals v, or -1 if no element of t is equal to v */ /*@ requires @ n >= 0 && \valid_range(t,0,n-1) && sorted((int[])t,n-1); @ behavior search_success: @ ensures \result >= 0 ==> t[\result] == v; @ behavior search_failure: @ ensures \result < 0 ==> @ \forall integer k; 0 <= k < n ==> t[k] != v; @*/ int bsearch(int* t, int n, int v) { int l = 0, u = n-1; /*@ loop invariant @ 0 <= l && u <= n-1 && @ \forall int k; 0 <= k && k < n ==> t[k] == v ==> l <= k && k <= u; @ loop variant u-l; @*/ while (l <= u ) { int m = (l + u) / 2; if (t[m] < v) l = m + 1; else if (t[m] > v) u = m - 1; else return m; } return -1; } /* Local Variables: compile-command: "../../bin/toplevel.opt -jessie bsearch.c" End: */ �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/axiom_included.c�����������������������������������������������0000644�0001750�0001750�00000000145�12155630271�021223� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/spec/axiom_included_1.c" */ #include "tests/spec/axiom_included.h" ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/merge_bts938.h�������������������������������������������������0000644�0001750�0001750�00000000122�12155630271�020452� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������extern int tab[10]; //@ ensures tab == {tab \with [0]= (int)0} ; int main(void) ; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/merge_bts938_1.c�����������������������������������������������0000644�0001750�0001750�00000000137�12155630271�020673� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is merge_bts938.c */ #include "tests/spec/merge_bts938.h" ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bool.c���������������������������������������������������������0000644�0001750�0001750�00000000230�12155630271�017165� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������//@ logic boolean f(int x) = x == 0 ; //@ predicate f_pred(int x,int y) = f(x) && f(y) ; //@ predicate foo(boolean x, boolean y) = x == \false || y ; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/multi_labels.i�������������������������������������������������0000644�0001750�0001750�00000000137�12155630271�020722� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int labels (void) { int x = 0 ; L1: L2: //@ assert \at(x,L1) == \at(x,L2) ; return x ; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/unused.c�������������������������������������������������������0000644�0001750�0001750�00000000303�12155630271�017536� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef struct { int i; } T; /*@ lemma toto{L}: @ \forall T t; t.i == 0; @*/ extern int G; /*@ global invariant G_const: G == 0; */ static int i; /*@ global invariant invi: i >= 0; */ �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/footprint.c����������������������������������������������������0000644�0001750�0001750�00000000407�12155630271�020264� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������struct S { char *x; int *y; }; /*@ logic set<char*> footprint(struct S s) = \union(s.x, (char*)s.y + (0 .. sizeof(int) - 1)) ; */ /*@ requires \valid(\union(s,footprint(*s))); assigns footprint(*s); */ int f(struct S* s) { return *s->x + *s->y; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/second.c�������������������������������������������������������0000644�0001750�0001750�00000000311�12155630271�017505� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/use2.c���������������������������������������������������������0000644�0001750�0001750�00000000206�12155630271�017113� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is in use.c */ #include "tests/spec/dec.h" //@ ensures X > 0 ; ensures F(1)>0 ; void g(void) {} ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/max.c����������������������������������������������������������0000644�0001750�0001750�00000002376�12155630271�017034� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* various specification of max function */ /*@ axiomatic IsMax { @ predicate is_max{L}(integer max, int t[], integer length); @ // reads t[..]; @ axiom max_gt{L}: @ \forall int t[], integer max, length, i; @ is_max(max,t,length) ==> 0 <= i < length ==> t[i] <= max; @ axiom max_eq{L}: @ \forall int t[], integer max, length; @ is_max(max, t, length) ==> \exists integer i; t[i] == max; @ } @*/ /*@ requires \valid_range(t,0,n-1); @ behavior nonempty: @ assumes n > 0; @ ensures 0<= \result < n && @ (\forall int i; 0 <= i < n ==> t[\result] >= t[i]) && @ is_max(t[\result],(int[])t,n); @ behavior empty: @ assumes n <= 0; @ ensures \result == -1; @*/ int max(int t[], int n) { int imax = 0, i; /*@ ghost int max; */ if (n<=0) return -1; /*@ ghost max = t[0]; */ /*@ loop invariant (\forall int j; 0<= j < i ==> t[imax] >= t[j]) && is_max(max,(int[])t,i-1); */ for(i = 1; i < n; i++) { if (t[i] > t[imax]) { imax = i; /*@ ghost max = t[i]; */ } } return imax; } int main() { int test [] = { 1, 2, 3, 4, 9, 8, 7, 6, 5, 10}; /*@ assert \valid_range(test,0,9); */ int x = max(test,10); /*@ assert test[x] >= 10; */ return 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/multi_behavior.c�����������������������������������������������0000644�0001750�0001750�00000000275�12155630271�021254� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int a,b; /*@ behavior b: ensures a!=0; ensures a==0; assigns a; behavior c: ensures a==0; ensures a==0; assigns a; behavior d: assumes a==0; */ void f(void) { a=0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/boolean_ops.c��������������������������������������������������0000644�0001750�0001750�00000000244�12155630271�020537� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ ensures (x==0||y==1)?\result==0:\result == 1; */ int f(int x, int y) { return (x==0||y==1); } int main() { int x = f(42,1); int y = f(0,36); return 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/preprocess.c���������������������������������������������������0000644�0001750�0001750�00000000602�12155630271�020422� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -pp-annot -val -journal-disable */ // see bts 1357 #define assert(x) (x)?1:0 int x = 1; #define FOO 1 #undef FOO #define FOO 2 #include "preprocess.h" int y = 1; /*@ requires x >= MIN_X; behavior default: ensures test(\result) && FOO == FOO; */ int f(int x) { return (x + MIN_X); } int main() { int y = f(MIN_X); //@ assert (x) == 1; return 0; } ������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/spec_zero_arg.c������������������������������������������������0000644�0001750�0001750�00000000364�12155630271�021064� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* see bug #128 */ int e; /*@ requires e > 0; */ void f(void); // this spec is already lost after type-checking /*@ requires e > 0; */ void g(); int x; /*@ requires a > 0; */ void i(int a); void i(int b) { x = b; } void h() { f(); g();} ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/volatile.c�����������������������������������������������������0000644�0001750�0001750�00000000513�12155630271�020055� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/logic_type.c���������������������������������������������������0000644�0001750�0001750�00000000152�12155630271�020373� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ type t; */ /*@ logic t create(int x); */ /*@ logic t1 create(int y); // error: type does not exist */ ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/logic_compare.c������������������������������������������������0000644�0001750�0001750�00000000260�12155630271�021040� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ axiomatic Foo { @ type foo; @ predicate test(foo x); @ axiom foo_eq_refl: \forall foo x; x == x; @ axiom foo_test: \forall foo x; test(x); @ } @*/ ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/lib.c����������������������������������������������������������0000644�0001750�0001750�00000000302�12155630271�017000� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -pp-annot -cpp-command="gcc -C -E -I tests/spec" -cpp-extra-args="-include lib.h" -print -journal-disable */ /*@ ensures f((int)0) == (int)0; */ int main () { return 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/purse.c��������������������������������������������������������0000644�0001750�0001750�00000006310�12155630271�017375� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/**************************************************************************/ /* */ /* The Why/Caduceus/Krakatoa tool suite for program certification */ /* Copyright (C) 2002-2006 */ /* Jean-Franois COUCHOT */ /* Mehdi DOGGUY */ /* Jean-Christophe FILLITRE */ /* Thierry HUBERT */ /* Claude MARCH */ /* Yannick MOY */ /* */ /* 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). */ /* */ /**************************************************************************/ #define FRAMA_C_MALLOC_INDIVIDUAL #include "share/libc/stdlib.c" typedef struct purse { int balance; } purse; //@ predicate purse_inv{L}(purse *p) = \valid(p) && p->balance >= 0 ; /*@ requires purse_inv(p) && s >= 0; @ assigns p->balance; @ ensures purse_inv(p) && p->balance == \old(p->balance) + s ; @*/ void credit(purse *p,int s) { p->balance = p->balance + s; } /*@ requires purse_inv(p) && s >= 0 ; @ assigns p->balance; @ ensures purse_inv(p) && p->balance == \old(p->balance) + s ; @*/ void f(purse *p,int s) { p->balance = p->balance + s; } /*@ requires purse_inv(p) && 0 <= s <= p->balance; @ assigns p->balance; @ ensures purse_inv(p) && p->balance == \old(p->balance) - s; @*/ void withdraw(purse *p,int s) { p->balance = p->balance - s; } /*@ requires purse_inv(p1) && purse_inv(p2) ; @ assigns p1->balance, p2->balance; @ ensures \result == 0; @*/ int test1(purse *p1, purse *p2) { p1->balance = 0; credit(p2,100); return p1->balance; } /*@ assigns \empty; @ ensures \fresh(\result,sizeof(purse)) && purse_inv(\result) && \result->balance == 0; @*/ purse *new_purse() { purse* p = (purse*) malloc(1 * sizeof(purse)); p->balance = 0; return p; } /*@ ensures \result == 150; @*/ int test2() { purse *p1 = new_purse(); purse *p2 = new_purse(); credit(p1,100); credit(p2,200); withdraw(p1,50); withdraw(p2,100); return p1->balance + p2->balance; } /* void main() { purse *p = new_purse(); test1(p,p); } */ ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/heterogeneous_set_bts1146.i������������������������������������0000644�0001750�0001750�00000001302�12155630271�023154� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: bugfix in progress EXECNOW: make -s tests/spec/Type_of_term.cmxs OPT: -load-module ./tests/spec/Type_of_term.cmxs -check -print */ /*@ lemma foo: \union(1) == \union(1.0); */ /*@ lemma foo2: \union(1.0) == \union(1); */ /*@ lemma foo3: \union(1.0,2) == \union(1,2.0); */ /*@ lemma foo4: 1.0 == 1; */ /*@ lemma bar: \union() != \union(1); */ /*@ lemma bla: \union(1) != \union(); */ /*@ predicate P{L1,L2}(set<char *>s) = \forall char* p; \subset(p,s) ==> \at(*p,L1) == \at(*p,L2); */ /*@ ensures P{Pre,Post}(x); */ void f(int *x, double *y); /*@ ensures P{Pre,Post}(\union(x,y)); */ void h(int *x, int *y); int x; /*@ ensures P{Pre,Post}(&x); */ void g(); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/multidim.c�����������������������������������������������������0000644�0001750�0001750�00000000540�12155630271�020062� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef int TT[3][4] ; TT ttt[5] ; int (*pt)[3][4] = ttt ; // int (*)[3][4] and TT* are identical /*@ axiomatic A { @ predicate P(TT * pt) ; @ predicate Q(int (*pt)[3][4] ) ; @ } @*/ //KO: implicit conversion from array to pointer /*@ requires P(ttt) ; */ void g(); //OK: explicit conversion. /*@ requires Q(&ttt[0]) ; @*/ void f() { } ����������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/assigns_result.i�����������������������������������������������0000644�0001750�0001750�00000000335�12155630271�021313� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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(); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts0549.i������������������������������������������������������0000644�0001750�0001750�00000001405�12155630271�017357� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 } } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/volatile_aux.c�������������������������������������������������0000644�0001750�0001750�00000000215�12155630271�020731� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test file is volatile.c */ #include "tests/spec/volatile.h" int f (int x) { x++; v = x; return v+x; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/homax.c��������������������������������������������������������0000644�0001750�0001750�00000000417�12155630271�017355� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ requires n > 0 &&\valid(p + (0..n-1)); ensures \result == \max(0,n-1,\lambda integer i; p[i]); */ int max_seq(int* p, int n); int max_seq(int* p, int n) { int res = *p; for(int i = 0; i < n; i++) { if (res < *p) { res = *p; } p++; } return res; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/array_prm.c����������������������������������������������������0000644�0001750�0001750�00000000210�12155630271�020224� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* see bug 131 */ void g(int a[]); /*@ predicate p(int *a) = \valid_index(a,0); */ /*@ requires p(a); */ void f(int a[]) { g(a); } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/assigns.c������������������������������������������������������0000644�0001750�0001750�00000001470�12155630271�017710� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������struct list { int hd; struct list *next; }; /*@ predicate reachable{L}(struct list *root, struct list *to) = @ root == to || root != \null && reachable(root->next,to) ; @*/ int * q; //@ assigns *p; assigns *p,q; void reset(int *p) { *p = 0; } // three equivalent assigns clauses //@ assigns t[0..n-1]; void reset_array1(int t[],int n) { int i; for (i=0; i < n; i++) t[i] = 0; } //@ assigns *(t+(0..n-1)); void reset_array2(int t[],int n) { int i; for (i=0; i < n; i++) t[i] = 0; } //@ assigns *(t+{ i | int i ; 0 <= i < n }); void reset_array3(int t[],int n) { int i; for (i=0; i < n; i++) t[i] = 0; } //@ assigns { q->hd | struct list *q ; reachable(p,q) }; void incr_list(struct list *p) { while (p) { p->hd++ ; p = p->next; } } /*@ predicate is_empty (set<int *> s) = s == \empty; @*/ ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/prototype_assigns.c��������������������������������������������0000644�0001750�0001750�00000000203�12155630271�022026� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ /*@ assigns *p; */ extern int f(char * p); // fonction de mise jour qui "crit" dans *p int main(char *x) { return f(x); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/behaviors_decl_def.c�������������������������������������������0000644�0001750�0001750�00000001063�12155630271�022026� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int G; /*@ behavior b2: assumes c < 1 ; */ void f (int c); /*@ behavior b1: assumes c > 0 ; complete behaviors b1, b2; */ void f (int c) { /*@ for b1: assert \true; */ } /*@ requires \true; assigns G ; ensures \result == 0 || \result == 1; @ behavior no : assumes c < 1 ; assigns \nothing ; ensures \result == 0 ; @ behavior at_least_one : assumes c > 0 ; assigns G ; ensures \result == 1 ; @ complete behaviors ; @ disjoint behaviors ; @*/ int main(int c) { f(c) ; return c> 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/exit_clause.c��������������������������������������������������0000644�0001750�0001750�00000001203�12155630271�020540� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������//@ exits never_exits: \false; int main() { return 0; } /*@ assigns \nothing ; ensures never_returns: \false; exits \exit_status==status; */ extern void exit(int status); /*@ behavior never_exits: assumes x>=0; exits \false; behavior never_returns: assumes x<0; assigns \nothing ; ensures never_returns: \false; 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); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/merge_different_assigns.i��������������������������������������0000644�0001750�0001750�00000000340�12155630271�023116� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/spec/merge_different_assigns_bis.i" */ int x, z, t, u, v, w; /*@ assigns x; assigns z \from x; assigns u; assigns t \from \nothing; assigns w; assigns x \from x; */ int f(int y); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/kw.c�����������������������������������������������������������0000644�0001750�0001750�00000000743�12155630271�016664� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef int assert; assert behavior = 0; /*@ logic assert foo(assert x) = x; */ /*@ requires behavior >= 0; assigns behavior \from behavior; ensures behavior >= 0; */ int main () { behavior++; return 0; } /*@ type List<A> = Nil | Cons(A,List<A>); */ /*@ inductive model{L}(List<integer> root, List<integer>logic_list) { case nil{L}: model(Nil,Nil); case cons{L}: \forall List<integer> l1,List<integer>ll1; model{L}(l1,ll1) ==> model(Cons(0,l1),Cons(0,ll1)); } */ �����������������������������frama-c-Fluorine-20130601/tests/spec/tsets.c��������������������������������������������������������0000644�0001750�0001750�00000001411�12155630271�017376� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������struct foo { char bar[4]; }; /*@ assigns x->bar[0..3] \from x->bar[0..3]; */ int f(struct foo* x); typedef char baz[4]; struct bli { baz bli; }; /*@ assigns x[0..3] \from y->bli[0..3]; */ int g(baz x,struct bli* y); int main() { struct foo x; baz y; struct bli z; f(&x); g(y,&z); /*@ assert \separated(&x,&y[2]); */ return 0; } /*@ predicate test1(set<int> s1,set<int> s2) = \subset(s1,\union(s2,{k + 1 | int k ; constraint: 0 <= k < 10})); @*/ /*@ predicate test2(set<int> s1,set<int> s2) = \subset(\union({k + 1 | int k ; constraint: 0 <= k < 10},s2),s1); @*/ /*@ ensures \subset(\result,\union(x,x+1,x-1)); */ int h(int x, int c) { return c>0 ? x+1 : c<0 ? x-1: x; } /*@ requires \valid((\union(a,b))[0..1]);*/ int foo(int **a, int **b) { return 0; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/comparison.i���������������������������������������������������0000644�0001750�0001750�00000000504�12155630271�020416� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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); */ } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/array_typedef.c������������������������������������������������0000644�0001750�0001750�00000001550�12155630271�021076� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*run.config OPT: -print -val -journal-disable */ #define IP_FIELD 4 typedef int ip_address[IP_FIELD]; typedef struct { ip_address src; int dst[IP_FIELD]; } msg; /*@ assigns \empty; */ void send_addr(const ip_address addr); void send_msg(const msg *msg) { send_addr(msg->src); } void host_address(ip_address ip) { unsigned int i = sizeof (int [4]) / sizeof (int); ip[0] = 192; ip[1] = 100; ip[2] = 200; ip[i - 1] = 101; // @ assert ip[(sizeof (int [4]) / sizeof (int)) - 1] == 101; } void create_msg(msg *msg) { host_address(msg->src); host_address(msg->dst); //@ assert msg->dst[0] == 192; //@ assert msg->src[0] == 192; //@ assert msg->dst[(sizeof (ip_address) / sizeof (int)) - 1] == 101; // @ assert msg->src[(sizeof (int [4]) / sizeof (int)) - 1] == 101; } int main() { msg msg1; create_msg(&msg1); send_msg(&msg1); return 0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/loop_labels.i��������������������������������������������������0000644�0001750�0001750�00000000404�12155630271�020536� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int main () { int x = 0; /*@ loop invariant \at(x,LoopEntry) == 0; loop invariant \at(x,LoopCurrent) <= 15; */ while (x<15) { x++; /*@ assert x == \at(x,LoopCurrent) + 1; */ } // Rejected. /*@ assert \at(x,LoopEntry) == 0; */ } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/statement_behavior.c�������������������������������������������0000644�0001750�0001750�00000000663�12155630271�022127� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -inout -journal-disable */ /*@ ensures \result == (int)(5 * x); */ int pfsqopfc(int x) { int five_times; /*@ assigns five_times; ensures five_times == (int)(5 * x); */ asm ("leal (%1,%1,4), %0" : "=r" (five_times) : "r" (x) ); /*@ assert five_times == (int) (5 * x);*/ // valid return five_times; } int main () { int x = 1; int y = pfsqopfc(x); return 0; } �����������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/temporal.i�����������������������������������������������������0000644�0001750�0001750�00000036317�12155630271�020102� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/behavior_assert.c����������������������������������������������0000644�0001750�0001750�00000002401�12155630271�021414� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -memory-footprint 1 -val -deps -out -input -journal-disable -lib-entry OPT: -memory-footprint 1 -val -deps -out -input -journal-disable */ int e; /*@ behavior b: assumes e==0; */ void f(void) { int x = 1; //@ for b: assert \false; x = 2; //@ for b: assert 1==1; x = 3; } int G; /*@ behavior be: assumes e==0; ensures G==3; */ void g(void) { int i=0 ; while (i < 3) //@ for be: invariant 0<=i<3; //@ for be: assert 0<=i<3; i++; 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; } /*@ behavior b: assumes e==0; behavior c: assumes e != 0; complete behaviors; */ void k(void) { //@ for c: assert \true; //@ for b: assert \false; } void main(int v) { if (v) f(); g(); h2(); k(); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/abrupt.i�������������������������������������������������������0000644�0001750�0001750�00000001036�12155630271�017542� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/pointer_cast.c�������������������������������������������������0000644�0001750�0001750�00000000152�12155630271�020727� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void f(int **a) { int *b; //@ assert a == b; //@ assert (int*)a == b; //@ assert a == (int**)b; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/multiple_decl_def_2.c������������������������������������������0000644�0001750�0001750�00000000212�12155630271�022113� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: linked with multiple_decl_def_1.c which is the real test. */ /*@ requires y <= 0; */ int f(int y) { return y; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/precedence.i���������������������������������������������������0000644�0001750�0001750�00000000354�12155630271�020344� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/at.c�����������������������������������������������������������0000644�0001750�0001750�00000001134�12155630271�016642� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int x; /*@ axiomatic A { predicate E(integer v) = x == v; predicate P{L1,L2}(integer i) = \at(x,L1) == \at(x,L2)+ i; predicate Q{L1,L2}(integer i) = \at(x == \at(x,L2)+ i,L1); axiom idem{L1,L2}: \forall integer i ; P{L1,L2}(i) <==> Q{L1,L2}(i); } */ /*@ ensures x == 2+\old(x)+y; ensures \at(E(\at(x-2-y,Here)),Pre); */ int f(int y) { x += y; L1: x++; //@ ghost L2: ; x++; //@ assert \at(x,L1) == \at(x,Pre)+y; //@ assert \at(x,L2) == 1+\at(x,Pre)+y; //@ assert P{Here,Pre}(2+y); return x; } /* Local Variables: compile-command: "PPCHOME=../.. LC_ALL=C make at" End: */ ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/separated.c����������������������������������������������������0000644�0001750�0001750�00000000402�12155630271�020203� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ requires \base_addr(q) != p; requires \separated(p,q); requires \valid(p+(0..(n-1))); requires \valid(q+(0..(n-1))); assigns p[0..n-1]; */ void put(char* p, char* q, int n) { for(int i = 0; i<n; i++) /*@ assert \separated(p,q); */ *p++=*q++; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/local.c��������������������������������������������������������0000644�0001750�0001750�00000000771�12155630271�017336� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ ensures \let i = x + 1; i == \result; ensures \result == \let i = x; i+1; */ int f(int x) { return x+1; } /*@ requires (int)(x+y+1) == x+y+1; ensures \let f = \lambda integer x; \let x1 = x + 1; \lambda integer y; x1 + y; \let P = \lambda integer x,y; x == y; 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 ; �������frama-c-Fluorine-20130601/tests/spec/axiom_redef_bts1005.i������������������������������������������0000644�0001750�0001750�00000000166�12155630271�021710� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* must terminate with a type-checking error */ /*@ axiomatic Inj { axiom inj1: \true; axiom inj1: \true; } */ ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/result/��������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017412� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/complete_behaviors.c�������������������������������������������0000644�0001750�0001750�00000001061�12155630271�022107� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef enum { Max, Min } kind; int extremum (kind k, int x, int y) { return ((k == Max ? x > y : x < y) ? x: y); } /*@ requires k == Max || k == Min; assigns \nothing; ensures \result == x || \result == y; behavior is_max: assumes k == Max; ensures \result >= x && \result >= y; behavior is_min: assumes k == Min; ensures \result <= x && \result <= y; complete behaviors is_max, is_min; disjoint behaviors is_max, is_min; complete behaviors; disjoint behaviors; */ int extremum (kind k, int x, int y); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/multiple_include_2.c�������������������������������������������0000644�0001750�0001750�00000000250�12155630271�022013� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -print tests/spec/multiple_include_1.c -journal-disable */ #include "multiple_include.h" /*@ requires p(x); */ void bar(int x) { i+=x; return; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts0283.c������������������������������������������������������0000644�0001750�0001750�00000000272�12155630271�017345� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int b, *p; /*@ requires p != 0 ; // accepted (null pointer constant) */ int main() { /*@ assert p !=4 ; */ // forbidden p = b?4:7 ; /*@ assert p !=b; */ // forbidden return 1; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/stmt_contract.i������������������������������������������������0000644�0001750�0001750�00000001352�12155630271�021132� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int main(int c) { int x = 5, y = 2; /*@ requires x == 5; */ /*@ requires y == 2; */ x = x + y; // BTS 1320: \result must be modified to __ret_res, as // assigns also account for abrupt termination //@ assigns \result \from x, y; if (c) { //@ assigns \result \from x; return x; } else { // this loop assigns should be rejected though, as loop assigns // only speak about successful loop steps. //@ loop assigns \result \from y; while (1) { return y; } } // we should also add an assigns __ret_res here, to match the implicit \result //@ assigns x; if (c) { x++; return x; } // END BTS 1320 /*@ requires x == 7; */ /*@ ensures x == 7; */ return 0; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/assigns_array.c������������������������������������������������0000644�0001750�0001750�00000001642�12155630271�021107� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ ghost int ghost_loctable[100] ;*/ // The specification below should be rejected /*@ requires \valid(ghost_loctable + m); requires !ghost_loctable[m]; ensures ghost_loctable[m]; assigns ghost_loctable; */ void acquire_lock(int m) { ghost_loctable[m]++; } // The specification above should be accepted /*@ requires \valid(ghost_loctable + m); requires ghost_loctable[m]==1; ensures !ghost_loctable[m]; assigns ghost_loctable[..]; */ void release_lock(int m) { ghost_loctable[m]--; } 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 ; } ����������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/onelineghost.c�������������������������������������������������0000644�0001750�0001750�00000000126�12155630271�020734� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int main () { //@ ghost int x = 0; //@ ghost x++; return 0; } //@ ghost int G; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts0570.i������������������������������������������������������0000644�0001750�0001750�00000000131�12155630271�017344� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int main(char *data ) { //@ assert \pointer_comparable(data, (void *)0); return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/pred_def.i�����������������������������������������������������0000644�0001750�0001750�00000000042�12155630271�020011� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������//@ predicate f(integer x) = x+1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/alloc_string_marshall.c����������������������������������������0000644�0001750�0001750�00000005466�12155630271�022615� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: no annotation here! */ /*****************************************************************************/ /* Attempt to define a running example for ACSL (Ansi C Specification */ /* Language), much as the Purse example in JML description papers. */ /* The goal is to exercise as much as possible of ACSL. */ /*****************************************************************************/ #define N 10000 enum error_tag { MARSHALL_ERROR = 1, ALLOC_ERROR = 2, MESSAGE_ERROR = 3, }; /* Allocation */ static char heap[N]; static char *pos = heap; static char *end = heap + N; char* alloc(unsigned int n) { char *cur = pos; char *next = pos + n; if (next > end) return 0; pos = next; return cur; } /* Strings */ unsigned int strlen(char *s) { unsigned int size = 0; while (*s++ != '\0') { size++; } return size; } char* strcpy(char* dest, char* src) { char *cur = dest; while (*src != '\0') { *cur++ = *src++; } return dest; } /* Marshalling */ enum marshall_tag { MARSHALL_INT = 1, MARSHALL_STRING = 2, }; char *marshall_int(char* p, int i) { char *dest = p; char *src = (char*)&i; char *end; *dest++ = MARSHALL_INT; end = dest + sizeof(int); while (dest < end) { *dest++ = *src++; } return dest; } char *marshall_string(char* p, char* s) { char *dest = p; char *src = s; *dest++ = MARSHALL_STRING; strcpy(dest,src); return dest; } char* unmarshall_int(char* p, int* i) { char *src = p; char *dest = (char*)i; char *end; if (*src != MARSHALL_INT) return 0; src++; end = dest + sizeof(int); while (dest < end) { *dest++ = *src++; } return src; } char* unmarshall_string(char* p, char** s) { char *src = p; char *dest; int size; if (*src != MARSHALL_STRING) return 0; src++; size = strlen(src); *s = alloc(size + 1); if (s == 0) return 0; dest = *s; strcpy(dest,src); src += size + 1; return src; } /* Messages */ struct Msg { int level; char* text; }; char* msg_create(struct Msg* s) { char *msg = alloc(2 + sizeof(int) + strlen(s->text) + 1); char *p = msg; if (p == 0) return 0; p = marshall_int(p,s->level); if (p == 0) return 0; p = marshall_string(p,s->text); if (p == 0) return 0; return msg; } int msg_receive(char* p, struct Msg* s) { p = unmarshall_int(p,&s->level); if (p == 0) return MESSAGE_ERROR; p = unmarshall_string(p,&s->text); if (p == 0) return MESSAGE_ERROR; return 0; } /* Test */ int main(int argc, char** argv) { struct Msg m1; struct Msg m2; char *msg; int iter, status; for (iter = 0; iter < argc; iter++) { m1.level = iter; m1.text = argv[iter]; msg = msg_create(&m1); if (msg == 0) return MESSAGE_ERROR; status = msg_receive(msg,&m2); if (status != 0) return MESSAGE_ERROR; } return 0; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/pi.c�����������������������������������������������������������0000644�0001750�0001750�00000001756�12155630271�016660� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/****** int a=10000,b,c=2800,d,e,f[2801],g;main(){for(;b-c;)f[b++]=a/5; for(;d=0,g=c*2;c-=14,printf("%.4d",e+d/a),e=d%a)for(b=c;d+=f[b]*a, f[b]=d%--g,d/=g--,--b;d*=b);} ******/ /*@ lemma simplify_dumb_1 : 2800 % 14 == 0; */ /*@ lemma simplify_dumb_2 : \forall integer c; c*2>0 ==> c*2>1; */ /*@ lemma simplify_dumb_3 : \forall integer c; c%14==0 ==> (c-14)%14==0; */ /*@ lemma simplify_dumb_4 : \forall integer c; c%14==0 ==> c>0 ==> c>=14; */ void print4(int); int a=10000,b,c=2800,d,e,f[2801],g; /*@ requires b == 0 && c == 2800 && a == 10000; */ void main(){ /*@ loop invariant 0 <= b <= 2800 ; loop variant c-b; */ for(; b-c; b++) f[b] = a/5; /*@ loop invariant 0 <= c <= 2800 && c%14==0; loop variant c; */ for(; d=0, g=c*2; ) { /*@ loop invariant 1 <= b <= c && g == b*2; loop variant b; */ for(b=c; 1; ) { d+=f[b]*a; f[b]=d%--g; d/=g--; --b; if (!b) break; d*=b; } c-=14; print4(e+d/a); e=d%a; } } ������������������frama-c-Fluorine-20130601/tests/spec/acsl_allocator.c�����������������������������������������������0000644�0001750�0001750�00000031650�12155630271�021226� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: annotations grammar needs update. */ /*****************************************************************************/ /* Attempt to define a running example for ACSL (Ansi C Specification */ /* Language), much as the Purse example in JML description papers. */ /* It is a memory allocator, whose main functions are [memory_alloc] and */ /* [memory_free], to respectively allocate and deallocate memory. */ /* The goal is to exercise as much as possible of ACSL. */ /* This file presents the more complex version of the allocator. */ /*****************************************************************************/ #include <stdlib.h> #define DEFAULT_BLOCK_SIZE 1000 typedef enum _bool { false = 0, true = 1 } bool; /*@ predicate finite_list<a>((a* -> a*) next_elem, a* ptr) { @ ptr == \null || (\valid(ptr) && finite_list(next_elem(ptr))) @ } @ @ logic int list_length<a>((a* -> a*) next_elem, a* ptr) { @ (ptr == \null) ? 0 : 1 + list_length(next_elem(ptr)) @ } @ @ predicate lower_length<a>((a* -> a*) next_elem, a* ptr1, a* ptr2) { @ finite_list(next_elem, ptr1) && finite_list(next_elem, ptr2) @ && list_length(next_elem, ptr1) < list_length(next_elem, ptr2) @ } */ // forward reference struct _memory_slice; /* A memory block holds a pointer to a raw block of memory allocated by * calling [malloc]. It is sliced into chunks, which are maintained by * the [slice] structure. It maintains additional information such as * the [size] of the memory block, the number of bytes [used] and the [next] * index at which to put a chunk. */ typedef struct _memory_block { //@ ghost bool packed; // ghost field [packed] is meant to be used as a guard that tells when // the invariant of a structure of type [memory_block] holds unsigned int size; // size of the array [data] unsigned int next; // next index in [data] at which to put a chunk unsigned int used; // how many bytes are used in [data], not necessarily contiguous ones char* data; // raw memory block allocated by [malloc] struct _memory_slice* slice; // structure that describes the slicing of a block into chunks } memory_block; /*@ type invariant inv_memory_block(memory_block mb) { @ mb.packed ==> @ (0 < mb.size && mb.used <= mb.next <= mb.size @ && \offset(mb.data) == 0 @ && \block_length(mb.data) == mb.size) @ } @ @ predicate valid_memory_block(memory_block* mb) { @ \valid(mb) && mb->packed @ } */ /* A memory chunk holds a pointer [data] to some part of a memory block * [block]. It maintains the [offset] at which it points in the block, as well * as the [size] of the block it is allowed to access. A field [free] tells * whether the chunk is used or not. */ typedef struct _memory_chunk { //@ ghost bool packed; // ghost field [packed] is meant to be used as a guard that tells when // the invariant of a structure of type [memory_chunk] holds unsigned int offset; // offset at which [data] points into [block->data] unsigned int size; // size of the chunk bool free; // true if the chunk is not used, false otherwise memory_block* block; // block of memory into which the chunk points char* data; // shortcut for [block->data + offset] } memory_chunk; /*@ type invariant inv_memory_chunk(memory_chunk mc) { @ mc.packed ==> @ (0 < mc.size && valid_memory_block(mc.block) @ && mc.offset + mc.size <= mc.block->next) @ } @ @ predicate valid_memory_chunk(memory_chunk* mc, int s) { @ \valid(mc) && mc->packed && mc->size == s @ } @ @ predicate used_memory_chunk(memory_chunk mc) { @ mc.free == false @ } @ @ predicate freed_memory_chunk(memory_chunk mc) { @ mc.free == true @ } */ /* A memory chunk list links memory chunks in the same memory block. * Newly allocated chunks are put first, so that the offset of chunks * decreases when following the [next] pointer. Allocated chunks should * fill the memory block up to its own [next] index. */ typedef struct _memory_chunk_list { memory_chunk* chunk; // current list element struct _memory_chunk_list* next; // tail of the list } memory_chunk_list; /*@ \let next_chunk = \lambda memory_chunk_list* ptr; ptr->next ; @ @ predicate valid_memory_chunk_list @ (memory_chunk_list* mcl, memory_block* mb) { @ \valid(mcl) && valid_memory_chunk(mcl->chunk,mcl->chunk->size) @ && mcl->chunk->block == mb @ && (mcl->next == \null || valid_memory_chunk_list(mcl->next, mb)) @ && mcl->offset == mcl->chunk->offset @ && ( @ // it is the last chunk in the list @ (mcl->next == \null && mcl->chunk->offset == 0) @ || @ // it is a chunk in the middle of the list @ (mcl->next != \null @ && mcl->next->chunk->offset + mcl->next->chunk->size @ == mcl->chunk->offset) @ ) @ && finite_list(next_chunk, mcl) @ } @ @ predicate valid_complete_chunk_list @ (memory_chunk_list* mcl, memory_block* mb) { @ valid_memory_chunk_list(mcl,mb) @ && mcl->next->chunk->offset + mcl->next->chunk->size == mb->next @ } @ @ predicate chunk_lower_length(memory_chunk_list* ptr1, @ memory_chunk_list* ptr2) { @ lower_length(next_chunk, ptr1, ptr2) @ } */ /* A memory slice holds together a memory block [block] and a list of chunks * [chunks] on this memory block. */ typedef struct _memory_slice { //@ ghost bool packed; // ghost field [packed] is meant to be used as a guard that tells when // the invariant of a structure of type [memory_slice] holds memory_block* block; memory_chunk_list* chunks; } memory_slice; /*@ type invariant inv_memory_slice(memory_slice* ms) { @ ms.packed ==> @ (valid_memory_block(ms->block) && ms->block->slice == ms @ && (ms->chunks == \null @ || valid_complete_chunk_list(ms->chunks, ms->block))) @ } @ @ predicate valid_memory_slice(memory_slice* ms) { @ \valid(ms) && ms->packed @ } */ /* A memory slice list links memory slices, to form a memory pool. */ typedef struct _memory_slice_list { //@ ghost bool packed; // ghost field [packed] is meant to be used as a guard that tells when // the invariant of a structure of type [memory_slice_list] holds memory_slice* slice; // current list element struct _memory_slice_list* next; // tail of the list } memory_slice_list; /*@ \let next_slice = \lambda memory_slice_list* ptr; ptr->next ; @ @ type invariant inv_memory_slice_list(memory_slice_list* msl) { @ msl.packed ==> @ (valid_memory_slice(msl->slice) @ && (msl->next == \null || valid_memory_slice_list(msl->next)) @ && finite_list(next_slice, msl)) @ } @ @ predicate valid_memory_slice_list(memory_slice_list* msl) { @ \valid(msl) && msl->packed @ } @ @ predicate slice_lower_length(memory_slice_list* ptr1, @ memory_slice_list* ptr2) { @ \let next_slice = \lambda memory_slice_list* ptr; ptr->next ; @ lower_length(next_slice, ptr1, ptr2) @ } */ typedef memory_slice_list* memory_pool; /*@ type invariant valid_memory_pool(memory_pool *mp) { @ \valid(mp) && valid_memory_slice_list(*mp) @ } */ /*@ behavior zero_size: @ assumes s == 0; @ assigns \empty; @ ensures \result == 0; @ @ behavior positive_size: @ assumes s > 0; @ requires valid_memory_pool(arena); @ ensures \result == 0 @ || (valid_memory_chunk(\result,s) && used_memory_chunk(*\result)); @ */ memory_chunk* memory_alloc(memory_pool* arena, unsigned int s) { memory_slice_list *msl = *arena; memory_chunk_list *mcl; memory_slice *ms; memory_block *mb; memory_chunk *mc; unsigned int mb_size; //@ ghost unsigned int mcl_offset; char *mb_data; // guard condition if (s == 0) return 0; // iterate through memory blocks (or slices) /*@ @ loop invariant valid_memory_slice_list(msl); @ loop variant msl for slice_lower_length; @ */ while (msl != 0) { ms = msl->slice; mb = ms->block; mcl = ms->chunks; // does [mb] contain enough free space? if (s <= mb->size - mb->next) { //@ ghost ms->ghost = false; // unpack the slice // allocate a new chunk mc = (memory_chunk*)malloc(sizeof(memory_chunk)); if (mc == 0) return 0; mc->offset = mb->next; mc->size = s; mc->free = false; mc->block = mb; //@ ghost mc->ghost = true; // pack the chunk // update block accordingly //@ ghost mb->ghost = false; // unpack the block mb->next += s; mb->used += s; //@ ghost mb->ghost = true; // pack the block // add the new chunk to the list mcl = (memory_chunk_list*)malloc(sizeof(memory_chunk_list)); if (mcl == 0) return 0; mcl->chunk = mc; mcl->next = ms->chunks; ms->chunks = mcl; //@ ghost ms->ghost = true; // pack the slice return mc; } // iterate through memory chunks /*@ @ loop invariant valid_memory_chunk_list(mcl,mb); @ loop variant mcl for chunk_lower_length; @ */ while (mcl != 0) { mc = mcl->chunk; // is [mc] free and large enough? if (mc->free && s <= mc->size) { mc->free = false; mb->used += mc->size; return mc; } // try next chunk mcl = mcl->next; } msl = msl->next; } // allocate a new block mb_size = (DEFAULT_BLOCK_SIZE < s) ? s : DEFAULT_BLOCK_SIZE; mb_data = (char*)malloc(mb_size); if (mb_data == 0) return 0; mb = (memory_block*)malloc(sizeof(memory_block)); if (mb == 0) return 0; mb->size = mb_size; mb->next = s; mb->used = s; mb->data = mb_data; //@ ghost mb->ghost = true; // pack the block // allocate a new chunk mc = (memory_chunk*)malloc(sizeof(memory_chunk)); if (mc == 0) return 0; mc->offset = 0; mc->size = s; mc->free = false; mc->block = mb; //@ ghost mc->ghost = true; // pack the chunk // allocate a new chunk list mcl = (memory_chunk_list*)malloc(sizeof(memory_chunk_list)); if (mcl == 0) return 0; //@ ghost mcl->offset = 0; mcl->chunk = mc; mcl->next = 0; // allocate a new slice ms = (memory_slice*)malloc(sizeof(memory_slice)); if (ms == 0) return 0; ms->block = mb; ms->chunks = mcl; //@ ghost ms->ghost = true; // pack the slice // update the block accordingly mb->slice = ms; // add the new slice to the list msl = (memory_slice_list*)malloc(sizeof(memory_slice_list)); if (msl == 0) return 0; msl->slice = ms; msl->next = *arena; //@ ghost msl->ghost = true; // pack the slice list *arena = msl; return mc; } /*@ behavior null_chunk: @ assumes chunk == \null; @ assigns \empty; @ @ behavior valid_chunk: @ assumes chunk != \null; @ requires valid_memory_pool(arena); @ requires valid_memory_chunk(chunk,chunk->size); @ requires used_memory_chunk(chunk); @ ensures @ // if it is not the last chunk in the block, mark it as free @ (valid_memory_chunk(chunk,chunk->size) @ && freed_memory_chunk(chunk)) @ || @ // if it is the last chunk in the block, deallocate the block @ ! \valid(chunk); @ */ void memory_free(memory_pool* arena, memory_chunk* chunk) { memory_slice_list *msl = *arena; memory_block *mb = chunk->block; memory_slice *ms = mb->slice; memory_chunk_list *mcl; memory_chunk *mc; // is it the last chunk in use in the block? if (mb->used == chunk->size) { // remove the corresponding slice from the memory pool // case it is the first slice if (msl->slice == ms) { *arena = msl->next; //@ ghost msl->ghost = false; // unpack the slice list free(msl); } // case it is not the first slice while (msl != 0) { if (msl->next != 0 && msl->next->slice == ms) { memory_slice_list* msl_next = msl->next; msl->next = msl->next->next; // unpack the slice list //@ ghost msl_next->ghost = false; free(msl_next); break; } msl = msl->next; } //@ ghost ms->ghost = false; // unpack the slice // deallocate all chunks in the block mcl = ms->chunks; // iterate through memory chunks /*@ @ loop invariant valid_memory_chunk_list(mcl,mb); @ loop variant mcl for chunk_lower_length; @ */ while (mcl != 0) { memory_chunk_list *mcl_next = mcl->next; mc = mcl->chunk; //@ ghost mc->ghost = false; // unpack the chunk free(mc); free(mcl); mcl = mcl_next; } mb->next = 0; mb->used = 0; // deallocate the memory block and its data //@ ghost mb->ghost = false; // unpack the block free(mb->data); free(mb); // deallocate the corresponding slice free(ms); return; } // mark the chunk as freed chunk->free = true; // update the block accordingly mb->used -= chunk->size; return; } ����������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/model1.h�������������������������������������������������������0000644�0001750�0001750�00000001064�12155630271�017426� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������struct S; /*@ model struct S { integer foo; }; */ /*@ requires \valid(s); assigns *s; ensures s->foo == 0; */ void reset (struct S* s); /*@ requires \valid(s); assigns *s; ensures s->foo > \at(s->foo,Pre); */ void inc(struct S* s); /*@ requires \valid(s); assigns *s; ensures s->foo < \at(s->foo,Pre); */ void dec(struct S* s); /*@ requires \valid(s); assigns \nothing; behavior is_true: assumes s->foo > 0; ensures \result == 1; behavior is_false: assumes s->foo <= 0; ensures \result == 0; */ int is_pos(struct S* s); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts0254.i������������������������������������������������������0000644�0001750�0001750�00000001202�12155630271�017343� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ behavior d: assumes \true; assumes \false; requires \true; ensures \true && x && \true && x && \true && x && \true && x && \true && x && \true; */ int f(int x) { return 0; }; /*@ requires \true; ensures \false; assigns \nothing; */ int g(void) { return 0; }; /*@ requires \true; terminates \false; decreases x; ensures \false; assigns \nothing; behavior b1: assumes \true; behavior b2: assumes \false; disjoint behaviors b1, b2; */ int h(int x) { return 0; }; /*@ requires \true; */ int a(void) { return 0; }; /*@ behavior d: ensures \true; */ int bts(void) { return 0; }; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/returns.i������������������������������������������������������0000644�0001750�0001750�00000000541�12155630271�017747� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ 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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/property_test.ml�����������������������������������������������0000644�0001750�0001750�00000002705�12155630271�021354� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil open Cil_types let emitter = Emitter.create "Property_test" [ Emitter.Funspec ] ~correctness:[] ~tuning:[] class visit prj = object(self) inherit Visitor.frama_c_copy prj method vbehavior b = let kf = Extlib.the self#current_kf in if Kernel_function.get_name kf = "main" then begin 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 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)] ] end; ChangeTo b end let show_properties () = Format.printf "In project %a:@." Project.pretty (Project.current()); let strs = Property_status.fold (fun p acc -> let s = Pretty_utils.sfprintf "Status of %a: %a@." Property.pretty p Property_status.pretty (Property_status.get p) in Datatype.String.Set.add s acc ) Datatype.String.Set.empty in Datatype.String.Set.iter (Format.pp_print_string Format.std_formatter) strs 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 �����������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/dec.h����������������������������������������������������������0000644�0001750�0001750�00000000164�12155630271�017000� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#ifndef __DEC #define __DEC /*@ axiomatic S { logic integer F(integer x) ; } */ //@ logic integer X = 42; #endif ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/shifts.c�������������������������������������������������������0000644�0001750�0001750�00000000412�12155630271�017534� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -deps -journal-disable */ int e; /*@ behavior a: ensures \result >> 2 == x; behavior b: ensures e >> 2 == x; */ int f(int x) { int y = 4 * x; /*@ assert y == x << 2; */ e = y; return y; } int main() { f(42); return 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts1068.i������������������������������������������������������0000644�0001750�0001750�00000010565�12155630271�017363� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -print -journal-disable -continue-annot-error */ // test of label inference into typedef struct { int a; unsigned char *b; } S ; typedef struct { int a; unsigned char b[10]; } T ; int * P ; int V, Tab[10] ; /*@ axiomatic A { logic T t reads \nothing; logic integer ft (T x) = x.b[1] ; logic integer ft2 (T x) reads x.b[1] ; predicate PT(T x) = x.b[1] > 1; predicate PT2(T x) reads x.b[1]; axiom T1: t.a == 0; axiom T2: t.b[0] == 0; axiom T3: PT(t) ==> PT2(t); logic S s reads \nothing; logic integer fs (S x) = x.b[1] ; // <- label to infer logic integer fs2 (S x) reads x.b[1] ; // <- label to infer predicate PS(S x) = x.b[1] > 1; // <- label to infer predicate PS2(S x) reads x.b[1]; // <- label to infer axiom S1: s.a == 0; axiom S2: s.b[0] == 0; // <- label to infer axiom S3: PS(s) ==> PS2(s); // <- label to infer logic integer p reads *P; // <- label to infer logic int * va reads &V; // <- label to infer logic integer v reads V; // <- label to infer logic int *fa(int *q) = q; logic int fa2(int *q) = *q; // <- label to infer logic char *fa3(integer i) = i + (char *)&P; // <- label to infer logic integer fa4(T *q) reads q->a ; // <- label to infer predicate Initialized(int *q) = \initialized(q); // <- label to infer predicate Valid(int *q) = \valid(q); // <- label to infer predicate ValidIndex(int *q) = \valid_index(q,1); // <- label to infer predicate ValidRange(int *q) = \valid_range(q,0,2); // <- label to infer predicate Separated(int *a,int *b) = \separated(a,b); logic integer BlockLength(int *q) = \block_length(q); // <- label to infer logic char * Base_addr(int *q) = \base_addr(q); // <- label to infer // logic integer Offset(int *q) = \offset(q); // <- BUG parsing logic integer fi(T* t) = t->a + (*t).a; } */ typedef struct _list { int element; struct _list* next; } list; /*@ type List<A> = Nil | Cons(A,List<A>); */ /*@ inductive model_0{L1,L2}(list* root, List<int>logic_list) { case nil{L1,L2}: model_0{L1,L2}(\null,Nil); case cons{L1,L2}: \forall list* l1,List<int>ll1; \at(\valid(l1),L1) ==> model_0{L1,L2}(\at(l1->next,L1),ll1) ==> model_0{L1,L2}(l1,Cons(\at(l1->element,L1),ll1)); } */ /*@ inductive model_1{L}(list* root, List<int>logic_list) { case nil{L}: model_1{L}(\null,Nil); case cons{L}: \forall list* l1,List<int>ll1; \valid(l1) ==> model_1{L}(\at(l1->next,L),ll1) ==> model_1{L}(l1,Cons(\at(l1->element,L),ll1)); } */ /*@ inductive model_2(list* root, List<int>logic_list) { case nil: model_2(\null,Nil); case cons: \forall list* l1,List<int>ll1; \valid(l1) ==> model_2(l1->next,ll1) ==> model_2(l1,Cons(l1->element,ll1)); } */ /*@ inductive model_3{L}(list* root, List<int>logic_list) { case nil: model_3(\null,Nil); case cons{L}: \forall list* l1,List<int>ll1; \valid(l1) ==> model_3(l1->next,ll1) ==> model_3(l1,Cons(l1->element,ll1)); } */ /*@ inductive model_4{L1}(list* root, List<int>logic_list) { case nil: model_4(\null,Nil); case cons{L1}: \forall list* l1,List<int>ll1; \valid(l1) ==> model_4(l1->next,ll1) ==> model_4(l1,Cons(l1->element,ll1)); } */ /*@ inductive model_5{L}(list* root, List<int>logic_list) { case nil: model_5(\null,Nil); case cons{L1}: \forall list* l1,List<int>ll1; \valid(l1) ==> model_5(l1->next,ll1) ==> model_5(l1,Cons(l1->element,ll1)); } */ /*@ inductive model_6(list* root, List<int>logic_list) { case nil{L1}: model_6(\null,Nil); case cons: \forall list* l1,List<int>ll1; \valid(l1) ==> model_6(l1->next,ll1) ==> model_6(l1,Cons(l1->element,ll1)); } */ /*@ inductive model_7{L1}(list* root, List<int>logic_list) { case nil{L1}: model_7(\null,Nil); case cons: \forall list* l1,List<int>ll1; \valid(l1) ==> model_7(l1->next,ll1) ==> model_7(l1,Cons(l1->element,ll1)); } */ /*@ inductive model_8{L1}(list* root, List<int>logic_list) { case nil{L}: model_8(\null,Nil); case cons: \forall list* l1,List<int>ll1; \valid(l1) ==> model_8(l1->next,ll1) ==> model_8(l1,Cons(l1->element,ll1)); } */ /*@ inductive model_9{L1,L2}(list* root, List<int>logic_list) { case nil: \valid(P); } */ /* inductive model_10{L}(list* root, List<int>logic_list) { case nil: model_10(\null,Nil); case cons{L}: \forall list* l1,List<int>ll1; \valid{L}(l1) ==> model_10(l1->next,ll1) ==> model_10(l1,Cons(l1->element,ll1)); } */ �������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/annot_main.c���������������������������������������������������0000644�0001750�0001750�00000000135�12155630271�020361� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ requires \valid(p); ensures *p == 0; */ void main(int*p) { *p = 0; CEA_DUMP(); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/type_of_term.i�������������������������������������������������0000644�0001750�0001750�00000000446�12155630271�020745� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/spec/Type_of_term.cmxs OPT: -load-module tests/spec/Type_of_term.cmxs -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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/merge_2.i������������������������������������������������������0000644�0001750�0001750�00000000557�12155630271�017574� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/axiom_included.h�����������������������������������������������0000644�0001750�0001750�00000000053�12155630271�021226� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ axiomatic foo { axiom foo: \true; } */ �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/global_invariant.c���������������������������������������������0000644�0001750�0001750�00000000671�12155630271�021556� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: ghost code is not supported */ int G= 1, H = 2; /*@ ghost char toggle = 0, y[10] = {1,2} ; */ //@ global invariant sum_G_H : toggle ==> G + H <= 3; void main () { /*@ ghost int LOCAL2 = 0; */ if (H) /*@ ghost int local = 0; goto HH; local += G; */ /*@ ghost int local = 0; goto HH; HH:local += G; */ //@ assert \false; LL:G++; /*@ghost LOCAL2++ ; */ } �����������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/liens.c��������������������������������������������������������0000644�0001750�0001750�00000000222�12155630271�017345� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ int e; /*@ assigns e; @ ensures e == 2; @*/ void f() { e=2; } /*@ assigns e; @ ensures e == 6; @*/ int main() { e=1; f(); return 0; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/allocates.i����������������������������������������������������0000644�0001750�0001750�00000001145�12155630271�020215� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int *p,*q,*r; /*@ //idem allocates \nothing @ behavior a: requires *p==0 ; //idem allocates \everything; */ void f1 (void) { return ; } /*@ requires !q ; //idem allocates \nothing @ behavior a: requires p; frees p ; */ void f2 (void) { return ; } /*@ requires i<0 ; //idem allocates \nothing @ behavior a: requires p; frees r ; allocates q, \old(r); frees p ; */ void f3 (int i) { /*@ //idem loop allocates \nothing @ for a: loop invariant i <0; //idem loop allocates \everything; */ while (i) { i--; p++; } } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/builtins.c�����������������������������������������������������0000644�0001750�0001750�00000000047�12155630271�020071� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ //@ lemma cos_pi: \cos(\pi) == -1.0; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/model2.c�������������������������������������������������������0000644�0001750�0001750�00000000545�12155630271�017425� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is in tests/spec/model1.c */ #include "tests/spec/model1.h" struct S { int bar; }; /*@ type invariant foobar(struct S s) = s.bar == s.foo; */ void reset (struct S* s) { s->bar == 0; } void inc(struct S* s) { s->bar += 5; } void dec(struct S* s) { s->bar--; } int is_pos (struct S* s) { return (s->bar > 0) ? 1 : 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/ghost.c��������������������������������������������������������0000644�0001750�0001750�00000000417�12155630271�017365� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: ghost code is not supported */ struct A { int x; }; /*@ ghost struct B { int y; }; */ /*@ ghost struct B b1; */ /*@ requires b1.y == 0 ; */ int main() { /*@ ghost struct B b; */ struct A a; /*@ ghost b.y = 0; a.x = b.y; */ return 0; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/default_assigns_bts0966.i��������������������������������������0000644�0001750�0001750�00000001205�12155630271�022613� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/tableau_zones.c������������������������������������������������0000644�0001750�0001750�00000001367�12155630271�021101� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ requires \valid(p); @ assigns *p; @ ensures *p==n; @*/ int f(int *p,int n) { *p = n; return 0; //NdV not sure it is correct, but the return statelent was // missing anyway } int t[10]; /* post-condition should be trivially established * if a separation analysis is able to separate * t[0..4] and t[5..9] */ /*@ ensures t[0]==0; */ int main() { int i; /*@ loop invariant 0 <= i && i <= 5 && @ \forall int j; 0 <= j && j < i ==> t[j]==0; @*/ for(i=0; i<5; i++) { f(t+i,0); } /*@ loop invariant 5 <= i && i <= 10 && @ \forall int j; 5 <= j && j < i ==> t[j]==1; @ loop assigns t[5..9]; // needed when separation analysis too weak @*/ for(i=5; i<10; i++) { f(t+i,1); } return 0; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/regions2.c�����������������������������������������������������0000644�0001750�0001750�00000000677�12155630271�020001� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ struct S { int t1[2]; int t2[2]; }; struct T { struct S *t[2]; }; /*@ requires \valid(s) && \valid(s->t[0]); @*/ void f(struct T *s) { s->t[0]->t1[0] = 1; } int main(struct T s, struct S a) { s.t[0] = &a; f(&s); return 0; } /* on veut : zones globales : Zone 0: {s.t[0]; }; Zone 1: {a.t1[0]; }; zones locales : f: Zone 4: { *s; } Zone 5: { s->t[0]; } Appels: f(..) ligne 25: zone 4 -> zone 0, zone 5 -> zone 1 */ �����������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/preprocess.h���������������������������������������������������0000644�0001750�0001750�00000000073�12155630271�020431� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#define MIN_X 42 //@ predicate test(int x) = x >= MIN_X ; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/multiple_spec.c������������������������������������������������0000644�0001750�0001750�00000000207�12155630271�021103� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* see bug #43 */ /*@ requires x >=0; */ int f (int x); /*@ requires y <= 0; */ int f (int y); int main () { f (0); return 0; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/constant_predicate.i�������������������������������������������0000644�0001750�0001750�00000000271�12155630271�022116� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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; */ } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/unification.c��������������������������������������������������0000644�0001750�0001750�00000000543�12155630271�020551� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef struct _list { int element; struct _list* next; } list; /*@ type List<A> = Nil | Cons(A,List<A>); */ /*@ inductive logic_model{L}(list* root, List<int>logic_list) { case nil{L}: logic_model(\null,Nil); case cons{L}: \forall list* l1,List<int>ll1; \valid(l1) ==> logic_model(l1->next,ll1) ==> logic_model(l1,Cons(l1->element,ll1)); } */ �������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/model.i��������������������������������������������������������0000644�0001750�0001750�00000002045�12155630271�017346� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-load-script tests/spec/model.ml" */ struct S { int x; int y; }; typedef struct S T; /*@ model struct S { integer z }; */ /*@ model struct S { integer x }; */ // KO field exists in the struct /*@ model T { integer t; }; */ /*@ model T { integer z }; */ //KO field exists in parent type /*@ model T { integer x }; */ //KO field exists in parent type /*@ type invariant t_invariant(T t) = t.t == t.z * 2; */ /*@ assigns *s; ensures s->z == \result; */ int f(struct S* s); /*@ type invariant sum(struct S s) = s.z == s.x + s.y; */ void main() { struct S s = { 0, 0 }; T t = {1,2}; /*@ assert t.t == 6 && t.z == 3; */ int a = f(&s); if (a && !s.x) { /*@ assert s.y != 0; */ } else { s.x == 1; } /*@ assert s.z != 0; */ } /*@ model double { real exact }; */ /*@ model double { real round }; */ /*@ ensures \result == (double)(x+y); ensures \result.exact == x.exact + y.exact; ensures \result == \result.exact + \result.round; */ double add(double x, double y); double foo(double x) { return add(x,x); } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/acsl_basic_allocator.c�����������������������������������������0000644�0001750�0001750�00000006262�12155630271�022370� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ /*****************************************************************************/ /* Attempt to define a running example for ACSL (Ansi C Specification */ /* Language), much as the Purse example in JML description papers. */ /* It is a memory allocator, whose main functions are [memory_alloc] and */ /* [memory_free], to respectively allocate and deallocate memory. */ /* The goal is to exercise as much as possible of ACSL. */ /* This file presents the basic version of the allocator. */ /*****************************************************************************/ //#include <stdlib.h> //#include "../../share/libc.h" #define FRAMA_C_MALLOC_POSITION #include "share/libc/stdlib.c" #define DEFAULT_BLOCK_SIZE 1000 typedef enum _bool { false = 0, true = 1 } bool; typedef struct _memory_block { size_t size; bool free; char* data; } memory_block; /*@ type invariant inv_memory_block(memory_block mb) = @ 0 < mb.size && \offset(mb.data) == 0 && \block_length{Here}(mb.data) == mb.size ; @*/ /*@ predicate used_memory_block{L}(memory_block mb) = @ mb.free == false && inv_memory_block(mb) ; @*/ /*@ predicate freed_memory_block{L}(memory_block mb) = @ mb.free == true && inv_memory_block(mb) ; @*/ /*@ predicate valid_memory_block{L}(memory_block* mb) = @ \valid(mb) && inv_memory_block(*mb) ; @*/ /*@ predicate valid_used_memory_block{L}(memory_block* mb) = @ \valid(mb) && used_memory_block(*mb) ; @*/ /*@ predicate valid_freed_memory_block{L}(memory_block* mb) = @ \valid(mb) && freed_memory_block(*mb) ; @*/ typedef struct _memory_block_list { memory_block* block; struct _memory_block_list* next; } memory_block_list; /*@ predicate valid_memory_block_list{L}(memory_block_list* mbl) = @ \valid(mbl) && valid_memory_block(mbl->block) @ && (mbl->next == \null || valid_memory_block_list(mbl->next)) ; @*/ typedef memory_block_list* memory_pool; /*@ predicate valid_memory_pool{L}(memory_pool *mp) = @ \valid(mp) && valid_memory_block_list(*mp) ; @*/ /*@ requires valid_memory_pool(arena) && 0 < s; @ ensures valid_used_memory_block(\result); @ */ memory_block* memory_alloc(memory_pool* arena, size_t s) { memory_block_list *mbl = *arena; memory_block *mb; size_t mb_size; char *mb_data; // iterate through memory blocks while (mbl != 0) { mb = mbl->block; // is [mb] free and large enough? if (mb->free && s <= mb->size) { mb->free = false; return mb; } // try next block mbl = mbl->next; } // allocate a new block mb_size = (DEFAULT_BLOCK_SIZE < s) ? s : DEFAULT_BLOCK_SIZE; mb_data = (char*)malloc(mb_size); mb = (memory_block*)malloc(sizeof(memory_block)); mb->size = mb_size; mb->free = false; mb->data = mb_data; // add the new block to the arena mbl = (memory_block_list*)malloc(sizeof(memory_block_list)); mbl->block = mb; mbl->next = *arena; *arena = mbl; return mb; } /*@ requires valid_memory_pool(arena) && valid_used_memory_block(block); @ ensures valid_freed_memory_block(block); @ */ void memory_free(memory_pool* arena, memory_block* block) { block->free = true; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/use.c����������������������������������������������������������0000644�0001750�0001750�00000000223�12155630271�017030� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/spec/use2.c" */ // BTS 0887 #include "tests/spec/dec.h" //@ ensures X > 0 ; ensures F(1) > 0 ; void f(void) {} �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts1262.c������������������������������������������������������0000644�0001750�0001750�00000000120�12155630271�017333� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int main() { char *s = "\\\\.\\"; //@ assert s[0] == '\\'; s[2] = '\\'; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/ptr_cast.c�����������������������������������������������������0000644�0001750�0001750�00000000120�12155630271�020047� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int f() { return 0; } /*@ predicate is_f( void (*g)()) = g == (void(*)())f; */ ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/real_typing_bts1309.i������������������������������������������0000644�0001750�0001750�00000000113�12155630271�021742� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void foo(int c) { float f = 1.0; /*@ assert 0.0 <= (c ? f : 2.0); */ } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/logic_def.c����������������������������������������������������0000644�0001750�0001750�00000000153�12155630271�020151� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������//@ logic integer foo(int x) = x + 2 ; int main() { int x = 42; //@ assert foo(x) >= x; return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/logic_labels_wrong.c�������������������������������������������0000644�0001750�0001750�00000001412�12155630271�022070� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int x; // wrong: multiply defined label //@ predicate p{L,L}(integer n) = n > 0 ; // label missing, but automatically inferred //@ predicate p(int t[]) = t[0]; /*@ axiomatic Q { @ predicate q(int t[]); @ //label missing, but automatically inferred @ axiom q_ax: \forall int t[]; t[0] == 0 ==> q(t); @ } @*/ void f() { // wrong: \old forbidden in loop invariants //@ loop invariant x == \old(x); for (;;) ; // wrong: label undefined //@ assert \at(x,L0) == 0; // wrong: label defined later //@ assert \at(x,L1) == 0; for(;;) { L2: x = 0; } // wrong: label defined in inner block //@ assert \at(x,L2) == 0; L1: x = 0; } /* Local Variables: compile-command: "../../bin/toplevel.opt -pp-annot -print logic_labels_wrong.c" End: */ ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/multiple_include.h���������������������������������������������0000644�0001750�0001750�00000000744�12155630271�021607� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* a.h */ typedef struct s_t { int n; } t; /*@ type invariant inv_t(t x) = x.n > 0; */ /* @ predicate p(int x) reads x; */ /* if uncommented, should lead to an error */ static int i = 42; /*@ predicate p{Here}(int x) = x >= i; */ /*@ axiomatic Bar { logic integer li; } */ /*@ ensures i == li; */ void test() { } /*@ axiomatic Foo { type foo; logic foo ff(foo x,char * y); predicate fp(foo x, foo y); axiom fffp: \forall foo x, char* y; fp(x,ff(x,y)) && *y == 0; } */ ����������������������������frama-c-Fluorine-20130601/tests/spec/bug96.c��������������������������������������������������������0000644�0001750�0001750�00000000210�12155630271�017164� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef struct node { int hd; struct list * next; } list; /*@ logic set<struct node *> tata(struct node * p) = \empty; @*/ ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/lib.h����������������������������������������������������������0000644�0001750�0001750�00000000034�12155630271�017007� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ logic int f (int i); */ ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/axiom_ignored_bts1116.i����������������������������������������0000644�0001750�0001750�00000000271�12155630271�022252� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ /*@ axiom l: // must be rejected as axiom outside an axiomatic \forall int i; i < 0; */ struct _str { int x; }; //@ ensures \result < 0; int ftest(int i) { return i; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/conversion.c���������������������������������������������������0000644�0001750�0001750�00000001130�12155630271�020417� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* bts 60: 1 should be lifted to a real number implicitely. */ /*@ ensures 1.0 == 1; */ void f(); /*@ lemma foo: 1.0 == (float)1; */ /*@ axiomatic toto { @ logic integer g; @ predicate foo(real x); @ } */ void f() { double B; /*@ assert B==g; */ } /*@ ensures foo(\result); */ int g() { return 0; } typedef int T, T4[4], *T_PTR; const T X, Tab[4]; typedef T_PTR T_PTR_T4[4]; const T_PTR_T4 Tab_Ptr = { &X, &X, &X, &X}; /*@ axiomatic useless_logic_cast { @ logic int vX = (int) X; @ logic int[4] vTab = (T4) Tab; @ logic T_PTR_T4 * vTab_Ptr = (T_PTR_T4 *)(&Tab_Ptr); @ } */ ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/struct_invariant.c���������������������������������������������0000644�0001750�0001750�00000000617�12155630271�021642� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������struct T { int ok; int* pt; int tab[10]; } u ; //@ type invariant pt_validity(struct T t) = t.ok ==> \valid(t.pt) ; /*@ type invariant tab_nonnegative(struct T t) = @ \forall int i; 0 <= i && i < 10 ==> t.tab[i] >=0 ; @*/ //@ type invariant strange(struct T t) = t == u ; //@ global invariant u_inv: u.ok == 1; // error: redefined invariant. //@ global invariant u_inv: u.ok <= 1; �����������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/pointer_comparable.c�������������������������������������������0000644�0001750�0001750�00000000171�12155630271�022103� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ requires \pointer_comparable((void*)p,(void*)q) && \is_finite(*p) ; */ void f(float*p, char const * q) { return; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/merge_bts938.c�������������������������������������������������0000644�0001750�0001750�00000000141�12155630271�020446� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"tests/spec/merge_bts938_1.c" */ #include "tests/spec/merge_bts938.h" �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/concrete_type.c������������������������������������������������0000644�0001750�0001750�00000001041�12155630271�021076� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ type list<A> = Nil | Cons(A,list<A>); axiomatic length { logic integer length<B> (list<B> l); axiom length_empty<C>: length(Nil) == 0; axiom length_cons<D>: \forall D a, list<D> l; length(Cons(a,l)) == length(l)+1; } */ /*@ type my_list = list<integer>; logic my_list foo = Cons(1,Nil); */ /*@ type other_list<B> = list<B>; logic other_list<int> bar = Cons((int)42, Nil); */ /*@ lemma foo: length(bar) == length(foo); */ /*@ type my_int = int; logic my_int x = (int) 42; lemma baz: x + 1== 43; */ �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/used_before_decl_bts0109.i�������������������������������������0000644�0001750�0001750�00000000233�12155630271�022676� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int f(); int g () { return f(0) + h(1); } /*@ requires a>=0; assigns \result \from a; */ int f(int a); /*@ ensures \result == b + 1; */ int h(int b); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/volatile.h�����������������������������������������������������0000644�0001750�0001750�00000001043�12155630271�020061� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 ; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/updater.c������������������������������������������������������0000644�0001750�0001750�00000001512�12155630271�017702� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������typedef int a; struct S {int v ; int a[5]; int b;} x = { 1,.b=2 } ; struct SS {struct S a[5]; struct S b;} y; /*@ logic struct S foo(struct S x) = {x \with .b = (int)(x.b+1), .v = (int)3 } ; */ /*@ lemma foo2 : x == {foo(x) \with .b = (int)(x.a[0]+1) } ; */ /*@ lemma bar : {foo(x) \with .a = { \with [..] = (int)0, [3] = (int)3 }} == {foo(x) \with .a[..] = (int)0, .a[3]= (int)3 } ; */ /*@ lemma bar2 : x == {x \with .a = {x.a \with [4] = (int)0 }} ; */ /*@ lemma bar3 : y == {y \with .a[3+1].b = (int)(x.b+1)} ; */ /*@ lemma bar4 : y == {y \with .a[4].a[..] = (int)(x.b+1)} ; */ /*@ lemma bar5 : y == {y \with .a[4] = {\with .a[..] = (int)(x.b+1), .v = (int)3}, .b.v = (int) 4} ; */ /*@ lemma cast : y.a[0].v == ((struct S) y).v ; */ int * f(void) { if (y.a[0].v == ((struct SS) y).b.v) return y.a[0].v ; return x.b ; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/polymorph.c����������������������������������������������������0000644�0001750�0001750�00000001611�12155630271�020267� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ type foo<a>; */ /* should be rejected (free type variable) */ /*@ logic integer bad(foo<a> x); */ /*@ logic integer f<a>(foo<a> x); */ /*@ logic integer g<a>(foo<a> x, foo<a> y); */ /*@ logic foo<a> h<a>(foo<a> x); */ /* definition of i should be rejected (free variable in return type) */ /*@ logic foo<a> i<a,b>(foo<b> x); */ //@ predicate bla(foo<int> x) = f(x) == 0 ; //@ predicate bli(foo<real> x) = g(x,x) == 42 ; /* blu should be rejected (force unification between two user-introduced type variables) */ //@ predicate blu<a,b>(foo<a> x, foo<b> y) = g(x,y) == 36 ; //@ predicate blu2<a,b>(foo<a> x, foo<b> y) = g(x,x) == 36 && g(y,y) == 72 ; //@ predicate bar(foo<real> x) = bli(x) && blu2(x,x) ; // should be rejected //@ predicate unif1<a,b>(foo<a> x,foo<b>y) = h(x) == h(y); // should be rejected //@ logic foo<a> unif2<a,b>(foo<a> x, foo<b>y) = h(y); �����������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/axiom_included_1.c���������������������������������������������0000644�0001750�0001750�00000000146�12155630271�021444� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is in axiom_included.c */ #include "tests/spec/axiom_included.h" ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/transitive_rel.c�����������������������������������������������0000644�0001750�0001750�00000000562�12155630271�021274� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ predicate bound(int x, int y, int z) = @ x<=y<z && z>=y>x ; @*/ /*@ predicate bound2 (int x, int y, int z) = @ x <= y == z ; @*/ // not the same as above, see pr#16 /*@ predicate test(int x, int y, boolean z) = @ (x<=y) == z ; @*/ // sense of inequalities matters /*@ predicate reject(int x, int y, int z, int t) = @ x <= y == z >= t; @*/ ����������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/printf_assigns.c�����������������������������������������������0000644�0001750�0001750�00000000617�12155630271�021274� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: support for discussion on printf specification */ /* How to specify this code ? */ #ifndef PTEST #include <stdio.h> #else extern int printf (__const char *__restrict __format, ...); #endif int main(int argc, char* argv[]) { char * str = (argc < 2 ? "" : argv [1]) ; int pos; printf("%2$2s%1$n.\n", &pos, str); printf("dot position=%d\n", 1+pos); return 0; } �����������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/va.c�����������������������������������������������������������0000644�0001750�0001750�00000000201�12155630271�016636� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#include "../../share/libc/stdio.h" void main(int x, ...) { int x,y; va_list p; va_start(p,x); vscanf("FOO %d %d",p); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/predicates.c���������������������������������������������������0000644�0001750�0001750�00000000673�12155630271�020370� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ predicate is_valid_int_range(int* p, int n) = (pred1:0 <= n) && pred2:\valid_range(p, 0, n-1); */ /*@ predicate P(int *p) = *p ==0 ; */ /* predicate Q(int p) = *(((char*)&p)+2) ==0 ; */ /*@ predicate R(int *p) = \valid(p) ; */ /*@ 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) ; ���������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/assert_label.i�������������������������������������������������0000644�0001750�0001750�00000000570�12155630271�020707� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config STDOPT: +"-copy" */ void bar () { //@ assert bli: \true; } void f() { L: //@ assert lab: \true; ; } void foo (int n) { switch (n) { case 4: /*@ assert "foo + bar" "=" @ "foobar": \true; */ break; case 5: //@ assert foo: \true; break; case 6: //@ assert bar: \true; case 7: //@ assert bla: \true; ; } } ����������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/merge_different_assigns_bis.i����������������������������������0000644�0001750�0001750�00000000351�12155630271�023755� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: main test is merge_different_assigns.i */ int x, t, u, v, w, x; /*@ assigns x; assigns t \from t; assigns u; assigns v; assigns \result \from y; assigns w \from w; assigns x; */ int f(int y); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/char_cst.c�����������������������������������������������������0000644�0001750�0001750�00000000510�12155630271�020021� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ requires c != '0'; 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) { } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/at_exit.c������������������������������������������������������0000644�0001750�0001750�00000001341�12155630271�017673� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: support for discussion on atexit specification */ /* Asked question: * How to specify this code with ACSL ? */ #ifndef PTEST #include <stdio.h> #else extern int printf (__const char *__restrict __format, ...); #endif #ifndef PTEST #include <stdlib.h> #else extern int atexit (void (*__func) (void)) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))); extern void exit (int __status) __attribute__ ((__nothrow__)) __attribute__ ((__noreturn__)); #endif char *glob; int res; void test(void) { printf("%s (%d);\n", glob, res); } int main(int argc, char *argv[]) { atexit(test); res = argc - 2 ; if (res > 1) { glob = "exit"; exit (res); } glob = "return"; return res; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/declspec.c�����������������������������������������������������0000644�0001750�0001750�00000000157�12155630271�020024� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������//@ axiomatic Foo { predicate p(char *s); } void f(const char *__declspec(whatever) a) { //@ assert p(a); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/bts0440.i������������������������������������������������������0000644�0001750�0001750�00000000237�12155630271�017347� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int fact(int n) { int r = 1 ; while ( n > 0 ) { //@ ensures n >= 0 ; before: r *= n-- ; //@ assert r == \at(r*n,before) ; } return r ; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/multiple_include_1.c�������������������������������������������0000644�0001750�0001750�00000000272�12155630271�022016� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config DONTRUN: whole test is done in multiple_include_2.c */ #include "multiple_include.h" /* @ logic integer li = 42; */ /*@ ensures p(\result); */ int foo() { return i; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/spec/hosum.c��������������������������������������������������������0000644�0001750�0001750�00000000653�12155630271�017376� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*@ requires n >= 0; requires \valid(p+ (0..n-1)); assigns \nothing; ensures \result == \sum(0,n-1,\lambda integer i; p[i]*p[i]); */ int sqsum(int* p, int n); #define INT_MAX (1<<30-1) int sqsum(int* p, int n) { int S=0, tmp; for(int i = 0; i < n; i++) { //@ assert p[i] * p[i] <= INT_MAX; tmp = p[i] * p[i]; //@ assert tmp >= 0; //@ assert S + tmp <= INT_MAX; S += tmp; } return S; } �������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing2/�����������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016654� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing2/oracle/����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020121� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing2/adpcm.ml���������������������������������������������������0000644�0001750�0001750�00000000656�12155630327�020302� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* ledit bin/toplevel.top -no-annot -deps -slicing_level 2 tests/slicing2/adpcm.c #use "tests/slicing2/select.ml";; *) include LibSelect;; (* Kernel.slicing_level := 2;; = MinimizeNbCalls *) (* let resname = "tests/slicing2/adpcm.sliced" in ignore (test "uppol2" ~do_prop_to_callers:true ~resname (select_retres));; *) let () = Db.Main.extend (fun _ -> ignore (test "uppol2" ~do_prop_to_callers:true (select_retres))) ����������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing2/result/����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020172� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/slicing2/adpcm.c����������������������������������������������������0000644�0001750�0001750�00000000277�12155630327�020113� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: make -s tests/slicing2/adpcm.opt CMD: tests/slicing2/adpcm.opt OPT: -check -no-annot -deps -slicing-level 2 -journal-disable */ #include "tests/test/adpcm.c" ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/scope/��������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016253� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/scope/oracle/�������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017520� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/scope/zones.c�������������������������������������������������������0000644�0001750�0001750�00000002461�12155630326�017560� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -load-script tests/scope/zones.ml -val -journal-disable */ /* bin/viewer.opt -val tests/scope/zones.c */ int T [10]; struct Tstr { int a; int b; } S; int X,Y,Z; int simple (int x, int y, int z) { y = 3; //no need for y before x ++; //not used x = y + z; return x; } int array1 (int x, int y) { T[x] = 3; T[0] += y; return T[0]; } int struct1 (int x, int y) { struct Tstr s; s = S; // lose precision : even if we need s.b after, we need S before s.a = x; s.b += y; return s.a; } int ctrl1 (int x, int y, int z) { int a; if (x) { a = y; goto Lt2; // to keep Lt2 Lt2 : ; } else { a = z; } return a; } //================================================================ int Xf, Xg, Yf, Yg; int f (int x, int y, int z) { Xf += x; Yf = z; return x + y; } int g (int a, int b, int c) { Xg += b; Yg = c; return a + b; } int caller (int cond, int t, int u, int v) { int x1 = 0, y1 = 0, z1 = 0, a1 = 0, b1 = 0, c1 = 0; int (*pf)(int, int, int) = cond ? &f : &g; f(x1, y1, z1); g(a1, b1, c1); return (*pf)(t, u, v); } //================================================================ int main (int x, int y, int z) { simple (x, y, z); array1 (x, y); struct1 (x, y); ctrl1 (x, y, z); caller (x, x, y, z); return 0; } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/scope/bts971.ml�����������������������������������������������������0000644�0001750�0001750�00000004546�12155630326�017647� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ 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" Printer.pp_location (Cil_datatype.Stmt.loc s) (Printer.without_annot Printer.pp_stmt) s) defs in Format.printf "@]@]@." open Cil_types let tests () = let main = fst (Globals.entry_point ()) in if Kernel_function.get_name main = "main" then 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.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" else if Kernel_function.get_name main = "main2" then let s = Kernel_function.find_return main in let s = List.hd s.preds in compute_and_print (s, main) "t[1].a" else Kernel.result "Unknown main %a@." Kernel_function.pretty main 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/scope/bts971.c������������������������������������������������������0000644�0001750�0001750�00000000756�12155630326�017460� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -journal-disable -load-script tests/scope/bts971.ml -then -main main2 */ /* bug 971: */ 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 ();}; } } /* bug 972 */ typedef struct { int a; int b; } ts; ts t[10]; void init() { t[1].a = 1; t[1].b = 2; } int main2 () { init(); return t[1].a; } ������������������frama-c-Fluorine-20130601/tests/scope/no-effect.i���������������������������������������������������0000644�0001750�0001750�00000000437�12155630326�020277� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -print -journal-disable -scope-verbose 1 -remove-redundant-alarms */ typedef struct { int v; } tt; void main (const tt *p1) { int i; int j; while(1) { switch ((p1+1)->v) { case 1: case 2: case 3: case 4: (p1+1)->v; break; } } } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/scope/result/�������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017571� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/scope/bts383.c������������������������������������������������������0000644�0001750�0001750�00000002066�12155630326�017451� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -print -journal-disable -scope-verbose 1 -remove-redundant-alarms -context-width 3 */ /* echo '!Db.Scope.check_asserts();;' \ | bin/toplevel.top -val tests/scope/bts383.c */ int v; void if1 (int * p) { if (*p > 0) v = *p; } int if2 (int c, int * p) { if (c) v = *p; return *p; } void loop1 (int * p) { int i; int n = *p; for (i = 0; i < n; i++) { v = *p; } } int loop2 (int n, int * p) { int i; for (i = 0; i < n; i++) { v = *p; } return *p; } void out_char (char c); void out_string (const char *value) { for(; *value; value++) out_char(*value); } typedef struct { int a; int b; } Tstruct; int fstruct (Tstruct * ps) { int x; ps->a = 3; ps->b = 5; ps->a = ps->b; ps->b = ps->a; x = ps->a + ps->b; ps++; ps->a = 3; ps->b = 5; ps->a = ps->b; ps->b = ps->a; x += ps->a + ps->b; return x; } int main (int * p, Tstruct * ps) { int x; x = *(p+1); v = *(p+1); if1(p+1); if2(x,p+1); loop1(p+1); loop2(x,p+1); out_string(p+1); x += fstruct (ps+1); return x; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/scope/zones.ml������������������������������������������������������0000644�0001750�0001750�00000003563�12155630326�017752� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* when using toplevel.top : bin/topleval.top -val tests/scope/zones.c #directory "cil/src";; *) let fmt = Format.std_formatter;; (* let old_debug = Kernel.Debug.get ();; Kernel.Debug.set 1;; (* to see sid *) Format.fprintf fmt "@[%a@]" Printer.pp_file ( Ast.get ());; Kernel.Debug.set old_debug;; *) let find_ret kf_name = let kf = Globals.Functions.find_by_name kf_name in let stmt = Kernel_function.find_return kf in Format.printf "Current program point = return in function %s@\n" kf_name; stmt, kf ;; 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 kf; stmt, kf ;; let find_label kf_name lab_name = let kf = Globals.Functions.find_by_name kf_name in let stmt = !(Kernel_function.find_label kf lab_name) in Format.printf "Current program point = label %s in function %s@\n" lab_name 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 (_used_stmts, zones) = !Db.Scope.build_zones kf stmt lval in Format.printf "Zones for %s at current program point =@.%a\n@\n" str_data !Db.Scope.pretty_zones zones ;; let main _ = let pp = find_ret "simple" in compute_and_print pp "x"; let pp = find_ret "array1" in compute_and_print pp "T[0]"; compute_and_print pp "T[1]"; compute_and_print pp "T[x]"; let pp = find_ret "struct1" in compute_and_print pp "s.a"; compute_and_print pp "s.b"; compute_and_print pp "s"; let pp = find_ret "ctrl1" in compute_and_print pp "a"; let pp = find_label "ctrl1" "Lt2" in compute_and_print pp "a"; let pp = find_ret "caller" in compute_and_print pp "Yf" let () = Db.Main.extend main ���������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/scope/scope.c�������������������������������������������������������0000644�0001750�0001750�00000002371�12155630326�017533� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -main f share/builtin.c -journal-disable OPT: -val -main f2 -journal-disable OPT: -val -main loop -journal-disable */ /* * bin/viewer.byte -main f tests/scope/scope.c -val share/builtin.c * bin/viewer.byte -main f2 tests/scope/scope.c -val * bin/viewer.byte -main loop tests/scope/scope.c -val */ #include "share/builtin.h" typedef struct {int a; int b; } Tstr; Tstr S1, S2; int T[100]; int f (int x, int y, Tstr s) { int a, b; int * p; int i; if (x > 0) { p = &x; a = 0; s.a = 3; i = Frama_C_interval (5, 15); T[i] = 1; } else { p = &y; b = 0; i = Frama_C_interval (10, 20); T[i] = 2; } i = 0; x = 5; y = 10; /* It can be interesting to see that selecting T[i] * is not the same than selecting T[0] even if i=0 */ *p = i; x = 4; return *p; } void f2 (int c) { int x, y; y = 0; x = 1; y++; if (c) { y++; } else { y++; x = 2; y++; } y++; } int loop (int n) { int a, b, i, s; i = 0; s = 0; a = 0; b = 0; while (i < n) { a++; b++; s++; /* selecting i here select also stmts before the loop */ /* selecting s here select also stmts after the loop */ i++; } a++; b++; i++; return s; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/idct/���������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016065� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/idct/oracle/��������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017332� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/idct/ieee_1180_1990.c�����������������������������������������������0000644�0001750�0001750�00000026401�12155630244�020275� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: OPT: -float-normal -no-warn-signed-overflow -val -deps -out -input tests/idct/idct.c share/libc/stdio.c share/math.c -journal-disable -remove-redundant-alarms -memexec-all -then -report -report-print-properties */ /* IEEE_1180_1990: a testbed for IDCT accuracy * Copyright (C) 2001 Renaud Pacalet * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program 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 for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. * * Renaud Pacalet * Departement Comunications et Electronique, * Ecole Nationale Superieure des Telecommunications * 46, Rue Barrault 75634 Paris Cedex 13 * Tel : +33 1 45 81 78 08 * Fax : +33 1 45 80 40 36 * Email : pacalet@enst.fr * * The following program checks a IDCT C-code against the IEEE * 1180-1990 Standard Specification for the Implementation of 8x8 * Inverse Discrete Cosine Transform */ #include "share/libc/stdio.h" #include "share/math.h" void exit (int x); #ifndef M_PI #define M_PI 3.14159265358979323846 #endif #define IEEE_1180_1990_TH M_PI/16.0 #define IEEE_1180_1990_ABS(a) ((a < 0) ? -a : a) extern void idct (long m1[8][8], long m2[8][8]); static long M1[8][8]; typedef struct { long pmse[8][8]; long pme[8][8]; } IEEE_1180_1990_stat_set; /* The random generator of the IEEE 1180/1990 standard */ long IEEE_1180_1990_rand(long L, long H) { static long randx = 1; static double z = (double)0x7fffffff; long i, j; double x; randx = (randx * 1103515245) + 12345; i = randx & 0x7ffffffe; x = ((double)i) / z; x *= (L + H + 1); j = x; return(j - L); } /* Generates random blocks with values between min and max */ static void IEEE_1180_1990_mkbk(long min, long max) { long i, j; for(i = 0; i < 8; i++) for(j = 0; j < 8; j++) M1[i][j] = IEEE_1180_1990_rand(-min, max); } /* Floating point DCT */ void IEEE_1180_1990_dctf(long m1[8][8], long m2[8][8]) { long i, j, k; double tmp1[8][8], tmp2[8][8]; static double mcos[8][8]; static int init = 1; if(init) { for(i = 0; i < 8; i++) for(j = 0; j < 8; j++) mcos[i][j] = ((j == 0) ? 0.5 / sqrt(2.0) : 0.5) * cos((2.0 * i + 1.0) * j * IEEE_1180_1990_TH); init = 0; } for(i = 0; i < 8; i++) for(j = 0; j < 8; j++) { tmp1[i][j] = 0.0; for(k = 0; k < 8; k++) tmp1[i][j] = tmp1[i][j] + mcos[k][i] * m1[k][j]; } for(i = 0; i < 8; i++) for(j = 0; j < 8; j++) { tmp2[i][j] = 0.0; for(k = 0; k < 8; k++) tmp2[i][j] = tmp2[i][j] + tmp1[i][k] * mcos[k][j]; if(tmp2[i][j] < -2048.0) m2[i][j] = -2048; else if(tmp2[i][j] > 2047.0) m2[i][j] = 2047; else if(tmp2[i][j] > 0.0) m2[i][j] = tmp2[i][j] + 0.5; else m2[i][j] = tmp2[i][j] - 0.5; } } /* Floating point IDCT */ void IEEE_1180_1990_idctf(long m1[8][8], long m2[8][8]) { long i, j, k; double tmp1[8][8], tmp2[8][8]; static double mcos[8][8]; static int init = 1; if(init) { for(i = 0; i < 8; i++) for(j = 0; j < 8; j++) mcos[i][j] = ((j == 0) ? 0.5 / sqrt(2.0) : 0.5) * cos((2.0 * i + 1.0) * j * IEEE_1180_1990_TH); init = 0; } for(i = 0; i < 8; i++) for(j = 0; j < 8; j++) { tmp1[i][j] = 0.0; for(k = 0; k < 8; k++) tmp1[i][j] = tmp1[i][j] + mcos[i][k] * m1[k][j]; } for(i = 0; i < 8; i++) for(j = 0; j < 8; j++) { tmp2[i][j] = 0.0; for(k = 0; k < 8; k++) tmp2[i][j] = tmp2[i][j] + tmp1[i][k] * mcos[j][k]; if(tmp2[i][j] < -256.0) m2[i][j] = -256; else if(tmp2[i][j] > 255.0) m2[i][j] = 255; else if(tmp2[i][j] > 0.0) m2[i][j] = tmp2[i][j] + 0.5; else m2[i][j] = tmp2[i][j] - 0.5; } } int main() { IEEE_1180_1990_stat_set res[6]; long i, j, k, m1[8][8], m2[8][8], m3[8][8], m4[8][8], succ, omse, ome, err; succ = 1; /*@ loop pragma UNROLL 7; */ for(i = 0; i < 6; i++) for(j = 0; j < 8; j++) for(k = 0; k < 8; k++) { res[i].pmse[j][k] = 0; res[i].pme[j][k] = 0; } for(i = 0; i < 8; i++) for(j = 0; j < 8; j++) M1[i][j] = 0; idct(M1, m2); for(i = 0; i < 8; i++) for(j = 0; j < 8; j++) if(m2[i][j] != 0) succ = 0; if(succ != 1) { printf("For all-zero input, the proposed IDCT shall generate all-zero "); printf("output.\n"); ; } /*fprintf(stderr, "------------------------------------------------->\n");*/ /* loop pragma UNROLL 0 */ for(i = 0; i < 10000; i++) { if((i + 1) % 200 == 0) { /* fprintf(stderr, "*"); fflush(stderr); */ } IEEE_1180_1990_mkbk(-256, 255); IEEE_1180_1990_dctf(M1, m2); IEEE_1180_1990_idctf(m2, m3); idct(m2, m4); for(j = 0; j < 8; j++) for(k = 0; k < 8; k++) { err = m4[j][k] - m3[j][k]; res[0].pme[j][k] = res[0].pme[j][k] + err; if(IEEE_1180_1990_ABS(err) > 1) { /* printf("For any pixel location, the peak error (ppe) shall not "); printf("exceed 1 in magnitude.\n"); printf(" (%ld in set 1, block %ld, line %ld, column %ld).\n", err, i, j, k); */ succ = 0; } err = err * err; res[0].pmse[j][k] = res[0].pmse[j][k] + err; } for(j = 0; j < 8; j++) for(k = 0; k < 8; k++) M1[j][k] = - M1[j][k]; IEEE_1180_1990_dctf(M1, m2); IEEE_1180_1990_idctf(m2, m3); idct(m2, m4); for(j = 0; j < 8; j++) for(k = 0; k < 8; k++) { err = m4[j][k] - m3[j][k]; res[3].pme[j][k] = res[3].pme[j][k] + err; if(IEEE_1180_1990_ABS(err) > 1) { /* printf("For any pixel location, the peak error (ppe) shall not "); printf("exceed 1 in magnitude.\n"); printf(" (%ld in set 4, block %ld, line %ld, column %ld).\n", err, i, j, k); */ succ = 0; } err = err * err; res[3].pmse[j][k] = res[3].pmse[j][k] + err; } IEEE_1180_1990_mkbk(-5, 5); IEEE_1180_1990_dctf(M1, m2); IEEE_1180_1990_idctf(m2, m3); idct(m2, m4); for(j = 0; j < 8; j++) for(k = 0; k < 8; k++) { err = m4[j][k] - m3[j][k]; res[1].pme[j][k] = res[1].pme[j][k] + err; if(IEEE_1180_1990_ABS(err) > 1) { /* printf("For any pixel location, the peak error (ppe) shall not "); printf("exceed 1 in magnitude.\n"); printf(" (%ld in set 2, block %ld, line %ld, column %ld).\n", err, i, j, k); */ succ = 0; } err = err * err; res[1].pmse[j][k] = res[1].pmse[j][k] + err; } for(j = 0; j < 8; j++) for(k = 0; k < 8; k++) M1[j][k] = - M1[j][k]; IEEE_1180_1990_dctf(M1, m2); IEEE_1180_1990_idctf(m2, m3); idct(m2, m4); for(j = 0; j < 8; j++) for(k = 0; k < 8; k++) { err = m4[j][k] - m3[j][k]; res[4].pme[j][k] = res[4].pme[j][k] + err; if(IEEE_1180_1990_ABS(err) > 1) { /* printf("For any pixel location, the peak error (ppe) shall not "); printf("exceed 1 in magnitude.\n"); printf(" (%ld in set 5, block %ld, line %ld, column %ld).\n", err, i, j, k); */ succ = 0; } err = err * err; res[4].pmse[j][k] = res[4].pmse[j][k] + err; } IEEE_1180_1990_mkbk(-300, 300); IEEE_1180_1990_dctf(M1, m2); IEEE_1180_1990_idctf(m2, m3); idct(m2, m4); for(j = 0; j < 8; j++) for(k = 0; k < 8; k++) { err = m4[j][k] - m3[j][k]; res[2].pme[j][k] = res[2].pme[j][k] + err; if(IEEE_1180_1990_ABS(err) > 1) { /* printf("For any pixel location, the peak error (ppe) shall not "); printf("exceed 1 in magnitude.\n"); printf(" (%ld in set 3, block %ld, line %ld, column %ld).\n", err, i, j, k); */ succ = 0; } err = err * err; res[2].pmse[j][k] = res[2].pmse[j][k] + err; } for(j = 0; j < 8; j++) for(k = 0; k < 8; k++) M1[j][k] = - M1[j][k]; IEEE_1180_1990_dctf(M1, m2); IEEE_1180_1990_idctf(m2, m3); idct(m2, m4); for(j = 0; j < 8; j++) for(k = 0; k < 8; k++) { err = m4[j][k] - m3[j][k]; res[5].pme[j][k] = res[5].pme[j][k] + err; if(IEEE_1180_1990_ABS(err) > 1) { /* printf("For any pixel location, the peak error (ppe) shall not "); printf("exceed 1 in magnitude.\n"); printf(" (%ld in set 6, block %ld, line %ld, column %ld).\n", err, i, j, k); */ succ = 0; } err = err * err; res[5].pmse[j][k] = res[5].pmse[j][k] + err; } } for(i = 0; i < 6; i++) { omse = 0; ome = 0; for(j = 0; j < 8; j++) for(k = 0; k < 8; k++) { omse = omse + res[i].pmse[j][k]; if(res[i].pmse[j][k] > 600) { /* printf("For any pixel location, the mean square error (pmse) shall "); printf("not exceed 0.06.\n"); printf(" (%0.5f in set %ld, line %ld, column %ld).\n", res[i].pmse[j][k] / 10000.0, i, j, k); */ succ = 0; } ome = ome + res[i].pme[j][k]; if(IEEE_1180_1990_ABS(res[i].pme[j][k]) > 150) { /* printf("For any pixel location, the mean error (pme) shall "); printf("not exceed 0.015 in magnitude.\n"); printf(" (%0.5f in set %ld, line %ld, column %ld).\n", res[i].pme[j][k] / 10000.0, i, j, k); */ succ = 0; } } if(omse > 12800) { /* printf("Overall, the mean square error (omse) shall "); printf("not exceed 0.02 in magnitude.\n"); printf(" (%0.5f in set %ld).\n", omse / 640000.0, i); */ succ = 0; } if(IEEE_1180_1990_ABS(ome) > 960) { /* printf("Overall, the mean error (ome) shall "); printf("not exceed 0.0015 in magnitude.\n"); printf(" (%0.5f in set %ld).\n", ome / 640000.0, i); */ succ = 0; } } /* fprintf(stderr, "\n"); */ if(succ == 1) { /* fprintf(stderr, "Your IDCT meets the IEEE Std 1180-1990 accuracy "); fprintf(stderr, "requirements.\n"); */ exit(0); } else { /* fprintf(stderr, "Your IDCT does not meet the IEEE Std 1180-1990 accuracy "); fprintf(stderr, "requirements.\n"); */ exit(1); } } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/idct/idct.c���������������������������������������������������������0000644�0001750�0001750�00000016573�12155630244�017167� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config GCC: DONTRUN: */ /* IDCT: a fixed point IDCT implementation. * Copyright (C) 2001 Renaud Pacalet * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program 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 for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. * * Renaud Pacalet * Departement Comunications et Electronique, * Ecole Nationale Superieure des Telecommunications * 46, Rue Barrault 75634 Paris Cedex 13 * Tel : +33 1 45 81 78 08 * Fax : +33 1 45 80 40 36 * Email : pacalet@enst.fr * * The following code implements a 2-steps IDCT. The * computations are done in finite accuracy, controlled by the 3 macros * NBC1, NBI, NBC2. It behaves exactly the same as our hardware * distributed arithmetics based architecture. The default values for * NBC1, NBI and NBC2 (14, 14 and 14) are a kind of best choice if you * need to pass the IEEE 1180-1990 requirements but want the different * dynamics to be as small as possible. You can play with them but be * aware that accuracy strongly depends on them. * * The input of the function should be a 8x8 matrix of integers in the * range of -2048 ... 2047 (2's complement coded on 12 bits). * The output will be a 8x8 matrix of integers in the * range -256 ... 255. */ #include "share/math.h" #ifndef M_PI #define M_PI 3.14159265358979323846 #endif #define TH M_PI/16.0 #define NBC1 14 /* Number of bits used to represent the first pass hard-coded cosines * matrix. */ #define NBI 14 /* Number of bits kept on partial results after first pass. This will * be the word length of the transposition RAM. */ #define NBC2 14 /* Number of bits used to represent the second pass hard-coded cosines * matrix (usually the same as NBC1 but...). */ void idct (long m1[8][8], long m2[8][8]) /* m1 is the input 8x8 matrix of DCT coefficients. m2 will hold the * IDCT result. */ { long i, j, k, tmp1[8][8], tmp2[8][8]; /* Loops indexes and temporary matrices. */ double ftmp1, ftmp2; /* Temporary variables used for rounding purpose when computing the * hard-coded cosines matrices. */ static int init = 1; /* A simple flag that tells it's the first time the function is called. * When init is true we will compute the hard-coded cosines matrices for * pass one and pass two, then reset init and compute the IDCT. If not * we will only compute the IDCT. */ static long mc1[8][8], mc2[8][8]; /* hard-coded cosines matrices. */ if (init) { /* If init (it's the first time the function is called), let's compute * the hard-coded cosines matrices for pass one and pass two. */ for (i = 0; i < 8; i++) for (j = 0; j < 8; j++) { ftmp1 = ((j == 0) ? 0.5 / sqrt (2.0) : 0.5) * cos ((2.0 * i + 1.0) * j * TH); ftmp2 = ftmp1; /* The well known formula. The max absolute value for ftmp1 and ftmp2 is 0.5. */ ftmp1 *= (1 << NBC1); /* Multiply the cosine coefficient by 2^NBC1. The max absolute value for * ftmp1 is 2^(NBC1-1). */ if (ftmp1 < 0) ftmp1 -= 0.5; else ftmp1 += 0.5; /* For symetrical rounding. */ mc1[i][j] = ftmp1; /* The rounding itself. mc1 * contains now the cosines reprensented in 2's complement form, fixed * point on NBC1 bits. */ ftmp2 *= (1 << NBC2); /* Multiply the cosine coefficient by 2^NBC2. The max absolute value for * ftmp2 is 2^(NBC2-1). */ if (ftmp2 < 0) ftmp2 -= 0.5; else ftmp2 += 0.5; /* For symetrical rounding. */ mc2[i][j] = ftmp2; /* The rounding itself. mc2 * contains now the cosines reprensented in 2's complement form, fixed * point on NBC2 bits. */ } init = 0; /* Reset the init flag. On the next call mc1 and mc2 will not be * computed anymore. */ } /* Then the first pass. */ for(i = 0; i < 8; i++) for(j = 0; j < 8; j++) { for(k = 0, tmp1[i][j] = 0; k < 8; k++) tmp1[i][j] += mc1[i][k] * m1[k][j]; /* The [i,j] coefficient of the matrix product MC1*M1. */ tmp1[i][j] >>= (NBC1 + 10 - NBI); /* In order to keep NBI bits only. The DCT coefficients of m1 are * integers, 2's complement coded on 12 bits. The result should be * reprensented on NBC1 + 12 + 3 bits (sum of 8 partial products, each * of them beeing reprensented on NBC1 + 12 bits). A dynamic study can * prove that m1 beeing a DCT output tmp1[i][j] can be represented on * NBC1 + 11 bits only. * So as we have a NBC1 + 11 long integer and want to * keep NBI bits only we first drop NBC1 + 10 - NBI bits. We will drop * the last bit after rounding. */ tmp1[i][j] += 1; /* For rounding purpose. */ tmp1[i][j] >>= 1; /* Final rounding. tmp1[i][j] is now represented on NBI bits. */ if (tmp1[i][j] < -(1 << (NBI - 1))) tmp2[j][i] = -(1 << (NBI - 1)); else if (tmp1[i][j] >= (1 << (NBI - 1))) tmp2[j][i] = (1 << (NBI - 1)) - 1; else tmp2[j][i] = tmp1[i][j]; /* Saturation and transposition at the same time. Why saturation? I * wrote above that it can be proved that tmp1[i][j] can be represented * on NBI bits after truncation and rounding but it assumed that m1 was * a DCT output, which is usually not the case because of quantization * and inverse quantization. So saturation is needed. */ } /* Then the second pass. Looks like the first one. */ for(i = 0; i < 8; i++) for(j = 0; j < 8; j++) { for(k = 0, tmp1[i][j] = 0; k < 8; k++) tmp1[i][j] += mc2[i][k] * tmp2[k][j]; /* The [i,j] coefficient of the matrix product MC2*TMP2, that is, * MC2*t(TMP1) = MC2*t(MC1*M1) = MC2*tM1*tMC1. */ tmp1[i][j] >>= (NBC2 + NBI - 12); /* In order to keep 9 bits only. The coefficients of tmp2 are fixed * point, 2's complement coded on NBI bits. The result should be * reprensented on NBC2 + NBI + 3 bits (sum of 8 partial products, each * of them beeing reprensented on NBC2 + NBI bits). A dynamic study can * prove that m1 beeing a DCT output tmp2[i][j] can be represented on * NBC2 + NBI - 2 bits only (I wrote a paper on this study once; If * you're interested...). So as we have a NBC2 + NBI - 2 long integer * and want to keep 9 bits only we first drop NBC2 + NBI - 12 bits. We * will drop the last bit after rounding. */ tmp1[i][j] += 1; /* For rounding purpose. */ tmp1[i][j] >>= 1; /* Final rounding. tmp2[i][j] is now represented on 9 bits. */ if (tmp1[i][j] < -256) m2[j][i] = -256; else if (tmp1[i][j] > 255) m2[j][i] = 255; else m2[j][i] = tmp1[i][j]; /* Saturation and transposition at the same time. Why saturation? I * wrote above that it can be proved that tmp2[i][j] can be represented * on 9 bits after truncation and rounding but it assumed that m1 was * a DCT output, which is usually not the case because of quantization * and inverse quantization. So saturation is needed. The last * transposition leads to M2 = t(MC2*tM1*tMC1) = MC1*M1*tMC2, that is, * the IDCT formula of M1. */ } } �������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/idct/result/��������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017403� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/test/���������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016121� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/test/oracle/��������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017366� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/test/result/��������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�017437� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/more_wp/������������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016612� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/more_wp/bubblesort.c������������������������������������������������0000644�0001750�0001750�00000005266�12155630325�021131� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������int a[100]; /*@ predicate my_sorted_array(int old_a[], integer start_index, integer end_index) = \forall integer k1, k2; start_index <= k1 <= k2 <= end_index ==> a[k1] <= a[k2]; */ /*@ predicate all_smaller_than_the_last (int old_a[], integer start_index, integer end_index) = \forall integer k1; start_index <= k1 < end_index ==> a[k1] <= a[end_index]; */ //use of swap funktion causes ERROR /*@ requires 0 < length; requires \valid_range(a, 0, length-1); ensures my_sorted_array(a, 0, length-1); */ void bubble_sort(int* old_a, int length) { int auf = 1; int ab; int fixed_auf = auf; /*@ loop invariant fixed_auf == auf; loop invariant 0 < auf <= length; loop invariant all_smaller_than_the_last(a, 0, auf-1); loop invariant my_sorted_array(a, 0, auf-1); loop invariant \forall integer k; auf < k < length ==> a[k] == \at(a[k], Pre); loop assigns auf, fixed_auf, ab, a[0..auf]; */ for (; auf < length; auf++, fixed_auf = auf) { //@ assert my_sorted_array(a, 0, auf-1); //IMPORTANT fixed_auf = auf; ab=auf; //@ assert my_sorted_array(a, ab, auf); /*@ loop invariant fixed_auf == auf; loop invariant 0 <= ab <= auf; loop invariant all_smaller_than_the_last(a, 0, auf-1); loop invariant my_sorted_array(a, 0, ab-1); loop invariant my_sorted_array(a, ab, auf); loop invariant \forall integer k; auf < k < length ==> a[k] == \at(a[k], Pre); loop assigns ab, a[0..auf]; */ while (0 < ab && a[ab] < a[ab-1]) { //@ assert my_sorted_array(a, 0, ab-1); //IMPORTANT //@ assert my_sorted_array(a, ab, auf); //IMPORTANT //@ assert a[ab] < a[ab-1]; //IMPORTANT //@ assert a[ab] <= a[auf]; int temp = a[ab]; a[ab] = a[ab-1]; a[ab-1] = temp; //@ assert a[ab-1] <= a[ab]; //IMPORTANT // not completely correct (actually <), because only swapped when a[ab] < a[ab-1], //@ assert my_sorted_array(a, ab+1, auf); // OK //@ assert a[ab] <= a[auf]; //Problem: should be correct but is not proven //Solved: is proven due to predicate "all_smaller_than_the_last" //@ assert my_sorted_array(a, 0, ab-2); //ok //IMPORTANT //@ assert ab < auf ==> all_smaller_than_the_last(a, ab, ab+1); // NEEDS TO BE PROVEN //@ assert a[ab] <= a[auf]; // NEEDS TO BE PROVEN //@ assert my_sorted_array(a, ab, auf); // FAILURE // ==> //@ assert my_sorted_array(a, ab-1, auf); //IMPORTANT ab = ab-1; //@ assert my_sorted_array(a, 0, ab-1); //IMPORTANT //@ assert my_sorted_array(a, ab, auf); //IMPORTANT } //@ assert my_sorted_array(a, 0, auf); //IMPORTANT } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/more_wp/oracle/�����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020057� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/more_wp/quicksort.c�������������������������������������������������0000644�0001750�0001750�00000005245�12155630325�021007� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* FRAMAC_SHARE=share bin/viewer.opt -pp-annot tests/wp/quicksort.c */ /*external permut_ij : ptr -> ptr -> int -> int -> Prop : Quicksort ; external permut : ptr -> ptr -> Prop : Quicksort ; external high_bound : ptr -> int -> int -> int -> Prop : Quicksort ; external low_bound : ptr -> int -> int -> int -> Prop : Quicksort ; */ #define SIZE 100 int T[SIZE]; /*@ requires (0 <= i < SIZE) && (0 <= j < SIZE); ensures T[i] == \old(T[j]) && T[j] == \old(T[i]); assigns T[i], T[j]; */ void swap (int i, int j) { int v; v = T[i]; T[i] = T[j]; T[j] = v; } /*@ requires (0 <= l < i) && (i < SIZE) && (\forall int k; l+1 <= k <= i-1 ==> T[k] <= T[l]); ensures i-1 <= \result <= i && (\forall int k; l <= k <= \result ==> T[k] <= T[\result]) && (\forall int res; res == \result ==> T[l] == \old(T[res]) && T[res] == \old(T[l])) && T[\result] <= T[i]; */ int mv_pv (int l, int i) { int res; if (T[i] < T[l]) { swap(l, i); res = i; } else { swap(l, i - 1); res = i - 1; } return res; } /* Pre : (0 <= l < r) && r < length(T); Modifies : T; Post : (l <= result && result <= r) && high_bound (T, l, result, T[result]) && low_bound (T, result, r, T[result]) && permut (T, T@0) && (forall k:int. (k < l \/ k > r) => T[k] = T@0[k]); */ int partition (int l, int r) { int pv, i, j, res; pv = T[l]; i = l+1; j = r; while (i < j) /* Inv: (l+1 <= i <= r) && j <= r && i <= j+1 && permut (T, T@0) && high_bound (T, l+1, i-1, pv) && (low_bound (T, j+1, r, pv)) && (forall k:int. (k <= l \/ k > r) => T[k] = T@0[k]); Modifies : i, j, T; */ { while (T[i] <= pv && i < j) /* Inv: l+1 <= i <= r && high_bound (T, l+1, i-1, pv) && i <= j+1; Modifies : i; */ { i = i + 1; } while (T[j] >= pv && i < j) /* Inv: j <= r && low_bound (T, j+1, r, pv) && ~(T[i] <= pv && i < j) && i <= j+1; Modifies : j; */ { j = j - 1; } if (i < j) { swap( i, j); i = i + 1; j = j - 1; } } res = mv_pv (l, i); return res; } /* Pre: 0 <= l && r < length(T); Modifies: T; Post: (forall i j:int. l <= i <= j <= r => T[i] <= T[j]) && (forall k:int. (k < l \/ k > r) => T[k] = T@0[k]) && permut (T, T@0) ; */ void quick_rec (int l, int r) { int p; if (l < r) { p = partition(l, r); quick_rec(l, p-1); quick_rec(p+1, r); } } /* void sort (int n) Pre: n = length (T); Modifies: T; { quick_rec (0, n-1); } Post : (forall i j:int. (0 <= i <= j < n) => T[i] <= T[j]) && permut (T, T@0) ; */ �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/more_wp/result/�����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020130� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/�����������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016740� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/oracle/����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020205� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/load_one.i�������������������������������������������������0000644�0001750�0001750�00000000761�12155630322�020672� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ���������������frama-c-Fluorine-20130601/tests/saveload/segfault_datatypes_B.ml������������������������������������0000644�0001750�0001750�00000000256�12155630322�023422� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������module StateA = State_builder.Option_ref (Datatype.Int) (struct let name = "Project.Test.StateA" let dependencies = [] end) let () = StateA.set 3 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/status.ml��������������������������������������������������0000644�0001750�0001750�00000001377�12155630322�020621� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������open Cil_types let emitter = Emitter.create "Test" [ Emitter.Property_status ] ~correctness:[] ~tuning:[] let main () = Ast.compute (); let o = object inherit Visitor.frama_c_inplace method vstmt_aux stmt = Annotations.iter_code_annot (fun _ ca -> let kf = Kernel_function.find_englobing_kf stmt in let ps = Property.ip_of_code_annot kf stmt ca in List.iter (fun p -> Property_status.emit emitter p ~hyps:[ Property.ip_other "Blob" None Kglobal ] Property_status.Dont_know; Format.printf "%a@." Property_status.pretty (Property_status.get p)) ps) stmt; Cil.DoChildren end in Visitor.visitFramacFileSameGlobals o (Ast.get ()) let () = Db.Main.extend main �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/basic.i����������������������������������������������������0000644�0001750�0001750�00000002547�12155630322�020177� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ���������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/deps_C.ml��������������������������������������������������0000644�0001750�0001750�00000000570�12155630322�020465� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������module StateA = State_builder.Ref (Datatype.Int) (struct let name = "Project.Test.StateA" let dependencies = [] let default () = 0 end) module StateABis = State_builder.Option_ref (Datatype.Int) (struct let name = "Project.Test.StateABis" let dependencies = [] end) let () = StateA.set 5 let () = StateABis.set 10 ����������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/basic.ml���������������������������������������������������0000644�0001750�0001750�00000000533�12155630322�020350� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* This datatype tests the bug fix of BTS #1277 *) module A = Datatype.Pair (Datatype.List(Datatype.String)) (Datatype.List(Datatype.String)) module StateA = State_builder.Ref (Datatype.Int) (struct let name = "Project.Test.StateA" let dependencies = [] let default () = 0 end) let () = StateA.set 10 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/sparecode.i������������������������������������������������0000644�0001750�0001750�00000001254�12155630322�021055� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/callbacks.i������������������������������������������������0000644�0001750�0001750�00000001306�12155630322�021025� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: LOG callbacks_initial.res LOG callbacks_initial.err BIN callbacks.sav ./bin/toplevel.opt tests/saveload/callbacks.i -inout-callwise -out -calldeps -main main1 -save ./tests/saveload/result/callbacks.sav > ./tests/saveload/result/callbacks_initial.res 2> ./tests/saveload/result/callbacks_initial.err OPT: -load ./tests/saveload/result/callbacks.sav -main main2 -then -main main3 */ /* This tests whether the callbacks for callwise inout and from survive after a saveload or a -then */ void f(int *p) { *p = 1; } int x, y; void g1() { f(&x); } void g2() { f(&y); } void main1() { g1(); g2(); } void main2() { g1(); g2(); } void main3() { g1(); g2(); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/deps_E.ml��������������������������������������������������0000644�0001750�0001750�00000001661�12155630322�020471� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������(* test of incompatible state datatype *) (* the same than deps_A.ml *) module StateA = State_builder.Ref (Datatype.Int) (struct let name = "Project.Test.StateA" let dependencies = [] let default () = 0 end) (* same name but incompatible with deps_A.ml *) module StateB = State_builder.Option_ref (Datatype.Float) (struct let name = "Project.Test.StateB" let dependencies = [] end) (* the unchanged dependency of StateB *) module StateC = State_builder.Option_ref (Datatype.Int) (struct let name = "Project.Test.StateC" let dependencies = [ StateB.self ] end) let () = StateA.set 5 let () = StateB.set 10. let () = StateC.set 3 let main () = assert (StateA.get () = 10); assert (StateB.get_option () = None); (* reset to default *) assert (StateC.get_option () = None) (* reset because of dependency of B *) let () = Db.Main.extend main �������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/multi_project.i��������������������������������������������0000644�0001750�0001750�00000001156�12155630322�021771� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/multi_project.ml�������������������������������������������0000644�0001750�0001750�00000001251�12155630322�022145� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������let check name test = Kernel.log "Checking %S@." name; Project.on (Project.from_unique_name name) (fun () -> assert (test (Kernel.Files.get ()) [])) () let main () = ignore (Project.create_by_copy "foo"); ignore (Project.create "foobar"); Project.save_all "foo.sav"; check "foo" (<>); check "foobar" (=); check "default" (<>); Kernel.Files.set []; Project.load_all "foo.sav"; Extlib.safe_remove "foo.sav"; ignore (Project.create_by_copy "bar"); assert (Project.equal (Project.current ()) (Project.from_unique_name "default")); check "foo" (<>); check "foobar" (=); check "default" (<>); check "bar" (<>) let () = Db.Main.extend main �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/bool.c�����������������������������������������������������0000644�0001750�0001750�00000001330�12155630322�020030� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: BIN bool.sav LOG bool_sav.res LOG bool_sav.err ./bin/toplevel.opt -save ./tests/saveload/result/bool.sav -val ./tests/saveload/bool.c > tests/saveload/result/bool_sav.res 2> tests/saveload/result/bool_sav.err OPT: -load ./tests/saveload/result/bool.sav -out -input -deps -memory-footprint 1 OPT: -load ./tests/saveload/result/bool.sav -val */ #include "stdbool.h" #include "share/libc/stdio.h" bool x; int y; int f() { int i, j; i = 10; /*@ assert (i == 10); */ while(i--); j = 5; return 0; } int main() { f(); 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; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/deps_B.ml��������������������������������������������������0000644�0001750�0001750�00000000647�12155630322�020471� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������module StateABis = State_builder.Option_ref (Datatype.Int) (struct let name = "Project.Test.StateABis" let dependencies = [] end) module StateB = State_builder.Option_ref (Datatype.Bool) (struct let name = "Project.Test.StateB" let dependencies = [ StateABis.self ] end) let () = StateABis.set 10 let () = StateB.set (if StateABis.get () = 10 then true else false) �����������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/segfault_datatypes_A.ml������������������������������������0000644�0001750�0001750�00000000301�12155630322�023410� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������module StateA = State_builder.Ref (Datatype.Int) (struct let name = "Project.Test.StateA" let dependencies = [] let default () = 0 end) let () = StateA.set 10 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/result/����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020256� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/isset.c����������������������������������������������������0000644�0001750�0001750�00000001037�12155630322�020230� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config EXECNOW: LOG isset_sav.res LOG isset_sav.err BIN isset.sav ./bin/toplevel.opt -quiet -val -save tests/saveload/result/isset.sav tests/saveload/isset.c > ./tests/saveload/result/isset_sav.res 2> ./tests/saveload/result/isset_sav.err OPT: -quiet -load ./tests/saveload/result/isset.sav OPT: -load ./tests/saveload/result/isset.sav OPT: -val -load ./tests/saveload/result/isset.sav OPT: -quiet -val -load ./tests/saveload/result/isset.sav */ int main() { int i, j; i = 10; while(i--); j = 5; return 0; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/deps_D.ml��������������������������������������������������0000644�0001750�0001750�00000001604�12155630322�020465� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������module StateA = State_builder.Ref (Datatype.Int) (struct let name = "Project.Test.StateA" let dependencies = [] let default () = 0 end) module StateB = State_builder.Option_ref (Datatype.Bool) (struct let name = "Project.Test.StateB" let dependencies = [ StateA.self ] end) module StateD = State_builder.Ref (Datatype.Int) (struct let name = "Project.Test.StateD" let dependencies = [ StateA.self ] let default () = 0 end) module StateC = State_builder.Option_ref (Datatype.Int) (struct let name = "Project.Test.StateC" let dependencies = [ StateB.self; StateD.self ] end) let () = StateA.set 10 let () = StateB.set (StateA.get () = 10) let () = StateD.set (if StateA.get () = 5 then 5 else 0) let () = StateC.set (if StateB.get () && StateD.get () = 5 then 10 else 5) ����������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/load_one.ml������������������������������������������������0000644�0001750�0001750�00000001326�12155630322�021050� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������let () = at_exit (fun _ -> Sys.remove "tests/saveload/result/load_one.sav") let main () = let sparecode () = !Db.Sparecode.get ~select_annot:false ~select_slice_pragma:false in let p = sparecode () in Project.save "tests/saveload/result/load_one.sav"; Project.remove ~project:p (); let p = Project.load "tests/saveload/result/load_one.sav" in Project.on p (fun () -> !Db.Value.compute (); ignore (sparecode ())) () let () = Db.Main.extend main (* testing Project.create_by_copy *) let main2 () = !Db.Value.compute (); let prj = Project.create_by_copy "copy" in Format.printf "INIT AST@."; File.pretty_ast (); Format.printf "COPY AST@."; File.pretty_ast ~prj () let () = Db.Main.extend main2 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/deps_A.ml��������������������������������������������������0000644�0001750�0001750�00000001253�12155630322�020462� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������module StateA = State_builder.Ref (Datatype.Int) (struct let name = "Project.Test.StateA" let dependencies = [] let default () = 0 end) module StateB = State_builder.Option_ref (Datatype.Bool) (struct let name = "Project.Test.StateB" let dependencies = [ StateA.self ] end) module StateC = State_builder.Option_ref (Datatype.Int) (struct let name = "Project.Test.StateC" let dependencies = [ StateB.self ] end) let () = StateA.set 10 let () = StateB.set (if StateA.get () = 10 then true else false) let () = assert (StateB.get ()) let () = StateC.set (if StateB.get () then 10 else 5) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/deps.i�����������������������������������������������������0000644�0001750�0001750�00000002012�12155630322�020034� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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 ./tests/saveload/deps_E.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 CMD: ./tests/saveload/deps_E.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; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/saveload/segfault_datatypes.i���������������������������������������0000644�0001750�0001750�00000001333�12155630322�022776� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/non-free/�����������������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�016653� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/non-free/oracle/����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020120� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/non-free/free.i�����������������������������������������������������0000644�0001750�0001750�00000000677�12155630326�017760� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������void Frama_C_free(void*); void* Frama_C_alloc_size(unsigned long); void main(volatile int foo) { int *p = Frama_C_alloc_size(40); p[1] = 1; int *q = Frama_C_alloc_size(40); q[2] = 2; int *r = foo ? p : q; Frama_C_dump_each(); Frama_C_free(r); int *u = Frama_C_alloc_size(40); u[3] = 3; Frama_C_free(u); int* r = 0; Frama_C_free(r); int* s = Frama_C_alloc_size(40); s[4] = 4; s = foo ? 0 : s; Frama_C_free(s); } �����������������������������������������������������������������frama-c-Fluorine-20130601/tests/non-free/memexec-malloc.c�������������������������������������������0000644�0001750�0001750�00000000563�12155630326�021713� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#define N 2000 int t[N]; void f() { for (int i=0; i<N; i++) t[i] = i; } int *alloc() { return Frama_C_alloc_by_stack(4); } int *k() { return alloc(); } void main() { f(); f(); f(); Frama_C_show_each(t[1]); Frama_C_show_each(t[1]); Frama_C_show_each(t[2]); f(); int *p1 = alloc(); int *p2 = alloc(); int *p3 = k(); int *p4 = k(); } ���������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/non-free/result/����������������������������������������������������0000755�0001750�0001750�00000000000�12155634043�020171� 5����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������frama-c-Fluorine-20130601/tests/non-free/malloc.c���������������������������������������������������0000644�0001750�0001750�00000001003�12155630326�020260� 0����������������������������������������������������������������������������������������������������ustar �mehdi���������������������������mehdi������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* run.config OPT: -val -slevel 10 */ void *Frama_C_alloc_by_stack(unsigned long i); void *Frama_C_alloc_size(unsigned long i); void main(int c) { int x; int *s; if(c) { x = 1; s = Frama_C_alloc_by_stack(100); } else { x = 2; s = 0; } int *p = Frama_C_alloc_by_stack(c); int *q = Frama_C_alloc_by_stack(12); int *r = Frama_C_alloc_size(100); *p = 1; *(p+2) = 3; *(p+24999) = 4; *q = 1; Frama_C_show_each(q+2); *(q+2) = 3; *r = 1; *(r+2) = 3; // *s = 1; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������